git.iko.soy/elk
on master help sign in
Migrate Json.Decode and Json.Encode over from builder
f775024Evan Czaplicki
src/Json/Decode.hsnew file+280
compare with master
unifiedsplit
@@ -0,0 +1,280 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Json.Decode
4+ ( Decoder, Error(..), decode, parse
5+ , text, bool, int, float
6+ , list, dict, maybe
7+ , field, at
8+ , map, map2, succeed, fail, andThen
9+ -- elm specific stuff
10+ , moduleName, packageName
11+ )
12+ where
13+
14+
15+import Data.Text (Text)
16+import Prelude hiding (fail, map, maybe)
17+
18+import qualified Control.Monad as Monad
19+import qualified Data.Aeson as Aeson
20+import qualified Data.ByteString.Lazy as BS
21+import qualified Data.HashMap.Lazy as HashMap
22+import qualified Data.Scientific as Scientific
23+import qualified Data.Text as Text
24+import qualified Data.Vector as Vector
25+
26+import qualified Elm.Compiler.Module as Module
27+import qualified Elm.Package as Pkg
28+
29+
30+
31+-- DECODERS
32+
33+
34+data Decoder a =
35+ Decoder
36+ { _run :: (Error -> Error) -> Aeson.Value -> Either Error a
37+ }
38+
39+
40+data Error
41+ = Field Text Error
42+ | Index Int Error
43+ | Failure Aeson.Value String
44+
45+
46+decode :: Decoder a -> Aeson.Value -> Either Error a
47+decode decoder value =
48+ _run decoder id value
49+
50+
51+parse :: Decoder a -> BS.ByteString -> Either (Maybe Error) a
52+parse decoder bytestring =
53+ case Aeson.eitherDecode bytestring of
54+ Left _ ->
55+ Left Nothing
56+
57+ Right json ->
58+ case decode decoder json of
59+ Left err ->
60+ Left (Just err)
61+
62+ Right value ->
63+ Right value
64+
65+
66+
67+-- PRIMITIVES
68+
69+
70+text :: Decoder Text
71+text =
72+ Decoder $ \mkError value ->
73+ case value of
74+ Aeson.String txt ->
75+ Right txt
76+
77+ _ ->
78+ Left (mkError (Failure value "a string"))
79+
80+
81+bool :: Decoder Bool
82+bool =
83+ Decoder $ \mkError value ->
84+ case value of
85+ Aeson.Bool boolean ->
86+ Right boolean
87+
88+ _ ->
89+ Left (mkError (Failure value "a boolean"))
90+
91+
92+int :: Decoder Int
93+int =
94+ Decoder $ \mkError value ->
95+ case value of
96+ Aeson.Number number ->
97+ case Scientific.toBoundedInteger number of
98+ Nothing ->
99+ Left (mkError (Failure value "an integer"))
100+
101+ Just integer ->
102+ Right integer
103+
104+ _ ->
105+ Left (mkError (Failure value "an integer"))
106+
107+
108+float :: Decoder Float
109+float =
110+ Decoder $ \mkError value ->
111+ case value of
112+ Aeson.Number number ->
113+ Right (Scientific.toRealFloat number)
114+
115+ _ ->
116+ Left (mkError (Failure value "a float"))
117+
118+
119+
120+-- DATA STRUCTURES
121+
122+
123+list :: Decoder a -> Decoder [a]
124+list (Decoder run) =
125+ Decoder $ \mkError value ->
126+ case value of
127+ Aeson.Array vector ->
128+ Vector.toList <$>
129+ Vector.imapM (\i v -> run (mkError . Index i) v) vector
130+
131+ _ ->
132+ Left (mkError (Failure value "an array"))
133+
134+
135+dict :: Decoder a -> Decoder (HashMap.HashMap Text a)
136+dict (Decoder run) =
137+ Decoder $ \mkError value ->
138+ case value of
139+ Aeson.Object hashMap ->
140+ HashMap.traverseWithKey (\k v -> run (mkError . Field k) v) hashMap
141+
142+ _ ->
143+ Left (mkError (Failure value "an object"))
144+
145+
146+maybe :: Decoder a -> Decoder (Maybe a)
147+maybe (Decoder run) =
148+ Decoder $ \mkError value ->
149+ case run mkError value of
150+ Left _ ->
151+ Right Nothing
152+
153+ Right a ->
154+ Right (Just a)
155+
156+
157+
158+-- OBJECT PRIMITIVES
159+
160+
161+field :: Text -> Decoder a -> Decoder a
162+field name (Decoder run) =
163+ Decoder $ \mkError value ->
164+ case value of
165+ Aeson.Object hashMap ->
166+ case HashMap.lookup name hashMap of
167+ Just v ->
168+ run (mkError . Field name) v
169+
170+ Nothing ->
171+ Left $ mkError $
172+ Failure value ("a \"" ++ Text.unpack name ++ "\" field")
173+
174+ _ ->
175+ Left (mkError (Failure value "an object"))
176+
177+
178+at :: [Text] -> Decoder a -> Decoder a
179+at names decoder =
180+ foldr field decoder names
181+
182+
183+
184+-- MAPPING
185+
186+
187+map :: (a -> value) -> Decoder a -> Decoder value
188+map func (Decoder run) =
189+ Decoder $ \mkError value ->
190+ func <$> run mkError value
191+
192+
193+map2 :: (a -> b -> value) -> Decoder a -> Decoder b -> Decoder value
194+map2 func (Decoder runA) (Decoder runB) =
195+ Decoder $ \mkError value ->
196+ func
197+ <$> runA mkError value
198+ <*> runB mkError value
199+
200+
201+apply :: Decoder (a -> b) -> Decoder a -> Decoder b
202+apply (Decoder runFunc) (Decoder runArg) =
203+ Decoder $ \mkError value ->
204+ do func <- runFunc mkError value
205+ arg <- runArg mkError value
206+ return (func arg)
207+
208+
209+instance Functor Decoder where
210+ fmap =
211+ map
212+
213+
214+instance Applicative Decoder where
215+ pure =
216+ succeed
217+
218+ (<*>) =
219+ apply
220+
221+
222+instance Monad Decoder where
223+ return =
224+ succeed
225+
226+ (>>=) decoder callback =
227+ andThen callback decoder
228+
229+ fail msg =
230+ fail msg
231+
232+
233+
234+-- FANCY PRIMITIVES
235+
236+
237+succeed :: a -> Decoder a
238+succeed a =
239+ Decoder $ \_ _ -> Right a
240+
241+
242+fail :: String -> Decoder a
243+fail msg =
244+ Decoder $ \mkError value ->
245+ Left (mkError (Failure value msg))
246+
247+
248+andThen :: (a -> Decoder b) -> Decoder a -> Decoder b
249+andThen callback (Decoder runA) =
250+ Decoder $ \mkError value ->
251+ do a <- runA mkError value
252+ let (Decoder runB) = callback a
253+ runB mkError value
254+
255+
256+
257+-- ELM SPECIFIC STUFF
258+
259+
260+moduleName :: Decoder Module.Raw
261+moduleName =
262+ do txt <- text
263+ case Module.nameFromText txt of
264+ Nothing ->
265+ fail "a module name like \"Html.Events\""
266+
267+ Just name ->
268+ succeed name
269+
270+
271+packageName :: Decoder Pkg.Name
272+packageName =
273+ do txt <- text
274+ case Pkg.fromText txt of
275+ Left _ ->
276+ fail "a valid project name, like \"elm-lang/core\""
277+
278+ Right name ->
279+ succeed name
280+
src/Json/Encode.hsnew file+244
@@ -0,0 +1,244 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Json.Encode
4+ ( write
5+ , encode
6+ , Value
7+ , array
8+ , object
9+ , text
10+ , string
11+ , bool
12+ , dict
13+ , list
14+ )
15+ where
16+
17+
18+import Control.Arrow ((***))
19+import qualified Data.ByteString.Char8 as BSC
20+import qualified Data.ByteString.Builder as B
21+import qualified Data.Map as Map
22+import Data.Monoid ((<>))
23+import qualified Data.Text as Text
24+import qualified Numeric
25+import System.IO (IOMode(WriteMode), withBinaryFile)
26+
27+
28+
29+-- VALUES
30+
31+
32+data Value
33+ = Array [Value]
34+ | Object [(String, Value)]
35+ | String B.Builder
36+ | Boolean Bool
37+
38+
39+array :: [Value] -> Value
40+array =
41+ Array
42+
43+
44+object :: [(String,Value)] -> Value
45+object =
46+ Object
47+
48+
49+text :: Text.Text -> Value
50+text txt =
51+ String (encodeString (Text.unpack txt))
52+
53+
54+string :: String -> Value
55+string str =
56+ String (encodeString str)
57+
58+
59+bool :: Bool -> Value
60+bool =
61+ Boolean
62+
63+
64+dict :: (k -> String) -> (v -> Value) -> Map.Map k v -> Value
65+dict encodeKey encodeValue pairs =
66+ Object $ map (encodeKey *** encodeValue) (Map.toList pairs)
67+
68+
69+list :: (a -> Value) -> [a] -> Value
70+list encodeEntry entries =
71+ Array $ map encodeEntry entries
72+
73+
74+
75+-- WRITE TO FILE
76+
77+
78+write :: FilePath -> Value -> IO ()
79+write path value =
80+ withBinaryFile path WriteMode $ \handle ->
81+ B.hPutBuilder handle (encode value)
82+
83+
84+
85+-- ENCODE
86+
87+
88+encode :: Value -> B.Builder
89+encode value =
90+ encodeHelp "" value
91+
92+
93+encodeHelp :: BSC.ByteString -> Value -> B.Builder
94+encodeHelp indent value =
95+ case value of
96+ Array [] ->
97+ B.string7 "[]"
98+
99+ Array (first : rest) ->
100+ encodeArray indent first rest
101+
102+ Object [] ->
103+ B.string7 "{}"
104+
105+ Object (first : rest) ->
106+ encodeObject indent first rest
107+
108+ String builder ->
109+ builder
110+
111+ Boolean boolean ->
112+ B.string7 (if boolean then "true" else "false")
113+
114+
115+
116+-- ENCODE ARRAY
117+
118+
119+encodeArray :: BSC.ByteString -> Value -> [Value] -> B.Builder
120+encodeArray =
121+ encodeSequence arrayOpen arrayClose encodeHelp
122+
123+
124+arrayOpen :: B.Builder
125+arrayOpen =
126+ B.string7 "[\n"
127+
128+
129+arrayClose :: B.Builder
130+arrayClose =
131+ B.char7 ']'
132+
133+
134+
135+-- ENCODE OBJECT
136+
137+
138+encodeObject :: BSC.ByteString -> (String, Value) -> [(String, Value)] -> B.Builder
139+encodeObject =
140+ encodeSequence objectOpen objectClose encodeField
141+
142+
143+objectOpen :: B.Builder
144+objectOpen =
145+ B.string7 "{\n"
146+
147+
148+objectClose :: B.Builder
149+objectClose =
150+ B.char7 '}'
151+
152+
153+encodeField :: BSC.ByteString -> (String, Value) -> B.Builder
154+encodeField indent (key, value) =
155+ encodeString key <> B.string7 ": " <> encodeHelp indent value
156+
157+
158+
159+-- ENCODE SEQUENCE
160+
161+
162+encodeSequence :: B.Builder -> B.Builder -> (BSC.ByteString -> a -> B.Builder) -> BSC.ByteString -> a -> [a] -> B.Builder
163+encodeSequence open close encodeEntry indent first rest =
164+ let
165+ newIndent =
166+ indent <> "\t"
167+
168+ newIndentBuilder =
169+ B.byteString newIndent
170+
171+ closer =
172+ newline <> B.byteString indent <> close
173+
174+ addValue field builder =
175+ builder
176+ <> commaNewline
177+ <> newIndentBuilder
178+ <> encodeEntry newIndent field
179+ in
180+ open
181+ <> newIndentBuilder
182+ <> encodeEntry newIndent first
183+ <> foldr addValue closer rest
184+
185+
186+commaNewline :: B.Builder
187+commaNewline =
188+ B.string7 ",\n"
189+
190+
191+newline :: B.Builder
192+newline =
193+ B.char7 '\n'
194+
195+
196+
197+-- ENCODE STRING
198+
199+
200+encodeString :: String -> B.Builder
201+encodeString str =
202+ B.char7 '"' <> escape str <> B.char7 '"'
203+
204+
205+escape :: String -> B.Builder
206+escape str =
207+ let
208+ (front, back) =
209+ break isEscape str
210+ in
211+ case back of
212+ "" ->
213+ B.stringUtf8 front
214+
215+ char : rest ->
216+ B.stringUtf8 front <> escapeChar char <> escape rest
217+
218+
219+isEscape :: Char -> Bool
220+isEscape c =
221+ c == '\"' || c == '\\' || c < '\x20'
222+
223+
224+escapeChar :: Char -> B.Builder
225+escapeChar char =
226+ case char of
227+ '\"' -> B.string7 "\\\""
228+ '\\' -> B.string7 "\\\\"
229+ '\n' -> B.string7 "\\n"
230+ '\r' -> B.string7 "\\r"
231+ '\t' -> B.string7 "\\t"
232+ _ -> if char < '\x20' then toEscapeCode char else B.charUtf8 char
233+
234+
235+toEscapeCode :: Char -> B.Builder
236+toEscapeCode char =
237+ let
238+ hex =
239+ Numeric.showHex (fromEnum char) ""
240+
241+ code =
242+ "\\u" ++ replicate (4 - length hex) '0' ++ hex
243+ in
244+ B.string7 code