{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings, UnboxedTuples #-}

-- Module:      Blaze.Text.Double.Native
-- Copyright:   (c) 2011 MailRank, Inc.
-- License:     BSD3
-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>
-- Stability:   experimental
-- Portability: portable
--
-- Efficiently serialize a Double as a lazy 'L.ByteString'.

module Blaze.Text.Double.Native
    (
      float
    , double
    ) where

import Blaze.ByteString.Builder (Builder, fromByteString)
import Blaze.ByteString.Builder.Char8 (fromChar)
import Blaze.Text.Int (digit, integral, minus)
import Data.ByteString.Char8 ()
import Data.Monoid (mappend, mconcat, mempty)
import qualified Data.Vector as V

-- The code below is originally from GHC.Float, but has been optimised
-- in quite a few ways.

data T = T [Int] {-# UNPACK #-} !Int

float :: Float -> Builder
float :: Float -> Builder
float = Double -> Builder
double forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac

double :: Double -> Builder
double :: Double -> Builder
double Double
f
    | forall a. RealFloat a => a -> Bool
isInfinite Double
f              = ByteString -> Builder
fromByteString forall a b. (a -> b) -> a -> b
$
                                  if Double
f forall a. Ord a => a -> a -> Bool
> Double
0 then ByteString
"Infinity" else ByteString
"-Infinity"
    | Double
f forall a. Ord a => a -> a -> Bool
< Double
0 Bool -> Bool -> Bool
|| forall a. RealFloat a => a -> Bool
isNegativeZero Double
f = Builder
minus forall a. Monoid a => a -> a -> a
`mappend` T -> Builder
goGeneric (Double -> T
floatToDigits (-Double
f))
    | Double
f forall a. Ord a => a -> a -> Bool
>= Double
0                    = T -> Builder
goGeneric (Double -> T
floatToDigits Double
f)
    | Bool
otherwise                 = ByteString -> Builder
fromByteString ByteString
"NaN"
  where
   goGeneric :: T -> Builder
goGeneric p :: T
p@(T [Int]
_ Int
e)
     | Int
e forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
e forall a. Ord a => a -> a -> Bool
> Int
7 = T -> Builder
goExponent T
p
     | Bool
otherwise      = T -> Builder
goFixed    T
p
   goExponent :: T -> Builder
goExponent (T [Int]
is Int
e) =
       case [Int]
is of
         []     -> forall a. HasCallStack => [Char] -> a
error [Char]
"putFormattedFloat"
         [Int
0]    -> ByteString -> Builder
fromByteString ByteString
"0.0e0"
         [Int
d]    -> forall a. Integral a => a -> Builder
digit Int
d forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
fromByteString ByteString
".0e" forall a. Monoid a => a -> a -> a
`mappend` forall a. (Integral a, Show a) => a -> Builder
integral (Int
eforall a. Num a => a -> a -> a
-Int
1)
         (Int
d:[Int]
ds) -> forall a. Integral a => a -> Builder
digit Int
d forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
fromChar Char
'.' forall a. Monoid a => a -> a -> a
`mappend` [Int] -> Builder
digits [Int]
ds forall a. Monoid a => a -> a -> a
`mappend`
                   Char -> Builder
fromChar Char
'e' forall a. Monoid a => a -> a -> a
`mappend` forall a. (Integral a, Show a) => a -> Builder
integral (Int
eforall a. Num a => a -> a -> a
-Int
1)
   goFixed :: T -> Builder
goFixed (T [Int]
is Int
e)
       | Int
e forall a. Ord a => a -> a -> Bool
<= Int
0    = Char -> Builder
fromChar Char
'0' forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
fromChar Char
'.' forall a. Monoid a => a -> a -> a
`mappend`
                     forall a. Monoid a => [a] -> a
mconcat (forall a. Int -> a -> [a]
replicate (-Int
e) (Char -> Builder
fromChar Char
'0')) forall a. Monoid a => a -> a -> a
`mappend`
                     [Int] -> Builder
digits [Int]
is
       | Bool
otherwise = let g :: t -> [Int] -> Builder
g t
0 [Int]
rs     = Char -> Builder
fromChar Char
'.' forall a. Monoid a => a -> a -> a
`mappend` [Int] -> Builder
mk0 [Int]
rs
                         g t
n []     = Char -> Builder
fromChar Char
'0' forall a. Monoid a => a -> a -> a
`mappend` t -> [Int] -> Builder
g (t
nforall a. Num a => a -> a -> a
-t
1) []
                         g t
n (Int
r:[Int]
rs) = forall a. Integral a => a -> Builder
digit Int
r forall a. Monoid a => a -> a -> a
`mappend` t -> [Int] -> Builder
g (t
nforall a. Num a => a -> a -> a
-t
1) [Int]
rs
                     in forall {t}. (Eq t, Num t) => t -> [Int] -> Builder
g Int
e [Int]
is
   mk0 :: [Int] -> Builder
mk0 [] = Char -> Builder
fromChar Char
'0'
   mk0 [Int]
rs = [Int] -> Builder
digits [Int]
rs

digits :: [Int] -> Builder
digits :: [Int] -> Builder
digits (Int
d:[Int]
ds) = forall a. Integral a => a -> Builder
digit Int
d forall a. Monoid a => a -> a -> a
`mappend` [Int] -> Builder
digits [Int]
ds
digits [Int]
_      = forall a. Monoid a => a
mempty
{-# INLINE digits #-}

floatToDigits :: Double -> T
floatToDigits :: Double -> T
floatToDigits Double
0 = [Int] -> Int -> T
T [Int
0] Int
0
floatToDigits Double
x = [Int] -> Int -> T
T (forall a. [a] -> [a]
reverse [Int]
rds) Int
k
 where
  (Integer
f0, Int
e0)     = forall a. RealFloat a => a -> (Integer, Int)
decodeFloat Double
x
  (Int
minExp0, Int
_) = forall a. RealFloat a => a -> (Int, Int)
floatRange (forall a. HasCallStack => a
undefined::Double)
  p :: Int
p = forall a. RealFloat a => a -> Int
floatDigits Double
x
  b :: Integer
b = forall a. RealFloat a => a -> Integer
floatRadix Double
x
  minExp :: Int
minExp = Int
minExp0 forall a. Num a => a -> a -> a
- Int
p -- the real minimum exponent
  -- Haskell requires that f be adjusted so denormalized numbers
  -- will have an impossibly low exponent.  Adjust for this.
  (# Integer
f, Int
e #) =
   let n :: Int
n = Int
minExp forall a. Num a => a -> a -> a
- Int
e0 in
   if Int
n forall a. Ord a => a -> a -> Bool
> Int
0 then (# Integer
f0 forall a. Integral a => a -> a -> a
`div` (Integer
bforall a b. (Num a, Integral b) => a -> b -> a
^Int
n), Int
e0forall a. Num a => a -> a -> a
+Int
n #) else (# Integer
f0, Int
e0 #)
  (# Integer
r, Integer
s, Integer
mUp, Integer
mDn #) =
   if Int
e forall a. Ord a => a -> a -> Bool
>= Int
0
   then let be :: Integer
be = Integer
bforall a b. (Num a, Integral b) => a -> b -> a
^ Int
e
        in if Integer
f forall a. Eq a => a -> a -> Bool
== Integer
bforall a b. (Num a, Integral b) => a -> b -> a
^(Int
pforall a. Num a => a -> a -> a
-Int
1)
           then (# Integer
fforall a. Num a => a -> a -> a
*Integer
beforall a. Num a => a -> a -> a
*Integer
bforall a. Num a => a -> a -> a
*Integer
2, Integer
2forall a. Num a => a -> a -> a
*Integer
b, Integer
beforall a. Num a => a -> a -> a
*Integer
b, Integer
b #)
           else (# Integer
fforall a. Num a => a -> a -> a
*Integer
beforall a. Num a => a -> a -> a
*Integer
2, Integer
2, Integer
be, Integer
be #)
   else if Int
e forall a. Ord a => a -> a -> Bool
> Int
minExp Bool -> Bool -> Bool
&& Integer
f forall a. Eq a => a -> a -> Bool
== Integer
bforall a b. (Num a, Integral b) => a -> b -> a
^(Int
pforall a. Num a => a -> a -> a
-Int
1)
        then (# Integer
fforall a. Num a => a -> a -> a
*Integer
bforall a. Num a => a -> a -> a
*Integer
2, Integer
bforall a b. (Num a, Integral b) => a -> b -> a
^(-Int
eforall a. Num a => a -> a -> a
+Int
1)forall a. Num a => a -> a -> a
*Integer
2, Integer
b, Integer
1 #)
        else (# Integer
fforall a. Num a => a -> a -> a
*Integer
2, Integer
bforall a b. (Num a, Integral b) => a -> b -> a
^(-Int
e)forall a. Num a => a -> a -> a
*Integer
2, Integer
1, Integer
1 #)
  k :: Int
k = Int -> Int
fixup Int
k0
   where
    k0 :: Int
k0 | Integer
b forall a. Eq a => a -> a -> Bool
== Integer
2 = (Int
p forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
+ Int
e0) forall a. Num a => a -> a -> a
* Int
3 forall a. Integral a => a -> a -> a
`div` Int
10
        -- logBase 10 2 is slightly bigger than 3/10 so the following
        -- will err on the low side.  Ignoring the fraction will make
        -- it err even more.  Haskell promises that p-1 <= logBase b f
        -- < p.
       | Bool
otherwise = forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((forall a. Floating a => a -> a
log (forall a. Num a => Integer -> a
fromInteger (Integer
fforall a. Num a => a -> a -> a
+Integer
1) :: Double) forall a. Num a => a -> a -> a
+
                               forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
e forall a. Num a => a -> a -> a
* forall a. Floating a => a -> a
log (forall a. Num a => Integer -> a
fromInteger Integer
b)) forall a. Fractional a => a -> a -> a
/ forall a. Floating a => a -> a
log Double
10)
    fixup :: Int -> Int
fixup Int
n
      | Int
n forall a. Ord a => a -> a -> Bool
>= Int
0    = if Integer
r forall a. Num a => a -> a -> a
+ Integer
mUp forall a. Ord a => a -> a -> Bool
<= Int -> Integer
exp10 Int
n forall a. Num a => a -> a -> a
* Integer
s then Int
n else Int -> Int
fixup (Int
nforall a. Num a => a -> a -> a
+Int
1)
      | Bool
otherwise = if Int -> Integer
exp10 (-Int
n) forall a. Num a => a -> a -> a
* (Integer
r forall a. Num a => a -> a -> a
+ Integer
mUp) forall a. Ord a => a -> a -> Bool
<= Integer
s then Int
n else Int -> Int
fixup (Int
nforall a. Num a => a -> a -> a
+Int
1)

  gen :: [a] -> Integer -> Integer -> Integer -> Integer -> [a]
gen [a]
ds !Integer
rn !Integer
sN !Integer
mUpN !Integer
mDnN =
   let (Integer
dn0, Integer
rn') = (Integer
rn forall a. Num a => a -> a -> a
* Integer
10) forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
sN
       mUpN' :: Integer
mUpN' = Integer
mUpN forall a. Num a => a -> a -> a
* Integer
10
       mDnN' :: Integer
mDnN' = Integer
mDnN forall a. Num a => a -> a -> a
* Integer
10
       !dn :: a
dn   = forall a. Num a => Integer -> a
fromInteger Integer
dn0
       !dn' :: a
dn'  = a
dn forall a. Num a => a -> a -> a
+ a
1
   in case (# Integer
rn' forall a. Ord a => a -> a -> Bool
< Integer
mDnN', Integer
rn' forall a. Num a => a -> a -> a
+ Integer
mUpN' forall a. Ord a => a -> a -> Bool
> Integer
sN #) of
        (# Bool
True,  Bool
False #) -> a
dn forall a. a -> [a] -> [a]
: [a]
ds
        (# Bool
False, Bool
True #)  -> a
dn' forall a. a -> [a] -> [a]
: [a]
ds
        (# Bool
True,  Bool
True #)  -> if Integer
rn' forall a. Num a => a -> a -> a
* Integer
2 forall a. Ord a => a -> a -> Bool
< Integer
sN then a
dn forall a. a -> [a] -> [a]
: [a]
ds else a
dn' forall a. a -> [a] -> [a]
: [a]
ds
        (# Bool
False, Bool
False #) -> [a] -> Integer -> Integer -> Integer -> Integer -> [a]
gen (a
dnforall a. a -> [a] -> [a]
:[a]
ds) Integer
rn' Integer
sN Integer
mUpN' Integer
mDnN'

  rds :: [Int]
rds | Int
k forall a. Ord a => a -> a -> Bool
>= Int
0    = forall {a}.
Num a =>
[a] -> Integer -> Integer -> Integer -> Integer -> [a]
gen [] Integer
r (Integer
s forall a. Num a => a -> a -> a
* Int -> Integer
exp10 Int
k) Integer
mUp Integer
mDn
      | Bool
otherwise = forall {a}.
Num a =>
[a] -> Integer -> Integer -> Integer -> Integer -> [a]
gen [] (Integer
r forall a. Num a => a -> a -> a
* Integer
bk) Integer
s (Integer
mUp forall a. Num a => a -> a -> a
* Integer
bk) (Integer
mDn forall a. Num a => a -> a -> a
* Integer
bk)
      where bk :: Integer
bk = Int -> Integer
exp10 (-Int
k)
                    
exp10 :: Int -> Integer
exp10 :: Int -> Integer
exp10 Int
n
    | Int
n forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
n forall a. Ord a => a -> a -> Bool
< Int
maxExpt = forall a. Vector a -> Int -> a
V.unsafeIndex Vector Integer
expts Int
n
    | Bool
otherwise             = Integer
10 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
n
  where expts :: Vector Integer
expts = forall a. Int -> (Int -> a) -> Vector a
V.generate Int
maxExpt (Integer
10forall a b. (Num a, Integral b) => a -> b -> a
^)
        {-# NOINLINE expts #-}
        maxExpt :: Int
maxExpt = Int
17
{-# INLINE exp10 #-}