git.iko.soy/elk
on ea77dcf help sign in
elk/src/Json/Encode.hs
337 lines 5.7 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 , string
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.Map as Map
29import qualified Data.Scientific as Sci
30import Data.Monoid ((<>))
31import qualified Data.Text as Text
32import qualified Numeric
33import System.IO (IOMode(WriteMode), withBinaryFile)
37-- VALUES
40data Value
41 = Array [Value]
42 | Object [(String, Value)]
43 | String B.Builder
44 | Boolean Bool
45 | Integer Int
46 | Number Sci.Scientific
47 | Null
50array :: [Value] -> Value
51array =
52 Array
55object :: [(String,Value)] -> Value
56object =
57 Object
60text :: Text.Text -> Value
61text txt =
62 String (encodeString (Text.unpack txt))
65string :: String -> Value
66string str =
67 String (encodeString str)
70bool :: Bool -> Value
71bool =
72 Boolean
75int :: Int -> Value
76int =
77 Integer
80number :: Sci.Scientific -> Value
81number =
82 Number
85null :: Value
86null =
87 Null
90dict :: (k -> String) -> (v -> Value) -> Map.Map k v -> Value
91dict encodeKey encodeValue pairs =
92 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
95list :: (a -> Value) -> [a] -> Value
96list encodeEntry entries =
97 Array $ map encodeEntry entries
101-- HELPERS
104(==>) :: a -> b -> (a, b)
105(==>) a b =
106 (a, b)
110-- WRITE TO FILE
113write :: FilePath -> Value -> IO ()
114write path value =
115 withBinaryFile path WriteMode $ \handle ->
116 B.hPutBuilder handle (encode value)
119writeUgly :: FilePath -> Value -> IO ()
120writeUgly path value =
121 withBinaryFile path WriteMode $ \handle ->
122 B.hPutBuilder handle (encodeUgly value)
126-- ENCODE UGLY
129encodeUgly :: Value -> B.Builder
130encodeUgly value =
131 case value of
132 Array [] ->
133 B.string7 "[]"
135 Array (first : rest) ->
136 let
137 encodeEntry entry =
138 B.char7 ',' <> encodeUgly entry
139 in
140 B.char7 '[' <> encodeUgly first <> mconcat (map encodeEntry rest) <> B.char7 ']'
142 Object [] ->
143 B.string7 "{}"
145 Object (first : rest) ->
146 let
147 encodeEntry char (key, entry) =
148 B.char7 char <> encodeString key <> B.char7 ':' <> encodeUgly entry
149 in
150 encodeEntry '{' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 '}'
152 String builder ->
153 builder
155 Boolean boolean ->
156 B.string7 (if boolean then "true" else "false")
158 Integer n ->
159 B.intDec n
161 Number scientific ->
162 B.string7 (Sci.formatScientific Sci.Generic Nothing scientific)
164 Null ->
165 "null"
169-- ENCODE
172encode :: Value -> B.Builder
173encode value =
174 encodeHelp "" value
177encodeHelp :: BSC.ByteString -> Value -> B.Builder
178encodeHelp indent value =
179 case value of
180 Array [] ->
181 B.string7 "[]"
183 Array (first : rest) ->
184 encodeArray indent first rest
186 Object [] ->
187 B.string7 "{}"
189 Object (first : rest) ->
190 encodeObject indent first rest
192 String builder ->
193 builder
195 Boolean boolean ->
196 B.string7 (if boolean then "true" else "false")
198 Integer n ->
199 B.intDec n
201 Number scientific ->
202 B.string7 (Sci.formatScientific Sci.Generic Nothing scientific)
204 Null ->
205 "null"
209-- ENCODE ARRAY
212encodeArray :: BSC.ByteString -> Value -> [Value] -> B.Builder
213encodeArray =
214 encodeSequence arrayOpen arrayClose encodeHelp
217arrayOpen :: B.Builder
218arrayOpen =
219 B.string7 "[\n"
222arrayClose :: B.Builder
223arrayClose =
224 B.char7 ']'
228-- ENCODE OBJECT
231encodeObject :: BSC.ByteString -> (String, Value) -> [(String, Value)] -> B.Builder
232encodeObject =
233 encodeSequence objectOpen objectClose encodeField
236objectOpen :: B.Builder
237objectOpen =
238 B.string7 "{\n"
241objectClose :: B.Builder
242objectClose =
243 B.char7 '}'
246encodeField :: BSC.ByteString -> (String, Value) -> B.Builder
247encodeField indent (key, value) =
248 encodeString key <> B.string7 ": " <> encodeHelp indent value
252-- ENCODE SEQUENCE
255encodeSequence :: B.Builder -> B.Builder -> (BSC.ByteString -> a -> B.Builder) -> BSC.ByteString -> a -> [a] -> B.Builder
256encodeSequence open close encodeEntry indent first rest =
257 let
258 newIndent =
259 indent <> " "
261 newIndentBuilder =
262 B.byteString newIndent
264 closer =
265 newline <> B.byteString indent <> close
267 addValue field builder =
268 commaNewline
269 <> newIndentBuilder
270 <> encodeEntry newIndent field
271 <> builder
272 in
273 open
274 <> newIndentBuilder
275 <> encodeEntry newIndent first
276 <> foldr addValue closer rest
279commaNewline :: B.Builder
280commaNewline =
281 B.string7 ",\n"
284newline :: B.Builder
285newline =
286 B.char7 '\n'
290-- ENCODE STRING
293encodeString :: String -> B.Builder
294encodeString str =
295 B.char7 '"' <> escape str <> B.char7 '"'
298escape :: String -> B.Builder
299escape str =
300 let
301 (front, back) =
302 break isEscape str
303 in
304 case back of
305 "" ->
306 B.stringUtf8 front
308 char : rest ->
309 B.stringUtf8 front <> escapeChar char <> escape rest
312isEscape :: Char -> Bool
313isEscape c =
314 c == '\"' || c == '\\' || c < '\x20'
317escapeChar :: Char -> B.Builder
318escapeChar char =
319 case char of
320 '\"' -> B.string7 "\\\""
321 '\\' -> B.string7 "\\\\"
322 '\n' -> B.string7 "\\n"
323 '\r' -> B.string7 "\\r"
324 '\t' -> B.string7 "\\t"
325 _ -> if char < '\x20' then toEscapeCode char else B.charUtf8 char
328toEscapeCode :: Char -> B.Builder
329toEscapeCode char =
330 let
331 hex =
332 Numeric.showHex (fromEnum char) ""
334 code =
335 "\\u" ++ replicate (4 - length hex) '0' ++ hex
336 in
337 B.string7 code