git.iko.soy/elk
on 2deedfb help sign in
elk/src/Json/Decode.hs
320 lines 6.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Json.Decode
4 ( Decoder, Error(..), decode, parse
5 , string, text, bool, int, float
6 , list, dict, maybe
7 , field, at
8 , index
9 , map, map2, succeed, fail, andThen, oneOf
10 , aeson
11 )
12 where
15import Data.Text (Text)
16import Prelude hiding (fail, map, maybe)
18import qualified Control.Monad as Monad
19import qualified Data.Aeson as Aeson
20import qualified Data.ByteString.Lazy as BS
21import qualified Data.HashMap.Lazy as HashMap
22import qualified Data.Scientific as Scientific
23import qualified Data.Text as Text
24import qualified Data.Vector as Vector
25import Data.Vector ((!?))
29-- DECODERS
32data Decoder a =
33 Decoder
34 { _run :: (Error -> Error) -> Aeson.Value -> Either Error a
35 }
38data Error
39 = Field Text Error
40 | Index Int Error
41 | OneOf [Error]
42 | Failure Aeson.Value String
43 deriving (Show)
46decode :: Decoder a -> Aeson.Value -> Either Error a
47decode decoder value =
48 _run decoder id value
51parse :: Decoder a -> BS.ByteString -> Either (Maybe Error) a
52parse decoder bytestring =
53 case Aeson.eitherDecode bytestring of
54 Left _ ->
55 Left Nothing
57 Right json ->
58 case decode decoder json of
59 Left err ->
60 Left (Just err)
62 Right value ->
63 Right value
67-- PRIMITIVES
70string :: Decoder String
71string =
72 Text.unpack <$> text
75text :: Decoder Text
76text =
77 Decoder $ \mkError value ->
78 case value of
79 Aeson.String txt ->
80 Right txt
82 _ ->
83 Left (mkError (Failure value "Expecting a STRING"))
86bool :: Decoder Bool
87bool =
88 Decoder $ \mkError value ->
89 case value of
90 Aeson.Bool boolean ->
91 Right boolean
93 _ ->
94 Left (mkError (Failure value "Expecting a BOOL"))
97int :: Decoder Int
98int =
99 Decoder $ \mkError value ->
100 case value of
101 Aeson.Number number ->
102 case Scientific.toBoundedInteger number of
103 Nothing ->
104 Left (mkError (Failure value "Expecting an INT"))
106 Just integer ->
107 Right integer
109 _ ->
110 Left (mkError (Failure value "Expecting an INT"))
113float :: Decoder Float
114float =
115 Decoder $ \mkError value ->
116 case value of
117 Aeson.Number number ->
118 Right (Scientific.toRealFloat number)
120 _ ->
121 Left (mkError (Failure value "Expecting a FLOAT"))
125-- DATA STRUCTURES
128list :: Decoder a -> Decoder [a]
129list (Decoder run) =
130 Decoder $ \mkError value ->
131 case value of
132 Aeson.Array vector ->
133 Vector.toList <$>
134 Vector.imapM (\i v -> run (mkError . Index i) v) vector
136 _ ->
137 Left (mkError (Failure value "Expecting an ARRAY"))
140dict :: Decoder a -> Decoder (HashMap.HashMap Text a)
141dict (Decoder run) =
142 Decoder $ \mkError value ->
143 case value of
144 Aeson.Object hashMap ->
145 HashMap.traverseWithKey (\k v -> run (mkError . Field k) v) hashMap
147 _ ->
148 Left (mkError (Failure value "Expecting an OBJECT"))
151maybe :: Decoder a -> Decoder (Maybe a)
152maybe (Decoder run) =
153 Decoder $ \mkError value ->
154 case run mkError value of
155 Left _ ->
156 Right Nothing
158 Right a ->
159 Right (Just a)
163-- OBJECT PRIMITIVES
166field :: Text -> Decoder a -> Decoder a
167field name (Decoder run) =
168 Decoder $ \mkError value ->
169 case value of
170 Aeson.Object hashMap ->
171 case HashMap.lookup name hashMap of
172 Just v ->
173 run (mkError . Field name) v
175 Nothing ->
176 Left $ mkError $ Failure value $
177 "Expecting a \"" ++ Text.unpack name ++ "\" field."
179 _ ->
180 Left (mkError (Failure value "Expecting an OBJECT"))
183at :: [Text] -> Decoder a -> Decoder a
184at names decoder =
185 foldr field decoder names
189-- ARRAY PRIMITIVES
192index :: Int -> Decoder a -> Decoder a
193index i (Decoder run) =
194 Decoder $ \mkError value ->
195 case value of
196 Aeson.Array vector ->
197 case vector !? i of
198 Just v ->
199 run (mkError . Index i) v
201 Nothing ->
202 Left $ mkError $ Failure value $
203 "Expecting a longer ARRAY. I need index " ++ show i
204 ++ ", but the array only has " ++ show (Vector.length vector)
205 ++ " elements."
207 _ ->
208 Left (mkError (Failure value "Expecting an ARRAY"))
212-- MAPPING
215map :: (a -> value) -> Decoder a -> Decoder value
216map func (Decoder run) =
217 Decoder $ \mkError value ->
218 func <$> run mkError value
221map2 :: (a -> b -> value) -> Decoder a -> Decoder b -> Decoder value
222map2 func (Decoder runA) (Decoder runB) =
223 Decoder $ \mkError value ->
224 func
225 <$> runA mkError value
226 <*> runB mkError value
229apply :: Decoder (a -> b) -> Decoder a -> Decoder b
230apply (Decoder runFunc) (Decoder runArg) =
231 Decoder $ \mkError value ->
232 do func <- runFunc mkError value
233 arg <- runArg mkError value
234 return (func arg)
237instance Functor Decoder where
238 fmap =
239 map
242instance Applicative Decoder where
243 pure =
244 succeed
246 (<*>) =
247 apply
250instance Monad Decoder where
251 return =
252 succeed
254 (>>=) decoder callback =
255 andThen callback decoder
257 fail msg =
258 fail msg
262-- FANCY PRIMITIVES
265succeed :: a -> Decoder a
266succeed a =
267 Decoder $ \_ _ -> Right a
270fail :: String -> Decoder a
271fail msg =
272 Decoder $ \mkError value ->
273 Left (mkError (Failure value msg))
276andThen :: (a -> Decoder b) -> Decoder a -> Decoder b
277andThen callback (Decoder runA) =
278 Decoder $ \mkError value ->
279 do a <- runA mkError value
280 let (Decoder runB) = callback a
281 runB mkError value
285-- ONE OF
288oneOf :: [Decoder a] -> Decoder a
289oneOf decoders =
290 Decoder (oneOfHelp decoders [])
293oneOfHelp :: [Decoder a] -> [Error] -> (Error -> Error) -> Aeson.Value -> Either Error a
294oneOfHelp decoders errors mkError value =
295 case decoders of
296 [] ->
297 Left (mkError (OneOf (reverse errors)))
299 Decoder run : otherDecoders ->
300 case run mkError value of
301 Right a ->
302 Right a
304 Left err ->
305 oneOfHelp otherDecoders (err:errors) mkError value
309-- AESON
312aeson :: (Aeson.FromJSON a) => Decoder a
313aeson =
314 Decoder $ \mkError value ->
315 case Aeson.fromJSON value of
316 Aeson.Error msg ->
317 Left (mkError (Failure value msg))
319 Aeson.Success a ->
320 Right a