@@ -122,14 +122,14 @@ import Prelude.Compat hiding (exp)
122122import Control.Applicative ((<|>))
123123import Data.Aeson (Object, (.=), (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
124124import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
125−import Data.Aeson.Types.Internal ((<?>), Pair, JSONPathElement(Key))
125+import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
126126import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)
127127import Control.Monad (liftM2, unless, when)
128128import Data.Foldable (foldr')
129129#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)
130130import Data.List (nub)
131131#endif
132−import Data.List (foldl', genericLength , intercalate , intersperse, partition, union)
132+import Data.List (foldl', genericLength, intercalate, partition, union)
133133import Data.List.NonEmpty ((<|), NonEmpty((:|)))
134134import Data.Map (Map)
135135import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
@@ -156,7 +156,7 @@ import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
156156import qualified Data.Semigroup as Semigroup (Option(..))
157157import qualified Data.Set as Set (empty, insert, member)
158158import qualified Data.Text as T (Text, pack, unpack)
159−import qualified Data.Vector as V (unsafeIndex, null, length, create, fromList)
159+import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)
160160import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)
161161
162162{-# ANN module "Hlint: ignore Reduce duplication" #-}
@@ -254,8 +254,8 @@ deriveToJSONCommon :: JSONClass
254254 -> Name
255255 -- ^ Name of the type for which to generate an instance.
256256 -> Q [Dec]
257−deriveToJSONCommon = deriveJSONClass [ (ToJSON, \jc _ -> consToValue jc)
258− , (ToEncoding, \jc _ -> consToEncoding jc)
257+deriveToJSONCommon = deriveJSONClass [ (ToJSON, \jc _ -> consToValue Value jc)
258+ , (ToEncoding, \jc _ -> consToValue Encoding jc)
259259 ]
260260
261261-- | Generates a lambda expression which encodes the given data type or
@@ -285,7 +285,7 @@ mkToJSONCommon :: JSONClass -- ^ Which class's method is being derived.
285285 -> Options -- ^ Encoding options.
286286 -> Name -- ^ Name of the encoded type.
287287 -> Q Exp
288−mkToJSONCommon = mkFunCommon (\jc _ -> consToValue jc)
288+mkToJSONCommon = mkFunCommon (\jc _ -> consToValue Value jc)
289289
290290-- | Generates a lambda expression which encodes the given data type or
291291-- data family instance constructor as a JSON string.
@@ -314,12 +314,14 @@ mkToEncodingCommon :: JSONClass -- ^ Which class's method is being derived.
314314 -> Options -- ^ Encoding options.
315315 -> Name -- ^ Name of the encoded type.
316316 -> Q Exp
317−mkToEncodingCommon = mkFunCommon (\jc _ -> consToEncoding jc)
317+mkToEncodingCommon = mkFunCommon (\jc _ -> consToValue Encoding jc)
318318
319319-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates
320−-- code to generate a 'Value' of a number of constructors. All constructors
321−-- must be from the same type.
322−consToValue :: JSONClass
320+-- code to generate a 'Value' or 'Encoding' of a number of constructors. All
321+-- constructors must be from the same type.
322+consToValue :: ToJSONFun
323+ -- ^ The method ('toJSON' or 'toEncoding') being derived.
324+ -> JSONClass
323325 -- ^ The ToJSON variant being derived.
324326 -> Options
325327 -- ^ Encoding options.
@@ -329,10 +331,10 @@ consToValue :: JSONClass
329331 -- ^ Constructors for which to generate JSON generating code.
330332 -> Q Exp
331333
332−consToValue _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "
334+consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "
333335 ++ "Not a single constructor given!"
334336
335−consToValue jc opts vars cons = do
337+consToValue target jc opts vars cons = do
336338 value <- newName "value"
337339 tjs <- newNameList "_tj" $ arityInt jc
338340 tjls <- newNameList "_tjl" $ arityInt jc
@@ -346,66 +348,26 @@ consToValue jc opts vars cons = do
346348 matches tvMap = case cons of
347349 -- A single constructor is directly encoded. The constructor itself may be
348350 -- forgotten.
349− [con] | not (tagSingleConstructors opts) -> [argsToValue jc tvMap opts False con]
351+ [con] | not (tagSingleConstructors opts) -> [argsToValue target jc tvMap opts False con]
350352 _ | allNullaryToStringTag opts && all isNullary cons ->
351− [ match (conP conName []) (normalB $ conStr opts conName) []
353+ [ match (conP conName []) (normalB $ conStr target opts conName) []
352354 | con <- cons
353355 , let conName = constructorName con
354356 ]
355− | otherwise -> [argsToValue jc tvMap opts True con | con <- cons]
357+ | otherwise -> [argsToValue target jc tvMap opts True con | con <- cons]
356358
357−conStr :: Options -> Name -> Q Exp
358−conStr opts = appE [|String|] . conTxt opts
359+-- | Name of the constructor as a quoted 'Value' or 'Encoding'.
360+conStr :: ToJSONFun -> Options -> Name -> Q Exp
361+conStr Value opts = appE [|String|] . conTxt opts
362+conStr Encoding opts = appE [|E.text|] . conTxt opts
359363
364+-- | Name of the constructor as a quoted 'Text'.
360365conTxt :: Options -> Name -> Q Exp
361−conTxt opts = appE [|T.pack|] . conStringE opts
362−
363−conStringE :: Options -> Name -> Q Exp
364−conStringE opts = stringE . constructorTagModifier opts . nameBase
365−
366−-- | Helper function used by both 'deriveToJSON' and 'mkToEncoding'. Generates
367−-- code to write out a value for a number of constructors. All constructors
368−-- must be from the same type.
369−consToEncoding :: JSONClass
370− -- ^ The ToJSON variant being derived.
371− -> Options
372− -- ^ Encoding options.
373− -> [Type]
374− -- ^ The types from the data type/data family instance declaration
375− -> [ConstructorInfo]
376− -- ^ Constructors for which to generate JSON generating code.
377− -> Q Exp
366+conTxt opts = appE [|T.pack|] . stringE . conString opts
378367
379−consToEncoding _ _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "
380− ++ "Not a single constructor given!"
381−
382−consToEncoding jc opts vars cons = do
383− value <- newName "value"
384− tes <- newNameList "_te" $ arityInt jc
385− tels <- newNameList "_tel" $ arityInt jc
386− let zippedTEs = zip tes tels
387− interleavedTEs = interleave tes tels
388− lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars
389− tvMap = M.fromList $ zip lastTyVars zippedTEs
390− lamE (map varP $ interleavedTEs ++ [value]) $
391− caseE (varE value) (matches tvMap)
392− where
393− matches tvMap = case cons of
394− -- A single constructor is directly encoded. The constructor itself may be
395− -- forgotten.
396− [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tvMap opts False con]
397− -- Encode just the name of the constructor of a sum type iff all the
398− -- constructors are nullary.
399− _ | allNullaryToStringTag opts && all isNullary cons ->
400− [ match (conP conName [])
401− (normalB $ encStr opts conName) []
402− | con <- cons
403− , let conName = constructorName con
404− ]
405− | otherwise -> [argsToEncoding jc tvMap opts True con | con <- cons]
406−
407−encStr :: Options -> Name -> Q Exp
408−encStr opts = appE [|E.text|] . conTxt opts
368+-- | Name of the constructor.
369+conString :: Options -> Name -> String
370+conString opts = constructorTagModifier opts . nameBase
409371
410372-- | If constructor is nullary.
411373isNullary :: ConstructorInfo -> Bool
@@ -413,129 +375,133 @@ isNullary ConstructorInfo { constructorVariant = NormalConstructor
413375 , constructorFields = tys } = null tys
414376isNullary _ = False
415377
416−sumToValue :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
417−sumToValue opts multiCons nullary conName exp
378+-- | Wrap fields of a non-record constructor. See 'sumToValue'.
379+opaqueSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
380+opaqueSumToValue target opts multiCons nullary conName value =
381+ sumToValue target opts multiCons nullary conName
382+ value
383+ pairs
384+ where
385+ pairs contentsFieldName = listE [toPair target contentsFieldName value]
386+
387+-- | Wrap fields of a record constructor. See 'sumToValue'.
388+recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
389+recordSumToValue target opts multiCons nullary conName pairs =
390+ sumToValue target opts multiCons nullary conName
391+ (objectExp target pairs)
392+ (const pairs)
393+
394+-- | Wrap fields of a constructor.
395+sumToValue
396+ :: ToJSONFun
397+ -- ^ The method being derived.
398+ -> Options
399+ -- ^ Deriving options.
400+ -> Bool
401+ -- ^ Does this type have multiple constructors.
402+ -> Bool
403+ -- ^ Is this constructor nullary.
404+ -> Name
405+ -- ^ Constructor name.
406+ -> ExpQ
407+ -- ^ Fields of the constructor as a 'Value' or 'Encoding'.
408+ -> (String -> ExpQ)
409+ -- ^ Representation of an 'Object' fragment used for the 'TaggedObject'
410+ -- variant; of type @[(Text,Value)]@ or @[Encoding]@, depending on the method
411+ -- being derived.
412+ --
413+ -- - For non-records, produces a pair @"contentsFieldName":value@,
414+ -- given a @contentsFieldName@ as an argument. See 'opaqueSumToValue'.
415+ -- - For records, produces the list of pairs corresponding to fields of the
416+ -- encoded value (ignores the argument). See 'recordSumToValue'.
417+ -> ExpQ
418+sumToValue target opts multiCons nullary conName value pairs
418419 | multiCons =
419420 case sumEncoding opts of
420421 TwoElemArray ->
421− [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp])
422+ array target [conStr target opts conName, value]
422423 TaggedObject{tagFieldName, contentsFieldName} ->
423− let tag = infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)
424− contents = infixApp [|T.pack contentsFieldName|] [|(.=)|] exp
425− in
426− [|A.object|] `appE` listE (if nullary then [tag] else [tag, contents])
424+ -- TODO: Maybe throw an error in case
425+ -- tagFieldName overwrites a field in pairs.
426+ let tag = toPair target tagFieldName (conStr target opts conName)
427+ content = pairs contentsFieldName
428+ in objectExp target $
429+ if nullary then listE [tag] else infixApp tag [|(:)|] content
427430 ObjectWithSingleField ->
428− [|A.object|] `appE` listE
429− [ infixApp (conTxt opts conName) [|(.=)|] exp
430− ]
431− UntaggedValue | nullary -> conStr opts conName
432− UntaggedValue -> exp
433− | otherwise = exp
431+ object target [(conString opts conName, value)]
432+ UntaggedValue | nullary -> conStr target opts conName
433+ UntaggedValue -> value
434+ | otherwise = value
434435
435436-- | Generates code to generate the JSON encoding of a single constructor.
436−argsToValue :: JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match
437+argsToValue :: ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match
437438
438439-- Polyadic constructors with special case for unary constructors.
439−argsToValue jc tvMap opts multiCons
440+argsToValue target jc tvMap opts multiCons
440441 ConstructorInfo { constructorName = conName
441442 , constructorVariant = NormalConstructor
442443 , constructorFields = argTys } = do
443444 argTys' <- mapM resolveTypeSynonyms argTys
444445 let len = length argTys'
445446 args <- newNameList "arg" len
446− js <- case [ dispatchToJSON jc conName tvMap argTy
447− `appE` varE arg
448− | (arg, argTy) <- zip args argTys'
449− ] of
450− -- Single argument is directly converted.
451− [e] -> return e
452− -- Multiple arguments are converted to a JSON array.
453− es -> do
454− mv <- newName "mv"
455− let newMV = bindS (varP mv)
456− ([|VM.unsafeNew|] `appE`
457− litE (integerL $ fromIntegral len))
458− stmts = [ noBindS $
459− [|VM.unsafeWrite|] `appE`
460− varE mv `appE`
461− litE (integerL ix) `appE`
462− e
463− | (ix, e) <- zip [(0::Integer)..] es
464− ]
465− ret = noBindS $ [|return|] `appE` varE mv
466− return $ [|Array|] `appE`
467− (varE 'V.create `appE`
468− doE (newMV:stmts++[ret]))
447+ let js = case [ dispatchToJSON target jc conName tvMap argTy
448+ `appE` varE arg
449+ | (arg, argTy) <- zip args argTys'
450+ ] of
451+ -- Single argument is directly converted.
452+ [e] -> e
453+ -- Zero and multiple arguments are converted to a JSON array.
454+ es -> array target es
455+
469456 match (conP conName $ map varP args)
470− (normalB $ sumToValue opts multiCons (null argTys') conName js)
457+ (normalB $ opaqueSumToValue target opts multiCons (null argTys') conName js)
471458 []
472459
473460-- Records.
474−argsToValue jc tvMap opts multiCons
461+argsToValue target jc tvMap opts multiCons
475462 info@ConstructorInfo { constructorName = conName
476463 , constructorVariant = RecordConstructor fields
477464 , constructorFields = argTys } =
478465 case (unwrapUnaryRecords opts, not multiCons, argTys) of
479− (True,True,[_]) -> argsToValue jc tvMap opts multiCons
466+ (True,True,[_]) -> argsToValue target jc tvMap opts multiCons
480467 (info{constructorVariant = NormalConstructor})
481468 _ -> do
482469 argTys' <- mapM resolveTypeSynonyms argTys
483470 args <- newNameList "arg" $ length argTys'
484− let exp = [|A.object|] `appE` pairs
485−
486− pairs | omitNothingFields opts = infixApp maybeFields
471+ let pairs | omitNothingFields opts = infixApp maybeFields
487472 [|(++)|]
488473 restFields
489− | otherwise = listE $ map toPair argCons
474+ | otherwise = listE $ map pureToPair argCons
490475
491476 argCons = zip3 (map varE args) argTys' fields
492477
493478 maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
494479
495− restFields = listE $ map toPair rest
480+ restFields = listE $ map pureToPair rest
496481
497482 (maybes0, rest0) = partition isMaybe argCons
498483 (options, rest) = partition isOption rest0
499484 maybes = maybes0 ++ map optionToMaybe options
500485
501− maybeToPair (arg, argTy, field) =
502− infixApp ([|keyValuePairWith|]
503− `appE` dispatchToJSON jc conName tvMap argTy
504− `appE` toFieldName field)
505− [|(<$>)|]
506− arg
507−
508− toPair (arg, argTy, field) =
509− [|keyValuePairWith|]
510− `appE` dispatchToJSON jc conName tvMap argTy
511− `appE` toFieldName field
512− `appE` arg
486+ maybeToPair = toPairLifted True
487+ pureToPair = toPairLifted False
513488
514− toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field
489+ toPairLifted lifted (arg, argTy, field) =
490+ let toValue = dispatchToJSON target jc conName tvMap argTy
491+ fieldName = fieldLabel opts field
492+ e arg' = toPair target fieldName (toValue `appE` arg')
493+ in if lifted
494+ then do
495+ x <- newName "x"
496+ infixApp (lam1E (varP x) (e (varE x))) [|(<$>)|] arg
497+ else e arg
515498
516499 match (conP conName $ map varP args)
517− ( normalB
518− $ if multiCons
519− then case sumEncoding opts of
520− TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
521− TaggedObject{tagFieldName} ->
522− [|A.object|] `appE`
523− -- TODO: Maybe throw an error in case
524− -- tagFieldName overwrites a field in pairs.
525− infixApp (infixApp [|T.pack tagFieldName|]
526− [|(.=)|]
527− (conStr opts conName))
528− [|(:)|]
529− pairs
530− ObjectWithSingleField ->
531− [|A.object|] `appE` listE
532− [ infixApp (conTxt opts conName) [|(.=)|] exp ]
533− UntaggedValue -> exp
534− else exp
535− ) []
500+ (normalB $ recordSumToValue target opts multiCons (null argTys) conName pairs)
501+ []
536502
537503-- Infix constructors.
538−argsToValue jc tvMap opts multiCons
504+argsToValue target jc tvMap opts multiCons
539505 ConstructorInfo { constructorName = conName
540506 , constructorVariant = InfixConstructor
541507 , constructorFields = argTys } = do
@@ -544,11 +510,12 @@ argsToValue jc tvMap opts multiCons
544510 ar <- newName "argR"
545511 match (infixP (varP al) conName (varP ar))
546512 ( normalB
547− $ sumToValue opts multiCons False conName
548− $ [|toJSON|] `appE` listE [ dispatchToJSON jc conName tvMap aTy
549− `appE` varE a
550− | (a, aTy) <- [(al,alTy), (ar,arTy)]
551− ]
513+ $ opaqueSumToValue target opts multiCons False conName
514+ $ array target
515+ [ dispatchToJSON target jc conName tvMap aTy
516+ `appE` varE a
517+ | (a, aTy) <- [(al,alTy), (ar,arTy)]
518+ ]
552519 )
553520 []
554521
@@ -575,141 +542,85 @@ infixr 5 <:>
575542(<%>) a b = a <^> [|E.comma|] <^> b
576543infixr 4 <%>
577544
578−array :: ExpQ -> ExpQ
579−array exp = [|E.wrapArray|] `appE` exp
580−
581−object :: ExpQ -> ExpQ
582−object exp = [|E.wrapObject|] `appE` exp
583−
584−sumToEncoding :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
585−sumToEncoding opts multiCons nullary conName exp
586− | multiCons =
587− let fexp = exp in
588− case sumEncoding opts of
589− TwoElemArray ->
590− array (encStr opts conName <%> fexp)
591− TaggedObject{tagFieldName, contentsFieldName} ->
592− let tag = [|E.text (T.pack tagFieldName)|] <:> encStr opts conName
593− contents = [|E.text (T.pack contentsFieldName)|] <:> fexp
594− in
595− object $
596− if nullary then tag else tag <%> contents
597− ObjectWithSingleField ->
598− object (encStr opts conName <:> fexp)
599− UntaggedValue | nullary -> encStr opts conName
600− UntaggedValue -> exp
601− | otherwise = exp
602−
603−-- | Generates code to generate the JSON encoding of a single constructor.
604−argsToEncoding :: JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match
605−
606−-- Polyadic constructors with special case for unary constructors.
607−argsToEncoding jc tvMap opts multiCons
608− ConstructorInfo { constructorName = conName
609− , constructorVariant = NormalConstructor
610− , constructorFields = argTys } = do
611− argTys' <- mapM resolveTypeSynonyms argTys
612− args <- newNameList "arg" $ length argTys'
613− js <- case zip args argTys' of
614− -- Nullary constructors are converted to an empty array.
615− [] -> return [| E.emptyArray_ |]
616−
617− -- Single argument is directly converted.
618− [(e,eTy)] -> return (dispatchToEncoding jc conName tvMap eTy
619− `appE` varE e)
620− -- Multiple arguments are converted to a JSON array.
621− es ->
622− return (array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap xTy
623− `appE` varE x
624− | (x,xTy) <- es
625− ]))
626− match (conP conName $ map varP args)
627− (normalB $ sumToEncoding opts multiCons (null argTys') conName js)
628− []
629−
630−-- Records.
631−argsToEncoding jc tvMap opts multiCons
632− info@ConstructorInfo { constructorName = conName
633− , constructorVariant = RecordConstructor fields
634− , constructorFields = argTys } =
635− case (unwrapUnaryRecords opts, not multiCons, argTys) of
636− (True,True,[_]) -> argsToEncoding jc tvMap opts multiCons
637− (info{constructorVariant = NormalConstructor})
638− _ -> do
639− argTys' <- mapM resolveTypeSynonyms argTys
640− args <- newNameList "arg" $ length argTys'
641− let exp = object objBody
642−
643− objBody = [|E.econcat|] `appE`
644− ([|intersperse E.comma|] `appE` pairs)
645− pairs | omitNothingFields opts = infixApp maybeFields
646− [|(++)|]
647− restFields
648− | otherwise = listE (map toPair argCons)
649−
650− argCons = zip3 (map varE args) argTys' fields
651−
652− maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
653−
654− restFields = listE (map toPair rest)
545+-- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value').
546+array :: ToJSONFun -> [ExpQ] -> ExpQ
547+array Encoding [] = [|E.emptyArray_|]
548+array Value [] = [|Array V.empty|]
549+array Encoding es = [|E.wrapArray|] `appE` foldr1 (<%>) es
550+array Value es = do
551+ mv <- newName "mv"
552+ let newMV = bindS (varP mv)
553+ ([|VM.unsafeNew|] `appE`
554+ litE (integerL $ fromIntegral (length es)))
555+ stmts = [ noBindS $
556+ [|VM.unsafeWrite|] `appE`
557+ varE mv `appE`
558+ litE (integerL ix) `appE`
559+ e
560+ | (ix, e) <- zip [(0::Integer)..] es
561+ ]
562+ ret = noBindS $ [|return|] `appE` varE mv
563+ [|Array|] `appE`
564+ (varE 'V.create `appE`
565+ doE (newMV:stmts++[ret]))
566+
567+-- | Wrap an associative list of keys and quoted values in a quoted 'Object'.
568+object :: ToJSONFun -> [(String, ExpQ)] -> ExpQ
569+object target = wrapObject target . catPairs target . fmap (uncurry (toPair target))
570+
571+-- |
572+-- - When deriving 'ToJSON', map a list of quoted key-value pairs to an
573+-- expression of the list of pairs.
574+-- - When deriving 'ToEncoding', map a list of quoted 'Encoding's representing
575+-- key-value pairs to a comma-separated 'Encoding' of them.
576+--
577+-- > catPairs Value [ [|(k0,v0)|], [|(k1,v1)|] ] = [| [(k0,v0), (k1,v1)] |]
578+-- > catPairs Encoding [ [|"\"k0\":v0"|], [|"\"k1\":v1"|] ] = [| "\"k0\":v0,\"k1\":v1" |]
579+catPairs :: ToJSONFun -> [ExpQ] -> ExpQ
580+catPairs Value = listE
581+catPairs Encoding = foldr1 (<%>)
582+
583+-- |
584+-- - When deriving 'ToJSON', wrap a quoted list of key-value pairs in an 'Object'.
585+-- - When deriving 'ToEncoding', wrap a quoted list of encoded key-value pairs
586+-- in an encoded 'Object'.
587+--
588+-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]
589+-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "{\"k0\":v0,\"k1\":v1}" |]
590+objectExp :: ToJSONFun -> ExpQ -> ExpQ
591+objectExp target = wrapObject target . catPairsExp target
655592
656− (maybes0, rest0) = partition isMaybe argCons
657− (options, rest) = partition isOption rest0
658− maybes = maybes0 ++ map optionToMaybe options
593+-- | Counterpart of 'catPairsExp' when the list of pairs is already quoted.
594+--
595+-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| [(k0,v0), (k1,v1)] |]
596+-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "\"k0\":v0,\"k1\":v1" |]
597+catPairsExp :: ToJSONFun -> ExpQ -> ExpQ
598+catPairsExp Value e = e
599+catPairsExp Encoding e = [|commaSep|] `appE` e
659600
660− maybeToPair (arg, argTy, field) =
661− infixApp
662− (infixApp
663− (infixE
664− (Just $ toFieldName field <^> [|E.colon|])
665− [|(E.><)|]
666− Nothing)
667− [|(.)|]
668− (dispatchToEncoding jc conName tvMap argTy))
669− [|(<$>)|]
670− arg
671−
672− toPair (arg, argTy, field) =
673− toFieldName field
674− <:> dispatchToEncoding jc conName tvMap argTy
675− `appE` arg
676−
677− toFieldName field = [|E.text|] `appE`
678− ([|T.pack|] `appE` fieldLabelExp opts field)
601+-- | Create (an encoding of) a key-value pair.
602+--
603+-- > toPair Value "k" [|v|] = [|("k",v)|] -- The quoted string is actually Text.
604+-- > toPair Encoding "k" [|"v"|] = [|"\"k\":v"|]
605+toPair :: ToJSONFun -> String -> ExpQ -> ExpQ
606+toPair Value k v = infixApp [|T.pack k|] [|(.=)|] v
607+toPair Encoding k v = [|E.string k|] <:> v
679608
680− match (conP conName $ map varP args)
681− ( normalB
682− $ if multiCons
683− then case sumEncoding opts of
684− TwoElemArray -> array $
685− encStr opts conName <%> exp
686− TaggedObject{tagFieldName} -> object $
687− ([|E.text (T.pack tagFieldName)|] <:>
688− encStr opts conName) <%>
689− objBody
690− ObjectWithSingleField -> object $
691− encStr opts conName <:> exp
692− UntaggedValue -> exp
693− else exp
694− ) []
609+-- | Map an associative list in an 'Object'.
610+--
611+-- > wrapObject Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]
612+-- > wrapObject Encoding [| "\"k0\":v0,\"k1\":v1" |] = [| "{\"k0\":v0,\"k1\":v1}" |]
613+wrapObject :: ToJSONFun -> ExpQ -> ExpQ
614+wrapObject Value e = [|A.object|] `appE` e
615+wrapObject Encoding e = [|E.wrapObject|] `appE` e
695616
696−-- Infix constructors.
697−argsToEncoding jc tvMap opts multiCons
698− ConstructorInfo { constructorName = conName
699− , constructorVariant = InfixConstructor
700− , constructorFields = argTys } = do
701− al <- newName "argL"
702− ar <- newName "argR"
703− [alTy,arTy] <- mapM resolveTypeSynonyms argTys
704− match (infixP (varP al) conName (varP ar))
705− ( normalB
706− $ sumToEncoding opts multiCons False conName
707− $ array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap aTy
708− `appE` varE a
709− | (a,aTy) <- [(al,alTy), (ar,arTy)]
710− ])
711− )
712− []
617+-- | Separate 'Encoding's by commas.
618+--
619+-- > commaSep ["a","b","c"] = "a,b,c"
620+commaSep :: [E.Encoding] -> E.Encoding
621+commaSep [] = E.empty
622+commaSep [x] = x
623+commaSep (x : xs) = x E.>< E.comma E.>< commaSep xs
713624
714625--------------------------------------------------------------------------------
715626-- FromJSON
@@ -836,8 +747,7 @@ consFromJSON jc tName opts vars cons = do
836747 [ liftM2 (,) (normalG $
837748 infixApp (varE txt)
838749 [|(==)|]
839− ([|T.pack|] `appE`
840− conStringE opts conName)
750+ (conTxt opts conName)
841751 )
842752 ([|pure|] `appE` conE conName)
843753 | con <- cons
@@ -929,7 +839,7 @@ consFromJSON jc tName opts vars cons = do
929839 caseE (varE conVal)
930840 [ match (conP 'String [varP str])
931841 (guardedB
932− [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] ([|T.pack|] `appE` conStringE opts conName)
842+ [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] (conTxt opts conName)
933843 )
934844 ([|pure|] `appE` conE conName)
935845 ]
@@ -1073,7 +983,7 @@ parseRecord jc tvMap argTys opts tName conName fields obj =
1073983 `appE` litE (stringL $ show tName)
1074984 `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName)
1075985 `appE` varE obj
1076− `appE` ( [|T.pack|] `appE` fieldLabelExp opts field
986+ `appE` ( [|T.pack|] `appE` stringE (fieldLabel opts field)
1077987 )
1078988 | (field, argTy) <- zip fields argTys
1079989 ]
@@ -1258,9 +1168,6 @@ lookupFieldWith pj tName rec obj key =
12581168 Nothing -> unknownFieldFail tName rec (T.unpack key)
12591169 Just v -> pj v <?> Key key
12601170
1261−keyValuePairWith :: (v -> Value) -> T.Text -> v -> Pair
1262−keyValuePairWith tj name value = (name, tj value)
1263−
12641171unknownFieldFail :: String -> String -> String -> Parser fail
12651172unknownFieldFail tName rec key =
12661173 fail $ printf "When parsing the record %s of type %s the key %s was not present."
@@ -1430,10 +1337,13 @@ dispatchFunByType jc jf conName tvMap list ty = do
14301337 (interleave rhsArgs rhsArgs)
14311338 else varE $ jsonFunValOrListName list jf Arity0
14321339
1433−dispatchToJSON, dispatchToEncoding, dispatchParseJSON
1340+dispatchToJSON
1341+ :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1342+dispatchToJSON target jc n tvMap =
1343+ dispatchFunByType jc (targetToJSONFun target) n tvMap False
1344+
1345+dispatchParseJSON
14341346 :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
1435−dispatchToJSON jc n tvMap = dispatchFunByType jc ToJSON n tvMap False
1436−dispatchToEncoding jc n tvMap = dispatchFunByType jc ToEncoding n tvMap False
14371347dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap False
14381348
14391349--------------------------------------------------------------------------------
@@ -1901,11 +1811,11 @@ conNameExp opts = litE
19011811 . nameBase
19021812 . constructorName
19031813
1904−-- | Creates a string literal expression from a record field label.
1905−fieldLabelExp :: Options -- ^ Encoding options
1906− -> Name
1907− -> Q Exp
1908−fieldLabelExp opts = litE . stringL . fieldLabelModifier opts . nameBase
1814+-- | Extracts a record field label.
1815+fieldLabel :: Options -- ^ Encoding options
1816+ -> Name
1817+ -> String
1818+fieldLabel opts = fieldLabelModifier opts . nameBase
19091819
19101820-- | The name of the outermost 'Value' constructor.
19111821valueConName :: Value -> String
@@ -2038,6 +1948,13 @@ data Direction = To | From
20381948-- | A representation of which typeclass method is being spliced in.
20391949data JSONFun = ToJSON | ToEncoding | ParseJSON
20401950
1951+-- | A refinement of JSONFun to [ToJSON, ToEncoding].
1952+data ToJSONFun = Value | Encoding
1953+
1954+targetToJSONFun :: ToJSONFun -> JSONFun
1955+targetToJSONFun Value = ToJSON
1956+targetToJSONFun Encoding = ToEncoding
1957+
20411958-- | A representation of which typeclass is being derived.
20421959data JSONClass = JSONClass { direction :: Direction, arity :: Arity }
20431960