    {-# 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 = double . realToFrac

    double :: Double -> Builder
    double f
        | isInfinite f              = fromByteString $
                                      if f > 0 then "Infinity" else "-Infinity"
        | f < 0 || isNegativeZero f = minus `mappend` goGeneric (floatToDigits (-f))
        | f >= 0                    = goGeneric (floatToDigits f)
        | otherwise                 = fromByteString "NaN"
      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 (e-1)
             (d:ds) -> digit d `mappend` fromChar '.' `mappend` digits ds `mappend`
                       fromChar 'e' `mappend` integral (e-1)
       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 (n-1) []
                             g n (r:rs) = digit r `mappend` g (n-1) 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
    {-# INLINE digits #-}

    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 -- the real minimum exponent
      -- Haskell requires that f be adjusted so denormalized numbers
      -- will have an impossibly low exponent.  Adjust for this.
      (# 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^(p-1)
               then (# f*be*b*2, 2*b, be*b, b #)
               else (# f*be*2, 2, be, be #)
       else if e > minExp && f == b^(p-1)
            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
            -- 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.
           | 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^)
            {-# NOINLINE expts #-}
            maxExpt = 17
    {-# INLINE exp10 #-}