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