@@ -84,10 +84,10 @@ import Control.Applicative ( pure, (<$>), (<*>) )
8484import Control.Monad ( return, mapM, liftM2, fail )
8585import Data.Bool ( Bool(False, True), otherwise, (&&) )
8686import Data.Eq ( (==) )
87−import Data.Function ( ($), (.), id, const )
87+import Data.Function ( ($), (.), id )
8888import Data.Functor ( fmap )
8989import Data.Int ( Int )
90−import Data.Either ( Either(Left, Right), either )
90+import Data.Either ( Either(Left, Right) )
9191import Data.List ( (++), foldl, foldl', intercalate
9292 , length, map, zip, genericLength, all
9393 )
@@ -100,7 +100,7 @@ import Control.Monad ( (>>=), (>>) )
100100import Prelude ( fromInteger )
101101#endif
102102-- from unordered-containers:
103−import qualified Data.HashMap.Strict as H ( lookup )
103+import qualified Data.HashMap.Strict as H ( lookup, toList )
104104-- from template-haskell:
105105import Language.Haskell.TH
106106import Language.Haskell.TH.Syntax ( VarStrictType )
@@ -142,6 +142,10 @@ data SumEncoding =
142142 -- 'typeFieldName' which specifies the constructor name. If the
143143 -- constructor is not a record the constructor content will be
144144 -- stored under the 'valueFieldName' field.
145+ | ObjectWithSingleField
146+ -- ^ A constructor will be encoded to an object with a single
147+ -- field named after the constructor and the value will be the
148+ -- contents of the constructor.
145149
146150-- | Default encoding options which specify to not modify field names,
147151-- encode the constructors of a datatype with all nullary constructors
@@ -257,7 +261,10 @@ consToJSON opts cons = do
257261 ]
258262
259263conStr :: Name -> Q Exp
260−conStr = appE [|String|] . appE [|T.pack|] . stringE . nameBase
264+conStr = appE [|String|] . conTxt
265+
266+conTxt :: Name -> Q Exp
267+conTxt = appE [|T.pack|] . stringE . nameBase
261268
262269-- | If constructor is nullary.
263270isNullary :: Con -> Bool
@@ -275,6 +282,11 @@ encodeSum opts multiCons conName exp
275282 [ infixApp [|T.pack typeFieldName|] [|(.=)|] (conStr conName)
276283 , infixApp [|T.pack valueFieldName|] [|(.=)|] exp
277284 ]
285+ ObjectWithSingleField ->
286+ [|object|] `appE` listE
287+ [ infixApp (conTxt conName) [|(.=)|] exp
288+ ]
289+
278290 | otherwise = exp
279291
280292-- | Generates code to generate the JSON encoding of a single constructor.
@@ -335,6 +347,9 @@ encodeArgs opts multiCons (RecC conName ts) = do
335347 (conStr conName)
336348 : js
337349 )
350+ ObjectWithSingleField ->
351+ [|object|] `appE` listE
352+ [ infixApp (conTxt conName) [|(.=)|] exp ]
338353 else exp
339354 ) []
340355
@@ -453,19 +468,9 @@ consFromJSON tName opts cons = do
453468 mixedMatches =
454469 case sumEncoding opts of
455470 ObjectWithType {typeFieldName, valueFieldName} ->
456− [ do obj <- newName "obj"
457− match (conP 'Object [varP obj])
458− (normalB $ parseObject typeFieldName valueFieldName obj)
459− []
460− , do other <- newName "other"
461− match (varP other)
462− ( normalB
463− $ [|noObjectFail|]
464− `appE` (litE $ stringL $ show tName)
465− `appE` ([|valueConName|] `appE` varE other)
466− )
467− []
468− ]
471+ parseObject $ parseObjectWithType typeFieldName valueFieldName
472+ ObjectWithSingleField ->
473+ parseObject $ parseObjectWithSingleField
469474 TwoElemArray ->
470475 [ do arr <- newName "array"
471476 match (conP 'Array [varP arr])
@@ -491,13 +496,26 @@ consFromJSON tName opts cons = do
491496 []
492497 ]
493498
494− parseObject typFieldName valFieldName obj = do
499+ parseObject f =
500+ [ do obj <- newName "obj"
501+ match (conP 'Object [varP obj]) (normalB $ f obj) []
502+ , do other <- newName "other"
503+ match (varP other)
504+ ( normalB
505+ $ [|noObjectFail|]
506+ `appE` (litE $ stringL $ show tName)
507+ `appE` ([|valueConName|] `appE` varE other)
508+ )
509+ []
510+ ]
511+
512+ parseObjectWithType typFieldName valFieldName obj = do
495513 conKey <- newName "conKey"
496514 doE [ bindS (varP conKey)
497515 (infixApp (varE obj)
498516 [|(.:)|]
499517 ([|T.pack|] `appE` stringE typFieldName))
500− , noBindS $ parseContents conKey (Left (valFieldName, obj))
518+ , noBindS $ parseContents conKey (Left (valFieldName, obj)) 'conNotFoundFailObjectWithType
501519 ]
502520
503521 parse2ElemArray arr = do
@@ -512,51 +530,57 @@ consFromJSON tName opts cons = do
512530 letE [ letIx conKey 0
513531 , letIx conVal 1
514532 ]
515− (parseContents conKey (Right conVal))
533+ (caseE (varE conKey)
534+ [ do txt <- newName "txt"
535+ match (conP 'String [varP txt])
536+ (normalB $ parseContents txt
537+ (Right conVal)
538+ 'conNotFoundFail2ElemArray
539+ )
540+ []
541+ ]
542+ )
543+
544+ parseObjectWithSingleField obj = do
545+ conKey <- newName "conKey"
546+ conVal <- newName "conVal"
547+ caseE ([e|H.toList|] `appE` varE obj)
548+ [ match (listP [tupP [varP conKey, varP conVal]])
549+ (normalB $ parseContents conKey (Right conVal) 'conNotFoundFailObjectSingleField)
550+ []
551+ , do other <- newName "other"
552+ match (varP other)
553+ (normalB $ [|wrongPairCountFail|]
554+ `appE` (litE $ stringL $ show tName)
555+ `appE` ([|show . length|] `appE` varE other)
556+ )
557+ []
558+ ]
516559
517− parseContents conKey contents =
560+ parseContents conKey contents errorFun =
518561 caseE (varE conKey)
519− [ do txt <- newName "txt"
520− match (conP 'String [varP txt])
521− (guardedB $
522− [ liftM2 (,) (normalG $
523− infixApp (varE txt)
524− [|(==)|]
525− ([|T.pack|] `appE`
526− conNameExp con))
527− (parseArgs tName opts con contents)
528− | con <- cons
529− ]
530− ++
531− [ liftM2 (,)
532− (normalG [|otherwise|])
533− ( [|conNotFoundFail|]
534− `appE` (litE $ stringL $ show tName)
535− `appE` listE (map ( litE
536− . stringL
537− . nameBase
538− . getConName
539− )
540− cons
541− )
542− `appE` ([|T.unpack|] `appE` varE txt)
543− )
544− ]
545− )
546− []
547− , do other <- newName "other"
548− match (varP other)
549− ( normalB $
550− (either (const [|typeNotString|])
551− (const [|firstElemNotString|])
552− contents)
553− `appE` (litE $ stringL $ show tName)
554− `appE` ([|valueConName|] `appE` varE other)
555− )
556− []
562+ [ match wildP
563+ ( guardedB $
564+ [ do g <- normalG $ infixApp (varE conKey)
565+ [|(==)|]
566+ ([|T.pack|] `appE` conNameExp con)
567+ e <- parseArgs tName opts con contents
568+ return (g, e)
569+ | con <- cons
570+ ]
571+ ++
572+ [ liftM2 (,)
573+ (normalG [e|otherwise|])
574+ ( varE errorFun
575+ `appE` (litE $ stringL $ show tName)
576+ `appE` listE (map (litE . stringL . nameBase . getConName) cons)
577+ `appE` ([|T.unpack|] `appE` varE conKey)
578+ )
579+ ]
580+ )
581+ []
557582 ]
558583
559−
560584parseNullaryMatches :: Name -> Name -> [Q Match]
561585parseNullaryMatches tName conName =
562586 [ do arr <- newName "arr"
@@ -746,6 +770,11 @@ noArrayFail t o = fail $ printf "When parsing %s expected Array but got %s." t o
746770noObjectFail :: String -> String -> Parser fail
747771noObjectFail t o = fail $ printf "When parsing %s expected Object but got %s." t o
748772
773+wrongPairCountFail :: String -> String -> Parser fail
774+wrongPairCountFail t n =
775+ fail $ printf "When parsing %s expected an Object with a single name/value pair but got %s pairs."
776+ t n
777+
749778noStringFail :: String -> String -> Parser fail
750779noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o
751780
@@ -754,19 +783,23 @@ noMatchFail t o =
754783 fail $ printf "When parsing %s expected a String with the name of a constructor but got %s." t o
755784
756785not2ElemArray :: String -> Int -> Parser fail
757−not2ElemArray t i = fail $ printf "When parsing %s expected an Array of 2-elements but got %i elements"
758− t i
759−typeNotString :: String -> String -> Parser fail
760−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
786+not2ElemArray t i = fail $ printf "When parsing %s expected an Array of 2-elements but got %i elements" t i
761787
762−firstElemNotString :: String -> String -> Parser fail
763−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
764−
765−conNotFoundFail :: String -> [String] -> String -> Parser fail
766−conNotFoundFail t cs o =
788+conNotFoundFail2ElemArray :: String -> [String] -> String -> Parser fail
789+conNotFoundFail2ElemArray t cs o =
767790 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."
768791 t (intercalate ", " cs) o
769792
793+conNotFoundFailObjectSingleField :: String -> [String] -> String -> Parser fail
794+conNotFoundFailObjectSingleField t cs o =
795+ fail $ printf "When parsing %s expected an Object with a name/value pair where the name is one of [%s], but got %s."
796+ t (intercalate ", " cs) o
797+
798+conNotFoundFailObjectWithType :: String -> [String] -> String -> Parser fail
799+conNotFoundFailObjectWithType t cs o =
800+ fail $ printf "When parsing %s expected an Object with a type field where the value is one of [%s], but got %s."
801+ t (intercalate ", " cs) o
802+
770803parseTypeMismatch' :: String -> String -> String -> String -> Parser fail
771804parseTypeMismatch' tName conName expected actual =
772805 fail $ printf "When parsing the constructor %s of type %s expected %s but got %s."