git.iko.soy/elk
on d4e9599 help sign in
elk/compiler/src/Json/Encode.hs
322 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.Text as Text
34import qualified Data.Text.Encoding as Text
35import qualified Data.Word as W
36import System.IO (IOMode(WriteMode), withBinaryFile)
38import qualified Elm.Name as N
42-- VALUES
45data Value
46 = Array [Value]
47 | Object [(Text.Text, Value)]
48 | String B.Builder
49 | Boolean Bool
50 | Integer Int
51 | Number Sci.Scientific
52 | Null
55array :: [Value] -> Value
56array =
57 Array
60object :: [(Text.Text,Value)] -> Value
61object =
62 Object
65text :: Text.Text -> Value
66text txt =
67 String (encodeText txt)
70name :: N.Name -> Value
71name nm =
72 String ("\"" <> N.toBuilder nm <> "\"")
75bool :: Bool -> Value
76bool =
77 Boolean
80int :: Int -> Value
81int =
82 Integer
85number :: Sci.Scientific -> Value
86number =
87 Number
90null :: Value
91null =
92 Null
95dict :: (k -> Text.Text) -> (v -> Value) -> Map.Map k v -> Value
96dict encodeKey encodeValue pairs =
97 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
100list :: (a -> Value) -> [a] -> Value
101list encodeEntry entries =
102 Array $ map encodeEntry entries
106-- HELPERS
109(==>) :: a -> b -> (a, b)
110(==>) a b =
111 (a, b)
115-- WRITE TO FILE
118write :: FilePath -> Value -> IO ()
119write path value =
120 withBinaryFile path WriteMode $ \handle ->
121 B.hPutBuilder handle (encode value)
124writeUgly :: FilePath -> Value -> IO ()
125writeUgly path value =
126 withBinaryFile path WriteMode $ \handle ->
127 B.hPutBuilder handle (encodeUgly value)
131-- ENCODE UGLY
134encodeUgly :: Value -> B.Builder
135encodeUgly value =
136 case value of
137 Array [] ->
138 B.string7 "[]"
140 Array (first : rest) ->
141 let
142 encodeEntry entry =
143 B.char7 ',' <> encodeUgly entry
144 in
145 B.char7 '[' <> encodeUgly first <> mconcat (map encodeEntry rest) <> B.char7 ']'
147 Object [] ->
148 B.string7 "{}"
150 Object (first : rest) ->
151 let
152 encodeEntry char (key, entry) =
153 B.char7 char <> encodeText key <> B.char7 ':' <> encodeUgly entry
154 in
155 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
157 String builder ->
158 builder
160 Boolean boolean ->
161 B.string7 (if boolean then "true" else "false")
163 Integer n ->
164 B.intDec n
166 Number scientific ->
167 B.string7 (Sci.formatScientific Sci.Generic Nothing scientific)
169 Null ->
170 "null"
174-- ENCODE
177encode :: Value -> B.Builder
178encode value =
179 encodeHelp "" value
182encodeHelp :: BSC.ByteString -> Value -> B.Builder
183encodeHelp indent value =
184 case value of
185 Array [] ->
186 B.string7 "[]"
188 Array (first : rest) ->
189 encodeArray indent first rest
191 Object [] ->
192 B.string7 "{}"
194 Object (first : rest) ->
195 encodeObject indent first rest
197 String builder ->
198 builder
200 Boolean boolean ->
201 B.string7 (if boolean then "true" else "false")
203 Integer n ->
204 B.intDec n
206 Number scientific ->
207 B.string7 (Sci.formatScientific Sci.Generic Nothing scientific)
209 Null ->
210 "null"
214-- ENCODE ARRAY
217encodeArray :: BSC.ByteString -> Value -> [Value] -> B.Builder
218encodeArray =
219 encodeSequence arrayOpen arrayClose encodeHelp
222arrayOpen :: B.Builder
223arrayOpen =
224 B.string7 "[\n"
227arrayClose :: B.Builder
228arrayClose =
229 B.char7 ']'
233-- ENCODE OBJECT
236encodeObject :: BSC.ByteString -> (Text.Text, Value) -> [(Text.Text, Value)] -> B.Builder
237encodeObject =
238 encodeSequence objectOpen objectClose encodeField
241objectOpen :: B.Builder
242objectOpen =
243 B.string7 "{\n"
246objectClose :: B.Builder
247objectClose =
248 B.char7 '}'
251encodeField :: BSC.ByteString -> (Text.Text, Value) -> B.Builder
252encodeField indent (key, value) =
253 encodeText key <> B.string7 ": " <> encodeHelp indent value
257-- ENCODE SEQUENCE
260encodeSequence :: B.Builder -> B.Builder -> (BSC.ByteString -> a -> B.Builder) -> BSC.ByteString -> a -> [a] -> B.Builder
261encodeSequence open close encodeEntry indent first rest =
262 let
263 newIndent =
264 indent <> " "
266 newIndentBuilder =
267 B.byteString newIndent
269 closer =
270 newline <> B.byteString indent <> close
272 addValue field builder =
273 commaNewline
274 <> newIndentBuilder
275 <> encodeEntry newIndent field
276 <> builder
277 in
278 open
279 <> newIndentBuilder
280 <> encodeEntry newIndent first
281 <> foldr addValue closer rest
284commaNewline :: B.Builder
285commaNewline =
286 B.string7 ",\n"
289newline :: B.Builder
290newline =
291 B.char7 '\n'
295-- ENCODE TEXT
298encodeText :: Text.Text -> B.Builder
299encodeText txt =
300 B.char7 '"' <> Text.encodeUtf8BuilderEscaped escapeAscii txt <> B.char7 '"'
303{-# INLINE escapeAscii #-}
304escapeAscii :: BP.BoundedPrim W.Word8
305escapeAscii =
306 BP.condB (== 0x5C {- \\ -}) (ascii2 ('\\','\\')) $
307 BP.condB (== 0x22 {- \" -}) (ascii2 ('\\','"' )) $
308 BP.condB (>= 0x20 ) (BP.liftFixedToBounded BP.word8) $
309 BP.condB (== 0x0A {- \n -}) (ascii2 ('\\','n' )) $
310 BP.condB (== 0x0D {- \r -}) (ascii2 ('\\','r' )) $
311 BP.condB (== 0x09 {- \t -}) (ascii2 ('\\','t' )) $
312 BP.liftFixedToBounded hexEscape -- fallback for chars < 0x20
313 where
314 hexEscape :: BP.FixedPrim W.Word8
315 hexEscape = (\c -> ('\\', ('u', fromIntegral c))) BP.>$<
316 BP.char8 >*< BP.char8 >*< BP.word16HexFixed
319{-# INLINE ascii2 #-}
320ascii2 :: (Char, Char) -> BP.BoundedPrim a
321ascii2 cs =
322 BP.liftFixedToBounded $ const cs BP.>$< BP.char7 >*< BP.char7