git.iko.soy/elk
on 2ecbee3 help sign in
elk/compiler/src/Json/Encode.hs
321 lines 5.9 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 , name
13 , bool
14 , int
15 , number
16 , null
17 , dict
18 , list
19 , (==>)
20 )
21 where
24import Prelude hiding (null)
25import Control.Arrow ((***))
26import qualified Data.ByteString.Char8 as BSC
27import qualified Data.ByteString.Builder as B
28import qualified Data.ByteString.Builder.Prim as BP
29import Data.ByteString.Builder.Prim ((>*<))
30import qualified Data.Map as Map
31import qualified Data.Scientific as Sci
32import Data.Monoid ((<>))
33import qualified Data.Name as Name
34import qualified Data.Text as Text
35import qualified Data.Text.Encoding as Text
36import qualified Data.Word as W
37import System.IO (IOMode(WriteMode), withBinaryFile)
41-- VALUES
44data Value
45 = Array [Value]
46 | Object [(Text.Text, Value)]
47 | String B.Builder
48 | Boolean Bool
49 | Integer Int
50 | Number Sci.Scientific
51 | Null
54array :: [Value] -> Value
55array =
56 Array
59object :: [(Text.Text,Value)] -> Value
60object =
61 Object
64text :: Text.Text -> Value
65text txt =
66 String (encodeText txt)
69name :: Name.Name -> Value
70name nm =
71 String ("\"" <> Name.toBuilder nm <> "\"")
74bool :: Bool -> Value
75bool =
76 Boolean
79int :: Int -> Value
80int =
81 Integer
84number :: Sci.Scientific -> Value
85number =
86 Number
89null :: Value
90null =
91 Null
94dict :: (k -> Text.Text) -> (v -> Value) -> Map.Map k v -> Value
95dict encodeKey encodeValue pairs =
96 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
99list :: (a -> Value) -> [a] -> Value
100list encodeEntry entries =
101 Array $ map encodeEntry entries
105-- HELPERS
108(==>) :: a -> b -> (a, b)
109(==>) a b =
110 (a, b)
114-- WRITE TO FILE
117write :: FilePath -> Value -> IO ()
118write path value =
119 withBinaryFile path WriteMode $ \handle ->
120 B.hPutBuilder handle (encode value <> "\n")
123writeUgly :: FilePath -> Value -> IO ()
124writeUgly path value =
125 withBinaryFile path WriteMode $ \handle ->
126 B.hPutBuilder handle (encodeUgly value)
130-- ENCODE UGLY
133encodeUgly :: Value -> B.Builder
134encodeUgly value =
135 case value of
136 Array [] ->
137 B.string7 "[]"
139 Array (first : rest) ->
140 let
141 encodeEntry entry =
142 B.char7 ',' <> encodeUgly entry
143 in
144 B.char7 '[' <> encodeUgly first <> mconcat (map encodeEntry rest) <> B.char7 ']'
146 Object [] ->
147 B.string7 "{}"
149 Object (first : rest) ->
150 let
151 encodeEntry char (key, entry) =
152 B.char7 char <> encodeText key <> B.char7 ':' <> encodeUgly entry
153 in
154 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
156 String builder ->
157 builder
159 Boolean boolean ->
160 B.string7 (if boolean then "true" else "false")
162 Integer n ->
163 B.intDec n
165 Number scientific ->
166 B.string7 (Sci.formatScientific Sci.Generic Nothing scientific)
168 Null ->
169 "null"
173-- ENCODE
176encode :: Value -> B.Builder
177encode value =
178 encodeHelp "" value
181encodeHelp :: BSC.ByteString -> Value -> B.Builder
182encodeHelp indent value =
183 case value of
184 Array [] ->
185 B.string7 "[]"
187 Array (first : rest) ->
188 encodeArray indent first rest
190 Object [] ->
191 B.string7 "{}"
193 Object (first : rest) ->
194 encodeObject indent first rest
196 String builder ->
197 builder
199 Boolean boolean ->
200 B.string7 (if boolean then "true" else "false")
202 Integer n ->
203 B.intDec n
205 Number scientific ->
206 B.string7 (Sci.formatScientific Sci.Generic Nothing scientific)
208 Null ->
209 "null"
213-- ENCODE ARRAY
216encodeArray :: BSC.ByteString -> Value -> [Value] -> B.Builder
217encodeArray =
218 encodeSequence arrayOpen arrayClose encodeHelp
221arrayOpen :: B.Builder
222arrayOpen =
223 B.string7 "[\n"
226arrayClose :: B.Builder
227arrayClose =
228 B.char7 ']'
232-- ENCODE OBJECT
235encodeObject :: BSC.ByteString -> (Text.Text, Value) -> [(Text.Text, Value)] -> B.Builder
236encodeObject =
237 encodeSequence objectOpen objectClose encodeField
240objectOpen :: B.Builder
241objectOpen =
242 B.string7 "{\n"
245objectClose :: B.Builder
246objectClose =
247 B.char7 '}'
250encodeField :: BSC.ByteString -> (Text.Text, Value) -> B.Builder
251encodeField indent (key, value) =
252 encodeText key <> B.string7 ": " <> encodeHelp indent value
256-- ENCODE SEQUENCE
259encodeSequence :: B.Builder -> B.Builder -> (BSC.ByteString -> a -> B.Builder) -> BSC.ByteString -> a -> [a] -> B.Builder
260encodeSequence open close encodeEntry indent first rest =
261 let
262 newIndent =
263 indent <> " "
265 newIndentBuilder =
266 B.byteString newIndent
268 closer =
269 newline <> B.byteString indent <> close
271 addValue field builder =
272 commaNewline
273 <> newIndentBuilder
274 <> encodeEntry newIndent field
275 <> builder
276 in
277 open
278 <> newIndentBuilder
279 <> encodeEntry newIndent first
280 <> foldr addValue closer rest
283commaNewline :: B.Builder
284commaNewline =
285 B.string7 ",\n"
288newline :: B.Builder
289newline =
290 B.char7 '\n'
294-- ENCODE TEXT
297encodeText :: Text.Text -> B.Builder
298encodeText txt =
299 B.char7 '"' <> Text.encodeUtf8BuilderEscaped escapeAscii txt <> B.char7 '"'
302{-# INLINE escapeAscii #-}
303escapeAscii :: BP.BoundedPrim W.Word8
304escapeAscii =
305 BP.condB (== 0x5C {- \\ -}) (ascii2 ('\\','\\')) $
306 BP.condB (== 0x22 {- \" -}) (ascii2 ('\\','"' )) $
307 BP.condB (>= 0x20 ) (BP.liftFixedToBounded BP.word8) $
308 BP.condB (== 0x0A {- \n -}) (ascii2 ('\\','n' )) $
309 BP.condB (== 0x0D {- \r -}) (ascii2 ('\\','r' )) $
310 BP.condB (== 0x09 {- \t -}) (ascii2 ('\\','t' )) $
311 BP.liftFixedToBounded hexEscape -- fallback for chars < 0x20
312 where
313 hexEscape :: BP.FixedPrim W.Word8
314 hexEscape = (\c -> ('\\', ('u', fromIntegral c))) BP.>$<
315 BP.char8 >*< BP.char8 >*< BP.word16HexFixed
318{-# INLINE ascii2 #-}
319ascii2 :: (Char, Char) -> BP.BoundedPrim a
320ascii2 cs =
321 BP.liftFixedToBounded $ const cs BP.>$< BP.char7 >*< BP.char7