git.iko.soy/elk
on 52e43bb help sign in
elk/src/Json/Encode.hs
323 lines 5.4 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 , 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.Map as Map
28import Data.Monoid ((<>))
29import qualified Data.Text as Text
30import qualified Numeric
31import System.IO (IOMode(WriteMode), withBinaryFile)
35-- VALUES
38data Value
39 = Array [Value]
40 | Object [(String, Value)]
41 | String B.Builder
42 | Boolean Bool
43 | Integer Int
44 | Null
47array :: [Value] -> Value
48array =
49 Array
52object :: [(String,Value)] -> Value
53object =
54 Object
57text :: Text.Text -> Value
58text txt =
59 String (encodeString (Text.unpack txt))
62string :: String -> Value
63string str =
64 String (encodeString str)
67bool :: Bool -> Value
68bool =
69 Boolean
72int :: Int -> Value
73int =
74 Integer
77null :: Value
78null =
79 Null
82dict :: (k -> String) -> (v -> Value) -> Map.Map k v -> Value
83dict encodeKey encodeValue pairs =
84 Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
87list :: (a -> Value) -> [a] -> Value
88list encodeEntry entries =
89 Array $ map encodeEntry entries
93-- HELPERS
96(==>) :: a -> b -> (a, b)
97(==>) a b =
98 (a, b)
102-- WRITE TO FILE
105write :: FilePath -> Value -> IO ()
106write path value =
107 withBinaryFile path WriteMode $ \handle ->
108 B.hPutBuilder handle (encode value)
111writeUgly :: FilePath -> Value -> IO ()
112writeUgly path value =
113 withBinaryFile path WriteMode $ \handle ->
114 B.hPutBuilder handle (encodeUgly value)
118-- ENCODE UGLY
121encodeUgly :: Value -> B.Builder
122encodeUgly value =
123 case value of
124 Array [] ->
125 B.string7 "[]"
127 Array (first : rest) ->
128 let
129 encodeEntry entry =
130 B.char7 ',' <> encodeUgly entry
131 in
132 B.char7 '[' <> encodeUgly first <> mconcat (map encodeEntry rest) <> B.char7 ']'
134 Object [] ->
135 B.string7 "{}"
137 Object (first : rest) ->
138 let
139 encodeEntry char (key, entry) =
140 B.char7 char <> encodeString key <> B.char7 ':' <> encodeUgly entry
141 in
142 encodeEntry '[' first <> mconcat (map (encodeEntry ',') rest) <> B.char7 ']'
144 String builder ->
145 builder
147 Boolean boolean ->
148 B.string7 (if boolean then "true" else "false")
150 Integer n ->
151 B.intDec n
153 Null ->
154 "null"
158-- ENCODE
161encode :: Value -> B.Builder
162encode value =
163 encodeHelp "" value
166encodeHelp :: BSC.ByteString -> Value -> B.Builder
167encodeHelp indent value =
168 case value of
169 Array [] ->
170 B.string7 "[]"
172 Array (first : rest) ->
173 encodeArray indent first rest
175 Object [] ->
176 B.string7 "{}"
178 Object (first : rest) ->
179 encodeObject indent first rest
181 String builder ->
182 builder
184 Boolean boolean ->
185 B.string7 (if boolean then "true" else "false")
187 Integer n ->
188 B.intDec n
190 Null ->
191 "null"
195-- ENCODE ARRAY
198encodeArray :: BSC.ByteString -> Value -> [Value] -> B.Builder
199encodeArray =
200 encodeSequence arrayOpen arrayClose encodeHelp
203arrayOpen :: B.Builder
204arrayOpen =
205 B.string7 "[\n"
208arrayClose :: B.Builder
209arrayClose =
210 B.char7 ']'
214-- ENCODE OBJECT
217encodeObject :: BSC.ByteString -> (String, Value) -> [(String, Value)] -> B.Builder
218encodeObject =
219 encodeSequence objectOpen objectClose encodeField
222objectOpen :: B.Builder
223objectOpen =
224 B.string7 "{\n"
227objectClose :: B.Builder
228objectClose =
229 B.char7 '}'
232encodeField :: BSC.ByteString -> (String, Value) -> B.Builder
233encodeField indent (key, value) =
234 encodeString key <> B.string7 ": " <> encodeHelp indent value
238-- ENCODE SEQUENCE
241encodeSequence :: B.Builder -> B.Builder -> (BSC.ByteString -> a -> B.Builder) -> BSC.ByteString -> a -> [a] -> B.Builder
242encodeSequence open close encodeEntry indent first rest =
243 let
244 newIndent =
245 indent <> "\t"
247 newIndentBuilder =
248 B.byteString newIndent
250 closer =
251 newline <> B.byteString indent <> close
253 addValue field builder =
254 commaNewline
255 <> newIndentBuilder
256 <> encodeEntry newIndent field
257 <> builder
258 in
259 open
260 <> newIndentBuilder
261 <> encodeEntry newIndent first
262 <> foldr addValue closer rest
265commaNewline :: B.Builder
266commaNewline =
267 B.string7 ",\n"
270newline :: B.Builder
271newline =
272 B.char7 '\n'
276-- ENCODE STRING
279encodeString :: String -> B.Builder
280encodeString str =
281 B.char7 '"' <> escape str <> B.char7 '"'
284escape :: String -> B.Builder
285escape str =
286 let
287 (front, back) =
288 break isEscape str
289 in
290 case back of
291 "" ->
292 B.stringUtf8 front
294 char : rest ->
295 B.stringUtf8 front <> escapeChar char <> escape rest
298isEscape :: Char -> Bool
299isEscape c =
300 c == '\"' || c == '\\' || c < '\x20'
303escapeChar :: Char -> B.Builder
304escapeChar char =
305 case char of
306 '\"' -> B.string7 "\\\""
307 '\\' -> B.string7 "\\\\"
308 '\n' -> B.string7 "\\n"
309 '\r' -> B.string7 "\\r"
310 '\t' -> B.string7 "\\t"
311 _ -> if char < '\x20' then toEscapeCode char else B.charUtf8 char
314toEscapeCode :: Char -> B.Builder
315toEscapeCode char =
316 let
317 hex =
318 Numeric.showHex (fromEnum char) ""
320 code =
321 "\\u" ++ replicate (4 - length hex) '0' ++ hex
322 in
323 B.string7 code