aeson 1.2.2.0 → 1.2.3.0
raw patch · 23 files changed
+446/−384 lines, 23 filesdep ~QuickCheckdep ~quickcheck-instancesPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: QuickCheck, quickcheck-instances
API changes (from Hackage documentation)
+ Data.Aeson: withEmbeddedJSON :: (FromJSON a) => String -> (Value -> Parser a) -> Value -> Parser a
+ Data.Aeson.TH: instance Data.Aeson.TH.LookupField (Data.Semigroup.Option a)
+ Data.Aeson.Types: withEmbeddedJSON :: (FromJSON a) => String -> (Value -> Parser a) -> Value -> Parser a
Files
- Data/Aeson.hs +2/−1
- Data/Aeson/Compat.hs +16/−0
- Data/Aeson/TH.hs +226/−292
- Data/Aeson/Types.hs +1/−0
- Data/Aeson/Types/Class.hs +1/−0
- Data/Aeson/Types/FromJSON.hs +22/−1
- Data/Aeson/Types/ToJSON.hs +13/−0
- aeson.cabal +4/−3
- benchmarks/Escape.hs +25/−0
- benchmarks/aeson-benchmarks.cabal +14/−0
- changelog.md +7/−0
- pure/Data/Aeson/Parser/UnescapePure.hs +8/−13
- stack-ffi-unescape.yaml +7/−0
- stack-lts6.yaml +7/−3
- stack-lts7.yaml +5/−1
- stack-lts8.yaml +4/−1
- stack-pure-unescape.yaml +0/−10
- tests/Encoders.hs +27/−0
- tests/Instances.hs +4/−57
- tests/Options.hs +6/−0
- tests/Properties.hs +21/−1
- tests/Types.hs +6/−0
- tests/UnitTests.hs +20/−1
Data/Aeson.hs view
@@ -111,6 +111,7 @@ , withNumber , withScientific , withBool+ , withEmbeddedJSON -- * Constructors and accessors , Series , pairs@@ -381,7 +382,7 @@ -- The 'Object' type contains JSON objects: -- -- > λ> decode "{\"name\":\"Dave\",\"age\":2}" :: Maybe Object--- > Just (fromList) [("name",String "Dave"),("age",Number 2)]+-- > Just (fromList [("name",String "Dave"),("age",Number 2)]) -- -- You can extract values from it with a parser using 'parse', -- 'parseEither' or, in this example, 'parseMaybe':
+ Data/Aeson/Compat.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE CPP #-}++module Data.Aeson.Compat+ (+ fromStrict+ ) where++import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++fromStrict :: S.ByteString -> L.ByteString+#if MIN_VERSION_bytestring(0, 9, 2)+fromStrict = L.fromChunks . (:[])+#else+fromStrict = L.fromStrict+#endif
Data/Aeson/TH.hs view
@@ -85,7 +85,6 @@ @ -}- module Data.Aeson.TH ( -- * Encoding configuration@@ -123,14 +122,14 @@ import Control.Applicative ((<|>)) import Data.Aeson (Object, (.=), (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..)) import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)-import Data.Aeson.Types.Internal ((<?>), Pair, JSONPathElement(Key))+import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key)) import Data.Aeson.Types.FromJSON (parseOptionalFieldWith) import Control.Monad (liftM2, unless, when) import Data.Foldable (foldr') #if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0) import Data.List (nub) #endif-import Data.List (foldl', genericLength , intercalate , intersperse, partition, union)+import Data.List (foldl', genericLength, intercalate, partition, union) import Data.List.NonEmpty ((<|), NonEmpty((:|))) import Data.Map (Map) import Data.Maybe (catMaybes, fromMaybe, mapMaybe)@@ -154,11 +153,13 @@ import qualified Data.HashMap.Strict as H (lookup, toList) import qualified Data.List.NonEmpty as NE (length, reverse) import qualified Data.Map as M (fromList, keys, lookup , singleton, size)+import qualified Data.Semigroup as Semigroup (Option(..)) import qualified Data.Set as Set (empty, insert, member) import qualified Data.Text as T (Text, pack, unpack)-import qualified Data.Vector as V (unsafeIndex, null, length, create, fromList)+import qualified Data.Vector as V (unsafeIndex, null, length, create, empty) import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite) +{-# ANN module "Hlint: ignore Reduce duplication" #-} -------------------------------------------------------------------------------- -- Convenience@@ -253,8 +254,8 @@ -> Name -- ^ Name of the type for which to generate an instance. -> Q [Dec]-deriveToJSONCommon = deriveJSONClass [ (ToJSON, \jc _ -> consToValue jc)- , (ToEncoding, \jc _ -> consToEncoding jc)+deriveToJSONCommon = deriveJSONClass [ (ToJSON, \jc _ -> consToValue Value jc)+ , (ToEncoding, \jc _ -> consToValue Encoding jc) ] -- | Generates a lambda expression which encodes the given data type or@@ -284,7 +285,7 @@ -> Options -- ^ Encoding options. -> Name -- ^ Name of the encoded type. -> Q Exp-mkToJSONCommon = mkFunCommon (\jc _ -> consToValue jc)+mkToJSONCommon = mkFunCommon (\jc _ -> consToValue Value jc) -- | Generates a lambda expression which encodes the given data type or -- data family instance constructor as a JSON string.@@ -313,12 +314,14 @@ -> Options -- ^ Encoding options. -> Name -- ^ Name of the encoded type. -> Q Exp-mkToEncodingCommon = mkFunCommon (\jc _ -> consToEncoding jc)+mkToEncodingCommon = mkFunCommon (\jc _ -> consToValue Encoding jc) -- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates--- code to generate a 'Value' of a number of constructors. All constructors--- must be from the same type.-consToValue :: JSONClass+-- code to generate a 'Value' or 'Encoding' of a number of constructors. All+-- constructors must be from the same type.+consToValue :: ToJSONFun+ -- ^ The method ('toJSON' or 'toEncoding') being derived.+ -> JSONClass -- ^ The ToJSON variant being derived. -> Options -- ^ Encoding options.@@ -328,10 +331,10 @@ -- ^ Constructors for which to generate JSON generating code. -> Q Exp -consToValue _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "+consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: " ++ "Not a single constructor given!" -consToValue jc opts vars cons = do+consToValue target jc opts vars cons = do value <- newName "value" tjs <- newNameList "_tj" $ arityInt jc tjls <- newNameList "_tjl" $ arityInt jc@@ -345,66 +348,26 @@ matches tvMap = case cons of -- A single constructor is directly encoded. The constructor itself may be -- forgotten.- [con] | not (tagSingleConstructors opts) -> [argsToValue jc tvMap opts False con]+ [con] | not (tagSingleConstructors opts) -> [argsToValue target jc tvMap opts False con] _ | allNullaryToStringTag opts && all isNullary cons ->- [ match (conP conName []) (normalB $ conStr opts conName) []+ [ match (conP conName []) (normalB $ conStr target opts conName) [] | con <- cons , let conName = constructorName con ]- | otherwise -> [argsToValue jc tvMap opts True con | con <- cons]+ | otherwise -> [argsToValue target jc tvMap opts True con | con <- cons] -conStr :: Options -> Name -> Q Exp-conStr opts = appE [|String|] . conTxt opts+-- | Name of the constructor as a quoted 'Value' or 'Encoding'.+conStr :: ToJSONFun -> Options -> Name -> Q Exp+conStr Value opts = appE [|String|] . conTxt opts+conStr Encoding opts = appE [|E.text|] . conTxt opts +-- | Name of the constructor as a quoted 'Text'. conTxt :: Options -> Name -> Q Exp-conTxt opts = appE [|T.pack|] . conStringE opts--conStringE :: Options -> Name -> Q Exp-conStringE opts = stringE . constructorTagModifier opts . nameBase---- | Helper function used by both 'deriveToJSON' and 'mkToEncoding'. Generates--- code to write out a value for a number of constructors. All constructors--- must be from the same type.-consToEncoding :: JSONClass- -- ^ The ToJSON variant being derived.- -> Options- -- ^ Encoding options.- -> [Type]- -- ^ The types from the data type/data family instance declaration- -> [ConstructorInfo]- -- ^ Constructors for which to generate JSON generating code.- -> Q Exp--consToEncoding _ _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "- ++ "Not a single constructor given!"--consToEncoding jc opts vars cons = do- value <- newName "value"- tes <- newNameList "_te" $ arityInt jc- tels <- newNameList "_tel" $ arityInt jc- let zippedTEs = zip tes tels- interleavedTEs = interleave tes tels- lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars- tvMap = M.fromList $ zip lastTyVars zippedTEs- lamE (map varP $ interleavedTEs ++ [value]) $- caseE (varE value) (matches tvMap)- where- matches tvMap = case cons of- -- A single constructor is directly encoded. The constructor itself may be- -- forgotten.- [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tvMap opts False con]- -- Encode just the name of the constructor of a sum type iff all the- -- constructors are nullary.- _ | allNullaryToStringTag opts && all isNullary cons ->- [ match (conP conName [])- (normalB $ encStr opts conName) []- | con <- cons- , let conName = constructorName con- ]- | otherwise -> [argsToEncoding jc tvMap opts True con | con <- cons]+conTxt opts = appE [|T.pack|] . stringE . conString opts -encStr :: Options -> Name -> Q Exp-encStr opts = appE [|E.text|] . conTxt opts+-- | Name of the constructor.+conString :: Options -> Name -> String+conString opts = constructorTagModifier opts . nameBase -- | If constructor is nullary. isNullary :: ConstructorInfo -> Bool@@ -412,127 +375,133 @@ , constructorFields = tys } = null tys isNullary _ = False -sumToValue :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp-sumToValue opts multiCons nullary conName exp+-- | Wrap fields of a non-record constructor. See 'sumToValue'.+opaqueSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ+opaqueSumToValue target opts multiCons nullary conName value =+ sumToValue target opts multiCons nullary conName+ value+ pairs+ where+ pairs contentsFieldName = listE [toPair target contentsFieldName value]++-- | Wrap fields of a record constructor. See 'sumToValue'.+recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ+recordSumToValue target opts multiCons nullary conName pairs =+ sumToValue target opts multiCons nullary conName+ (objectExp target pairs)+ (const pairs)++-- | Wrap fields of a constructor.+sumToValue+ :: ToJSONFun+ -- ^ The method being derived.+ -> Options+ -- ^ Deriving options.+ -> Bool+ -- ^ Does this type have multiple constructors.+ -> Bool+ -- ^ Is this constructor nullary.+ -> Name+ -- ^ Constructor name.+ -> ExpQ+ -- ^ Fields of the constructor as a 'Value' or 'Encoding'.+ -> (String -> ExpQ)+ -- ^ Representation of an 'Object' fragment used for the 'TaggedObject'+ -- variant; of type @[(Text,Value)]@ or @[Encoding]@, depending on the method+ -- being derived.+ --+ -- - For non-records, produces a pair @"contentsFieldName":value@,+ -- given a @contentsFieldName@ as an argument. See 'opaqueSumToValue'.+ -- - For records, produces the list of pairs corresponding to fields of the+ -- encoded value (ignores the argument). See 'recordSumToValue'.+ -> ExpQ+sumToValue target opts multiCons nullary conName value pairs | multiCons = case sumEncoding opts of TwoElemArray ->- [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp])+ array target [conStr target opts conName, value] TaggedObject{tagFieldName, contentsFieldName} ->- let tag = infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)- contents = infixApp [|T.pack contentsFieldName|] [|(.=)|] exp- in- [|A.object|] `appE` listE (if nullary then [tag] else [tag, contents])+ -- TODO: Maybe throw an error in case+ -- tagFieldName overwrites a field in pairs.+ let tag = toPair target tagFieldName (conStr target opts conName)+ content = pairs contentsFieldName+ in objectExp target $+ if nullary then listE [tag] else infixApp tag [|(:)|] content ObjectWithSingleField ->- [|A.object|] `appE` listE- [ infixApp (conTxt opts conName) [|(.=)|] exp- ]- UntaggedValue | nullary -> conStr opts conName- UntaggedValue -> exp- | otherwise = exp+ object target [(conString opts conName, value)]+ UntaggedValue | nullary -> conStr target opts conName+ UntaggedValue -> value+ | otherwise = value -- | Generates code to generate the JSON encoding of a single constructor.-argsToValue :: JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match+argsToValue :: ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match -- Polyadic constructors with special case for unary constructors.-argsToValue jc tvMap opts multiCons+argsToValue target jc tvMap opts multiCons ConstructorInfo { constructorName = conName , constructorVariant = NormalConstructor , constructorFields = argTys } = do argTys' <- mapM resolveTypeSynonyms argTys let len = length argTys' args <- newNameList "arg" len- js <- case [ dispatchToJSON jc conName tvMap argTy- `appE` varE arg- | (arg, argTy) <- zip args argTys'- ] of- -- Single argument is directly converted.- [e] -> return e- -- Multiple arguments are converted to a JSON array.- es -> do- mv <- newName "mv"- let newMV = bindS (varP mv)- ([|VM.unsafeNew|] `appE`- litE (integerL $ fromIntegral len))- stmts = [ noBindS $- [|VM.unsafeWrite|] `appE`- varE mv `appE`- litE (integerL ix) `appE`- e- | (ix, e) <- zip [(0::Integer)..] es- ]- ret = noBindS $ [|return|] `appE` varE mv- return $ [|Array|] `appE`- (varE 'V.create `appE`- doE (newMV:stmts++[ret]))+ let js = case [ dispatchToJSON target jc conName tvMap argTy+ `appE` varE arg+ | (arg, argTy) <- zip args argTys'+ ] of+ -- Single argument is directly converted.+ [e] -> e+ -- Zero and multiple arguments are converted to a JSON array.+ es -> array target es+ match (conP conName $ map varP args)- (normalB $ sumToValue opts multiCons (null argTys') conName js)+ (normalB $ opaqueSumToValue target opts multiCons (null argTys') conName js) [] -- Records.-argsToValue jc tvMap opts multiCons+argsToValue target jc tvMap opts multiCons info@ConstructorInfo { constructorName = conName , constructorVariant = RecordConstructor fields , constructorFields = argTys } = case (unwrapUnaryRecords opts, not multiCons, argTys) of- (True,True,[_]) -> argsToValue jc tvMap opts multiCons+ (True,True,[_]) -> argsToValue target jc tvMap opts multiCons (info{constructorVariant = NormalConstructor}) _ -> do argTys' <- mapM resolveTypeSynonyms argTys args <- newNameList "arg" $ length argTys'- let exp = [|A.object|] `appE` pairs-- pairs | omitNothingFields opts = infixApp maybeFields+ let pairs | omitNothingFields opts = infixApp maybeFields [|(++)|] restFields- | otherwise = listE $ map toPair argCons+ | otherwise = listE $ map pureToPair argCons - argCons = zip3 args argTys' fields+ argCons = zip3 (map varE args) argTys' fields maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes) - restFields = listE $ map toPair rest-- (maybes, rest) = partition isMaybe argCons+ restFields = listE $ map pureToPair rest - maybeToPair (arg, argTy, field) =- infixApp ([|keyValuePairWith|]- `appE` dispatchToJSON jc conName tvMap argTy- `appE` toFieldName field)- [|(<$>)|]- (varE arg)+ (maybes0, rest0) = partition isMaybe argCons+ (options, rest) = partition isOption rest0+ maybes = maybes0 ++ map optionToMaybe options - toPair (arg, argTy, field) =- [|keyValuePairWith|]- `appE` dispatchToJSON jc conName tvMap argTy- `appE` toFieldName field- `appE` varE arg+ maybeToPair = toPairLifted True+ pureToPair = toPairLifted False - toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field+ toPairLifted lifted (arg, argTy, field) =+ let toValue = dispatchToJSON target jc conName tvMap argTy+ fieldName = fieldLabel opts field+ e arg' = toPair target fieldName (toValue `appE` arg')+ in if lifted+ then do+ x <- newName "x"+ infixApp (lam1E (varP x) (e (varE x))) [|(<$>)|] arg+ else e arg match (conP conName $ map varP args)- ( normalB- $ if multiCons- then case sumEncoding opts of- TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]- TaggedObject{tagFieldName} ->- [|A.object|] `appE`- -- TODO: Maybe throw an error in case- -- tagFieldName overwrites a field in pairs.- infixApp (infixApp [|T.pack tagFieldName|]- [|(.=)|]- (conStr opts conName))- [|(:)|]- pairs- ObjectWithSingleField ->- [|A.object|] `appE` listE- [ infixApp (conTxt opts conName) [|(.=)|] exp ]- UntaggedValue -> exp- else exp- ) []+ (normalB $ recordSumToValue target opts multiCons (null argTys) conName pairs)+ [] -- Infix constructors.-argsToValue jc tvMap opts multiCons+argsToValue target jc tvMap opts multiCons ConstructorInfo { constructorName = conName , constructorVariant = InfixConstructor , constructorFields = argTys } = do@@ -541,11 +510,12 @@ ar <- newName "argR" match (infixP (varP al) conName (varP ar)) ( normalB- $ sumToValue opts multiCons False conName- $ [|toJSON|] `appE` listE [ dispatchToJSON jc conName tvMap aTy- `appE` varE a- | (a, aTy) <- [(al,alTy), (ar,arTy)]- ]+ $ opaqueSumToValue target opts multiCons False conName+ $ array target+ [ dispatchToJSON target jc conName tvMap aTy+ `appE` varE a+ | (a, aTy) <- [(al,alTy), (ar,arTy)]+ ] ) [] @@ -553,6 +523,13 @@ isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe isMaybe _ = False +isOption :: (a, Type, b) -> Bool+isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option+isOption _ = False++optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c)+optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)+ (<^>) :: ExpQ -> ExpQ -> ExpQ (<^>) a b = infixApp a [|(E.><)|] b infixr 6 <^>@@ -565,139 +542,85 @@ (<%>) a b = a <^> [|E.comma|] <^> b infixr 4 <%> -array :: ExpQ -> ExpQ-array exp = [|E.wrapArray|] `appE` exp--object :: ExpQ -> ExpQ-object exp = [|E.wrapObject|] `appE` exp--sumToEncoding :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp-sumToEncoding opts multiCons nullary conName exp- | multiCons =- let fexp = exp in- case sumEncoding opts of- TwoElemArray ->- array (encStr opts conName <%> fexp)- TaggedObject{tagFieldName, contentsFieldName} ->- let tag = [|E.text (T.pack tagFieldName)|] <:> encStr opts conName- contents = [|E.text (T.pack contentsFieldName)|] <:> fexp- in- object $- if nullary then tag else tag <%> contents- ObjectWithSingleField ->- object (encStr opts conName <:> fexp)- UntaggedValue | nullary -> encStr opts conName- UntaggedValue -> exp- | otherwise = exp---- | Generates code to generate the JSON encoding of a single constructor.-argsToEncoding :: JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match---- Polyadic constructors with special case for unary constructors.-argsToEncoding jc tvMap opts multiCons- ConstructorInfo { constructorName = conName- , constructorVariant = NormalConstructor- , constructorFields = argTys } = do- argTys' <- mapM resolveTypeSynonyms argTys- args <- newNameList "arg" $ length argTys'- js <- case zip args argTys' of- -- Nullary constructors are converted to an empty array.- [] -> return [| E.emptyArray_ |]-- -- Single argument is directly converted.- [(e,eTy)] -> return (dispatchToEncoding jc conName tvMap eTy- `appE` varE e)- -- Multiple arguments are converted to a JSON array.- es ->- return (array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap xTy- `appE` varE x- | (x,xTy) <- es- ]))- match (conP conName $ map varP args)- (normalB $ sumToEncoding opts multiCons (null argTys') conName js)- []---- Records.-argsToEncoding jc tvMap opts multiCons- info@ConstructorInfo { constructorName = conName- , constructorVariant = RecordConstructor fields- , constructorFields = argTys } =- case (unwrapUnaryRecords opts, not multiCons, argTys) of- (True,True,[_]) -> argsToEncoding jc tvMap opts multiCons- (info{constructorVariant = NormalConstructor})- _ -> do- argTys' <- mapM resolveTypeSynonyms argTys- args <- newNameList "arg" $ length argTys'- let exp = object objBody-- objBody = [|E.econcat|] `appE`- ([|intersperse E.comma|] `appE` pairs)- pairs | omitNothingFields opts = infixApp maybeFields- [|(++)|]- restFields- | otherwise = listE (map toPair argCons)-- argCons = zip3 args argTys' fields-- maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)+-- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value').+array :: ToJSONFun -> [ExpQ] -> ExpQ+array Encoding [] = [|E.emptyArray_|]+array Value [] = [|Array V.empty|]+array Encoding es = [|E.wrapArray|] `appE` foldr1 (<%>) es+array Value es = do+ mv <- newName "mv"+ let newMV = bindS (varP mv)+ ([|VM.unsafeNew|] `appE`+ litE (integerL $ fromIntegral (length es)))+ stmts = [ noBindS $+ [|VM.unsafeWrite|] `appE`+ varE mv `appE`+ litE (integerL ix) `appE`+ e+ | (ix, e) <- zip [(0::Integer)..] es+ ]+ ret = noBindS $ [|return|] `appE` varE mv+ [|Array|] `appE`+ (varE 'V.create `appE`+ doE (newMV:stmts++[ret])) - restFields = listE (map toPair rest)+-- | Wrap an associative list of keys and quoted values in a quoted 'Object'.+object :: ToJSONFun -> [(String, ExpQ)] -> ExpQ+object target = wrapObject target . catPairs target . fmap (uncurry (toPair target)) - (maybes, rest) = partition isMaybe argCons+-- |+-- - When deriving 'ToJSON', map a list of quoted key-value pairs to an+-- expression of the list of pairs.+-- - When deriving 'ToEncoding', map a list of quoted 'Encoding's representing+-- key-value pairs to a comma-separated 'Encoding' of them.+--+-- > catPairs Value [ [|(k0,v0)|], [|(k1,v1)|] ] = [| [(k0,v0), (k1,v1)] |]+-- > catPairs Encoding [ [|"\"k0\":v0"|], [|"\"k1\":v1"|] ] = [| "\"k0\":v0,\"k1\":v1" |]+catPairs :: ToJSONFun -> [ExpQ] -> ExpQ+catPairs Value = listE+catPairs Encoding = foldr1 (<%>) - maybeToPair (arg, argTy, field) =- infixApp- (infixApp- (infixE- (Just $ toFieldName field <^> [|E.colon|])- [|(E.><)|]- Nothing)- [|(.)|]- (dispatchToEncoding jc conName tvMap argTy))- [|(<$>)|]- (varE arg)+-- |+-- - When deriving 'ToJSON', wrap a quoted list of key-value pairs in an 'Object'.+-- - When deriving 'ToEncoding', wrap a quoted list of encoded key-value pairs+-- in an encoded 'Object'.+--+-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]+-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "{\"k0\":v0,\"k1\":v1}" |]+objectExp :: ToJSONFun -> ExpQ -> ExpQ+objectExp target = wrapObject target . catPairsExp target - toPair (arg, argTy, field) =- toFieldName field- <:> dispatchToEncoding jc conName tvMap argTy- `appE` varE arg+-- | Counterpart of 'catPairsExp' when the list of pairs is already quoted.+--+-- > objectExp Value [| [(k0,v0), (k1,v1)] |] = [| [(k0,v0), (k1,v1)] |]+-- > objectExp Encoding [| ["\"k0\":v0", "\"k1\":v1"] |] = [| "\"k0\":v0,\"k1\":v1" |]+catPairsExp :: ToJSONFun -> ExpQ -> ExpQ+catPairsExp Value e = e+catPairsExp Encoding e = [|commaSep|] `appE` e - toFieldName field = [|E.text|] `appE`- ([|T.pack|] `appE` fieldLabelExp opts field)+-- | Create (an encoding of) a key-value pair.+--+-- > toPair Value "k" [|v|] = [|("k",v)|] -- The quoted string is actually Text.+-- > toPair Encoding "k" [|"v"|] = [|"\"k\":v"|]+toPair :: ToJSONFun -> String -> ExpQ -> ExpQ+toPair Value k v = infixApp [|T.pack k|] [|(.=)|] v+toPair Encoding k v = [|E.string k|] <:> v - match (conP conName $ map varP args)- ( normalB- $ if multiCons- then case sumEncoding opts of- TwoElemArray -> array $- encStr opts conName <%> exp- TaggedObject{tagFieldName} -> object $- ([|E.text (T.pack tagFieldName)|] <:>- encStr opts conName) <%>- objBody- ObjectWithSingleField -> object $- encStr opts conName <:> exp- UntaggedValue -> exp- else exp- ) []+-- | Map an associative list in an 'Object'.+--+-- > wrapObject Value [| [(k0,v0), (k1,v1)] |] = [| Object (fromList [(k0,v0), (k1,v1)]) |]+-- > wrapObject Encoding [| "\"k0\":v0,\"k1\":v1" |] = [| "{\"k0\":v0,\"k1\":v1}" |]+wrapObject :: ToJSONFun -> ExpQ -> ExpQ+wrapObject Value e = [|A.object|] `appE` e+wrapObject Encoding e = [|E.wrapObject|] `appE` e --- Infix constructors.-argsToEncoding jc tvMap opts multiCons- ConstructorInfo { constructorName = conName- , constructorVariant = InfixConstructor- , constructorFields = argTys } = do- al <- newName "argL"- ar <- newName "argR"- [alTy,arTy] <- mapM resolveTypeSynonyms argTys- match (infixP (varP al) conName (varP ar))- ( normalB- $ sumToEncoding opts multiCons False conName- $ array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap aTy- `appE` varE a- | (a,aTy) <- [(al,alTy), (ar,arTy)]- ])- )- []+-- | Separate 'Encoding's by commas.+--+-- > commaSep ["a","b","c"] = "a,b,c"+commaSep :: [E.Encoding] -> E.Encoding+commaSep [] = E.empty+commaSep [x] = x+commaSep (x : xs) = x E.>< E.comma E.>< commaSep xs -------------------------------------------------------------------------------- -- FromJSON@@ -824,8 +747,7 @@ [ liftM2 (,) (normalG $ infixApp (varE txt) [|(==)|]- ([|T.pack|] `appE`- conStringE opts conName)+ (conTxt opts conName) ) ([|pure|] `appE` conE conName) | con <- cons@@ -917,7 +839,7 @@ caseE (varE conVal) [ match (conP 'String [varP str]) (guardedB- [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] ([|T.pack|] `appE` conStringE opts conName)+ [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] (conTxt opts conName) ) ([|pure|] `appE` conE conName) ]@@ -1061,7 +983,7 @@ `appE` litE (stringL $ show tName) `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName) `appE` varE obj- `appE` ( [|T.pack|] `appE` fieldLabelExp opts field+ `appE` ( [|T.pack|] `appE` stringE (fieldLabel opts field) ) | (field, argTy) <- zip fields argTys ]@@ -1234,6 +1156,11 @@ instance INCOHERENT_ LookupField (Maybe a) where lookupField pj _ _ = parseOptionalFieldWith pj +instance INCOHERENT_ LookupField (Semigroup.Option a) where+ lookupField pj tName rec obj key =+ fmap Semigroup.Option+ (lookupField (fmap Semigroup.getOption . pj) tName rec obj key)+ lookupFieldWith :: (Value -> Parser a) -> String -> String -> Object -> T.Text -> Parser a lookupFieldWith pj tName rec obj key =@@ -1241,9 +1168,6 @@ Nothing -> unknownFieldFail tName rec (T.unpack key) Just v -> pj v <?> Key key -keyValuePairWith :: (v -> Value) -> T.Text -> v -> Pair-keyValuePairWith tj name value = (name, tj value)- unknownFieldFail :: String -> String -> String -> Parser fail unknownFieldFail tName rec key = fail $ printf "When parsing the record %s of type %s the key %s was not present."@@ -1413,10 +1337,13 @@ (interleave rhsArgs rhsArgs) else varE $ jsonFunValOrListName list jf Arity0 -dispatchToJSON, dispatchToEncoding, dispatchParseJSON+dispatchToJSON+ :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp+dispatchToJSON target jc n tvMap =+ dispatchFunByType jc (targetToJSONFun target) n tvMap False++dispatchParseJSON :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp-dispatchToJSON jc n tvMap = dispatchFunByType jc ToJSON n tvMap False-dispatchToEncoding jc n tvMap = dispatchFunByType jc ToEncoding n tvMap False dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap False --------------------------------------------------------------------------------@@ -1884,11 +1811,11 @@ . nameBase . constructorName --- | Creates a string literal expression from a record field label.-fieldLabelExp :: Options -- ^ Encoding options- -> Name- -> Q Exp-fieldLabelExp opts = litE . stringL . fieldLabelModifier opts . nameBase+-- | Extracts a record field label.+fieldLabel :: Options -- ^ Encoding options+ -> Name+ -> String+fieldLabel opts = fieldLabelModifier opts . nameBase -- | The name of the outermost 'Value' constructor. valueConName :: Value -> String@@ -2020,6 +1947,13 @@ -- | A representation of which typeclass method is being spliced in. data JSONFun = ToJSON | ToEncoding | ParseJSON++-- | A refinement of JSONFun to [ToJSON, ToEncoding].+data ToJSONFun = Value | Encoding++targetToJSONFun :: ToJSONFun -> JSONFun+targetToJSONFun Value = ToJSON+targetToJSONFun Encoding = ToEncoding -- | A representation of which typeclass is being derived. data JSONClass = JSONClass { direction :: Direction, arity :: Arity }
Data/Aeson/Types.hs view
@@ -84,6 +84,7 @@ , withNumber , withScientific , withBool+ , withEmbeddedJSON , pairs , foldable
Data/Aeson/Types/Class.hs view
@@ -73,6 +73,7 @@ , withNumber , withScientific , withBool+ , withEmbeddedJSON -- * Functions , fromJSON
Data/Aeson/Types/FromJSON.hs view
@@ -55,6 +55,7 @@ , withNumber , withScientific , withBool+ , withEmbeddedJSON -- * Functions , fromJSON@@ -82,6 +83,7 @@ import Control.Applicative ((<|>), Const(..)) import Control.Monad ((<=<), zipWithM) import Data.Aeson.Internal.Functions (mapKey)+import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF) import Data.Aeson.Types.Generic import Data.Aeson.Types.Internal import Data.Attoparsec.Number (Number(..))@@ -114,6 +116,7 @@ import Numeric.Natural (Natural) import Text.ParserCombinators.ReadP (readP_to_S) import Unsafe.Coerce (unsafeCoerce)+import qualified Data.Aeson.Compat as Compat import qualified Data.Aeson.Parser.Time as Time import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific) import qualified Data.DList as DList@@ -316,7 +319,7 @@ -- -- @ -- instance 'FromJSON' Coord where--- 'parseJSON' = 'withObject' \"Coord\" $ \v -> Coord+-- 'parseJSON' = 'withObject' \"Coord\" $ \\v -> Coord -- '<$>' v '.:' \"x\" -- '<*>' v '.:' \"y\" -- @@@ -665,6 +668,16 @@ withBool expected _ v = typeMismatch expected v {-# INLINE withBool #-} +-- | Decode a nested JSON-encoded string.+withEmbeddedJSON :: (FromJSON a) => String -> (Value -> Parser a) -> Value -> Parser a+withEmbeddedJSON _ innerParser (String txt) =+ either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)+ where+ eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON+ eitherFormatError = either (Left . uncurry formatError) Right+withEmbeddedJSON name _ v = typeMismatch name v+{-# INLINE withEmbeddedJSON #-}+ -- | Convert a value from JSON, failing if the types do not match. fromJSON :: (FromJSON a) => Value -> Result a fromJSON = parse parseJSON@@ -1034,6 +1047,14 @@ where label = fieldLabelModifier opts $ selName (undefined :: t s (K1 i (Maybe a)) p)++-- Parse an Option like a Maybe.+instance INCOHERENT_ (Selector s, FromJSON a) =>+ FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where+ parseRecord opts fargs lab obj = wrap <$> parseRecord opts fargs lab obj+ where+ wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p+ wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a)) --------------------------------------------------------------------------------
Data/Aeson/Types/ToJSON.hs view
@@ -1023,6 +1023,19 @@ recordToPairs opts targs m1 = fieldToPair opts targs m1 {-# INLINE recordToPairs #-} +instance INCOHERENT_+ ( Selector s+ , GToJSON enc arity (K1 i (Maybe a))+ , GKeyValue enc pairs+ , Monoid pairs+ ) => RecordToPairs enc pairs arity (S1 s (K1 i (Semigroup.Option a)))+ where+ recordToPairs opts targs = recordToPairs opts targs . unwrap+ where+ unwrap :: S1 s (K1 i (Semigroup.Option a)) p -> S1 s (K1 i (Maybe a)) p+ unwrap (M1 (K1 (Semigroup.Option a))) = M1 (K1 a)+ {-# INLINE recordToPairs #-}+ fieldToPair :: (Selector s , GToJSON enc arity a , GKeyValue enc pairs)
aeson.cabal view
@@ -1,5 +1,5 @@ name: aeson-version: 1.2.2.0+version: 1.2.3.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON@@ -100,6 +100,7 @@ Data.Aeson.Encode other-modules:+ Data.Aeson.Compat Data.Aeson.Encoding.Builder Data.Aeson.Internal.Functions Data.Aeson.Parser.Unescape@@ -199,7 +200,7 @@ build-depends: HUnit,- QuickCheck >= 2.8 && <2.11,+ QuickCheck >= 2.10.0.1 && < 2.11, aeson, integer-logarithms >= 1 && <1.1, attoparsec,@@ -226,7 +227,7 @@ unordered-containers, uuid-types, vector,- quickcheck-instances >=0.3.14+ quickcheck-instances >= 0.3.16 if flag(bytestring-builder) build-depends: bytestring >= 0.9 && < 0.10.4,
+ benchmarks/Escape.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import Prelude ()+import Prelude.Compat++import Criterion.Main+import qualified "aeson-benchmarks" Data.Aeson.Parser.UnescapeFFI as FFI+import qualified "aeson-benchmarks" Data.Aeson.Parser.UnescapePure as Pure++import qualified Data.ByteString.Char8 as BS++n :: Int+n = 10000++input :: BS.ByteString+input = BS.concat $ replicate n $ BS.pack "\\\""++main :: IO ()+main = defaultMain+ [ bench "ffi" $ whnf FFI.unescapeText input+ , bench "pure" $ whnf Pure.unescapeText input+ ]
benchmarks/aeson-benchmarks.cabal view
@@ -80,6 +80,20 @@ ghc-options: -O2 -Wall cpp-options: -DGENERICS +executable aeson-benchmark-escape+ main-is: Escape.hs+ hs-source-dirs: ../examples .+ ghc-options: -Wall -O2 -rtsopts+ build-depends:+ aeson-benchmarks,+ base,+ base-compat,+ bytestring,+ criterion >= 1.0,+ deepseq,+ ghc-prim,+ text+ executable aeson-benchmark-compare main-is: Compare.hs hs-source-dirs: ../examples .
changelog.md view
@@ -1,5 +1,12 @@ For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md). +### 1.2.3.0++* Added `withEmbeddedJSON` to help parse JSON embedded inside a JSON string, thanks to Jesse Kempf.+* Memory usage improvements to the default (pure) parser, thanks to Jonathan Paugh. Also thanks to Neil Mitchell & Oleg Grenrus for contributing a benchmark.+* `omitNothingFields` now works for the `Option` newtype, thanks to Xia Li-yao.+* Some documentation fixes, thanks to Jonathan Paug & Philippe Crama.+ ### 1.2.2.0 * Add `FromJSON` and `ToJSON` instances for
pure/Data/Aeson/Parser/UnescapePure.hs view
@@ -119,8 +119,6 @@ w | 0x80 <= w && w <= 0xbf -> (UtfGround, setByte1 point word) _ -> throwDecodeError -{-# INLINE decode #-}- decodeHex :: Word8 -> Word16 decodeHex 48 = 0 -- '0' decodeHex 49 = 1 -- '1'@@ -145,13 +143,13 @@ decodeHex 70 = 15 -- 'F' decodeHex 102 = 15 -- 'f' decodeHex _ = throwDecodeError-{-# INLINE decodeHex #-} unescapeText' :: ByteString -> Text unescapeText' bs = runText $ \done -> do dest <- A.new len- (pos, finalState) <- B.foldl' (f' dest) (return (0, StateNone)) bs + (pos, finalState) <- loop dest (0, StateNone) 0+ -- Check final state. Currently pos gets only increased over time, so this check should catch overflows. when ( finalState /= StateNone || pos > len) throwDecodeError@@ -172,11 +170,12 @@ (st', p) -> return (pos, StateUtf st' p) - {-# INLINE runUtf #-}-- f' dest m c = m >>= \s -> f dest s c-- {-# INLINE f' #-}+ loop :: A.MArray s -> (Int, State) -> Int -> ST s (Int, State)+ loop _ ps i | i >= len = return ps+ loop dest ps i = do+ let c = B.index bs i -- JP: We can use unsafe index once we prove bounds with Liquid Haskell.+ ps' <- f dest ps c+ loop dest ps' $ i+1 -- No pending state. f dest (pos, StateNone) c = runUtf dest pos UtfGround 0 c@@ -253,8 +252,6 @@ else writeAndReturn dest pos u StateNone - {-# INLINE f #-}- write :: A.MArray s -> Int -> Word16 -> ST s () write dest pos char = A.unsafeWrite dest pos char@@ -270,8 +267,6 @@ throwDecodeError = let desc = "Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream" in throw (DecodeError desc Nothing)-{-# INLINE throwDecodeError #-} unescapeText :: ByteString -> Either UnicodeException Text unescapeText = unsafeDupablePerformIO . try . evaluate . unescapeText'-{-# INLINE unescapeText #-}
+ stack-ffi-unescape.yaml view
@@ -0,0 +1,7 @@+resolver: nightly-2017-09-04+packages:+- '.'+flags:+ aeson:+ fast: true+ cffi: true
stack-lts6.yaml view
@@ -4,12 +4,16 @@ - attoparsec-iso8601 extra-deps: - integer-logarithms-1-- QuickCheck-2.9.2-- quickcheck-instances-0.3.14 - semigroups-0.18.2 - tagged-0.8.5-- th-abstraction-0.2.2.0 - transformers-compat-0.5.1.4+- QuickCheck-2.10.0.1+- base-compat-0.9.3+- hashable-1.2.6.1+- integer-logarithms-1+- quickcheck-instances-0.3.16+- test-framework-quickcheck2-0.3.0.4+- th-abstraction-0.2.2.0 flags: flags: aeson:
stack-lts7.yaml view
@@ -3,8 +3,12 @@ - '.' - attoparsec-iso8601 extra-deps:+- QuickCheck-2.10.0.1+- base-compat-0.9.3+- hashable-1.2.6.1 - integer-logarithms-1-- quickcheck-instances-0.3.14+- quickcheck-instances-0.3.16+- test-framework-quickcheck2-0.3.0.4 - th-abstraction-0.2.2.0 flags: aeson:
stack-lts8.yaml view
@@ -3,8 +3,11 @@ - '.' - attoparsec-iso8601 extra-deps:-- quickcheck-instances-0.3.14+- QuickCheck-2.10.0.1+- base-compat-0.9.3+- quickcheck-instances-0.3.16 - th-abstraction-0.2.2.0+- test-framework-quickcheck2-0.3.0.4 flags: aeson: fast: true
− stack-pure-unescape.yaml
@@ -1,10 +0,0 @@-resolver: lts-8.1-packages:-- '.'-extra-deps:-- quickcheck-instances-0.3.14-- th-abstraction-0.2.2.0-flags:- aeson:- fast: true- cffi: false
tests/Encoders.hs view
@@ -235,6 +235,33 @@ gSomeTypeToEncodingOmitNothingFields :: SomeType Int -> Encoding gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields ++--------------------------------------------------------------------------------+-- Option fields+--------------------------------------------------------------------------------++thOptionFieldToJSON :: OptionField -> Value+thOptionFieldToJSON = $(mkToJSON optsOptionField 'OptionField)++thOptionFieldToEncoding :: OptionField -> Encoding+thOptionFieldToEncoding = $(mkToEncoding optsOptionField 'OptionField)++thOptionFieldParseJSON :: Value -> Parser OptionField+thOptionFieldParseJSON = $(mkParseJSON optsOptionField 'OptionField)++gOptionFieldToJSON :: OptionField -> Value+gOptionFieldToJSON = genericToJSON optsOptionField++gOptionFieldToEncoding :: OptionField -> Encoding+gOptionFieldToEncoding = genericToEncoding optsOptionField++gOptionFieldParseJSON :: Value -> Parser OptionField+gOptionFieldParseJSON = genericParseJSON optsOptionField++thMaybeFieldToJSON :: MaybeField -> Value+thMaybeFieldToJSON = $(mkToJSON optsOptionField 'MaybeField)++ -------------------------------------------------------------------------------- -- IncoherentInstancesNeeded --------------------------------------------------------------------------------
tests/Instances.hs view
@@ -22,31 +22,12 @@ import qualified Data.DList as DList import qualified Data.HashMap.Strict as HM -#if !MIN_VERSION_QuickCheck(2,9,0)-import Control.Applicative (Const(..))-import Data.Functor.Identity (Identity (..))-import Data.List.NonEmpty (NonEmpty(..))-import Data.Version-import Test.QuickCheck (getNonNegative, listOf1, resize)-#endif--#if !MIN_VERSION_QuickCheck(2,10,0)-import Data.Functor.Compose (Compose (..))-import Data.Proxy (Proxy(..))-#endif- import Data.Orphans () import Test.QuickCheck.Instances () #if MIN_VERSION_base(4,7,0) import Data.Hashable.Time () #endif -#if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,8,3)-import Numeric.Natural-#endif--{-# ANN module ("HLint: ignore Use fewer imports"::String) #-}- -- "System" types. instance Arbitrary DotNetTime where@@ -174,49 +155,15 @@ instance Arbitrary (GADT String) where arbitrary = GADT <$> arbitrary +instance Arbitrary OptionField where+ arbitrary = OptionField <$> arbitrary++ instance ApproxEq Char where (=~) = (==) instance (ApproxEq a) => ApproxEq [a] where a =~ b = length a == length b && all (uncurry (=~)) (zip a b) --- Version tags are deprecated, so we avoid using them in the Arbitrary--- instance. However, the recommended constructor 'makeVersion' is not--- exported by "Data.Version" until base-4.8.0.0. For previous versions,--- a definition is given below.---#if !MIN_VERSION_base(4,8,0) && !MIN_VERSION_QuickCheck(2,8,3)-instance Arbitrary Natural where- arbitrary = fromInteger . abs <$> arbitrary-#endif--#if !MIN_VERSION_QuickCheck(2,10,0)-instance Arbitrary (Proxy a) where- arbitrary = pure Proxy--instance Arbitrary (f (g a)) => Arbitrary (Compose f g a) where- arbitrary = Compose <$> arbitrary-#endif- instance Arbitrary a => Arbitrary (DList.DList a) where arbitrary = DList.fromList <$> arbitrary--#if !MIN_VERSION_QuickCheck(2,9,0)-instance Arbitrary a => Arbitrary (Const a b) where- arbitrary = Const <$> arbitrary--instance Arbitrary a => Arbitrary (NonEmpty a) where- arbitrary = (:|) <$> arbitrary <*> arbitrary--instance Arbitrary Version where- arbitrary = makeVersion . fmap getNonNegative <$> resize 4 (listOf1 arbitrary)--#if !MIN_VERSION_base(4,8,0)-makeVersion :: [Int] -> Version-makeVersion b = Version b []-#endif--instance Arbitrary a => Arbitrary (Identity a) where- arbitrary = Identity <$> arbitrary-#endif
tests/Options.hs view
@@ -48,3 +48,9 @@ { tagSingleConstructors = True , allNullaryToStringTag = False }++optsOptionField :: Options+optsOptionField = optsDefault+ { fieldLabelModifier = const "field"+ , omitNothingFields = True+ }
tests/Properties.hs view
@@ -25,6 +25,7 @@ import Data.Map (Map) import Data.Proxy (Proxy) import Data.Ratio (Ratio)+import Data.Semigroup (Option(..)) import Data.Sequence (Seq) import Data.Tagged (Tagged) import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)@@ -142,7 +143,10 @@ -- variation in JSON object key ordering. sameAs :: (a -> Value) -> (a -> Encoding) -> a -> Property sameAs toVal toEnc v =- eitherDecode (encodingToLazyByteString (toEnc v)) === Right (toVal v)+ counterexample (show s) $+ eitherDecode s === Right (toVal v)+ where+ s = encodingToLazyByteString (toEnc v) sameAs1 :: (forall a. LiftToJSON f a)@@ -376,6 +380,11 @@ , testProperty "Tagged" (toParseJSON gOneConstructorParseJSONTagged gOneConstructorToJSONTagged) ] ]+ , testGroup "OptionField" [+ testProperty "like Maybe" $+ \x -> gOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)+ , testProperty "roundTrip" (toParseJSON gOptionFieldParseJSON gOptionFieldToJSON)+ ] ] , testGroup "toEncoding" [ testProperty "NullaryString" $@@ -429,6 +438,9 @@ gOneConstructorToJSONDefault `sameAs` gOneConstructorToEncodingDefault , testProperty "OneConstructorTagged" $ gOneConstructorToJSONTagged `sameAs` gOneConstructorToEncodingTagged++ , testProperty "OptionField" $+ gOptionFieldToJSON `sameAs` gOptionFieldToEncoding ] ] , testGroup "template-haskell" [@@ -489,6 +501,11 @@ , testProperty "Tagged" (toParseJSON thOneConstructorParseJSONTagged thOneConstructorToJSONTagged) ] ]+ , testGroup "OptionField" [+ testProperty "like Maybe" $+ \x -> thOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)+ , testProperty "roundTrip" (toParseJSON thOptionFieldParseJSON thOptionFieldToJSON)+ ] ] , testGroup "toEncoding" [ testProperty "NullaryString" $@@ -533,6 +550,9 @@ thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault , testProperty "OneConstructorTagged" $ thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged++ , testProperty "OptionField" $+ thOptionFieldToJSON `sameAs` thOptionFieldToEncoding ] ] ]
tests/Types.hs view
@@ -17,6 +17,7 @@ import Data.Functor.Compose (Compose (..)) import Data.Functor.Identity (Identity (..)) import Data.Hashable (Hashable (..))+import Data.Semigroup (Option) import Data.Text import Data.Time (Day (..), fromGregorian) import GHC.Generics@@ -104,6 +105,10 @@ deriving instance Eq (GADT a) deriving instance Show (GADT a) +newtype MaybeField = MaybeField { maybeField :: Maybe Int }+newtype OptionField = OptionField { optionField :: Option Int }+ deriving (Eq, Show)+ deriving instance Generic Foo deriving instance Generic UFoo deriving instance Generic OneConstructor@@ -116,6 +121,7 @@ #if __GLASGOW_HASKELL__ >= 706 deriving instance Generic1 SomeType #endif+deriving instance Generic OptionField deriving instance Generic EitherTextInt failure :: Show a => String -> String -> a -> Property
tests/UnitTests.hs view
@@ -8,17 +8,22 @@ -- For Data.Aeson.Types.camelTo {-# OPTIONS_GHC -fno-warn-deprecations #-} +#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+#endif+ module UnitTests ( ioTests , tests+ , withEmbeddedJSONTest ) where import Prelude () import Prelude.Compat import Control.Monad (forM, forM_)-import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject)+import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject, withEmbeddedJSON) import Data.Aeson.Internal (JSONPathElement(..), formatError) import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1) import Data.Aeson.Text (encodeToTextBuilder)@@ -93,6 +98,7 @@ , testCase "Unescape string (PR #477)" unescapeString , testCase "Show Options" showOptions , testGroup "SingleMaybeField" singleMaybeField+ , testCase "withEmbeddedJSON" withEmbeddedJSONTest ] roundTripCamel :: String -> Assertion@@ -514,6 +520,19 @@ where v = SingleMaybeField Nothing opts = defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True}+++newtype EmbeddedJSONTest = EmbeddedJSONTest Int+ deriving (Eq, Show)++instance FromJSON EmbeddedJSONTest where+ parseJSON =+ withObject "Object" $ \o ->+ EmbeddedJSONTest <$> (o .: "prop" >>= withEmbeddedJSON "Quoted Int" parseJSON)++withEmbeddedJSONTest :: Assertion+withEmbeddedJSONTest =+ assertEqual "Unquote embedded JSON" (Right $ EmbeddedJSONTest 1) (eitherDecode "{\"prop\":\"1\"}") deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord