Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

266 lines (236 sloc) 9.373 kb
{-# LANGUAGE BangPatterns, CPP, MagicHash, RankNTypes, ScopedTypeVariables,
UnboxedTuples #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
-- Module: Data.Text.Lazy.Builder.Int
-- Copyright: (c) 2013 Bryan O'Sullivan
-- (c) 2011 MailRank, Inc.
-- License: BSD3
-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>
-- Stability: experimental
-- Portability: portable
--
-- Efficiently write an integral value to a 'Builder'.
module Data.Text.Lazy.Builder.Int
(
decimal
, hexadecimal
) where
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Monoid (mempty)
import qualified Data.ByteString.Unsafe as B
import Data.Text.Internal.Builder.Functions ((<>), i2d)
import Data.Text.Internal.Builder
import Data.Text.Internal.Builder.Int.Digits (digits)
import Data.Text.Array
import Data.Word (Word, Word8, Word16, Word32, Word64)
import GHC.Base (quotInt, remInt)
import GHC.Num (quotRemInteger)
import GHC.Types (Int(..))
import Control.Monad.ST
#ifdef __GLASGOW_HASKELL__
# if defined(INTEGER_GMP)
import GHC.Integer.GMP.Internals
# elif defined(INTEGER_SIMPLE)
import GHC.Integer
# else
# error "You need to use either GMP or integer-simple."
# endif
#endif
#if defined(INTEGER_GMP) || defined(INTEGER_SIMPLE)
# define PAIR(a,b) (# a,b #)
#else
# define PAIR(a,b) (a,b)
#endif
decimal :: Integral a => a -> Builder
{-# RULES "decimal/Int8" decimal = boundedDecimal :: Int8 -> Builder #-}
{-# RULES "decimal/Int" decimal = boundedDecimal :: Int -> Builder #-}
{-# RULES "decimal/Int16" decimal = boundedDecimal :: Int16 -> Builder #-}
{-# RULES "decimal/Int32" decimal = boundedDecimal :: Int32 -> Builder #-}
{-# RULES "decimal/Int64" decimal = boundedDecimal :: Int64 -> Builder #-}
{-# RULES "decimal/Word" decimal = positive :: Word -> Builder #-}
{-# RULES "decimal/Word8" decimal = positive :: Word8 -> Builder #-}
{-# RULES "decimal/Word16" decimal = positive :: Word16 -> Builder #-}
{-# RULES "decimal/Word32" decimal = positive :: Word32 -> Builder #-}
{-# RULES "decimal/Word64" decimal = positive :: Word64 -> Builder #-}
{-# RULES "decimal/Integer" decimal = integer 10 :: Integer -> Builder #-}
decimal i = decimal' (<= -128) i
{-# NOINLINE decimal #-}
boundedDecimal :: (Integral a, Bounded a) => a -> Builder
{-# SPECIALIZE boundedDecimal :: Int -> Builder #-}
{-# SPECIALIZE boundedDecimal :: Int8 -> Builder #-}
{-# SPECIALIZE boundedDecimal :: Int16 -> Builder #-}
{-# SPECIALIZE boundedDecimal :: Int32 -> Builder #-}
{-# SPECIALIZE boundedDecimal :: Int64 -> Builder #-}
boundedDecimal i = decimal' (== minBound) i
decimal' :: (Integral a) => (a -> Bool) -> a -> Builder
{-# INLINE decimal' #-}
decimal' p i
| i < 0 = if p i
then let (q, r) = i `quotRem` 10
qq = -q
!n = countDigits qq
in writeN (n + 2) $ \marr off -> do
unsafeWrite marr off minus
posDecimal marr (off+1) n qq
unsafeWrite marr (off+n+1) (i2w (-r))
else let j = -i
!n = countDigits j
in writeN (n + 1) $ \marr off ->
unsafeWrite marr off minus >> posDecimal marr (off+1) n j
| otherwise = positive i
positive :: (Integral a) => a -> Builder
{-# SPECIALIZE positive :: Int -> Builder #-}
{-# SPECIALIZE positive :: Int8 -> Builder #-}
{-# SPECIALIZE positive :: Int16 -> Builder #-}
{-# SPECIALIZE positive :: Int32 -> Builder #-}
{-# SPECIALIZE positive :: Int64 -> Builder #-}
{-# SPECIALIZE positive :: Word -> Builder #-}
{-# SPECIALIZE positive :: Word8 -> Builder #-}
{-# SPECIALIZE positive :: Word16 -> Builder #-}
{-# SPECIALIZE positive :: Word32 -> Builder #-}
{-# SPECIALIZE positive :: Word64 -> Builder #-}
positive i
| i < 10 = writeN 1 $ \marr off -> unsafeWrite marr off (i2w i)
| otherwise = let !n = countDigits i
in writeN n $ \marr off -> posDecimal marr off n i
posDecimal :: (Integral a) =>
forall s. MArray s -> Int -> Int -> a -> ST s ()
{-# INLINE posDecimal #-}
posDecimal marr off0 ds v0 = go (off0 + ds - 1) v0
where go off v
| v >= 100 = do
let (q, r) = v `quotRem` 100
write2 off r
go (off - 2) q
| v < 10 = unsafeWrite marr off (i2w v)
| otherwise = write2 off v
write2 off i0 = do
let i = fromIntegral i0; j = i + i
unsafeWrite marr off $ get (j + 1)
unsafeWrite marr (off - 1) $ get j
get = fromIntegral . B.unsafeIndex digits
minus, zero :: Word16
{-# INLINE minus #-}
{-# INLINE zero #-}
minus = 45
zero = 48
i2w :: (Integral a) => a -> Word16
{-# INLINE i2w #-}
i2w v = zero + fromIntegral v
countDigits :: (Integral a) => a -> Int
{-# INLINE countDigits #-}
countDigits v0
| fromIntegral v64 == v0 = go 1 v64
| otherwise = goBig 1 (fromIntegral v0)
where v64 = fromIntegral v0
goBig !k (v :: Integer)
| v > big = goBig (k + 19) (v `quot` big)
| otherwise = go k (fromIntegral v)
big = 10000000000000000000
go !k (v :: Word64)
| v < 10 = k
| v < 100 = k + 1
| v < 1000 = k + 2
| v < 1000000000000 =
k + if v < 100000000
then if v < 1000000
then if v < 10000
then 3
else 4 + fin v 100000
else 6 + fin v 10000000
else if v < 10000000000
then 8 + fin v 1000000000
else 10 + fin v 100000000000
| otherwise = go (k + 12) (v `quot` 1000000000000)
fin v n = if v >= n then 1 else 0
hexadecimal :: Integral a => a -> Builder
{-# SPECIALIZE hexadecimal :: Int -> Builder #-}
{-# SPECIALIZE hexadecimal :: Int8 -> Builder #-}
{-# SPECIALIZE hexadecimal :: Int16 -> Builder #-}
{-# SPECIALIZE hexadecimal :: Int32 -> Builder #-}
{-# SPECIALIZE hexadecimal :: Int64 -> Builder #-}
{-# SPECIALIZE hexadecimal :: Word -> Builder #-}
{-# SPECIALIZE hexadecimal :: Word8 -> Builder #-}
{-# SPECIALIZE hexadecimal :: Word16 -> Builder #-}
{-# SPECIALIZE hexadecimal :: Word32 -> Builder #-}
{-# SPECIALIZE hexadecimal :: Word64 -> Builder #-}
{-# RULES "hexadecimal/Integer"
hexadecimal = hexInteger :: Integer -> Builder #-}
hexadecimal i
| i < 0 = error hexErrMsg
| otherwise = go i
where
go n | n < 16 = hexDigit n
| otherwise = go (n `quot` 16) <> hexDigit (n `rem` 16)
{-# NOINLINE[0] hexadecimal #-}
hexInteger :: Integer -> Builder
hexInteger i
| i < 0 = error hexErrMsg
| otherwise = integer 16 i
hexErrMsg :: String
hexErrMsg = "Data.Text.Lazy.Builder.Int.hexadecimal: applied to negative number"
hexDigit :: Integral a => a -> Builder
hexDigit n
| n <= 9 = singleton $! i2d (fromIntegral n)
| otherwise = singleton $! toEnum (fromIntegral n + 87)
{-# INLINE hexDigit #-}
data T = T !Integer !Int
integer :: Int -> Integer -> Builder
#ifdef INTEGER_GMP
integer 10 (S# i#) = decimal (I# i#)
integer 16 (S# i#) = hexadecimal (I# i#)
#else
integer 10 i = decimal i
integer 16 i = hexadecimal i
#endif
integer base i
| i < 0 = singleton '-' <> 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 _ _ = []
T maxInt10 maxDigits10 =
until ((>mi) . (*10) . fstT) (\(T n d) -> T (n*10) (d+1)) (T 10 1)
where mi = fromIntegral (maxBound :: Int)
T maxInt16 maxDigits16 =
until ((>mi) . (*16) . fstT) (\(T n d) -> T (n*16) (d+1)) (T 16 1)
where mi = fromIntegral (maxBound :: Int)
fstT (T a _) = a
maxInt | base == 10 = maxInt10
| otherwise = maxInt16
maxDigits | base == 10 = maxDigits10
| otherwise = maxDigits16
putH (n:ns) = case n `quotRemInteger` maxInt of
PAIR(x,y)
| q > 0 -> int q <> pblock r <> putB ns
| otherwise -> int r <> putB ns
where q = fromInteger x
r = fromInteger y
putH _ = error "putH: the impossible happened"
putB (n:ns) = case n `quotRemInteger` maxInt of
PAIR(x,y) -> pblock q <> pblock r <> putB ns
where q = fromInteger x
r = fromInteger y
putB _ = mempty
int :: Int -> Builder
int x | base == 10 = decimal x
| otherwise = hexadecimal x
pblock = loop maxDigits
where
loop !d !n
| d == 1 = hexDigit n
| otherwise = loop (d-1) q <> hexDigit r
where q = n `quotInt` base
r = n `remInt` base
Jump to Line
Something went wrong with that request. Please try again.