@@ -1,4 +1,11 @@
1−{-# LANGUAGE CPP, NoImplicitPrelude, TemplateHaskell #-}
1+{-# LANGUAGE CPP
2+ , NoImplicitPrelude
3+ , TemplateHaskell
4+ , NamedFieldPuns
5+ , FlexibleInstances
6+ , UndecidableInstances
7+ , OverlappingInstances
8+ #-}
29
310{-|
411Module: Data.Aeson.TH
@@ -30,91 +37,9 @@ change record field names. In this case we drop the first 4 characters of every
3037field name.
3138
3239@
33−$('deriveJSON' ('drop' 4) ''D)
40+$('deriveJSON' 'defaultOptions'{'fieldNameModifier' = 'drop' 4} ''D)
3441@
3542
36−This will result in the following (simplified) code to be spliced in your program:
37−
38−@
39−import Control.Applicative
40−import Control.Monad
41−import Data.Aeson
42−import Data.Aeson.TH
43−import qualified Data.HashMap.Strict as H
44−import qualified Data.Text as T
45−import qualified Data.Vector as V
46−
47−instance 'ToJSON' a => 'ToJSON' (D a) where
48− 'toJSON' =
49− \\value ->
50− case value of
51− Nullary ->
52− 'object' [T.pack \"Nullary\" .= 'toJSON' ([] :: [()])]
53− Unary arg1 ->
54− 'object' [T.pack \"Unary\" .= 'toJSON' arg1]
55− Product arg1 arg2 arg3 ->
56− 'object' [ T.pack \"Product\"
57− .= ('Array' $ 'V.create' $ do
58− mv <- 'VM.unsafeNew' 3
59− 'VM.unsafeWrite' mv 0 ('toJSON' arg1)
60− 'VM.unsafeWrite' mv 1 ('toJSON' arg2)
61− 'VM.unsafeWrite' mv 2 ('toJSON' arg3)
62− return mv)
63− ]
64− Record arg1 arg2 arg3 ->
65− 'object' [ T.pack \"Record\"
66− .= 'object' [ T.pack \"One\" '.=' arg1
67− , T.pack \"Two\" '.=' arg2
68− , T.pack \"Three\" '.=' arg3
69− ]
70− ]
71−@
72−
73−@
74−instance 'FromJSON' a => 'FromJSON' (D a) where
75− 'parseJSON' =
76− \\value ->
77− case value of
78− 'Object' obj ->
79− case H.toList obj of
80− [(conKey, conVal)] ->
81− case conKey of
82− _ | conKey == T.pack \"Nullary\" ->
83− case conVal of
84− 'Array' arr ->
85− if V.null arr
86− then pure Nullary
87− else fail \"\<error message\>\"
88− _ -> fail \"\<error message\>\"
89− | conKey == T.pack \"Unary\" ->
90− case conVal of
91− arg -> Unary \<$\> parseJSON arg
92− | conKey == T.pack \"Product\" ->
93− case conVal of
94− 'Array' arr ->
95− if V.length arr == 3
96− then Product \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)
97− \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)
98− \<*\> 'parseJSON' (arr `V.unsafeIndex` 2)
99− else fail \"\<error message\>\"
100− _ -> fail \"\<error message\>\"
101− | conKey == T.pack \"Record\" ->
102− case conVal of
103− 'Object' recObj ->
104− if H.size recObj == 3
105− then Record \<$\> recObj '.:' T.pack \"One\"
106− \<*\> recObj '.:' T.pack \"Two\"
107− \<*\> recObj '.:' T.pack \"Three\"
108− else fail \"\<error message\>\"
109− _ -> fail \"\<error message\>\"
110− | otherwise -> fail \"\<error message\>\"
111− _ -> fail \"\<error message\>\"
112− _ -> fail \"\<error message\>\"
113−@
114−
115−Note that every \"\<error message\>\" is in fact a descriptive message which
116−provides as much information as is reasonable about the failed parse.
117−
11843Now we can use the newly created instances.
11944
12045@
@@ -132,13 +57,15 @@ Please note that you can derive instances for tuples using the following syntax:
13257
13358@
13459-- FromJSON and ToJSON instances for 4-tuples.
135−$('deriveJSON' id ''(,,,))
60+$('deriveJSON' 'defaultOptions' ''(,,,))
13661@
13762
13863-}
13964
14065module Data.Aeson.TH
141− ( deriveJSON
66+ ( Options(..), SumEncoding(..), defaultOptions
67+
68+ , deriveJSON
14269
14370 , deriveToJSON
14471 , deriveFromJSON
@@ -152,7 +79,7 @@ module Data.Aeson.TH
15279--------------------------------------------------------------------------------
15380
15481-- from aeson:
155−import Data.Aeson ( toJSON, Object, object, (.=)
82+import Data.Aeson ( toJSON, Object, object, (.=), (.:), (.:?)
15683 , ToJSON, toJSON
15784 , FromJSON, parseJSON
15885 )
@@ -160,12 +87,14 @@ import Data.Aeson.Types ( Value(..), Parser )
16087-- from base:
16188import Control.Applicative ( pure, (<$>), (<*>) )
16289import Control.Monad ( return, mapM, liftM2, fail )
163−import Data.Bool ( otherwise )
90+import Data.Bool ( Bool(False, True), otherwise, (&&) )
16491import Data.Eq ( (==) )
165−import Data.Function ( ($), (.), id )
92+import Data.Function ( ($), (.), id, const )
16693import Data.Functor ( fmap )
94+import Data.Int ( Int )
95+import Data.Either ( Either(Left, Right), either )
16796import Data.List ( (++), foldl, foldl', intercalate
168− , length, map, zip, genericLength
97+ , length, map, zip, genericLength, all
16998 )
17099import Data.Maybe ( Maybe(Nothing, Just) )
171100import Prelude ( String, (-), Integer, fromIntegral, error )
@@ -176,16 +105,60 @@ import Control.Monad ( (>>=) )
176105import Prelude ( fromInteger )
177106#endif
178107-- from unordered-containers:
179−import qualified Data.HashMap.Strict as H ( lookup, toList, size )
108+import qualified Data.HashMap.Strict as H ( lookup )
180109-- from template-haskell:
181110import Language.Haskell.TH
111+import Language.Haskell.TH.Syntax ( VarStrictType )
182112-- from text:
183113import qualified Data.Text as T ( Text, pack, unpack )
184114-- from vector:
185−import qualified Data.Vector as V ( unsafeIndex, null, length, create )
115+import qualified Data.Vector as V ( unsafeIndex, null, length, create, fromList )
186116import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
187117
188118
119+--------------------------------------------------------------------------------
120+-- Configuration
121+--------------------------------------------------------------------------------
122+
123+-- | Options that specify how to encode your datatype to JSON.
124+data Options = Options
125+ { fieldNameModifier :: String -> String
126+ -- ^ Function applied to field names.
127+ -- Handy for removing common record prefixes for example.
128+ , nullaryToString :: Bool
129+ -- ^ If 'True' the constructors of a datatypes, with all nullary
130+ -- constructors, will be encoded to a string with the
131+ -- constructor name. If 'False' the encoding will always follow
132+ -- the `sumEncoding`.
133+ , sumEncoding :: SumEncoding
134+ -- ^ Specifies how to encode constructors of a sum datatype.
135+ }
136+
137+-- | Specifies how to encode constructors of a sum datatype.
138+data SumEncoding =
139+ TwoElemArray -- ^ A constructor will be encoded to a 2-element
140+ -- array where the first element is the name of the
141+ -- constructor and the second element the content of
142+ -- the constructor.
143+ | ObjectWithType { typeFieldName :: String
144+ , valueFieldName :: String
145+ }
146+ -- ^ A constructor will be encoded to an object with a field
147+ -- 'typeFieldName' which specifies the constructor name. If the
148+ -- constructor is not a record the constructor content will be
149+ -- stored under the 'valueFieldName' field.
150+
151+-- | Default encoding options which specify to not modify field names,
152+-- encode the constructors of a datatype with all nullary constructors
153+-- to just strings with the name of the constructor and use a
154+-- 2-element array for other sum datatypes.
155+defaultOptions :: Options
156+defaultOptions = Options
157+ { fieldNameModifier = id
158+ , nullaryToString = True
159+ , sumEncoding = TwoElemArray
160+ }
161+
189162--------------------------------------------------------------------------------
190163-- Convenience
191164--------------------------------------------------------------------------------
@@ -195,16 +168,16 @@ import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
195168--
196169-- This is a convienience function which is equivalent to calling both
197170-- 'deriveToJSON' and 'deriveFromJSON'.
198−deriveJSON :: (String -> String)
199− -- ^ Function to change field names.
171+deriveJSON :: Options
172+ -- ^ Encoding options.
200173 -> Name
201174 -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
202175 -- instances.
203176 -> Q [Dec]
204−deriveJSON withField name =
177+deriveJSON opts name =
205178 liftM2 (++)
206− (deriveToJSON withField name)
207− (deriveFromJSON withField name)
179+ (deriveToJSON opts name)
180+ (deriveFromJSON opts name)
208181
209182
210183--------------------------------------------------------------------------------
@@ -221,33 +194,13 @@ The above (ToJSON a) constraint is not necessary and perhaps undesirable.
221194-}
222195
223196-- | Generates a 'ToJSON' instance declaration for the given data type.
224−--
225−-- Example:
226−--
227−-- @
228−-- data Foo = Foo 'Char' 'Int'
229−-- $('deriveToJSON' 'id' ''Foo)
230−-- @
231−--
232−-- This will splice in the following code:
233−--
234−-- @
235−-- instance 'ToJSON' Foo where
236−-- 'toJSON' =
237−-- \\value -> case value of
238−-- Foo arg1 arg2 -> 'Array' $ 'V.create' $ do
239−-- mv <- 'VM.unsafeNew' 2
240−-- 'VM.unsafeWrite' mv 0 ('toJSON' arg1)
241−-- 'VM.unsafeWrite' mv 1 ('toJSON' arg2)
242−-- return mv
243−-- @
244−deriveToJSON :: (String -> String)
245− -- ^ Function to change field names.
197+deriveToJSON :: Options
198+ -- ^ Encoding options.
246199 -> Name
247200 -- ^ Name of the type for which to generate a 'ToJSON' instance
248201 -- declaration.
249202 -> Q [Dec]
250−deriveToJSON withField name =
203+deriveToJSON opts name =
251204 withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
252205 where
253206 fromCons :: [TyVarBndr] -> [Con] -> Q Dec
@@ -256,7 +209,7 @@ deriveToJSON withField name =
256209 (classType `appT` instanceType)
257210 [ funD 'toJSON
258211 [ clause []
259− (normalB $ consToJSON withField cons)
212+ (normalB $ consToJSON opts cons)
260213 []
261214 ]
262215 ]
@@ -266,126 +219,145 @@ deriveToJSON withField name =
266219 instanceType = foldl' appT (conT name) $ map varT typeNames
267220
268221-- | Generates a lambda expression which encodes the given data type as JSON.
269−--
270−-- Example:
271−--
272−-- @
273−-- data Foo = Foo Int
274−-- @
275−--
276−-- @
277−-- encodeFoo :: Foo -> 'Value'
278−-- encodeFoo = $('mkToJSON' id ''Foo)
279−-- @
280−--
281−-- This will splice in the following code:
282−--
283−-- @
284−-- \\value -> case value of Foo arg1 -> 'toJSON' arg1
285−-- @
286−mkToJSON :: (String -> String) -- ^ Function to change field names.
222+mkToJSON :: Options -- ^ Encoding options.
287223 -> Name -- ^ Name of the type to encode.
288224 -> Q Exp
289−mkToJSON withField name = withType name (\_ cons -> consToJSON withField cons)
225+mkToJSON opts name = withType name (\_ cons -> consToJSON opts cons)
290226
291227-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates code
292228-- to generate the JSON encoding of a number of constructors. All constructors
293229-- must be from the same type.
294−consToJSON :: (String -> String)
295− -- ^ Function to change field names.
230+consToJSON :: Options
231+ -- ^ Encoding options.
296232 -> [Con]
297233 -- ^ Constructors for which to generate JSON generating code.
298234 -> Q Exp
235+
299236consToJSON _ [] = error $ "Data.Aeson.TH.consToJSON: "
300237 ++ "Not a single constructor given!"
238+
301239-- A single constructor is directly encoded. The constructor itself may be
302240-- forgotten.
303−consToJSON withField [con] = do
241+consToJSON opts [con] = do
304242 value <- newName "value"
305− lam1E (varP value)
306− $ caseE (varE value)
307− [encodeArgs id withField con]
308−-- With multiple constructors we need to remember which constructor is
309−-- encoded. This is done by generating a JSON object which maps to constructor's
310−-- name to the JSON encoding of its contents.
311−consToJSON withField cons = do
243+ lam1E (varP value) $ caseE (varE value) [encodeArgs opts False con]
244+
245+consToJSON opts cons = do
312246 value <- newName "value"
313− lam1E (varP value)
314− $ caseE (varE value)
315− [ encodeArgs (wrap $ getConName con) withField con
316− | con <- cons
317− ]
247+ lam1E (varP value) $ caseE (varE value) matches
318248 where
319− wrap :: Name -> Q Exp -> Q Exp
320− wrap name exp =
321− let fieldName = [e|T.pack|] `appE` litE (stringL $ nameBase name)
322− in [e|object|] `appE` listE [ infixApp fieldName
323− [e|(.=)|]
324− exp
325− ]
249+ -- Constructors of a datatype with all nullary constructors are encoded to
250+ -- just a string with the constructor name:
251+ matches | nullaryToString opts && all isNullary cons =
252+ [ match (conP conName []) (normalB $ conStr conName) []
253+ | con <- cons
254+ , let conName = getConName con
255+ ]
256+ -- Constructors of a datatype having some constructors with arity > 0 are
257+ -- encoded to a 2-element array where the first element is a string with
258+ -- the constructor name and the second element is the encoded argument or
259+ -- arguments of the constructor.
260+ | otherwise = [ encodeArgs opts True con
261+ | con <- cons
262+ ]
263+
264+conStr :: Name -> Q Exp
265+conStr = appE [|String|] . appE [|T.pack|] . stringE . nameBase
266+
267+-- | If constructor is nullary.
268+isNullary :: Con -> Bool
269+isNullary (NormalC _ []) = True
270+isNullary _ = False
271+
272+encodeSum :: Options -> Bool -> Name -> Q Exp -> Q Exp
273+encodeSum opts multiCons conName exp
274+ | multiCons =
275+ case sumEncoding opts of
276+ TwoElemArray ->
277+ [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr conName, exp])
278+ ObjectWithType{typeFieldName, valueFieldName} ->
279+ [|object|] `appE` listE
280+ [ infixApp [|T.pack typeFieldName|] [|(.=)|] (conStr conName)
281+ , infixApp [|T.pack valueFieldName|] [|(.=)|] exp
282+ ]
283+ | otherwise = exp
326284
327285-- | Generates code to generate the JSON encoding of a single constructor.
328−encodeArgs :: (Q Exp -> Q Exp) -> (String -> String) -> Con -> Q Match
286+encodeArgs :: Options -> Bool -> Con -> Q Match
329287-- Nullary constructors. Generates code that explicitly matches against the
330288-- constructor even though it doesn't contain data. This is useful to prevent
331289-- type errors.
332−encodeArgs withExp _ (NormalC conName []) =
290+encodeArgs opts multiCons (NormalC conName []) =
333291 match (conP conName [])
334− (normalB $ withExp [e|toJSON ([] :: [()])|])
292+ (normalB (encodeSum opts multiCons conName [e|toJSON ([] :: [()])|]))
335293 []
294+
336295-- Polyadic constructors with special case for unary constructors.
337−encodeArgs withExp _ (NormalC conName ts) = do
296+encodeArgs opts multiCons (NormalC conName ts) = do
338297 let len = length ts
339298 args <- mapM newName ["arg" ++ show n | n <- [1..len]]
340− js <- case [[e|toJSON|] `appE` varE arg | arg <- args] of
299+ js <- case [[|toJSON|] `appE` varE arg | arg <- args] of
341300 -- Single argument is directly converted.
342301 [e] -> return e
343302 -- Multiple arguments are converted to a JSON array.
344303 es -> do
345304 mv <- newName "mv"
346305 let newMV = bindS (varP mv)
347− ([e|VM.unsafeNew|] `appE`
306+ ([|VM.unsafeNew|] `appE`
348307 litE (integerL $ fromIntegral len))
349308 stmts = [ noBindS $
350− [e|VM.unsafeWrite|] `appE`
309+ [|VM.unsafeWrite|] `appE`
351310 (varE mv) `appE`
352311 litE (integerL ix) `appE`
353312 e
354313 | (ix, e) <- zip [(0::Integer)..] es
355314 ]
356− ret = noBindS $ [e|return|] `appE` varE mv
357− return $ [e|Array|] `appE`
315+ ret = noBindS $ [|return|] `appE` varE mv
316+ return $ [|Array|] `appE`
358317 (varE 'V.create `appE`
359318 doE (newMV:stmts++[ret]))
360319 match (conP conName $ map varP args)
361− (normalB $ withExp js)
320+ (normalB $ encodeSum opts multiCons conName js)
362321 []
322+
363323-- Records.
364−encodeArgs withExp withField (RecC conName ts) = do
324+encodeArgs opts multiCons (RecC conName ts) = do
365325 args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
366− let js = [ infixApp ([e|T.pack|] `appE` fieldNameExp withField field)
367− [e|(.=)|]
326+ let js = [ infixApp ([|T.pack|] `appE` fieldNameExp opts field)
327+ [|(.=)|]
368328 (varE arg)
369329 | (arg, (field, _, _)) <- zip args ts
370330 ]
331+ exp = [|object|] `appE` listE js
371332 match (conP conName $ map varP args)
372− (normalB $ withExp $ [e|object|] `appE` listE js)
373− []
333+ ( normalB
334+ $ if multiCons
335+ then case sumEncoding opts of
336+ TwoElemArray -> [|toJSON|] `appE` tupE [conStr conName, exp]
337+ ObjectWithType{typeFieldName} ->
338+ [|object|] `appE` listE
339+ ( infixApp [|T.pack typeFieldName|] [|(.=)|]
340+ (conStr conName)
341+ : js
342+ )
343+ else exp
344+ ) []
345+
374346-- Infix constructors.
375−encodeArgs withExp _ (InfixC _ conName _) = do
347+encodeArgs opts multiCons (InfixC _ conName _) = do
376348 al <- newName "argL"
377349 ar <- newName "argR"
378350 match (infixP (varP al) conName (varP ar))
379351 ( normalB
380− $ withExp
381− $ [e|toJSON|] `appE` listE [ [e|toJSON|] `appE` varE a
382− | a <- [al,ar]
383− ]
352+ $ encodeSum opts multiCons conName
353+ $ [|toJSON|] `appE` listE [ [|toJSON|] `appE` varE a
354+ | a <- [al,ar]
355+ ]
384356 )
385357 []
386358-- Existentially quantified constructors.
387−encodeArgs withExp withField (ForallC _ _ con) =
388− encodeArgs withExp withField con
359+encodeArgs opts multiCons (ForallC _ _ con) =
360+ encodeArgs opts multiCons con
389361
390362
391363--------------------------------------------------------------------------------
@@ -393,34 +365,13 @@ encodeArgs withExp withField (ForallC _ _ con) =
393365--------------------------------------------------------------------------------
394366
395367-- | Generates a 'FromJSON' instance declaration for the given data type.
396−--
397−-- Example:
398−--
399−-- @
400−-- data Foo = Foo Char Int
401−-- $('deriveFromJSON' id ''Foo)
402−-- @
403−--
404−-- This will splice in the following code:
405−--
406−-- @
407−-- instance 'FromJSON' Foo where
408−-- 'parseJSON' =
409−-- \\value -> case value of
410−-- 'Array' arr ->
411−-- if (V.length arr == 2)
412−-- then Foo \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)
413−-- \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)
414−-- else fail \"\<error message\>\"
415−-- other -> fail \"\<error message\>\"
416−-- @
417−deriveFromJSON :: (String -> String)
418− -- ^ Function to change field names.
368+deriveFromJSON :: Options
369+ -- ^ Encoding options.
419370 -> Name
420371 -- ^ Name of the type for which to generate a 'FromJSON' instance
421372 -- declaration.
422373 -> Q [Dec]
423−deriveFromJSON withField name =
374+deriveFromJSON opts name =
424375 withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
425376 where
426377 fromCons :: [TyVarBndr] -> [Con] -> Q Dec
@@ -429,7 +380,7 @@ deriveFromJSON withField name =
429380 (classType `appT` instanceType)
430381 [ funD 'parseJSON
431382 [ clause []
432− (normalB $ consFromJSON name withField cons)
383+ (normalB $ consFromJSON name opts cons)
433384 []
434385 ]
435386 ]
@@ -440,181 +391,280 @@ deriveFromJSON withField name =
440391
441392-- | Generates a lambda expression which parses the JSON encoding of the given
442393-- data type.
443−--
444−-- Example:
445−--
446−-- @
447−-- data Foo = Foo 'Int'
448−-- @
449−--
450−-- @
451−-- parseFoo :: 'Value' -> 'Parser' Foo
452−-- parseFoo = $('mkParseJSON' id ''Foo)
453−-- @
454−--
455−-- This will splice in the following code:
456−--
457−-- @
458−-- \\value -> case value of arg -> Foo \<$\> 'parseJSON' arg
459−-- @
460−mkParseJSON :: (String -> String) -- ^ Function to change field names.
394+mkParseJSON :: Options -- ^ Encoding options.
461395 -> Name -- ^ Name of the encoded type.
462396 -> Q Exp
463−mkParseJSON withField name =
464− withType name (\_ cons -> consFromJSON name withField cons)
397+mkParseJSON opts name =
398+ withType name (\_ cons -> consFromJSON name opts cons)
465399
466400-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates
467401-- code to parse the JSON encoding of a number of constructors. All constructors
468402-- must be from the same type.
469403consFromJSON :: Name
470404 -- ^ Name of the type to which the constructors belong.
471− -> (String -> String)
472− -- ^ Function to change field names.
405+ -> Options
406+ -- ^ Encoding options
473407 -> [Con]
474408 -- ^ Constructors for which to generate JSON parsing code.
475409 -> Q Exp
410+
476411consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
477412 ++ "Not a single constructor given!"
478−consFromJSON tName withField [con] = do
413+
414+consFromJSON tName opts [con] = do
415+ value <- newName "value"
416+ lam1E (varP value) (parseArgs tName opts con (Right value))
417+
418+consFromJSON tName opts cons = do
479419 value <- newName "value"
480− lam1E (varP value)
481− $ caseE (varE value)
482− (parseArgs tName withField con)
483−consFromJSON tName withField cons = do
484− value <- newName "value"
485− obj <- newName "obj"
486− conKey <- newName "conKey"
487− conVal <- newName "conVal"
488−
489− let -- Convert the Data.Map inside the Object to a list and pattern match
490− -- against it. It must contain a single element otherwise the parse will
491− -- fail.
492− caseLst = caseE ([e|H.toList|] `appE` varE obj)
493− [ match (listP [tupP [varP conKey, varP conVal]])
494− (normalB caseKey)
495− []
496− , do other <- newName "other"
497− match (varP other)
498− (normalB $ [|wrongPairCountFail|]
499− `appE` (litE $ stringL $ show tName)
500− `appE` ([|show . length|] `appE` varE other)
501− )
502− []
503− ]
504−
505− caseKey = caseE (varE conKey)
506− [match wildP (guardedB guards) []]
507− guards = [ do g <- normalG $ infixApp (varE conKey)
508− [|(==)|]
509− ( [|T.pack|]
510− `appE` conNameExp con
511− )
512− e <- caseE (varE conVal)
513− (parseArgs tName withField con)
514− return (g, e)
515− | con <- cons
516− ]
517− ++
518− [ liftM2 (,)
519− (normalG [e|otherwise|])
520− ( [|conNotFoundFail|]
521− `appE` (litE $ stringL $ show tName)
522− `appE` listE (map (litE . stringL . nameBase . getConName) cons)
523− `appE` ([|T.unpack|] `appE` varE conKey)
524− )
525− ]
526−
527− lam1E (varP value)
528− $ caseE (varE value)
529− [ match (conP 'Object [varP obj])
530− (normalB caseLst)
531− []
532− , do other <- newName "other"
533− match (varP other)
534− ( normalB
535− $ [|noObjectFail|]
420+ lam1E (varP value) $ caseE (varE value) $
421+ if nullaryToString opts && all isNullary cons
422+ then allNullaryMatches
423+ else mixedMatches
424+
425+ where
426+ allNullaryMatches =
427+ [ do txt <- newName "txt"
428+ match (conP 'String [varP txt])
429+ (guardedB $
430+ [ liftM2 (,) (normalG $
431+ infixApp (varE txt)
432+ [|(==)|]
433+ ([|T.pack|] `appE`
434+ stringE (nameBase conName)))
435+ ([|pure|] `appE` conE conName)
436+ | con <- cons
437+ , let conName = getConName con
438+ ]
439+ ++
440+ [ liftM2 (,)
441+ (normalG [|otherwise|])
442+ ( [|noMatchFail|]
443+ `appE` (litE $ stringL $ show tName)
444+ `appE` ([|T.unpack|] `appE` varE txt)
445+ )
446+ ]
447+ )
448+ []
449+ , do other <- newName "other"
450+ match (varP other)
451+ (normalB $ [|noStringFail|]
452+ `appE` (litE $ stringL $ show tName)
453+ `appE` ([|valueConName|] `appE` varE other)
454+ )
455+ []
456+ ]
457+
458+ mixedMatches =
459+ case sumEncoding opts of
460+ ObjectWithType {typeFieldName, valueFieldName} ->
461+ [ do obj <- newName "obj"
462+ match (conP 'Object [varP obj])
463+ (normalB $ parseObject typeFieldName valueFieldName obj)
464+ []
465+ , do other <- newName "other"
466+ match (varP other)
467+ ( normalB
468+ $ [|noObjectFail|]
536469 `appE` (litE $ stringL $ show tName)
537470 `appE` ([|valueConName|] `appE` varE other)
538− )
539− []
540− ]
471+ )
472+ []
473+ ]
474+ TwoElemArray ->
475+ [ do arr <- newName "array"
476+ match (conP 'Array [varP arr])
477+ (guardedB $
478+ [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
479+ [|(==)|]
480+ (litE $ integerL 2))
481+ (parse2ElemArray arr)
482+ , liftM2 (,) (normalG [|otherwise|])
483+ (([|not2ElemArray|]
484+ `appE` (litE $ stringL $ show tName)
485+ `appE` ([|V.length|] `appE` varE arr)))
486+ ]
487+ )
488+ []
489+ , do other <- newName "other"
490+ match (varP other)
491+ ( normalB
492+ $ [|noArrayFail|]
493+ `appE` (litE $ stringL $ show tName)
494+ `appE` ([|valueConName|] `appE` varE other)
495+ )
496+ []
497+ ]
498+
499+ parseObject typFieldName valFieldName obj = do
500+ conKey <- newName "conKey"
501+ doE [ bindS (varP conKey)
502+ (infixApp (varE obj)
503+ [|(.:)|]
504+ ([|T.pack|] `appE` stringE typFieldName))
505+ , noBindS $ parseContents conKey (Left (valFieldName, obj))
506+ ]
541507
542−-- | Generates code to parse the JSON encoding of a single constructor.
543−parseArgs :: Name -- ^ Name of the type to which the constructor belongs.
544− -> (String -> String) -- ^ Function to change field names.
545− -> Con -- ^ Constructor for which to generate JSON parsing code.
546− -> [Q Match]
547−-- Nullary constructors.
548−parseArgs tName _ (NormalC conName []) =
508+ parse2ElemArray arr = do
509+ conKey <- newName "conKey"
510+ conVal <- newName "conVal"
511+ let letIx n ix =
512+ valD (varP n)
513+ (normalB ([|V.unsafeIndex|] `appE`
514+ varE arr `appE`
515+ litE (integerL ix)))
516+ []
517+ letE [ letIx conKey 0
518+ , letIx conVal 1
519+ ]
520+ (parseContents conKey (Right conVal))
521+
522+ parseContents conKey contents =
523+ caseE (varE conKey)
524+ [ do txt <- newName "txt"
525+ match (conP 'String [varP txt])
526+ (guardedB $
527+ [ liftM2 (,) (normalG $
528+ infixApp (varE txt)
529+ [|(==)|]
530+ ([|T.pack|] `appE`
531+ conNameExp con))
532+ (parseArgs tName opts con contents)
533+ | con <- cons
534+ ]
535+ ++
536+ [ liftM2 (,)
537+ (normalG [|otherwise|])
538+ ( [|conNotFoundFail|]
539+ `appE` (litE $ stringL $ show tName)
540+ `appE` listE (map ( litE
541+ . stringL
542+ . nameBase
543+ . getConName
544+ )
545+ cons
546+ )
547+ `appE` ([|T.unpack|] `appE` varE txt)
548+ )
549+ ]
550+ )
551+ []
552+ , do other <- newName "other"
553+ match (varP other)
554+ ( normalB $
555+ (either (const [|typeNotString|])
556+ (const [|firstElemNotString|])
557+ contents)
558+ `appE` (litE $ stringL $ show tName)
559+ `appE` ([|valueConName|] `appE` varE other)
560+ )
561+ []
562+ ]
563+
564+
565+parseNullaryMatches :: Name -> Name -> [Q Match]
566+parseNullaryMatches tName conName =
549567 [ do arr <- newName "arr"
550568 match (conP 'Array [varP arr])
551− ( normalB $ condE ([|V.null|] `appE` varE arr)
552− ([e|pure|] `appE` conE conName)
553− ( parseTypeMismatch tName conName
554− (litE $ stringL "an empty Array")
555− ( infixApp (litE $ stringL $ "Array of length ")
556− [|(++)|]
557− ([|show . V.length|] `appE` varE arr)
558− )
559− )
569+ (guardedB $
570+ [ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr)
571+ ([|pure|] `appE` conE conName)
572+ , liftM2 (,) (normalG [|otherwise|])
573+ (parseTypeMismatch tName conName
574+ (litE $ stringL "an empty Array")
575+ (infixApp (litE $ stringL $ "Array of length ")
576+ [|(++)|]
577+ ([|show . V.length|] `appE` varE arr)
578+ )
579+ )
580+ ]
560581 )
561582 []
562583 , matchFailed tName conName "Array"
563584 ]
564−-- Unary constructors.
565−parseArgs _ _ (NormalC conName [_]) =
585+
586+parseUnaryMatches :: Name -> [Q Match]
587+parseUnaryMatches conName =
566588 [ do arg <- newName "arg"
567589 match (varP arg)
568590 ( normalB $ infixApp (conE conName)
569− [e|(<$>)|]
570− ([e|parseJSON|] `appE` varE arg)
591+ [|(<$>)|]
592+ ([|parseJSON|] `appE` varE arg)
571593 )
572594 []
573595 ]
596+
597+parseRecord :: Options -> Name -> Name -> [VarStrictType] -> Name -> ExpQ
598+parseRecord opts tName conName ts obj =
599+ foldl' (\a b -> infixApp a [|(<*>)|] b)
600+ (infixApp (conE conName) [|(<$>)|] x)
601+ xs
602+ where
603+ x:xs = [ [|lookupField|]
604+ `appE` (litE $ stringL $ show tName)
605+ `appE` (litE $ stringL $ nameBase conName)
606+ `appE` (varE obj)
607+ `appE` ( [|T.pack|] `appE` fieldNameExp opts field
608+ )
609+ | (field, _, _) <- ts
610+ ]
611+
612+getValField :: Name -> String -> [MatchQ] -> Q Exp
613+getValField obj valFieldName matches = do
614+ val <- newName "val"
615+ doE [ bindS (varP val) $ infixApp (varE obj)
616+ [|(.:)|]
617+ ([|T.pack|] `appE`
618+ (litE $ stringL valFieldName))
619+ , noBindS $ caseE (varE val) matches
620+ ]
621+
622+-- | Generates code to parse the JSON encoding of a single constructor.
623+parseArgs :: Name -- ^ Name of the type to which the constructor belongs.
624+ -> Options -- ^ Encoding options.
625+ -> Con -- ^ Constructor for which to generate JSON parsing code.
626+ -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
627+ -- Right valName
628+ -> Q Exp
629+-- Nullary constructors.
630+parseArgs tName _ (NormalC conName []) (Left (valFieldName, obj)) =
631+ getValField obj valFieldName $ parseNullaryMatches tName conName
632+parseArgs tName _ (NormalC conName []) (Right valName) =
633+ caseE (varE valName) $ parseNullaryMatches tName conName
634+
635+-- Unary constructors.
636+parseArgs _ _ (NormalC conName [_]) (Left (valFieldName, obj)) =
637+ getValField obj valFieldName $ parseUnaryMatches conName
638+parseArgs _ _ (NormalC conName [_]) (Right valName) =
639+ caseE (varE valName) $ parseUnaryMatches conName
640+
574641-- Polyadic constructors.
575−parseArgs tName _ (NormalC conName ts) = parseProduct tName conName $ genericLength ts
642+parseArgs tName _ (NormalC conName ts) (Left (valFieldName, obj)) =
643+ getValField obj valFieldName $ parseProduct tName conName $ genericLength ts
644+parseArgs tName _ (NormalC conName ts) (Right valName) =
645+ caseE (varE valName) $ parseProduct tName conName $ genericLength ts
646+
576647-- Records.
577−parseArgs tName withField (RecC conName ts) =
578− [ do obj <- newName "recObj"
579− let x:xs = [ [|lookupField|]
580− `appE` (litE $ stringL $ show tName)
581− `appE` (litE $ stringL $ nameBase conName)
582− `appE` (varE obj)
583− `appE` ( [e|T.pack|]
584− `appE`
585− fieldNameExp withField field
586− )
587− | (field, _, _) <- ts
588− ]
589− match (conP 'Object [varP obj])
590− ( normalB $ condE ( infixApp ([|H.size|] `appE` varE obj)
591− [|(==)|]
592− (litE $ integerL $ genericLength ts)
593− )
594− ( foldl' (\a b -> infixApp a [|(<*>)|] b)
595− (infixApp (conE conName) [|(<$>)|] x)
596− xs
597− )
598− ( parseTypeMismatch tName conName
599− ( litE $ stringL $ "Object with "
600− ++ show (length ts)
601− ++ " name/value pairs"
602− )
603− ( infixApp ([|show . H.size|] `appE` varE obj)
604− [|(++)|]
605− (litE $ stringL $ " name/value pairs")
606− )
607− )
608− )
609− []
648+parseArgs tName opts (RecC conName ts) (Left (_, obj)) =
649+ parseRecord opts tName conName ts obj
650+parseArgs tName opts (RecC conName ts) (Right valName) = do
651+ obj <- newName "recObj"
652+ caseE (varE valName)
653+ [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj) []
610654 , matchFailed tName conName "Object"
611655 ]
656+
612657-- Infix constructors. Apart from syntax these are the same as
613658-- polyadic constructors.
614−parseArgs tName _ (InfixC _ conName _) = parseProduct tName conName 2
659+parseArgs tName _ (InfixC _ conName _) (Left (valFieldName, obj)) =
660+ getValField obj valFieldName $ parseProduct tName conName 2
661+parseArgs tName _ (InfixC _ conName _) (Right valName) =
662+ caseE (varE valName) $ parseProduct tName conName 2
663+
615664-- Existentially quantified constructors. We ignore the quantifiers
616665-- and proceed with the contained constructor.
617−parseArgs tName withField (ForallC _ _ con) = parseArgs tName withField con
666+parseArgs tName opts (ForallC _ _ con) contents =
667+ parseArgs tName opts con contents
618668
619669-- | Generates code to parse the JSON encoding of an n-ary
620670-- constructor.
@@ -678,29 +728,48 @@ parseTypeMismatch tName conName expected actual =
678728 , actual
679729 ]
680730
681−lookupField :: (FromJSON a) => String -> String -> Object -> T.Text -> Parser a
682−lookupField tName rec obj key =
683− case H.lookup key obj of
684− Nothing -> unknownFieldFail tName rec (T.unpack key)
685− Just v -> parseJSON v
731+class (FromJSON a) => LookupField a where
732+ lookupField :: String -> String -> Object -> T.Text -> Parser a
733+
734+instance (FromJSON a) => LookupField a where
735+ lookupField tName rec obj key =
736+ case H.lookup key obj of
737+ Nothing -> unknownFieldFail tName rec (T.unpack key)
738+ Just v -> parseJSON v
739+
740+instance (FromJSON a) => LookupField (Maybe a) where
741+ lookupField _ _ = (.:?)
686742
687743unknownFieldFail :: String -> String -> String -> Parser fail
688744unknownFieldFail tName rec key =
689745 fail $ printf "When parsing the record %s of type %s the key %s was not present."
690746 rec tName key
691747
748+noArrayFail :: String -> String -> Parser fail
749+noArrayFail t o = fail $ printf "When parsing %s expected Array but got %s." t o
750+
692751noObjectFail :: String -> String -> Parser fail
693−noObjectFail t o =
694− fail $ printf "When parsing %s expected Object but got %s." t o
752+noObjectFail t o = fail $ printf "When parsing %s expected Object but got %s." t o
753+
754+noStringFail :: String -> String -> Parser fail
755+noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o
756+
757+noMatchFail :: String -> String -> Parser fail
758+noMatchFail t o =
759+ fail $ printf "When parsing %s expected a String with the name of a constructor but got %s." t o
760+
761+not2ElemArray :: String -> Int -> Parser fail
762+not2ElemArray t i = fail $ printf "When parsing %s expected an Array of 2-elements but got %i elements"
763+ t i
764+typeNotString :: String -> String -> Parser fail
765+typeNotString t o = fail $ printf "When parsing %s expected an Object where the type field is a String with the name of a constructor but got %s." t o
695766
696−wrongPairCountFail :: String -> String -> Parser fail
697−wrongPairCountFail t n =
698− fail $ printf "When parsing %s expected an Object with a single name/value pair but got %s pairs."
699− t n
767+firstElemNotString :: String -> String -> Parser fail
768+firstElemNotString t o = fail $ printf "When parsing %s expected an Array where the first element is a String with the name of a constructor but got %s." t o
700769
701770conNotFoundFail :: String -> [String] -> String -> Parser fail
702771conNotFoundFail t cs o =
703− fail $ printf "When parsing %s expected an Object with a name/value pair where the name is one of [%s], but got %s."
772+ fail $ printf "When parsing %s expected a 2-element Array with a name and value element where the name is one of [%s], but got %s."
704773 t (intercalate ", " cs) o
705774
706775parseTypeMismatch' :: String -> String -> String -> String -> Parser fail
@@ -753,10 +822,10 @@ conNameExp :: Con -> Q Exp
753822conNameExp = litE . stringL . nameBase . getConName
754823
755824-- | Creates a string literal expression from a record field name.
756−fieldNameExp :: (String -> String) -- ^ Function to change the field name.
825+fieldNameExp :: Options -- ^ Encoding options
757826 -> Name
758827 -> Q Exp
759−fieldNameExp f = litE . stringL . f . nameBase
828+fieldNameExp opts = litE . stringL . fieldNameModifier opts . nameBase
760829
761830-- | The name of the outermost 'Value' constructor.
762831valueConName :: Value -> String