@@ -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+