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