git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Json/Decode.hs
296 lines 5.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Json.Decode
4 ( Decoder, Error(..), decode, parse
5 , text, bool, int, float
6 , list, dict, maybe
7 , field, at
8 , index
9 , map, map2, succeed, fail, andThen, oneOf
10 )
11 where
14import Data.Text (Text)
15import Prelude hiding (fail, map, maybe)
17import qualified Control.Monad as Monad
18import qualified Data.Aeson as Aeson
19import qualified Data.ByteString.Lazy as BS
20import qualified Data.HashMap.Lazy as HashMap
21import qualified Data.Scientific as Scientific
22import qualified Data.Text as Text
23import qualified Data.Vector as Vector
24import Data.Vector ((!?))
28-- DECODERS
31data Decoder a =
32 Decoder
33 { _run :: (Error -> Error) -> Aeson.Value -> Either Error a
34 }
37data Error
38 = Field Text Error
39 | Index Int Error
40 | OneOf [Error]
41 | Failure Aeson.Value String
44decode :: Decoder a -> Aeson.Value -> Either Error a
45decode decoder value =
46 _run decoder id value
49parse :: Decoder a -> BS.ByteString -> Either (Maybe Error) a
50parse decoder bytestring =
51 case Aeson.eitherDecode bytestring of
52 Left _ ->
53 Left Nothing
55 Right json ->
56 case decode decoder json of
57 Left err ->
58 Left (Just err)
60 Right value ->
61 Right value
65-- PRIMITIVES
68text :: Decoder Text
69text =
70 Decoder $ \mkError value ->
71 case value of
72 Aeson.String txt ->
73 Right txt
75 _ ->
76 Left (mkError (Failure value "a string"))
79bool :: Decoder Bool
80bool =
81 Decoder $ \mkError value ->
82 case value of
83 Aeson.Bool boolean ->
84 Right boolean
86 _ ->
87 Left (mkError (Failure value "a boolean"))
90int :: Decoder Int
91int =
92 Decoder $ \mkError value ->
93 case value of
94 Aeson.Number number ->
95 case Scientific.toBoundedInteger number of
96 Nothing ->
97 Left (mkError (Failure value "an integer"))
99 Just integer ->
100 Right integer
102 _ ->
103 Left (mkError (Failure value "an integer"))
106float :: Decoder Float
107float =
108 Decoder $ \mkError value ->
109 case value of
110 Aeson.Number number ->
111 Right (Scientific.toRealFloat number)
113 _ ->
114 Left (mkError (Failure value "a float"))
118-- DATA STRUCTURES
121list :: Decoder a -> Decoder [a]
122list (Decoder run) =
123 Decoder $ \mkError value ->
124 case value of
125 Aeson.Array vector ->
126 Vector.toList <$>
127 Vector.imapM (\i v -> run (mkError . Index i) v) vector
129 _ ->
130 Left (mkError (Failure value "an array"))
133dict :: Decoder a -> Decoder (HashMap.HashMap Text a)
134dict (Decoder run) =
135 Decoder $ \mkError value ->
136 case value of
137 Aeson.Object hashMap ->
138 HashMap.traverseWithKey (\k v -> run (mkError . Field k) v) hashMap
140 _ ->
141 Left (mkError (Failure value "an object"))
144maybe :: Decoder a -> Decoder (Maybe a)
145maybe (Decoder run) =
146 Decoder $ \mkError value ->
147 case run mkError value of
148 Left _ ->
149 Right Nothing
151 Right a ->
152 Right (Just a)
156-- OBJECT PRIMITIVES
159field :: Text -> Decoder a -> Decoder a
160field name (Decoder run) =
161 Decoder $ \mkError value ->
162 case value of
163 Aeson.Object hashMap ->
164 case HashMap.lookup name hashMap of
165 Just v ->
166 run (mkError . Field name) v
168 Nothing ->
169 Left $ mkError $
170 Failure value ("a \"" ++ Text.unpack name ++ "\" field")
172 _ ->
173 Left (mkError (Failure value "an object"))
176at :: [Text] -> Decoder a -> Decoder a
177at names decoder =
178 foldr field decoder names
182-- ARRAY PRIMITIVES
185index :: Int -> Decoder a -> Decoder a
186index i (Decoder run) =
187 Decoder $ \mkError value ->
188 case value of
189 Aeson.Array vector ->
190 case vector !? i of
191 Just v ->
192 run (mkError . Index i) v
194 Nothing ->
195 Left $ mkError $
196 Failure value ("index " ++ show i ++ " of an array")
198 _ ->
199 Left (mkError (Failure value "an array"))
203-- MAPPING
206map :: (a -> value) -> Decoder a -> Decoder value
207map func (Decoder run) =
208 Decoder $ \mkError value ->
209 func <$> run mkError value
212map2 :: (a -> b -> value) -> Decoder a -> Decoder b -> Decoder value
213map2 func (Decoder runA) (Decoder runB) =
214 Decoder $ \mkError value ->
215 func
216 <$> runA mkError value
217 <*> runB mkError value
220apply :: Decoder (a -> b) -> Decoder a -> Decoder b
221apply (Decoder runFunc) (Decoder runArg) =
222 Decoder $ \mkError value ->
223 do func <- runFunc mkError value
224 arg <- runArg mkError value
225 return (func arg)
228instance Functor Decoder where
229 fmap =
230 map
233instance Applicative Decoder where
234 pure =
235 succeed
237 (<*>) =
238 apply
241instance Monad Decoder where
242 return =
243 succeed
245 (>>=) decoder callback =
246 andThen callback decoder
248 fail msg =
249 fail msg
253-- FANCY PRIMITIVES
256succeed :: a -> Decoder a
257succeed a =
258 Decoder $ \_ _ -> Right a
261fail :: String -> Decoder a
262fail msg =
263 Decoder $ \mkError value ->
264 Left (mkError (Failure value msg))
267andThen :: (a -> Decoder b) -> Decoder a -> Decoder b
268andThen callback (Decoder runA) =
269 Decoder $ \mkError value ->
270 do a <- runA mkError value
271 let (Decoder runB) = callback a
272 runB mkError value
276-- ONE OF
279oneOf :: [Decoder a] -> Decoder a
280oneOf decoders =
281 Decoder (oneOfHelp decoders [])
284oneOfHelp :: [Decoder a] -> [Error] -> (Error -> Error) -> Aeson.Value -> Either Error a
285oneOfHelp decoders errors mkError value =
286 case decoders of
287 [] ->
288 Left (mkError (OneOf (reverse errors)))
290 Decoder run : otherDecoders ->
291 case run mkError value of
292 Right a ->
293 Right a
295 Left err ->
296 oneOfHelp otherDecoders (err:errors) mkError value