@@ -47,21 +47,21 @@ instance 'ToJSON' a => 'ToJSON' (D a) where
4747 \value ->
4848 case value of
4949 Nullary ->
50− 'object' ['T.pack' \"Nullary\" .= 'toJSON' ([] :: [()])]
50+ 'object' [T.pack \"Nullary\" .= 'toJSON' ([] :: [()])]
5151 Unary arg1 ->
52− 'object' ['T.pack' \"Unary\" .= 'toJSON' arg1]
52+ 'object' [T.pack \"Unary\" .= 'toJSON' arg1]
5353 Product arg1 arg2 arg3 ->
54− 'object' [ 'T.pack' \"Product\"
54+ 'object' [ T.pack \"Product\"
5555 .= 'toJSON' [ 'toJSON' arg1
5656 , 'toJSON' arg2
5757 , 'toJSON' arg3
5858 ]
5959 ]
6060 Record arg1 arg2 arg3 ->
61− 'object' [ 'T.pack' \"Record\"
62− .= 'object' [ 'T.pack' \"One\" '.=' arg1
63− , 'T.pack' \"Two\" '.=' arg2
64− , 'T.pack' \"Three\" '.=' arg3
61+ 'object' [ T.pack \"Record\"
62+ .= 'object' [ T.pack \"One\" '.=' arg1
63+ , T.pack \"Two\" '.=' arg2
64+ , T.pack \"Three\" '.=' arg3
6565 ]
6666 ]
6767@
@@ -72,35 +72,45 @@ instance 'FromJSON' a => 'FromJSON' (D a) where
7272 \value ->
7373 case value of
7474 'Object' obj ->
75− case 'M.toList' obj of
75+ case M.toList obj of
7676 [(conKey, conVal)] ->
77− case conKey of
78− _ | (conKey '==' 'T.pack' \"Nullary\") ->
79− case conVal of
80− 'Array' arr | 'V.null' arr -> 'pure' Nullary
81− _ -> 'mzero'
82− | (conKey '==' 'T.pack' \"Unary\") ->
83− case conVal of
84− arg -> Unary '<$>' 'parseJSON' arg
85− | (conKey '==' 'T.pack' \"Product\") ->
86− case conVal of
87− 'Array' arr | 'V.length' arr '==' 3 ->
88− 'Product' '<$>' 'parseJSON' (arr 'V.!' 0)
89− '<*>' 'parseJSON' (arr 'V.!' 1)
90− '<*>' 'parseJSON' (arr 'V.!' 2)
91− _ -> 'mzero'
92− | (conKey '==' 'T.pack' \"Record\") ->
93− case conVal of
94− 'Object' obj ->
95− Record '<$>' (obj '.:' 'T.pack' \"One\")
96− '<*>' (obj '.:' 'T.pack' \"Two\")
97− '<*>' (obj '.:' 'T.pack' \"Three\")
98− _ -> 'mzero'
99− | 'otherwise' -> 'mzero'
100− _ -> 'mzero'
101− _ -> 'mzero'
77+ case conKey of
78+ _ | conKey == T.pack \"Nullary\" ->
79+ case conVal of
80+ 'Array' arr ->
81+ if V.null arr
82+ then pure Nullary
83+ else fail \"\<error message\>\"
84+ _ -> fail \"\<error message\>\"
85+ | conKey == T.pack \"Unary\" ->
86+ case conVal of
87+ arg -> Unary \<$\> parseJSON arg
88+ | conKey == T.pack \"Product\" ->
89+ case conVal of
90+ 'Array' arr ->
91+ if V.length arr == 3
92+ then Product \<$\> 'parseJSON' (arr V.! 0)
93+ \<*\> 'parseJSON' (arr V.! 1)
94+ \<*\> 'parseJSON' (arr V.! 2)
95+ else fail \"\<error message\>\"
96+ _ -> fail \"\<error message\>\"
97+ | conKey == T.pack \"Record\" ->
98+ case conVal of
99+ 'Object' recObj ->
100+ if M.size recObj == 3
101+ then Record \<$\> recObj '.:' T.pack \"One\"
102+ \<*\> recObj '.:' T.pack \"Two\"
103+ \<*\> recObj '.:' T.pack \"Three\"
104+ else fail \"\<error message\>\"
105+ _ -> fail \"\<error message\>\"
106+ | otherwise -> fail \"\<error message\>\"
107+ _ -> fail \"\<error message\>\"
108+ _ -> fail \"\<error message\>\"
102109@
103110
111+Note that every \"\<error message\>\" is in fact a descriptive message which
112+provides as much information as is reasonable about the failed parse.
113+
104114Now we can use the newly created instances.
105115
106116@
@@ -114,6 +124,13 @@ d = Record { testOne = 3.14159
114124>>> fromJSON (toJSON d) == Success d
115125> True
116126
127+Please note that you can derive instances for tuples using the following syntax:
128+
129+@
130+-- FromJSON and ToJSON instances for 4-tuples.
131+$('deriveJSON' id ''(,,,))
132+@
133+
117134-}
118135
119136module Data.Aeson.TH
@@ -131,31 +148,35 @@ module Data.Aeson.TH
131148--------------------------------------------------------------------------------
132149
133150-- from aeson:
134−import Data.Aeson ( toJSON, object, (.=), (.:)
151+import Data.Aeson ( toJSON, Object, object, (.=)
135152 , ToJSON, toJSON
136153 , FromJSON, parseJSON
137154 )
138−import Data.Aeson.Types ( Value(..) )
155+import Data.Aeson.Types ( Value(..), Parser )
139156-- from base:
140157import Control.Applicative ( pure, (<$>), (<*>) )
141−import Control.Monad ( return, mapM, mzero, liftM2 )
158+import Control.Monad ( return, mapM, liftM2, fail )
142159import Data.Bool ( otherwise )
143160import Data.Eq ( (==) )
144161import Data.Function ( ($), (.), id )
145162import Data.Functor ( fmap )
146−import Data.List ( (++), foldl', map, zip, genericLength )
163+import Data.List ( (++), foldl, foldl', intercalate
164+ , length, map, zip, genericLength
165+ )
166+import Data.Maybe ( Maybe(Nothing, Just) )
147167import Prelude ( String, (-), Integer, error )
168+import Text.Printf ( printf )
148169import Text.Show ( show )
149170#if __GLASGOW_HASKELL__ < 700
150171import Control.Monad ( (>>=), fail )
151172import Prelude ( fromInteger )
152173#endif
153174-- from containers:
154−import qualified Data.Map as M ( toList )
175+import qualified Data.Map as M ( lookup, toList, size )
155176-- from template-haskell:
156177import Language.Haskell.TH
157178-- from text:
158−import qualified Data.Text as T ( pack )
179+import qualified Data.Text as T ( Text, pack, unpack )
159180-- from vector:
160181import qualified Data.Vector as V ( (!), null, length )
161182
@@ -241,12 +262,12 @@ deriveToJSON withField name =
241262-- Example:
242263--
243264-- @
244−-- data Foo = Foo 'Int'
265+-- data Foo = Foo Int
245266-- @
246267--
247268-- @
248269-- encodeFoo :: Foo -> 'Value'
249−-- encodeFoo = $('mkToJSON' 'id' ''Foo)
270+-- encodeFoo = $('mkToJSON' id ''Foo)
250271-- @
251272--
252273-- This will splice in the following code:
@@ -352,8 +373,8 @@ encodeArgs withExp withField (ForallC _ _ con) =
352373-- Example:
353374--
354375-- @
355−-- data Foo = Foo 'Char' 'Int'
356−-- $('deriveFromJSON' 'id' ''Foo)
376+-- data Foo = Foo Char Int
377+-- $('deriveFromJSON' id ''Foo)
357378-- @
358379--
359380-- This will splice in the following code:
@@ -362,10 +383,12 @@ encodeArgs withExp withField (ForallC _ _ con) =
362383-- instance 'FromJSON' Foo where
363384-- 'parseJSON' =
364385-- \value -> case value of
365−-- 'Array' arr | ('V.length' arr '==' 2) ->
366−-- Foo '<$>' 'parseJSON' (arr 'V.!' 0)
367−-- '<*>' 'parseJSON' (arr 'V.!' 1)
368−-- _ -> 'mzero'
386+-- 'Array' arr ->
387+-- if (V.length arr == 2)
388+-- then Foo \<$\> 'parseJSON' (arr V.! 0)
389+-- \<*\> 'parseJSON' (arr V.! 1)
390+-- else fail \"\<error message\>\"
391+-- other -> fail \"\<error message\>\"
369392-- @
370393deriveFromJSON :: (String -> String)
371394 -- ^ Function to change field names.
@@ -382,7 +405,7 @@ deriveFromJSON withField name =
382405 (classType `appT` instanceType)
383406 [ funD 'parseJSON
384407 [ clause []
385− (normalB $ consFromJSON withField cons)
408+ (normalB $ consFromJSON name withField cons)
386409 []
387410 ]
388411 ]
@@ -402,36 +425,38 @@ deriveFromJSON withField name =
402425--
403426-- @
404427-- parseFoo :: 'Value' -> 'Parser' Foo
405−-- parseFoo = $('mkParseJSON' 'id' ''Foo)
428+-- parseFoo = $('mkParseJSON' id ''Foo)
406429-- @
407430--
408431-- This will splice in the following code:
409432--
410433-- @
411−-- \\value -> case value of arg -> Foo '<$>' 'parseJSON' arg
434+-- \\value -> case value of arg -> Foo \<$\> 'parseJSON' arg
412435-- @
413436mkParseJSON :: (String -> String) -- ^ Function to change field names.
414437 -> Name -- ^ Name of the encoded type.
415438 -> Q Exp
416439mkParseJSON withField name =
417− withType name (\_ cons -> consFromJSON withField cons)
440+ withType name (\_ cons -> consFromJSON name withField cons)
418441
419442-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates
420443-- code to parse the JSON encoding of a number of constructors. All constructors
421444-- must be from the same type.
422−consFromJSON :: (String -> String)
445+consFromJSON :: Name
446+ -- ^ Name of the type to which the constructors belong.
447+ -> (String -> String)
423448 -- ^ Function to change field names.
424449 -> [Con]
425450 -- ^ Constructors for which to generate JSON parsing code.
426451 -> Q Exp
427−consFromJSON _ [] = error $ "Data.Aeson.TH.consFromJSON: "
428− ++ "Not a single constructor given!"
429−consFromJSON withField [con] = do
452+consFromJSON _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
453+ ++ "Not a single constructor given!"
454+consFromJSON tName withField [con] = do
430455 value <- newName "value"
431456 lam1E (varP value)
432457 $ caseE (varE value)
433− (parseArgs withField con)
434−consFromJSON withField cons = do
458+ (parseArgs tName withField con)
459+consFromJSON tName withField cons = do
435460 value <- newName "value"
436461 obj <- newName "obj"
437462 conKey <- newName "conKey"
@@ -444,8 +469,15 @@ consFromJSON withField cons = do
444469 [ match (listP [tupP [varP conKey, varP conVal]])
445470 (normalB caseKey)
446471 []
447− , errorMatch
472+ , do other <- newName "other"
473+ match (varP other)
474+ (normalB $ [|wrongPairCountFail|]
475+ `appE` (litE $ stringL $ show tName)
476+ `appE` ([|show . length|] `appE` varE other)
477+ )
478+ []
448479 ]
480+
449481 caseKey = caseE (varE conKey)
450482 [match wildP (guardedB guards) []]
451483 guards = [ do g <- normalG $ infixApp (varE conKey)
@@ -454,44 +486,59 @@ consFromJSON withField cons = do
454486 `appE` conNameExp con
455487 )
456488 e <- caseE (varE conVal)
457− (parseArgs withField con)
489+ (parseArgs tName withField con)
458490 return (g, e)
459491 | con <- cons
460492 ]
461493 ++
462− [liftM2 (,) (normalG [e|otherwise|]) [e|mzero|]]
494+ [ liftM2 (,)
495+ (normalG [e|otherwise|])
496+ ( [|conNotFoundFail|]
497+ `appE` (litE $ stringL $ show tName)
498+ `appE` listE (map (litE . stringL . nameBase . getConName) cons)
499+ `appE` ([|T.unpack|] `appE` varE conKey)
500+ )
501+ ]
463502
464503 lam1E (varP value)
465504 $ caseE (varE value)
466505 [ match (conP 'Object [varP obj])
467506 (normalB caseLst)
468507 []
469− , errorMatch
508+ , do other <- newName "other"
509+ match (varP other)
510+ ( normalB
511+ $ [|noObjectFail|]
512+ `appE` (litE $ stringL $ show tName)
513+ `appE` ([|valueConName|] `appE` varE other)
514+ )
515+ []
470516 ]
471− where
472− -- Makes a string literal expression from a constructor's name.
473− conNameExp :: Con -> Q Exp
474− conNameExp = litE . stringL . nameBase . getConName
475517
476−-- | Generates code to parse the JSON encoding of a single
477−-- constructor.
478−parseArgs :: (String -> String) -- ^ Function to change field names.
518+-- | Generates code to parse the JSON encoding of a single constructor.
519+parseArgs :: Name -- ^ Name of the type to which the constructor belongs.
520+ -> (String -> String) -- ^ Function to change field names.
479521 -> Con -- ^ Constructor for which to generate JSON parsing code.
480522 -> [Q Match]
481523-- Nullary constructors.
482−parseArgs _ (NormalC conName []) =
524+parseArgs tName _ (NormalC conName []) =
483525 [ do arr <- newName "arr"
484− g <- normalG $ [|V.null|] `appE` varE arr
485− e <- [e|pure|] `appE` conE conName
486− -- TODO: Use applicative style: guardedB [(,) <$> g' <*> e']
487− -- But first need to have "instance Applicative Q".
488526 match (conP 'Array [varP arr])
489− (guardedB [return (g, e)])
527+ ( normalB $ condE ([|V.null|] `appE` varE arr)
528+ ([e|pure|] `appE` conE conName)
529+ ( parseTypeMismatch tName conName
530+ (litE $ stringL "an empty Array")
531+ ( infixApp (litE $ stringL $ "Array of length ")
532+ [|(++)|]
533+ ([|show . V.length|] `appE` varE arr)
534+ )
535+ )
536+ )
490537 []
491− , errorMatch
538+ , matchFailed tName conName "Array"
492539 ]
493540-- Unary constructors.
494−parseArgs _ (NormalC conName [_]) =
541+parseArgs _ _ (NormalC conName [_]) =
495542 [ do arg <- newName "arg"
496543 match (varP arg)
497544 ( normalB $ infixApp (conE conName)
@@ -500,46 +547,59 @@ parseArgs _ (NormalC conName [_]) =
500547 )
501548 []
502549 ]
503−
504550-- Polyadic constructors.
505−parseArgs _ (NormalC conName ts) = parseProduct conName $ genericLength ts
551+parseArgs tName _ (NormalC conName ts) = parseProduct tName conName $ genericLength ts
506552-- Records.
507−parseArgs withField (RecC conName ts) =
508− [ do obj <- newName "obj"
509− -- List of: "obj .: "<FIELD>""
510− let x:xs = [ infixApp (varE obj)
511− [|(.:)|]
512− ( [e|T.pack|]
513− `appE`
514− fieldNameExp withField field
515− )
553+parseArgs tName withField (RecC conName ts) =
554+ [ do obj <- newName "recObj"
555+ let x:xs = [ [|lookupField|]
556+ `appE` (litE $ stringL $ show tName)
557+ `appE` (litE $ stringL $ nameBase conName)
558+ `appE` (varE obj)
559+ `appE` ( [e|T.pack|]
560+ `appE`
561+ fieldNameExp withField field
562+ )
516563 | (field, _, _) <- ts
517564 ]
518565 match (conP 'Object [varP obj])
519− ( normalB $ foldl' (\a b -> infixApp a [|(<*>)|] b)
520− (infixApp (conE conName) [|(<$>)|] x)
521− xs
566+ ( normalB $ condE ( infixApp ([|M.size|] `appE` varE obj)
567+ [|(==)|]
568+ (litE $ integerL $ genericLength ts)
569+ )
570+ ( foldl' (\a b -> infixApp a [|(<*>)|] b)
571+ (infixApp (conE conName) [|(<$>)|] x)
572+ xs
573+ )
574+ ( parseTypeMismatch tName conName
575+ ( litE $ stringL $ "Object with "
576+ ++ show (length ts)
577+ ++ " name/value pairs"
578+ )
579+ ( infixApp ([|show . M.size|] `appE` varE obj)
580+ [|(++)|]
581+ (litE $ stringL $ " name/value pairs")
582+ )
583+ )
522584 )
523585 []
524− , errorMatch
586+ , matchFailed tName conName "Object"
525587 ]
526588-- Infix constructors. Apart from syntax these are the same as
527589-- polyadic constructors.
528−parseArgs _ (InfixC _ conName _) = parseProduct conName 2
590+parseArgs tName _ (InfixC _ conName _) = parseProduct tName conName 2
529591-- Existentially quantified constructors. We ignore the quantifiers
530592-- and proceed with the contained constructor.
531−parseArgs withField (ForallC _ _ con) = parseArgs withField con
593+parseArgs tName withField (ForallC _ _ con) = parseArgs tName withField con
532594
533595-- | Generates code to parse the JSON encoding of an n-ary
534596-- constructor.
535−parseProduct :: Name -- ^ 'Con'structor name.
597+parseProduct :: Name -- ^ Name of the type to which the constructor belongs.
598+ -> Name -- ^ 'Con'structor name.
536599 -> Integer -- ^ 'Con'structor arity.
537600 -> [Q Match]
538−parseProduct conName numArgs =
601+parseProduct tName conName numArgs =
539602 [ do arr <- newName "arr"
540− g <- normalG $ infixApp ([|V.length|] `appE` varE arr)
541− [|(==)|]
542− (litE $ integerL numArgs)
543603 -- List of: "parseJSON (arr V.! <IX>)"
544604 let x:xs = [ [|parseJSON|]
545605 `appE`
@@ -548,21 +608,81 @@ parseProduct conName numArgs =
548608 (litE $ integerL ix)
549609 | ix <- [0 .. numArgs - 1]
550610 ]
551− e <- foldl' (\a b -> infixApp a [|(<*>)|] b)
552− (infixApp (conE conName) [|(<$>)|] x)
553− xs
554611 match (conP 'Array [varP arr])
555− (guardedB [return (g, e)])
612+ (normalB $ condE ( infixApp ([|V.length|] `appE` varE arr)
613+ [|(==)|]
614+ (litE $ integerL numArgs)
615+ )
616+ ( foldl' (\a b -> infixApp a [|(<*>)|] b)
617+ (infixApp (conE conName) [|(<$>)|] x)
618+ xs
619+ )
620+ ( parseTypeMismatch tName conName
621+ (litE $ stringL $ "Array of length " ++ show numArgs)
622+ ( infixApp (litE $ stringL $ "Array of length ")
623+ [|(++)|]
624+ ([|show . V.length|] `appE` varE arr)
625+ )
626+ )
627+ )
556628 []
557− , errorMatch
629+ , matchFailed tName conName "Array"
558630 ]
559631
560−-- |
561−-- @
562−-- _ -> 'mzero'
563−-- @
564−errorMatch :: Q Match
565−errorMatch = match wildP (normalB [|mzero|]) []
632+
633+--------------------------------------------------------------------------------
634+-- Parsing errors
635+--------------------------------------------------------------------------------
636+
637+matchFailed :: Name -> Name -> String -> MatchQ
638+matchFailed tName conName expected = do
639+ other <- newName "other"
640+ match (varP other)
641+ ( normalB $ parseTypeMismatch tName conName
642+ (litE $ stringL expected)
643+ ([|valueConName|] `appE` varE other)
644+ )
645+ []
646+
647+parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ
648+parseTypeMismatch tName conName expected actual =
649+ foldl appE
650+ [|parseTypeMismatch'|]
651+ [ litE $ stringL $ nameBase conName
652+ , litE $ stringL $ show tName
653+ , expected
654+ , actual
655+ ]
656+
657+lookupField :: (FromJSON a) => String -> String -> Object -> T.Text -> Parser a
658+lookupField tName rec obj key =
659+ case M.lookup key obj of
660+ Nothing -> unknownFieldFail tName rec (T.unpack key)
661+ Just v -> parseJSON v
662+
663+unknownFieldFail :: String -> String -> String -> Parser fail
664+unknownFieldFail tName rec key =
665+ fail $ printf "When parsing the record %s of type %s the key %s was not present."
666+ rec tName key
667+
668+noObjectFail :: String -> String -> Parser fail
669+noObjectFail t o =
670+ fail $ printf "When parsing %s expected Object but got %s." t o
671+
672+wrongPairCountFail :: String -> String -> Parser fail
673+wrongPairCountFail t n =
674+ fail $ printf "When parsing %s expected an Object with a single name/value pair but got %s pairs."
675+ t n
676+
677+conNotFoundFail :: String -> [String] -> String -> Parser fail
678+conNotFoundFail t cs o =
679+ fail $ printf "When parsing %s expected an Object with a name/value pair where the name is one of [%s], but got %s."
680+ t (intercalate ", " cs) o
681+
682+parseTypeMismatch' :: String -> String -> String -> String -> Parser fail
683+parseTypeMismatch' tName conName expected actual =
684+ fail $ printf "When parsing the constructor %s of type %s expected %s but got %s."
685+ conName tName expected actual
566686
567687
568688--------------------------------------------------------------------------------
@@ -604,8 +724,21 @@ tvbName :: TyVarBndr -> Name
604724tvbName (PlainTV name ) = name
605725tvbName (KindedTV name _) = name
606726
727+-- | Makes a string literal expression from a constructor's name.
728+conNameExp :: Con -> Q Exp
729+conNameExp = litE . stringL . nameBase . getConName
730+
607731-- | Creates a string literal expression from a record field name.
608732fieldNameExp :: (String -> String) -- ^ Function to change the field name.
609733 -> Name
610734 -> Q Exp
611735fieldNameExp f = litE . stringL . f . nameBase
736+
737+-- | The name of the outermost 'Value' constructor.
738+valueConName :: Value -> String
739+valueConName (Object _) = "Object"
740+valueConName (Array _) = "Array"
741+valueConName (String _) = "String"
742+valueConName (Number _) = "Number"
743+valueConName (Bool _) = "Boolean"
744+valueConName Null = "Null"