@@ -0,0 +1,116 @@
1+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2+
3+-- |
4+-- Module: Data.Aeson.EncodeUtf8
5+-- Copyright: (c) 2011 MailRank, Inc.
6+-- (c) 2013 Simon Meier <iridcode@gmail.com>
7+-- License: Apache
8+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>
9+-- Stability: experimental
10+-- Portability: portable
11+--
12+-- Efficiently serialize a JSON value using the UTF-8 encoding.
13+
14+module Data.Aeson.Encode.ByteString
15+ ( encode
16+ , encodeToByteStringBuilder
17+ ) where
18+
19+import Prelude hiding (null)
20+import Data.Aeson.Types (ToJSON(..), Value(..))
21+import Data.Char (ord)
22+import Data.Scientific (Scientific, coefficient, base10Exponent, formatScientific, FPFormat(Generic))
23+import Data.Word (Word8)
24+import Data.Monoid (mappend)
25+import Data.ByteString.Builder as B
26+import Data.ByteString.Builder.Prim as BP
27+import qualified Data.ByteString.Lazy as L
28+import qualified Data.HashMap.Strict as HMS
29+import qualified Data.Text as T
30+import qualified Data.Text.Encoding as TE
31+import qualified Data.Vector as V
32+
33+(<>) :: Builder -> Builder -> Builder
34+(<>) = mappend
35+{-# INLINE (<>) #-}
36+infixr 6 <>
37+
38+-- | Efficiently serialize a JSON value as a lazy 'L.ByteString'.
39+encode :: ToJSON a => a -> L.ByteString
40+encode = B.toLazyByteString . encodeToByteStringBuilder . toJSON
41+
42+-- | Encode a JSON value to a ByteString 'B.Builder'. Use this function if you
43+-- must prepend or append further bytes to the encoded JSON value.
44+encodeToByteStringBuilder :: Value -> Builder
45+encodeToByteStringBuilder Null = null
46+encodeToByteStringBuilder (Bool b) = bool b
47+encodeToByteStringBuilder (Number n) = number n
48+encodeToByteStringBuilder (String s) = string s
49+encodeToByteStringBuilder (Array v) = array v
50+encodeToByteStringBuilder (Object m) = object m
51+
52+null :: Builder
53+null = BP.primBounded (ascii4 ('n',('u',('l','l')))) ()
54+
55+bool :: Bool -> Builder
56+bool = BP.primBounded (BP.condB id (ascii4 ('t',('r',('u','e'))))
57+ (ascii5 ('f',('a',('l',('s','e'))))))
58+
59+array :: V.Vector Value -> Builder
60+array v
61+ | V.null v = B.char8 '[' <> B.char8 ']'
62+ | otherwise = B.char8 '[' <>
63+ encodeToByteStringBuilder (V.unsafeHead v) <>
64+ V.foldr withComma (B.char8 ']') (V.unsafeTail v)
65+ where
66+ withComma a z = B.char8 ',' <> encodeToByteStringBuilder a <> z
67+
68+object :: HMS.HashMap T.Text Value -> Builder
69+object m = case HMS.toList m of
70+ (x:xs) -> B.char8 '{' <> one x <> foldr withComma (B.char8 '}') xs
71+ _ -> B.char8 '{' <> B.char8 '}'
72+ where
73+ withComma a z = B.char8 ',' <> one a <> z
74+ one (k,v) = string k <> B.char8 ':' <> encodeToByteStringBuilder v
75+
76+string :: T.Text -> B.Builder
77+string t =
78+ B.char8 '"' <> TE.encodeUtf8BuilderEscaped escapeAscii t <> B.char8 '"'
79+ where
80+ escapeAscii :: BP.BoundedPrim Word8
81+ escapeAscii =
82+ BP.condB (== c2w '\\' ) (ascii2 ('\\','\\')) $
83+ BP.condB (== c2w '\"' ) (ascii2 ('\\','"' )) $
84+ BP.condB (>= c2w '\x20') (BP.liftFixedToBounded BP.word8) $
85+ BP.condB (== c2w '\n' ) (ascii2 ('\\','n' )) $
86+ BP.condB (== c2w '\r' ) (ascii2 ('\\','r' )) $
87+ BP.condB (== c2w '\t' ) (ascii2 ('\\','t' )) $
88+ (BP.liftFixedToBounded hexEscape) -- fallback for chars < 0x20
89+
90+ c2w = fromIntegral . ord
91+
92+ hexEscape :: BP.FixedPrim Word8
93+ hexEscape = (\c -> ('\\', ('u', fromIntegral c))) BP.>$<
94+ BP.char8 BP.>*< BP.char8 BP.>*< BP.word16HexFixed
95+
96+number :: Scientific -> Builder
97+number s
98+ | e < 0 = B.string8 $ formatScientific Generic Nothing s
99+ | otherwise = B.integerDec (coefficient s * 10 ^ e)
100+ where
101+ e = base10Exponent s
102+
103+
104+{-# INLINE ascii2 #-}
105+ascii2 :: (Char, Char) -> BP.BoundedPrim a
106+ascii2 cs = BP.liftFixedToBounded $ (const cs) BP.>$< BP.char7 BP.>*< BP.char7
107+
108+{-# INLINE ascii4 #-}
109+ascii4 :: (Char, (Char, (Char, Char))) -> BP.BoundedPrim a
110+ascii4 cs = BP.liftFixedToBounded $ (const cs) >$<
111+ BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7
112+
113+{-# INLINE ascii5 #-}
114+ascii5 :: (Char, (Char, (Char, (Char, Char)))) -> BP.BoundedPrim a
115+ascii5 cs = BP.liftFixedToBounded $ (const cs) >$<
116+ BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7