1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE NoImplicitPrelude #-}
3{-# LANGUAGE TupleSections #-}
4-- |
5-- Module:      Data.Aeson.Encoding.Builder
6-- Copyright:   (c) 2011 MailRank, Inc.
7--              (c) 2013 Simon Meier <iridcode@gmail.com>
8-- License:     BSD3
9-- Maintainer:  Bryan O'Sullivan <bos@serpentine.com>
10-- Stability:   experimental
11-- Portability: portable
12--
13-- Efficiently serialize a JSON value using the UTF-8 encoding.
14
15module Data.Aeson.Encoding.Builder
16    (
17      encodeToBuilder
18    , null_
19    , bool
20    , array
21    , emptyArray_
22    , emptyObject_
23    , object
24    , text
25    , string
26    , unquoted
27    , quote
28    , scientific
29    , day
30    , localTime
31    , utcTime
32    , timeOfDay
33    , zonedTime
34    , ascii2
35    , ascii4
36    , ascii5
37    ) where
38
39import Prelude.Compat
40
41import Data.Aeson.Internal.Time
42import Data.Aeson.Types.Internal (Value (..))
43import Data.ByteString.Builder as B
44import Data.ByteString.Builder.Prim as BP
45import Data.ByteString.Builder.Scientific (scientificBuilder)
46import Data.Char (chr, ord)
47import Data.Scientific (Scientific, base10Exponent, coefficient)
48import Data.Text.Encoding (encodeUtf8BuilderEscaped)
49import Data.Time (UTCTime(..))
50import Data.Time.Calendar (Day(..), toGregorian)
51import Data.Time.LocalTime
52import Data.Word (Word8)
53import qualified Data.HashMap.Strict as HMS
54import qualified Data.Text as T
55import qualified Data.Vector as V
56
57-- | Encode a JSON value to a "Data.ByteString" 'B.Builder'.
58--
59-- Use this function if you are encoding over the wire, or need to
60-- prepend or append further bytes to the encoded JSON value.
61encodeToBuilder :: Value -> Builder
62encodeToBuilder Null       = null_
63encodeToBuilder (Bool b)   = bool b
64encodeToBuilder (Number n) = scientific n
65encodeToBuilder (String s) = text s
66encodeToBuilder (Array v)  = array v
67encodeToBuilder (Object m) = object m
68
69-- | Encode a JSON null.
70null_ :: Builder
71null_ = BP.primBounded (ascii4 ('n',('u',('l','l')))) ()
72
73-- | Encode a JSON boolean.
74bool :: Bool -> Builder
75bool = BP.primBounded (BP.condB id (ascii4 ('t',('r',('u','e'))))
76                                   (ascii5 ('f',('a',('l',('s','e'))))))
77
78-- | Encode a JSON array.
79array :: V.Vector Value -> Builder
80array v
81  | V.null v  = emptyArray_
82  | otherwise = B.char8 '[' <>
83                encodeToBuilder (V.unsafeHead v) <>
84                V.foldr withComma (B.char8 ']') (V.unsafeTail v)
85  where
86    withComma a z = B.char8 ',' <> encodeToBuilder a <> z
87
88-- Encode a JSON object.
89object :: HMS.HashMap T.Text Value -> Builder
90object m = case HMS.toList m of
91    (x:xs) -> B.char8 '{' <> one x <> foldr withComma (B.char8 '}') xs
92    _      -> emptyObject_
93  where
94    withComma a z = B.char8 ',' <> one a <> z
95    one (k,v)     = text k <> B.char8 ':' <> encodeToBuilder v
96
97-- | Encode a JSON string.
98text :: T.Text -> Builder
99text t = B.char8 '"' <> unquoted t <> B.char8 '"'
100
101-- | Encode a JSON string, without enclosing quotes.
102unquoted :: T.Text -> Builder
103unquoted = encodeUtf8BuilderEscaped escapeAscii
104
105-- | Add quotes surrounding a builder
106quote :: Builder -> Builder
107quote b = B.char8 '"' <> b <> B.char8 '"'
108
109-- | Encode a JSON string.
110string :: String -> Builder
111string t = B.char8 '"' <> BP.primMapListBounded go t <> B.char8 '"'
112  where go = BP.condB (> '\x7f') BP.charUtf8 (c2w >$< escapeAscii)
113
114escapeAscii :: BP.BoundedPrim Word8
115escapeAscii =
116    BP.condB (== c2w '\\'  ) (ascii2 ('\\','\\')) $
117    BP.condB (== c2w '\"'  ) (ascii2 ('\\','"' )) $
118    BP.condB (>= c2w '\x20') (BP.liftFixedToBounded BP.word8) $
119    BP.condB (== c2w '\n'  ) (ascii2 ('\\','n' )) $
120    BP.condB (== c2w '\r'  ) (ascii2 ('\\','r' )) $
121    BP.condB (== c2w '\t'  ) (ascii2 ('\\','t' )) $
122    BP.liftFixedToBounded hexEscape -- fallback for chars < 0x20
123  where
124    hexEscape :: BP.FixedPrim Word8
125    hexEscape = (\c -> ('\\', ('u', fromIntegral c))) BP.>$<
126        BP.char8 >*< BP.char8 >*< BP.word16HexFixed
127{-# INLINE escapeAscii #-}
128
129c2w :: Char -> Word8
130c2w c = fromIntegral (ord c)
131
132-- | Encode a JSON number.
133scientific :: Scientific -> Builder
134scientific s
135    | e < 0 || e > 1024 = scientificBuilder s
136    | otherwise = B.integerDec (coefficient s * 10 ^ e)
137  where
138    e = base10Exponent s
139
140emptyArray_ :: Builder
141emptyArray_ = BP.primBounded (ascii2 ('[',']')) ()
142
143emptyObject_ :: Builder
144emptyObject_ = BP.primBounded (ascii2 ('{','}')) ()
145
146ascii2 :: (Char, Char) -> BP.BoundedPrim a
147ascii2 cs = BP.liftFixedToBounded $ const cs BP.>$< BP.char7 >*< BP.char7
148{-# INLINE ascii2 #-}
149
150ascii4 :: (Char, (Char, (Char, Char))) -> BP.BoundedPrim a
151ascii4 cs = BP.liftFixedToBounded $ const cs >$<
152    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
153{-# INLINE ascii4 #-}
154
155ascii5 :: (Char, (Char, (Char, (Char, Char)))) -> BP.BoundedPrim a
156ascii5 cs = BP.liftFixedToBounded $ const cs >$<
157    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
158{-# INLINE ascii5 #-}
159
160ascii6 :: (Char, (Char, (Char, (Char, (Char, Char))))) -> BP.BoundedPrim a
161ascii6 cs = BP.liftFixedToBounded $ const cs >$<
162    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
163{-# INLINE ascii6 #-}
164
165ascii8 :: (Char, (Char, (Char, (Char, (Char, (Char, (Char, Char)))))))
166       -> BP.BoundedPrim a
167ascii8 cs = BP.liftFixedToBounded $ const cs >$<
168    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 >*<
169    BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7
170{-# INLINE ascii8 #-}
171
172day :: Day -> Builder
173day dd = encodeYear yr <>
174         BP.primBounded (ascii6 ('-',(mh,(ml,('-',(dh,dl)))))) ()
175  where (yr,m,d)    = toGregorian dd
176        !(T mh ml)  = twoDigits m
177        !(T dh dl)  = twoDigits d
178        encodeYear y
179            | y >= 1000 = B.integerDec y
180            | y >= 0    = BP.primBounded (ascii4 (padYear y)) ()
181            | y >= -999 = BP.primBounded (ascii5 ('-',padYear (- y))) ()
182            | otherwise = B.integerDec y
183        padYear y =
184            let (ab,c) = fromIntegral y `quotRem` 10
185                (a,b)  = ab `quotRem` 10
186            in ('0',(digit a,(digit b,digit c)))
187{-# INLINE day #-}
188
189timeOfDay :: TimeOfDay -> Builder
190timeOfDay t = timeOfDay64 (toTimeOfDay64 t)
191{-# INLINE timeOfDay #-}
192
193timeOfDay64 :: TimeOfDay64 -> Builder
194timeOfDay64 (TOD h m s)
195  | frac == 0 = hhmmss -- omit subseconds if 0
196  | otherwise = hhmmss <> BP.primBounded showFrac frac
197  where
198    hhmmss  = BP.primBounded (ascii8 (hh,(hl,(':',(mh,(ml,(':',(sh,sl)))))))) ()
199    !(T hh hl)  = twoDigits h
200    !(T mh ml)  = twoDigits m
201    !(T sh sl)  = twoDigits (fromIntegral real)
202    (real,frac) = s `quotRem` pico
203    showFrac = ('.',) >$< (BP.liftFixedToBounded BP.char7 >*< trunc12)
204    trunc12 = (`quotRem` micro) >$<
205              BP.condB (\(_,y) -> y == 0) (fst >$< trunc6) (digits6 >*< trunc6)
206    digits6 = ((`quotRem` milli) . fromIntegral) >$< (digits3 >*< digits3)
207    trunc6  = ((`quotRem` milli) . fromIntegral) >$<
208              BP.condB (\(_,y) -> y == 0) (fst >$< trunc3) (digits3 >*< trunc3)
209    digits3 = (`quotRem` 10) >$< (digits2 >*< digits1)
210    digits2 = (`quotRem` 10) >$< (digits1 >*< digits1)
211    digits1 = BP.liftFixedToBounded (digit >$< BP.char7)
212    trunc3  = BP.condB (== 0) BP.emptyB $
213              (`quotRem` 100) >$< (digits1 >*< trunc2)
214    trunc2  = BP.condB (== 0) BP.emptyB $
215              (`quotRem` 10)  >$< (digits1 >*< trunc1)
216    trunc1  = BP.condB (== 0) BP.emptyB digits1
217
218    pico       = 1000000000000 -- number of picoseconds  in 1 second
219    micro      =       1000000 -- number of microseconds in 1 second
220    milli      =          1000 -- number of milliseconds in 1 second
221
222timeZone :: TimeZone -> Builder
223timeZone (TimeZone off _ _)
224  | off == 0  = B.char7 'Z'
225  | otherwise = BP.primBounded (ascii6 (s,(hh,(hl,(':',(mh,ml)))))) ()
226  where !s         = if off < 0 then '-' else '+'
227        !(T hh hl) = twoDigits h
228        !(T mh ml) = twoDigits m
229        (h,m)      = abs off `quotRem` 60
230{-# INLINE timeZone #-}
231
232dayTime :: Day -> TimeOfDay64 -> Builder
233dayTime d t = day d <> B.char7 'T' <> timeOfDay64 t
234{-# INLINE dayTime #-}
235
236utcTime :: UTCTime -> B.Builder
237utcTime (UTCTime d s) = dayTime d (diffTimeOfDay64 s) <> B.char7 'Z'
238{-# INLINE utcTime #-}
239
240localTime :: LocalTime -> Builder
241localTime (LocalTime d t) = dayTime d (toTimeOfDay64 t)
242{-# INLINE localTime #-}
243
244zonedTime :: ZonedTime -> Builder
245zonedTime (ZonedTime t z) = localTime t <> timeZone z
246{-# INLINE zonedTime #-}
247
248data T = T {-# UNPACK #-} !Char {-# UNPACK #-} !Char
249
250twoDigits :: Int -> T
251twoDigits a     = T (digit hi) (digit lo)
252  where (hi,lo) = a `quotRem` 10
253
254digit :: Int -> Char
255digit x = chr (x + 48)
256