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