git.iko.soy/elk
on 3a07bd6 help sign in
elk/src/Json/Encode.hs
314 lines 5.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Json.Encode
4 ( write
5 , encode
6 , writeUgly
7 , encodeUgly
8 , Value
9 , array
10 , object
11 , text
12 , bool
13 , int
14 , number
15 , null
16 , dict
17 , list
18 , (==>)
19 )
20 where
23import Prelude hiding (null)
24import Control.Arrow ((***))
25import qualified Data.ByteString.Char8 as BSC
26import qualified Data.ByteString.Builder as B
27import qualified Data.ByteString.Builder.Prim as BP
28import Data.ByteString.Builder.Prim ((>*<))
29import qualified Data.Map as Map
30import qualified Data.Scientific as Sci
31import Data.Monoid ((<>))
32import qualified Data.Text as Text
33import qualified Data.Text.Encoding as Text
34import qualified Data.Word as W
35import System.IO (IOMode(WriteMode), withBinaryFile)
39-- VALUES
42data Value
43 = Array [Value]
44 | Object [(Text.Text, Value)]
45 | String Text.Text
46 | Boolean Bool
47 | Integer Int
48 | Number Sci.Scientific
49 | Null
52array :: [Value] -> Value
53array =
54 Array
57object :: [(Text.Text,Value)] -> Value
58object =
59 Object
62text :: Text.Text -> Value
63text =
64 String
67bool :: Bool -> Value
68bool =
69 Boolean
72int :: Int -> Value
73int =
74 Integer
77number :: Sci.Scientific -> Value
78number =
79 Number
82null :: Value
83null =
84 Null
87dict :: (k -> Text.Text) -> (v -> Value) -> Map.Map k v -> Value
88dict encodeKey encodeValue pairs =
89 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
92list :: (a -> Value) -> [a] -> Value
93list encodeEntry entries =
94 Array $ map encodeEntry entries
98-- HELPERS
101(==>) :: a -> b -> (a, b)
102(==>) a b =
103 (a, b)
107-- WRITE TO FILE
110write :: FilePath -> Value -> IO ()
111write path value =
112 withBinaryFile path WriteMode $ \handle ->
113 B.hPutBuilder handle (encode value)
116writeUgly :: FilePath -> Value -> IO ()
117writeUgly path value =
118 withBinaryFile path WriteMode $ \handle ->
119 B.hPutBuilder handle (encodeUgly value)
123-- ENCODE UGLY
126encodeUgly :: Value -> B.Builder
127encodeUgly value =
128 case value of
129 Array [] ->
130 B.string7 "[]"
132 Array (first : rest) ->
133 let
134 encodeEntry entry =
135 B.char7 ',' <> encodeUgly entry
136 in
137 B.char7 '[' <> encodeUgly first <> mconcat (map encodeEntry rest) <> B.char7 ']'
139 Object [] ->
140 B.string7 "{}"
142 Object (first : rest) ->
143 let
144 encodeEntry char (key, entry) =
145 B.char7 char <> encodeString key <> B.char7 ':' <> encodeUgly entry
146 in
147 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
149 String txt ->
150 encodeString txt
152 Boolean boolean ->
153 B.string7 (if boolean then "true" else "false")
155 Integer n ->
156 B.intDec n
158 Number scientific ->
159 B.string7 (Sci.formatScientific Sci.Generic Nothing scientific)
161 Null ->
162 "null"
166-- ENCODE
169encode :: Value -> B.Builder
170encode value =
171 encodeHelp "" value
174encodeHelp :: BSC.ByteString -> Value -> B.Builder
175encodeHelp indent value =
176 case value of
177 Array [] ->
178 B.string7 "[]"
180 Array (first : rest) ->
181 encodeArray indent first rest
183 Object [] ->
184 B.string7 "{}"
186 Object (first : rest) ->
187 encodeObject indent first rest
189 String txt ->
190 encodeString txt
192 Boolean boolean ->
193 B.string7 (if boolean then "true" else "false")
195 Integer n ->
196 B.intDec n
198 Number scientific ->
199 B.string7 (Sci.formatScientific Sci.Generic Nothing scientific)
201 Null ->
202 "null"
206-- ENCODE ARRAY
209encodeArray :: BSC.ByteString -> Value -> [Value] -> B.Builder
210encodeArray =
211 encodeSequence arrayOpen arrayClose encodeHelp
214arrayOpen :: B.Builder
215arrayOpen =
216 B.string7 "[\n"
219arrayClose :: B.Builder
220arrayClose =
221 B.char7 ']'
225-- ENCODE OBJECT
228encodeObject :: BSC.ByteString -> (Text.Text, Value) -> [(Text.Text, Value)] -> B.Builder
229encodeObject =
230 encodeSequence objectOpen objectClose encodeField
233objectOpen :: B.Builder
234objectOpen =
235 B.string7 "{\n"
238objectClose :: B.Builder
239objectClose =
240 B.char7 '}'
243encodeField :: BSC.ByteString -> (Text.Text, Value) -> B.Builder
244encodeField indent (key, value) =
245 encodeString key <> B.string7 ": " <> encodeHelp indent value
249-- ENCODE SEQUENCE
252encodeSequence :: B.Builder -> B.Builder -> (BSC.ByteString -> a -> B.Builder) -> BSC.ByteString -> a -> [a] -> B.Builder
253encodeSequence open close encodeEntry indent first rest =
254 let
255 newIndent =
256 indent <> " "
258 newIndentBuilder =
259 B.byteString newIndent
261 closer =
262 newline <> B.byteString indent <> close
264 addValue field builder =
265 commaNewline
266 <> newIndentBuilder
267 <> encodeEntry newIndent field
268 <> builder
269 in
270 open
271 <> newIndentBuilder
272 <> encodeEntry newIndent first
273 <> foldr addValue closer rest
276commaNewline :: B.Builder
277commaNewline =
278 B.string7 ",\n"
281newline :: B.Builder
282newline =
283 B.char7 '\n'
287-- ENCODE STRING
290encodeString :: Text.Text -> B.Builder
291encodeString txt =
292 B.char7 '"' <> Text.encodeUtf8BuilderEscaped escapeAscii txt <> B.char7 '"'
295{-# INLINE escapeAscii #-}
296escapeAscii :: BP.BoundedPrim W.Word8
297escapeAscii =
298 BP.condB (== 0x5C {- \\ -}) (ascii2 ('\\','\\')) $
299 BP.condB (== 0x22 {- \" -}) (ascii2 ('\\','"' )) $
300 BP.condB (>= 0x20 ) (BP.liftFixedToBounded BP.word8) $
301 BP.condB (== 0x0A {- \n -}) (ascii2 ('\\','n' )) $
302 BP.condB (== 0x0D {- \r -}) (ascii2 ('\\','r' )) $
303 BP.condB (== 0x09 {- \t -}) (ascii2 ('\\','t' )) $
304 BP.liftFixedToBounded hexEscape -- fallback for chars < 0x20
305 where
306 hexEscape :: BP.FixedPrim W.Word8
307 hexEscape = (\c -> ('\\', ('u', fromIntegral c))) BP.>$<
308 BP.char8 >*< BP.char8 >*< BP.word16HexFixed
311{-# INLINE ascii2 #-}
312ascii2 :: (Char, Char) -> BP.BoundedPrim a
313ascii2 cs =
314 BP.liftFixedToBounded $ const cs BP.>$< BP.char7 >*< BP.char7