git.iko.soy/elk
on 00a3069 help sign in
elk/src/Json/Decode/Internals.hs
316 lines 6.0 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Json.Decode.Internals
4 ( Value(..)
5 , Decoder(..)
6 , Error(..)
7 , string, text, bool, int
8 , list, dict, pairs
9 , maybe
10 , field, at
11 , index
12 , map, map2, mapError
13 , succeed, fail
14 , andThen, oneOf
15 )
16 where
19import Data.Text (Text)
20import Prelude hiding (fail, map, maybe)
22import qualified Data.HashMap.Strict as HashMap
23import qualified Data.Text as Text
24import qualified Data.Vector as Vector
25import Data.Vector ((!?))
29-- VALUE
32data Value
33 = Array (Vector.Vector Value)
34 | Object [(Text, Value)] (HashMap.HashMap Text Value)
35 | String Text
36 | TRUE
37 | FALSE
38 | Integer Int
39 | NULL
43-- DECODERS
46newtype Decoder e a =
47 Decoder
48 { _run :: (Error e -> Error e) -> Value -> Either (Error e) a
49 }
52data Error e
53 = Field Text (Error e)
54 | Index Int (Error e)
55 | OneOf [Error e]
56 | Failure Value e
57 | Expecting Value Type
60data Type
61 = TObject
62 | TArray
63 | TString
64 | TBool
65 | TInt
66 | TObjectWith Text
67 | TArrayWith Int Int
71-- PRIMITIVES
74string :: Decoder e String
75string =
76 Text.unpack <$> text
79text :: Decoder e Text
80text =
81 Decoder $ \mkError value ->
82 case value of
83 String txt ->
84 Right txt
86 _ ->
87 Left (mkError (Expecting value TString))
90bool :: Decoder e Bool
91bool =
92 Decoder $ \mkError value ->
93 case value of
94 TRUE ->
95 Right True
97 FALSE ->
98 Right False
100 _ ->
101 Left (mkError (Expecting value TBool))
104int :: Decoder e Int
105int =
106 Decoder $ \mkError value ->
107 case value of
108 Integer integer ->
109 Right integer
111 _ ->
112 Left (mkError (Expecting value TInt))
116-- DATA STRUCTURES
119list :: Decoder e a -> Decoder e [a]
120list (Decoder run) =
121 Decoder $ \mkError value ->
122 case value of
123 Array vector ->
124 Vector.toList <$>
125 Vector.imapM (\i v -> run (mkError . Index i) v) vector
127 _ ->
128 Left (mkError (Expecting value TArray))
131dict :: Decoder e a -> Decoder e (HashMap.HashMap Text a)
132dict (Decoder run) =
133 Decoder $ \mkError value ->
134 case value of
135 Object _ hashMap ->
136 HashMap.traverseWithKey (\k v -> run (mkError . Field k) v) hashMap
138 _ ->
139 Left (mkError (Expecting value TObject))
142pairs :: Decoder e a -> Decoder e [(Text, a)]
143pairs (Decoder run) =
144 Decoder $ \mkError value ->
145 case value of
146 Object kvs _ ->
147 traverse (\(k,v) -> (,) k <$> run (mkError . Field k) v) kvs
149 _ ->
150 Left (mkError (Expecting value TObject))
153maybe :: Decoder e a -> Decoder e (Maybe a)
154maybe (Decoder run) =
155 Decoder $ \mkError value ->
156 case run mkError value of
157 Left _ ->
158 Right Nothing
160 Right a ->
161 Right (Just a)
165-- OBJECT PRIMITIVES
168field :: Text -> Decoder e a -> Decoder e a
169field name (Decoder run) =
170 Decoder $ \mkError value ->
171 case value of
172 Object _ hashMap ->
173 case HashMap.lookup name hashMap of
174 Just v ->
175 run (mkError . Field name) v
177 Nothing ->
178 Left $ mkError $ Expecting value (ObjectWith name)
180 _ ->
181 Left (mkError (Expecting value TObject))
184at :: [Text] -> Decoder e a -> Decoder e a
185at names decoder =
186 foldr field decoder names
190-- ARRAY PRIMITIVES
193index :: Int -> Decoder e a -> Decoder e a
194index i (Decoder run) =
195 Decoder $ \mkError value ->
196 case value of
197 Array vector ->
198 case vector !? i of
199 Just v ->
200 run (mkError . Index i) v
202 Nothing ->
203 Left $ mkError $ Expecting value $ ArrayWith i (Vector.length vector)
205 _ ->
206 Left (mkError (Expecting value TArray))
210-- MAPPING
213map :: (a -> value) -> Decoder e a -> Decoder e value
214map func (Decoder run) =
215 Decoder $ \mkError value ->
216 func <$> run mkError value
219map2 :: (a -> b -> value) -> Decoder e a -> Decoder e b -> Decoder e value
220map2 func (Decoder runA) (Decoder runB) =
221 Decoder $ \mkError value ->
222 func
223 <$> runA mkError value
224 <*> runB mkError value
227mapError :: (e -> e') -> Decoder e a -> Decoder e' a
228mapError func (Decoder run) =
229 Decoder $ \mkError value ->
230 run (mapErrorHelp func . mkError) value
233mapErrorHelp :: (e -> e') -> Error e -> Error e'
234mapErrorHelp func err =
235 case err of
236 Field f subErr -> Field f (mapErrorHelp func subErr)
237 Index i subErr -> Index i (mapErrorHelp func subErr)
238 OneOf errors -> OneOf (map (mapErrorHelp func) errors)
239 Failure v e -> Failure v (func e)
240 Expecting v e -> Expecting v e
243apply :: Decoder e (a -> b) -> Decoder e a -> Decoder e b
244apply (Decoder runFunc) (Decoder runArg) =
245 Decoder $ \mkError value ->
246 do func <- runFunc mkError value
247 arg <- runArg mkError value
248 return (func arg)
251instance Functor (Decoder e) where
252 fmap =
253 map
256instance Applicative (Decoder e) where
257 pure =
258 succeed
260 (<*>) =
261 apply
264instance Monad (Decoder e) where
265 return =
266 succeed
268 (>>=) decoder callback =
269 andThen callback decoder
273-- FANCY PRIMITIVES
276succeed :: a -> Decoder e a
277succeed a =
278 Decoder $ \_ _ -> Right a
281fail :: e -> Decoder e a
282fail err =
283 Decoder $ \mkError value ->
284 Left (mkError (Failure value err))
287andThen :: (a -> Decoder e b) -> Decoder e a -> Decoder e b
288andThen callback (Decoder runA) =
289 Decoder $ \mkError value ->
290 do a <- runA mkError value
291 let (Decoder runB) = callback a
292 runB mkError value
296-- ONE OF
299oneOf :: [Decoder e a] -> Decoder e a
300oneOf decoders =
301 Decoder (oneOfHelp decoders [])
304oneOfHelp :: [Decoder e a] -> [Error e] -> (Error e -> Error e) -> Value -> Either (Error e) a
305oneOfHelp decoders errors mkError value =
306 case decoders of
307 [] ->
308 Left (mkError (OneOf (reverse errors)))
310 Decoder run : otherDecoders ->
311 case run mkError value of
312 Right a ->
313 Right a
315 Left err ->
316 oneOfHelp otherDecoders (err:errors) mkError value