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

-- | This module is designed to provide a shim for @blaze-textual@.
-- @blaze-textual@ does not support GHC 9. A PR has been opened to add that
-- support for GHC 9 here: https://github.com/bos/blaze-textual/pull/14
--
-- When GHC 9 support is merged in, we can delete the CPP in this and
-- re-export the blaze functions directly, which is what we do for older
-- versions of base.
module Database.MySQL.Internal.Blaze
    ( integral
    , double
    , float
    ) where

#if MIN_VERSION_base(4,15,0)

#define PAIR(a,b) (# a,b #)

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

import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char8
import Data.ByteString.Char8 ()
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Monoid (mappend, mempty)
import Data.Word (Word, Word8, Word16, Word32, Word64)
import GHC.Base (quotInt, remInt)
import GHC.Num (quotRemInteger)
-- import GHC.Types (Int(..))

#if defined(INTEGER_GMP)
import GHC.Integer.GMP.Internals
#elif defined(INTEGER_SIMPLE)
import GHC.Integer.Simple.Internals
#endif

minus :: Builder
minus = fromWord8 45
data TInt = TInt !Integer !Int
putH :: [Integer] -> Builder
putH (n:ns) = case n `quotRemInteger` maxInt of
                PAIR(x,y)
                    | q > 0     -> int q `mappend` pblock r `mappend` putB ns
                    | otherwise -> int r `mappend` putB ns
                    where q = fromInteger x
                          r = fromInteger y
putH _ = error "putH: the impossible happened"
int :: Int -> Builder
int = integral
{-# INLINE int #-}
fstT :: TInt -> Integer
fstT (TInt a _) = a
maxInt :: Integer
maxDigits :: Int
TInt maxInt maxDigits =
    until ((>mi) . (*10) . fstT) (\(TInt n d) -> TInt (n*10) (d+1)) (TInt 10 1)
  where mi = fromIntegral (maxBound :: Int)
integral :: (Integral a, Show a) => a -> Builder
{-# RULES "integral/Int" integral = bounded :: Int -> Builder #-}
{-# RULES "integral/Int8" integral = bounded :: Int8 -> Builder #-}
{-# RULES "integral/Int16" integral = bounded :: Int16 -> Builder #-}
{-# RULES "integral/Int32" integral = bounded :: Int32 -> Builder #-}
{-# RULES "integral/Int64" integral = bounded :: Int64 -> Builder #-}
{-# RULES "integral/Word" integral = nonNegative :: Word -> Builder #-}
{-# RULES "integral/Word8" integral = nonNegative :: Word8 -> Builder #-}
{-# RULES "integral/Word16" integral = nonNegative :: Word16 -> Builder #-}
{-# RULES "integral/Word32" integral = nonNegative :: Word32 -> Builder #-}
{-# RULES "integral/Word64" integral = nonNegative :: Word64 -> Builder #-}
{-# RULES "integral/Integer" integral = integer :: Integer -> Builder #-}

-- This definition of the function is here PURELY to be used by ghci
-- and those rare cases where GHC is being invoked without
-- optimization, as otherwise the rewrite rules above should fire. The
-- test for "-0" catches an overflow if we render minBound.
integral i
    | i >= 0                 = nonNegative i
    | toByteString b == "-0" = fromString (show i)
    | otherwise              = b
  where b = minus `mappend` nonNegative (-i)

{-# NOINLINE integral #-}

pblock :: Int -> Builder
pblock = go maxDigits
  where
    go !d !n
        | d == 1    = digit n
        | otherwise = go (d-1) q `mappend` digit r
        where q = n `quotInt` 10
              r = n `remInt` 10

putB :: [Integer] -> Builder
putB (n:ns) = case n `quotRemInteger` maxInt of
                PAIR(x,y) -> pblock q `mappend` pblock r `mappend` putB ns
                    where q = fromInteger x
                          r = fromInteger y
putB _ = mempty

bounded :: (Bounded a, Integral a) => a -> Builder
{-# SPECIALIZE bounded :: Int -> Builder #-}
{-# SPECIALIZE bounded :: Int8 -> Builder #-}
{-# SPECIALIZE bounded :: Int16 -> Builder #-}
{-# SPECIALIZE bounded :: Int32 -> Builder #-}
{-# SPECIALIZE bounded :: Int64 -> Builder #-}
bounded i
    | i >= 0        = nonNegative i
    | i > minBound  = minus `mappend` nonNegative (-i)
    | otherwise     = minus `mappend`
                      nonNegative (negate (k `quot` 10)) `mappend`
                      digit (negate (k `rem` 10))
  where k = minBound `asTypeOf` i

nonNegative :: Integral a => a -> Builder
{-# SPECIALIZE nonNegative :: Int -> Builder #-}
{-# SPECIALIZE nonNegative :: Int8 -> Builder #-}
{-# SPECIALIZE nonNegative :: Int16 -> Builder #-}
{-# SPECIALIZE nonNegative :: Int32 -> Builder #-}
{-# SPECIALIZE nonNegative :: Int64 -> Builder #-}
{-# SPECIALIZE nonNegative :: Word -> Builder #-}
{-# SPECIALIZE nonNegative :: Word8 -> Builder #-}
{-# SPECIALIZE nonNegative :: Word16 -> Builder #-}
{-# SPECIALIZE nonNegative :: Word32 -> Builder #-}
{-# SPECIALIZE nonNegative :: Word64 -> Builder #-}
nonNegative = go
  where
    go n | n < 10    = digit n
         | otherwise = go (n `quot` 10) `mappend` digit (n `rem` 10)

digit :: Integral a => a -> Builder
digit n = fromWord8 $! fromIntegral n + 48
{-# INLINE digit #-}

integer :: Integer -> Builder
#if defined(INTEGER_GMP)
integer (S# i#) = int (I# i#)
#endif
integer i
    | i < 0     = minus `mappend` go (-i)
    | otherwise = go i
  where
    go n | n < maxInt = int (fromInteger n)
         | otherwise  = putH (splitf (maxInt * maxInt) n)

    splitf p n
      | p > n       = [n]
      | otherwise   = splith p (splitf (p*p) n)

    splith p (n:ns) = case n `quotRemInteger` p of
                        PAIR(q,r) | q > 0     -> q : r : splitb p ns
                                  | otherwise -> r : splitb p ns
    splith _ _      = error "splith: the impossible happened."

    splitb p (n:ns) = case n `quotRemInteger` p of
                        PAIR(q,r) -> q : r : splitb p ns
    splitb _ _      = []


-- 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 #-}




#else

import Blaze.Text (integral, double, float)

#endif