{-# 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 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
> Double
0 then ByteString
"Infinity" else ByteString
"-Infinity"
    | Double
f Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
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
>= 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
e Int -> Int -> Bool
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
         []     -> [Char] -> Builder
forall a. HasCallStack => [Char] -> a
error [Char]
"putFormattedFloat"
         [Int
0]    -> ByteString -> Builder
fromByteString ByteString
"0.0e0"
         [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 ByteString
".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
-Int
1)
         (Int
d:[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 Char
'.' 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 Char
'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
-Int
1)
   goFixed :: T -> Builder
goFixed (T [Int]
is Int
e)
       | Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = Char -> Builder
fromChar Char
'0' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` Char -> Builder
fromChar Char
'.' 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 Char
'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 a
0 [Int]
rs     = Char -> Builder
fromChar Char
'.' Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` [Int] -> Builder
mk0 [Int]
rs
                         g a
n []     = Char -> Builder
fromChar Char
'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
-a
1) []
                         g a
n (Int
r:[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
-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 Char
'0'
   mk0 [Int]
rs = [Int] -> Builder
digits [Int]
rs

digits :: [Int] -> Builder
digits :: [Int] -> Builder
digits (Int
d:[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 [Int]
_      = Builder
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 ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
rds) Int
k
 where
  (Integer
f0, Int
e0)     = Double -> (Integer, Int)
forall a. RealFloat a => a -> (Integer, Int)
decodeFloat Double
x
  (Int
minExp0, Int
_) = 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.
  (# Integer
f, 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
> Int
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 #)
  (# Integer
r, Integer
s, Integer
mUp, Integer
mDn #) =
   if Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
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
-Int
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
*Integer
2, Integer
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
*Integer
2, Integer
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
-Int
1)
        then (# Integer
fInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
bInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
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
+Int
1)Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
2, Integer
b, Integer
1 #)
        else (# Integer
fInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
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
*Integer
2, Integer
1, Integer
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
== Integer
2 = (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
e0) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3 Int -> Int -> Int
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 = 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
+Integer
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 Double
10)
    fixup :: Int -> Int
fixup Int
n
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
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
+Int
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
+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 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
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
* Integer
10
       mDnN' :: Integer
mDnN' = Integer
mDnN Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
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
+ 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
        (# Bool
True,  Bool
False #) -> a
dn a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ds
        (# Bool
False, Bool
True #)  -> a
dn' a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ds
        (# Bool
True,  Bool
True #)  -> if Integer
rn' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
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
        (# Bool
False, Bool
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
>= Int
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 Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
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             = Integer
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 (Integer
10Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^)
        {-# NOINLINE expts #-}
        maxExpt :: Int
maxExpt = Int
17
{-# INLINE exp10 #-}