root / src / Ganeti / JSON.hs @ 15a53b1e
History | View | Annotate | Download (12.3 kB)
1 | edc1acde | Iustin Pop | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} |
---|---|---|---|
2 | daa79414 | Iustin Pop | {-# OPTIONS_GHC -fno-warn-orphans #-} |
3 | daa79414 | Iustin Pop | |
4 | f047f90f | Iustin Pop | {-| JSON utility functions. -} |
5 | f047f90f | Iustin Pop | |
6 | f047f90f | Iustin Pop | {- |
7 | f047f90f | Iustin Pop | |
8 | 06fb92cf | Bernardo Dal Seno | Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc. |
9 | f047f90f | Iustin Pop | |
10 | f047f90f | Iustin Pop | This program is free software; you can redistribute it and/or modify |
11 | f047f90f | Iustin Pop | it under the terms of the GNU General Public License as published by |
12 | f047f90f | Iustin Pop | the Free Software Foundation; either version 2 of the License, or |
13 | f047f90f | Iustin Pop | (at your option) any later version. |
14 | f047f90f | Iustin Pop | |
15 | f047f90f | Iustin Pop | This program is distributed in the hope that it will be useful, but |
16 | f047f90f | Iustin Pop | WITHOUT ANY WARRANTY; without even the implied warranty of |
17 | f047f90f | Iustin Pop | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
18 | f047f90f | Iustin Pop | General Public License for more details. |
19 | f047f90f | Iustin Pop | |
20 | f047f90f | Iustin Pop | You should have received a copy of the GNU General Public License |
21 | f047f90f | Iustin Pop | along with this program; if not, write to the Free Software |
22 | f047f90f | Iustin Pop | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
23 | f047f90f | Iustin Pop | 02110-1301, USA. |
24 | f047f90f | Iustin Pop | |
25 | f047f90f | Iustin Pop | -} |
26 | f047f90f | Iustin Pop | |
27 | f3baf5ef | Iustin Pop | module Ganeti.JSON |
28 | ebf38064 | Iustin Pop | ( fromJResult |
29 | 964a728f | Petr Pudlak | , fromJResultE |
30 | 885dafbc | Petr Pudlak | , readJSONWithDesc |
31 | ebf38064 | Iustin Pop | , readEitherString |
32 | ebf38064 | Iustin Pop | , JSRecord |
33 | ebf38064 | Iustin Pop | , loadJSArray |
34 | ebf38064 | Iustin Pop | , fromObj |
35 | ebf38064 | Iustin Pop | , maybeFromObj |
36 | ebf38064 | Iustin Pop | , fromObjWithDefault |
37 | 706f7f51 | Iustin Pop | , fromKeyValue |
38 | ebf38064 | Iustin Pop | , fromJVal |
39 | 964a728f | Petr Pudlak | , fromJValE |
40 | 77cab679 | Agata Murawska | , jsonHead |
41 | 318853ab | Iustin Pop | , getMaybeJsonHead |
42 | 06fb92cf | Bernardo Dal Seno | , getMaybeJsonElem |
43 | ebf38064 | Iustin Pop | , asJSObject |
44 | ebf38064 | Iustin Pop | , asObjectList |
45 | f3f76ccc | Iustin Pop | , tryFromObj |
46 | 0ec8cce2 | Bernardo Dal Seno | , arrayMaybeFromJVal |
47 | a4f35477 | Bernardo Dal Seno | , tryArrayMaybeFromObj |
48 | 3ad57194 | Iustin Pop | , toArray |
49 | 3c8e6d09 | Michele Tartara | , optionalJSField |
50 | 3c8e6d09 | Michele Tartara | , optFieldsToObj |
51 | 4884f187 | Santi Raffa | , readContainer |
52 | edc1acde | Iustin Pop | , HasStringRepr(..) |
53 | edc1acde | Iustin Pop | , GenericContainer(..) |
54 | edc1acde | Iustin Pop | , Container |
55 | 88b58ed6 | Hrvoje Ribicic | , MaybeForJSON(..) |
56 | 5ea9f6cb | Petr Pudlak | , TimeAsDoubleJSON(..) |
57 | ebf38064 | Iustin Pop | ) |
58 | ebf38064 | Iustin Pop | where |
59 | f047f90f | Iustin Pop | |
60 | daa79414 | Iustin Pop | import Control.DeepSeq |
61 | f047f90f | Iustin Pop | import Control.Monad (liftM) |
62 | 964a728f | Petr Pudlak | import Control.Monad.Error.Class |
63 | 3c8e6d09 | Michele Tartara | import Data.Maybe (fromMaybe, catMaybes) |
64 | 84835174 | Iustin Pop | import qualified Data.Map as Map |
65 | 5ea9f6cb | Petr Pudlak | import System.Time (ClockTime(..)) |
66 | f047f90f | Iustin Pop | import Text.Printf (printf) |
67 | f047f90f | Iustin Pop | |
68 | f047f90f | Iustin Pop | import qualified Text.JSON as J |
69 | c12a68e2 | Iustin Pop | import Text.JSON.Pretty (pp_value) |
70 | f047f90f | Iustin Pop | |
71 | 32a569fe | Iustin Pop | -- Note: this module should not import any Ganeti-specific modules |
72 | 32a569fe | Iustin Pop | -- beside BasicTypes, since it's used in THH which is used itself to |
73 | 32a569fe | Iustin Pop | -- build many other modules. |
74 | 32a569fe | Iustin Pop | |
75 | f3f76ccc | Iustin Pop | import Ganeti.BasicTypes |
76 | f3f76ccc | Iustin Pop | |
77 | f047f90f | Iustin Pop | -- * JSON-related functions |
78 | f047f90f | Iustin Pop | |
79 | daa79414 | Iustin Pop | instance NFData J.JSValue where |
80 | daa79414 | Iustin Pop | rnf J.JSNull = () |
81 | daa79414 | Iustin Pop | rnf (J.JSBool b) = rnf b |
82 | daa79414 | Iustin Pop | rnf (J.JSRational b r) = rnf b `seq` rnf r |
83 | daa79414 | Iustin Pop | rnf (J.JSString s) = rnf $ J.fromJSString s |
84 | daa79414 | Iustin Pop | rnf (J.JSArray a) = rnf a |
85 | daa79414 | Iustin Pop | rnf (J.JSObject o) = rnf o |
86 | daa79414 | Iustin Pop | |
87 | daa79414 | Iustin Pop | instance (NFData a) => NFData (J.JSObject a) where |
88 | daa79414 | Iustin Pop | rnf = rnf . J.fromJSObject |
89 | daa79414 | Iustin Pop | |
90 | 3c8e6d09 | Michele Tartara | -- | A type alias for a field of a JSRecord. |
91 | 3c8e6d09 | Michele Tartara | type JSField = (String, J.JSValue) |
92 | 3c8e6d09 | Michele Tartara | |
93 | f047f90f | Iustin Pop | -- | A type alias for the list-based representation of J.JSObject. |
94 | 3c8e6d09 | Michele Tartara | type JSRecord = [JSField] |
95 | f047f90f | Iustin Pop | |
96 | 885dafbc | Petr Pudlak | -- | Annotate @readJSON@ error messages with descriptions of what |
97 | 885dafbc | Petr Pudlak | -- is being parsed into what. |
98 | 885dafbc | Petr Pudlak | readJSONWithDesc :: (J.JSON a) |
99 | 885dafbc | Petr Pudlak | => String -- ^ description of @a@ |
100 | 885dafbc | Petr Pudlak | -> Bool -- ^ include input in |
101 | 885dafbc | Petr Pudlak | -- error messages |
102 | 885dafbc | Petr Pudlak | -> J.JSValue -- ^ input value |
103 | 885dafbc | Petr Pudlak | -> J.Result a |
104 | 885dafbc | Petr Pudlak | readJSONWithDesc typ incInput input = |
105 | 885dafbc | Petr Pudlak | case J.readJSON input of |
106 | 885dafbc | Petr Pudlak | J.Ok r -> J.Ok r |
107 | 885dafbc | Petr Pudlak | J.Error e -> J.Error $ if incInput then msg ++ " from " ++ show input |
108 | 885dafbc | Petr Pudlak | else msg |
109 | 885dafbc | Petr Pudlak | where msg = "Can't parse value for type " ++ typ ++ ": " ++ e |
110 | 885dafbc | Petr Pudlak | |
111 | f047f90f | Iustin Pop | -- | Converts a JSON Result into a monadic value. |
112 | f047f90f | Iustin Pop | fromJResult :: Monad m => String -> J.Result a -> m a |
113 | f047f90f | Iustin Pop | fromJResult s (J.Error x) = fail (s ++ ": " ++ x) |
114 | f047f90f | Iustin Pop | fromJResult _ (J.Ok x) = return x |
115 | f047f90f | Iustin Pop | |
116 | 964a728f | Petr Pudlak | -- | Converts a JSON Result into a MonadError value. |
117 | 964a728f | Petr Pudlak | fromJResultE :: (Error e, MonadError e m) => String -> J.Result a -> m a |
118 | 964a728f | Petr Pudlak | fromJResultE s (J.Error x) = throwError . strMsg $ s ++ ": " ++ x |
119 | 964a728f | Petr Pudlak | fromJResultE _ (J.Ok x) = return x |
120 | 964a728f | Petr Pudlak | |
121 | f047f90f | Iustin Pop | -- | Tries to read a string from a JSON value. |
122 | f047f90f | Iustin Pop | -- |
123 | f047f90f | Iustin Pop | -- In case the value was not a string, we fail the read (in the |
124 | f047f90f | Iustin Pop | -- context of the current monad. |
125 | f047f90f | Iustin Pop | readEitherString :: (Monad m) => J.JSValue -> m String |
126 | f047f90f | Iustin Pop | readEitherString v = |
127 | ebf38064 | Iustin Pop | case v of |
128 | ebf38064 | Iustin Pop | J.JSString s -> return $ J.fromJSString s |
129 | ebf38064 | Iustin Pop | _ -> fail "Wrong JSON type" |
130 | f047f90f | Iustin Pop | |
131 | f047f90f | Iustin Pop | -- | Converts a JSON message into an array of JSON objects. |
132 | f047f90f | Iustin Pop | loadJSArray :: (Monad m) |
133 | f047f90f | Iustin Pop | => String -- ^ Operation description (for error reporting) |
134 | f047f90f | Iustin Pop | -> String -- ^ Input message |
135 | f047f90f | Iustin Pop | -> m [J.JSObject J.JSValue] |
136 | f047f90f | Iustin Pop | loadJSArray s = fromJResult s . J.decodeStrict |
137 | f047f90f | Iustin Pop | |
138 | a4f35477 | Bernardo Dal Seno | -- | Helper function for missing-key errors |
139 | a4f35477 | Bernardo Dal Seno | buildNoKeyError :: JSRecord -> String -> String |
140 | a4f35477 | Bernardo Dal Seno | buildNoKeyError o k = |
141 | a4f35477 | Bernardo Dal Seno | printf "key '%s' not found, object contains only %s" k (show (map fst o)) |
142 | a4f35477 | Bernardo Dal Seno | |
143 | f047f90f | Iustin Pop | -- | Reads the value of a key in a JSON object. |
144 | f047f90f | Iustin Pop | fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a |
145 | f047f90f | Iustin Pop | fromObj o k = |
146 | ebf38064 | Iustin Pop | case lookup k o of |
147 | a4f35477 | Bernardo Dal Seno | Nothing -> fail $ buildNoKeyError o k |
148 | ebf38064 | Iustin Pop | Just val -> fromKeyValue k val |
149 | f047f90f | Iustin Pop | |
150 | f2f06e2e | Iustin Pop | -- | Reads the value of an optional key in a JSON object. Missing |
151 | f2f06e2e | Iustin Pop | -- keys, or keys that have a \'null\' value, will be returned as |
152 | f2f06e2e | Iustin Pop | -- 'Nothing', otherwise we attempt deserialisation and return a 'Just' |
153 | f2f06e2e | Iustin Pop | -- value. |
154 | f047f90f | Iustin Pop | maybeFromObj :: (J.JSON a, Monad m) => |
155 | f047f90f | Iustin Pop | JSRecord -> String -> m (Maybe a) |
156 | f047f90f | Iustin Pop | maybeFromObj o k = |
157 | ebf38064 | Iustin Pop | case lookup k o of |
158 | ebf38064 | Iustin Pop | Nothing -> return Nothing |
159 | f2f06e2e | Iustin Pop | -- a optional key with value JSNull is the same as missing, since |
160 | f2f06e2e | Iustin Pop | -- we can't convert it meaningfully anyway to a Haskell type, and |
161 | f2f06e2e | Iustin Pop | -- the Python code can emit 'null' for optional values (depending |
162 | f2f06e2e | Iustin Pop | -- on usage), and finally our encoding rules treat 'null' values |
163 | f2f06e2e | Iustin Pop | -- as 'missing' |
164 | f2f06e2e | Iustin Pop | Just J.JSNull -> return Nothing |
165 | ebf38064 | Iustin Pop | Just val -> liftM Just (fromKeyValue k val) |
166 | f047f90f | Iustin Pop | |
167 | f2f06e2e | Iustin Pop | -- | Reads the value of a key in a JSON object with a default if |
168 | f2f06e2e | Iustin Pop | -- missing. Note that both missing keys and keys with value \'null\' |
169 | 2f3d7a50 | Jose A. Lopes | -- will cause the default value to be returned. |
170 | f047f90f | Iustin Pop | fromObjWithDefault :: (J.JSON a, Monad m) => |
171 | f047f90f | Iustin Pop | JSRecord -> String -> a -> m a |
172 | f047f90f | Iustin Pop | fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k |
173 | f047f90f | Iustin Pop | |
174 | 0ec8cce2 | Bernardo Dal Seno | arrayMaybeFromJVal :: (J.JSON a, Monad m) => J.JSValue -> m [Maybe a] |
175 | 0ec8cce2 | Bernardo Dal Seno | arrayMaybeFromJVal (J.JSArray xs) = |
176 | 0ec8cce2 | Bernardo Dal Seno | mapM parse xs |
177 | 0ec8cce2 | Bernardo Dal Seno | where |
178 | 0ec8cce2 | Bernardo Dal Seno | parse J.JSNull = return Nothing |
179 | 0ec8cce2 | Bernardo Dal Seno | parse x = liftM Just $ fromJVal x |
180 | 0ec8cce2 | Bernardo Dal Seno | arrayMaybeFromJVal v = |
181 | 0ec8cce2 | Bernardo Dal Seno | fail $ "Expecting array, got '" ++ show (pp_value v) ++ "'" |
182 | 0ec8cce2 | Bernardo Dal Seno | |
183 | a4f35477 | Bernardo Dal Seno | -- | Reads an array of optional items |
184 | a4f35477 | Bernardo Dal Seno | arrayMaybeFromObj :: (J.JSON a, Monad m) => |
185 | a4f35477 | Bernardo Dal Seno | JSRecord -> String -> m [Maybe a] |
186 | a4f35477 | Bernardo Dal Seno | arrayMaybeFromObj o k = |
187 | a4f35477 | Bernardo Dal Seno | case lookup k o of |
188 | 0ec8cce2 | Bernardo Dal Seno | Just a -> arrayMaybeFromJVal a |
189 | a4f35477 | Bernardo Dal Seno | _ -> fail $ buildNoKeyError o k |
190 | a4f35477 | Bernardo Dal Seno | |
191 | a4f35477 | Bernardo Dal Seno | -- | Wrapper for arrayMaybeFromObj with better diagnostic |
192 | a4f35477 | Bernardo Dal Seno | tryArrayMaybeFromObj :: (J.JSON a) |
193 | a4f35477 | Bernardo Dal Seno | => String -- ^ Textual "owner" in error messages |
194 | a4f35477 | Bernardo Dal Seno | -> JSRecord -- ^ The object array |
195 | a4f35477 | Bernardo Dal Seno | -> String -- ^ The desired key from the object |
196 | a4f35477 | Bernardo Dal Seno | -> Result [Maybe a] |
197 | a4f35477 | Bernardo Dal Seno | tryArrayMaybeFromObj t o = annotateResult t . arrayMaybeFromObj o |
198 | a4f35477 | Bernardo Dal Seno | |
199 | f047f90f | Iustin Pop | -- | Reads a JValue, that originated from an object key. |
200 | f047f90f | Iustin Pop | fromKeyValue :: (J.JSON a, Monad m) |
201 | f047f90f | Iustin Pop | => String -- ^ The key name |
202 | f047f90f | Iustin Pop | -> J.JSValue -- ^ The value to read |
203 | f047f90f | Iustin Pop | -> m a |
204 | f047f90f | Iustin Pop | fromKeyValue k val = |
205 | 706f7f51 | Iustin Pop | fromJResult (printf "key '%s'" k) (J.readJSON val) |
206 | f047f90f | Iustin Pop | |
207 | f047f90f | Iustin Pop | -- | Small wrapper over readJSON. |
208 | f047f90f | Iustin Pop | fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a |
209 | f047f90f | Iustin Pop | fromJVal v = |
210 | ebf38064 | Iustin Pop | case J.readJSON v of |
211 | c12a68e2 | Iustin Pop | J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++ |
212 | ebf38064 | Iustin Pop | "', error: " ++ s) |
213 | ebf38064 | Iustin Pop | J.Ok x -> return x |
214 | f047f90f | Iustin Pop | |
215 | 964a728f | Petr Pudlak | -- | Small wrapper over 'readJSON' for 'MonadError'. |
216 | 964a728f | Petr Pudlak | fromJValE :: (Error e, MonadError e m, J.JSON a) => J.JSValue -> m a |
217 | 964a728f | Petr Pudlak | fromJValE v = |
218 | 964a728f | Petr Pudlak | case J.readJSON v of |
219 | 964a728f | Petr Pudlak | J.Error s -> throwError . strMsg $ |
220 | 964a728f | Petr Pudlak | "Cannot convert value '" ++ show (pp_value v) ++ |
221 | 964a728f | Petr Pudlak | "', error: " ++ s |
222 | 964a728f | Petr Pudlak | J.Ok x -> return x |
223 | 964a728f | Petr Pudlak | |
224 | 77cab679 | Agata Murawska | -- | Helper function that returns Null or first element of the list. |
225 | 77cab679 | Agata Murawska | jsonHead :: (J.JSON b) => [a] -> (a -> b) -> J.JSValue |
226 | 77cab679 | Agata Murawska | jsonHead [] _ = J.JSNull |
227 | 77cab679 | Agata Murawska | jsonHead (x:_) f = J.showJSON $ f x |
228 | 77cab679 | Agata Murawska | |
229 | 318853ab | Iustin Pop | -- | Helper for extracting Maybe values from a possibly empty list. |
230 | 318853ab | Iustin Pop | getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue |
231 | 318853ab | Iustin Pop | getMaybeJsonHead [] _ = J.JSNull |
232 | 318853ab | Iustin Pop | getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x) |
233 | 318853ab | Iustin Pop | |
234 | 06fb92cf | Bernardo Dal Seno | -- | Helper for extracting Maybe values from a list that might be too short. |
235 | 06fb92cf | Bernardo Dal Seno | getMaybeJsonElem :: (J.JSON b) => [a] -> Int -> (a -> Maybe b) -> J.JSValue |
236 | 06fb92cf | Bernardo Dal Seno | getMaybeJsonElem [] _ _ = J.JSNull |
237 | 06fb92cf | Bernardo Dal Seno | getMaybeJsonElem xs 0 f = getMaybeJsonHead xs f |
238 | 06fb92cf | Bernardo Dal Seno | getMaybeJsonElem (_:xs) n f |
239 | 06fb92cf | Bernardo Dal Seno | | n < 0 = J.JSNull |
240 | 06fb92cf | Bernardo Dal Seno | | otherwise = getMaybeJsonElem xs (n - 1) f |
241 | 06fb92cf | Bernardo Dal Seno | |
242 | f047f90f | Iustin Pop | -- | Converts a JSON value into a JSON object. |
243 | f047f90f | Iustin Pop | asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue) |
244 | f047f90f | Iustin Pop | asJSObject (J.JSObject a) = return a |
245 | f047f90f | Iustin Pop | asJSObject _ = fail "not an object" |
246 | f047f90f | Iustin Pop | |
247 | f047f90f | Iustin Pop | -- | Coneverts a list of JSON values into a list of JSON objects. |
248 | f047f90f | Iustin Pop | asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue] |
249 | f047f90f | Iustin Pop | asObjectList = mapM asJSObject |
250 | f3f76ccc | Iustin Pop | |
251 | 7209d304 | Klaus Aehlig | -- | Try to extract a key from an object with better error reporting |
252 | f3f76ccc | Iustin Pop | -- than fromObj. |
253 | f3f76ccc | Iustin Pop | tryFromObj :: (J.JSON a) => |
254 | f3f76ccc | Iustin Pop | String -- ^ Textual "owner" in error messages |
255 | f3f76ccc | Iustin Pop | -> JSRecord -- ^ The object array |
256 | f3f76ccc | Iustin Pop | -> String -- ^ The desired key from the object |
257 | f3f76ccc | Iustin Pop | -> Result a |
258 | f3f76ccc | Iustin Pop | tryFromObj t o = annotateResult t . fromObj o |
259 | 3ad57194 | Iustin Pop | |
260 | 3ad57194 | Iustin Pop | -- | Ensure a given JSValue is actually a JSArray. |
261 | 3ad57194 | Iustin Pop | toArray :: (Monad m) => J.JSValue -> m [J.JSValue] |
262 | 3ad57194 | Iustin Pop | toArray (J.JSArray arr) = return arr |
263 | c12a68e2 | Iustin Pop | toArray o = |
264 | c12a68e2 | Iustin Pop | fail $ "Invalid input, expected array but got " ++ show (pp_value o) |
265 | 84835174 | Iustin Pop | |
266 | 3c8e6d09 | Michele Tartara | -- | Creates a Maybe JSField. If the value string is Nothing, the JSField |
267 | 3c8e6d09 | Michele Tartara | -- will be Nothing as well. |
268 | 3c8e6d09 | Michele Tartara | optionalJSField :: (J.JSON a) => String -> Maybe a -> Maybe JSField |
269 | 3c8e6d09 | Michele Tartara | optionalJSField name (Just value) = Just (name, J.showJSON value) |
270 | 3c8e6d09 | Michele Tartara | optionalJSField _ Nothing = Nothing |
271 | 3c8e6d09 | Michele Tartara | |
272 | 3c8e6d09 | Michele Tartara | -- | Creates an object with all the non-Nothing fields of the given list. |
273 | 3c8e6d09 | Michele Tartara | optFieldsToObj :: [Maybe JSField] -> J.JSValue |
274 | 3c8e6d09 | Michele Tartara | optFieldsToObj = J.makeObj . catMaybes |
275 | 3c8e6d09 | Michele Tartara | |
276 | 84835174 | Iustin Pop | -- * Container type (special type for JSON serialisation) |
277 | 84835174 | Iustin Pop | |
278 | edc1acde | Iustin Pop | -- | Class of types that can be converted from Strings. This is |
279 | edc1acde | Iustin Pop | -- similar to the 'Read' class, but it's using a different |
280 | edc1acde | Iustin Pop | -- serialisation format, so we have to define a separate class. Mostly |
281 | edc1acde | Iustin Pop | -- useful for custom key types in JSON dictionaries, which have to be |
282 | edc1acde | Iustin Pop | -- backed by strings. |
283 | edc1acde | Iustin Pop | class HasStringRepr a where |
284 | edc1acde | Iustin Pop | fromStringRepr :: (Monad m) => String -> m a |
285 | edc1acde | Iustin Pop | toStringRepr :: a -> String |
286 | edc1acde | Iustin Pop | |
287 | edc1acde | Iustin Pop | -- | Trivial instance 'HasStringRepr' for 'String'. |
288 | edc1acde | Iustin Pop | instance HasStringRepr String where |
289 | edc1acde | Iustin Pop | fromStringRepr = return |
290 | edc1acde | Iustin Pop | toStringRepr = id |
291 | edc1acde | Iustin Pop | |
292 | 84835174 | Iustin Pop | -- | The container type, a wrapper over Data.Map |
293 | edc1acde | Iustin Pop | newtype GenericContainer a b = |
294 | edc1acde | Iustin Pop | GenericContainer { fromContainer :: Map.Map a b } |
295 | 139c0683 | Iustin Pop | deriving (Show, Eq) |
296 | 84835174 | Iustin Pop | |
297 | daa79414 | Iustin Pop | instance (NFData a, NFData b) => NFData (GenericContainer a b) where |
298 | daa79414 | Iustin Pop | rnf = rnf . Map.toList . fromContainer |
299 | daa79414 | Iustin Pop | |
300 | edc1acde | Iustin Pop | -- | Type alias for string keys. |
301 | edc1acde | Iustin Pop | type Container = GenericContainer String |
302 | edc1acde | Iustin Pop | |
303 | 84835174 | Iustin Pop | -- | Container loader. |
304 | edc1acde | Iustin Pop | readContainer :: (Monad m, HasStringRepr a, Ord a, J.JSON b) => |
305 | edc1acde | Iustin Pop | J.JSObject J.JSValue -> m (GenericContainer a b) |
306 | 84835174 | Iustin Pop | readContainer obj = do |
307 | 84835174 | Iustin Pop | let kjvlist = J.fromJSObject obj |
308 | edc1acde | Iustin Pop | kalist <- mapM (\(k, v) -> do |
309 | edc1acde | Iustin Pop | k' <- fromStringRepr k |
310 | edc1acde | Iustin Pop | v' <- fromKeyValue k v |
311 | edc1acde | Iustin Pop | return (k', v')) kjvlist |
312 | edc1acde | Iustin Pop | return $ GenericContainer (Map.fromList kalist) |
313 | 84835174 | Iustin Pop | |
314 | 417ab39c | Iustin Pop | {-# ANN showContainer "HLint: ignore Use ***" #-} |
315 | 84835174 | Iustin Pop | -- | Container dumper. |
316 | edc1acde | Iustin Pop | showContainer :: (HasStringRepr a, J.JSON b) => |
317 | edc1acde | Iustin Pop | GenericContainer a b -> J.JSValue |
318 | 84835174 | Iustin Pop | showContainer = |
319 | edc1acde | Iustin Pop | J.makeObj . map (\(k, v) -> (toStringRepr k, J.showJSON v)) . |
320 | edc1acde | Iustin Pop | Map.toList . fromContainer |
321 | 84835174 | Iustin Pop | |
322 | edc1acde | Iustin Pop | instance (HasStringRepr a, Ord a, J.JSON b) => |
323 | edc1acde | Iustin Pop | J.JSON (GenericContainer a b) where |
324 | 84835174 | Iustin Pop | showJSON = showContainer |
325 | 84835174 | Iustin Pop | readJSON (J.JSObject o) = readContainer o |
326 | 84835174 | Iustin Pop | readJSON v = fail $ "Failed to load container, expected object but got " |
327 | c12a68e2 | Iustin Pop | ++ show (pp_value v) |
328 | 88b58ed6 | Hrvoje Ribicic | |
329 | 88b58ed6 | Hrvoje Ribicic | -- | A Maybe newtype that allows for serialization more appropriate to the |
330 | 88b58ed6 | Hrvoje Ribicic | -- semantics of Maybe and JSON in our calls. Does not produce needless |
331 | 88b58ed6 | Hrvoje Ribicic | -- and confusing dictionaries. |
332 | 88b58ed6 | Hrvoje Ribicic | newtype MaybeForJSON a = MaybeForJSON { unMaybeForJSON :: Maybe a } |
333 | 6879dfd2 | Petr Pudlak | deriving (Show, Eq, Ord) |
334 | 88b58ed6 | Hrvoje Ribicic | instance (J.JSON a) => J.JSON (MaybeForJSON a) where |
335 | 6879dfd2 | Petr Pudlak | readJSON J.JSNull = return $ MaybeForJSON Nothing |
336 | 6879dfd2 | Petr Pudlak | readJSON x = (MaybeForJSON . Just) `liftM` J.readJSON x |
337 | 88b58ed6 | Hrvoje Ribicic | showJSON (MaybeForJSON (Just x)) = J.showJSON x |
338 | 88b58ed6 | Hrvoje Ribicic | showJSON (MaybeForJSON Nothing) = J.JSNull |
339 | 5ea9f6cb | Petr Pudlak | |
340 | 5ea9f6cb | Petr Pudlak | newtype TimeAsDoubleJSON |
341 | 5ea9f6cb | Petr Pudlak | = TimeAsDoubleJSON { unTimeAsDoubleJSON :: ClockTime } |
342 | 5ea9f6cb | Petr Pudlak | deriving (Show, Eq, Ord) |
343 | 5ea9f6cb | Petr Pudlak | instance J.JSON TimeAsDoubleJSON where |
344 | 5ea9f6cb | Petr Pudlak | readJSON v = do |
345 | 5ea9f6cb | Petr Pudlak | t <- J.readJSON v :: J.Result Double |
346 | 5ea9f6cb | Petr Pudlak | return . TimeAsDoubleJSON . uncurry TOD |
347 | 5ea9f6cb | Petr Pudlak | $ divMod (round $ t * pico) (pico :: Integer) |
348 | 5ea9f6cb | Petr Pudlak | where |
349 | 5ea9f6cb | Petr Pudlak | pico :: (Num a) => a |
350 | 5ea9f6cb | Petr Pudlak | pico = 10^(12 :: Int) |
351 | 5ea9f6cb | Petr Pudlak | showJSON (TimeAsDoubleJSON (TOD ss ps)) = J.showJSON |
352 | 5ea9f6cb | Petr Pudlak | (fromIntegral ss + fromIntegral ps / 10^(12 :: Int) :: Double) |