@@ -0,0 +1,125 @@
1+{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}
2+
3+-- Module: Data.Aeson.Encode.Number
4+-- Copyright: (c) 2011 MailRank, Inc.
5+-- License: Apache
6+-- Maintainer: Bryan O'Sullivan <bos@mailrank.com>
7+-- Stability: experimental
8+-- Portability: portable
9+--
10+-- Efficiently serialize a numeric JSON value as a lazy 'L.ByteString'.
11+
12+module Data.Aeson.Encode.Number
13+ (
14+ fromNumber
15+ ) where
16+
17+import Data.Monoid (mappend, mempty)
18+import Data.Attoparsec.Number (Number(..))
19+import Blaze.ByteString.Builder
20+import GHC.Num (quotRemInt, quotRemInteger)
21+import GHC.Types (Int(..))
22+import qualified Text.Show.ByteString as S
23+
24+#ifdef __GLASGOW_HASKELL__
25+# if __GLASGOW_HASKELL__ < 611
26+import GHC.Integer.Internals
27+# else
28+import GHC.Integer.GMP.Internals
29+# endif
30+#endif
31+
32+fromNumber :: Number -> Builder
33+fromNumber (I i) = integer i
34+fromNumber (D d) = fromLazyByteString (S.show d)
35+
36+integer :: Integer -> Builder
37+integer (S# i#) = int (I# i#)
38+integer i
39+ | i < 0 = fromWord8 45 `mappend` go (-i)
40+ | otherwise = go i
41+ where
42+ go n | n < maxInt = int (fromInteger n)
43+ | otherwise = putH (splitf (maxInt * maxInt) n)
44+
45+ splitf :: Integer -> Integer -> [Integer]
46+ splitf p n
47+ | p > n = [n]
48+ | otherwise = splith p (splitf (p*p) n)
49+
50+ splith :: Integer -> [Integer] -> [Integer]
51+ splith _ [ ] = error "splith: the impossible happened."
52+ splith p (n:ns) = case n `quotRemInteger` p of
53+#ifdef INTEGER_GMP
54+ (# q, r #) ->
55+#else
56+ (q, r) ->
57+#endif
58+ if q > 0
59+ then q : r : splitb p ns
60+ else r : splitb p ns
61+ splitb :: Integer -> [Integer] -> [Integer]
62+ splitb _ [ ] = []
63+ splitb p (n:ns) = case n `quotRemInteger` p of
64+#ifdef INTEGER_GMP
65+ (# q, r #) ->
66+#else
67+ (q, r) ->
68+#endif
69+ q : r : splitb p ns
70+
71+int :: Int -> Builder
72+int i
73+ | i < 0 = fromWord8 45 `mappend` go (-i)
74+ | otherwise = go i
75+ where
76+ go n | n < 10 = digit n
77+ | otherwise = go (n `rem` 10) `mappend` digit (n `quot` 10)
78+
79+digit :: Int -> Builder
80+digit n = fromWord8 (fromIntegral n + 48)
81+
82+data T = T !Integer !Int
83+
84+fstT :: T -> Integer
85+fstT (T a _) = a
86+
87+maxInt :: Integer
88+maxDigits :: Int
89+T maxInt maxDigits =
90+ until ((>mi) . (*10) . fstT) (\(T n d) -> T (n*10) (d+1)) (T 10 1)
91+ where mi = fromIntegral (maxBound :: Int)
92+
93+putH :: [Integer] -> Builder
94+putH (n:ns) = case n `quotRemInteger` maxInt of
95+#ifdef INTEGER_GMP
96+ (# q', r' #) ->
97+#else
98+ (q', r') ->
99+#endif
100+ let q = fromInteger q'
101+ r = fromInteger r'
102+ in if q > 0
103+ then int q `mappend` pblock r `mappend` putB ns
104+ else int r `mappend` putB ns
105+putH _ = error "putH: the impossible happened"
106+
107+putB :: [Integer] -> Builder
108+putB (n:ns) = case n `quotRemInteger` maxInt of
109+#ifdef INTEGER_GMP
110+ (# q', r' #) ->
111+#else
112+ (q', r') ->
113+#endif
114+ let q = fromInteger q'
115+ r = fromInteger r'
116+ in pblock q `mappend` pblock r `mappend` putB ns
117+putB _ = mempty
118+
119+pblock :: Int -> Builder
120+pblock = go maxDigits
121+ where
122+ go !d !n
123+ | d == 1 = digit n
124+ | otherwise = go (d-1) q `mappend` digit r
125+ where (q, r) = n `quotRemInt` 10