module Blaze.Text.Double
(
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
data T = T [Int] !Int
float :: Float -> Builder
float = double . fromRational . toRational
double :: Double -> Builder
double f
| isNaN f || isInfinite f = fromByteString "null"
| f < 0 || isNegativeZero f = minus `mappend` goGeneric (floatToDigits (f))
| otherwise = goGeneric (floatToDigits f)
where
goGeneric p@(T _ e)
| e < 0 || e > 7 = goExponent p
| otherwise = goFixed p
goExponent (T is e) =
case is of
[] -> error "putFormattedFloat"
[0] -> fromByteString "0.0e0"
[d] -> digit d `mappend` fromByteString ".0e" `mappend` integral (e1)
(d:ds) -> digit d `mappend` fromChar '.' `mappend` digits ds `mappend`
fromChar 'e' `mappend` integral (e1)
goFixed (T is e)
| e <= 0 = fromChar '0' `mappend` fromChar '.' `mappend`
mconcat (replicate (e) (fromChar '0')) `mappend`
digits is
| otherwise = let g 0 rs = fromChar '.' `mappend` mk0 rs
g n [] = fromChar '0' `mappend` g (n1) []
g n (r:rs) = digit r `mappend` g (n1) rs
in g e is
mk0 [] = fromChar '0'
mk0 rs = digits rs
digits :: [Int] -> Builder
digits (d:ds) = digit d `mappend` digits ds
digits _ = mempty
floatToDigits :: Double -> T
floatToDigits 0 = T [0] 0
floatToDigits x = T (reverse rds) k
where
(f0, e0) = decodeFloat x
(minExp0, _) = floatRange (undefined::Double)
p = floatDigits x
b = floatRadix x
minExp = minExp0 p
(# f, e #) =
let n = minExp e0 in
if n > 0 then (# f0 `div` (b^n), e0+n #) else (# f0, e0 #)
(# r, s, mUp, mDn #) =
if e >= 0
then let be = b^ e
in if f == b^(p1)
then (# f*be*b*2, 2*b, be*b, b #)
else (# f*be*2, 2, be, be #)
else if e > minExp && f == b^(p1)
then (# f*b*2, b^(e+1)*2, b, 1 #)
else (# f*2, b^(e)*2, 1, 1 #)
k = fixup k0
where
k0 | b == 2 = (p 1 + e0) * 3 `div` 10
| otherwise = ceiling ((log (fromInteger (f+1) :: Double) +
fromIntegral e * log (fromInteger b)) / log 10)
fixup n
| n >= 0 = if r + mUp <= exp10 n * s then n else fixup (n+1)
| otherwise = if exp10 (n) * (r + mUp) <= s then n else fixup (n+1)
gen ds !rn !sN !mUpN !mDnN =
let (dn0, rn') = (rn * 10) `divMod` sN
mUpN' = mUpN * 10
mDnN' = mDnN * 10
!dn = fromInteger dn0
!dn' = dn + 1
in case (# rn' < mDnN', rn' + mUpN' > sN #) of
(# True, False #) -> dn : ds
(# False, True #) -> dn' : ds
(# True, True #) -> if rn' * 2 < sN then dn : ds else dn' : ds
(# False, False #) -> gen (dn:ds) rn' sN mUpN' mDnN'
rds | k >= 0 = gen [] r (s * exp10 k) mUp mDn
| otherwise = gen [] (r * bk) s (mUp * bk) (mDn * bk)
where bk = exp10 (k)
exp10 :: Int -> Integer
exp10 n
| n >= 0 && n < maxExpt = V.unsafeIndex expts n
| otherwise = 10 ^ n
where expts = V.generate maxExpt (10^)
maxExpt = 17