{-# 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 (Double -> Builder) -> (Float -> Double) -> Float -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac

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

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

floatToDigits :: Double -> T
floatToDigits :: Double -> T
floatToDigits 0 = [Int] -> Int -> T
T [0] 0
floatToDigits x :: Double
x = [Int] -> Int -> T
T ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
rds) Int
k
 where
  (f0 :: Integer
f0, e0 :: Int
e0)     = Double -> (Integer, Int)
forall a. RealFloat a => a -> (Integer, Int)
decodeFloat Double
x
  (minExp0 :: Int
minExp0, _) = Double -> (Int, Int)
forall a. RealFloat a => a -> (Int, Int)
floatRange (Double
forall a. HasCallStack => a
undefined::Double)
  p :: Int
p = Double -> Int
forall a. RealFloat a => a -> Int
floatDigits Double
x
  b :: Integer
b = Double -> Integer
forall a. RealFloat a => a -> Integer
floatRadix Double
x
  minExp :: Int
minExp = Int
minExp0 Int -> Int -> Int
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.
  (# f :: Integer
f, e :: Int
e #) =
   let n :: Int
n = Int
minExp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
e0 in
   if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 then (# Integer
f0 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` (Integer
bInteger -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Int
n), Int
e0Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n #) else (# Integer
f0, Int
e0 #)
  (# r :: Integer
r, s :: Integer
s, mUp :: Integer
mUp, mDn :: Integer
mDn #) =
   if Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0
   then let be :: Integer
be = Integer
bInteger -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
e
        in if Integer
f Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
bInteger -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
pInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
           then (# Integer
fInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
beInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
bInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*2, 2Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
b, Integer
beInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
b, Integer
b #)
           else (# Integer
fInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
beInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*2, 2, Integer
be, Integer
be #)
   else if Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
minExp Bool -> Bool -> Bool
&& Integer
f Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
bInteger -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
pInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
        then (# Integer
fInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
bInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*2, Integer
bInteger -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(-Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*2, Integer
b, 1 #)
        else (# Integer
fInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*2, Integer
bInteger -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(-Int
e)Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*2, 1, 1 #)
  k :: Int
k = Int -> Int
fixup Int
k0
   where
    k0 :: Int
k0 | Integer
b Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 2 = (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
e0) Int -> Int -> Int
forall a. Num a => a -> a -> a
* 3 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 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 = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((Double -> Double
forall a. Floating a => a -> a
log (Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Integer
fInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+1) :: Double) Double -> Double -> Double
forall a. Num a => a -> a -> a
+
                               Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
e Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
log (Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
b)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double
forall a. Floating a => a -> a
log 10)
    fixup :: Int -> Int
fixup n :: Int
n
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0    = if Integer
r Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
mUp Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Int -> Integer
exp10 Int
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
s then Int
n else Int -> Int
fixup (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
      | Bool
otherwise = if Int -> Integer
exp10 (-Int
n) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* (Integer
r Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
mUp) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
s then Int
n else Int -> Int
fixup (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)

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

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