aeson 1.2.1.0 → 1.2.2.0
raw patch · 34 files changed
+875/−839 lines, 34 filesdep +th-abstractiondep ~QuickCheckdep ~attoparsecdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: th-abstraction
Dependency ranges changed: QuickCheck, attoparsec, base, hashable, template-haskell, time, vector
API changes (from Hackage documentation)
+ Data.Aeson: ObjectWithSingleField :: SumEncoding
+ Data.Aeson: TaggedObject :: String -> String -> SumEncoding
+ Data.Aeson: TwoElemArray :: SumEncoding
+ Data.Aeson: UntaggedValue :: SumEncoding
+ Data.Aeson: [contentsFieldName] :: SumEncoding -> String
+ Data.Aeson: [tagFieldName] :: SumEncoding -> String
+ Data.Aeson: allNullaryToStringTag :: Options -> Bool
+ Data.Aeson: camelTo2 :: Char -> String -> String
+ Data.Aeson: constructorTagModifier :: Options -> String -> String
+ Data.Aeson: data Options
+ Data.Aeson: data SumEncoding
+ Data.Aeson: defaultTaggedObject :: SumEncoding
+ Data.Aeson: fieldLabelModifier :: Options -> String -> String
+ Data.Aeson: omitNothingFields :: Options -> Bool
+ Data.Aeson: sumEncoding :: Options -> SumEncoding
+ Data.Aeson: tagSingleConstructors :: Options -> Bool
+ Data.Aeson: unwrapUnaryRecords :: Options -> Bool
+ Data.Aeson.Parser: scientific :: Parser Scientific
+ Data.Aeson.Parser.Internal: decodeStrictWith :: Parser Value -> (Value -> Result a) -> ByteString -> Maybe a
+ Data.Aeson.Parser.Internal: decodeWith :: Parser Value -> (Value -> Result a) -> ByteString -> Maybe a
+ Data.Aeson.Parser.Internal: eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> ByteString -> Either (JSONPath, String) a
+ Data.Aeson.Parser.Internal: eitherDecodeWith :: Parser Value -> (Value -> IResult a) -> ByteString -> Either (JSONPath, String) a
+ Data.Aeson.Parser.Internal: json :: Parser Value
+ Data.Aeson.Parser.Internal: json' :: Parser Value
+ Data.Aeson.Parser.Internal: jsonEOF :: Parser Value
+ Data.Aeson.Parser.Internal: jsonEOF' :: Parser Value
+ Data.Aeson.Parser.Internal: jstring :: Parser Text
+ Data.Aeson.Parser.Internal: jstring_ :: Parser Text
+ Data.Aeson.Parser.Internal: scientific :: Parser Scientific
+ Data.Aeson.Parser.Internal: value :: Parser Value
+ Data.Aeson.Parser.Internal: value' :: Parser Value
+ Data.Aeson.Types: allNullaryToStringTag :: Options -> Bool
+ Data.Aeson.Types: constructorTagModifier :: Options -> String -> String
+ Data.Aeson.Types: fieldLabelModifier :: Options -> String -> String
+ Data.Aeson.Types: omitNothingFields :: Options -> Bool
+ Data.Aeson.Types: sumEncoding :: Options -> SumEncoding
+ Data.Aeson.Types: tagSingleConstructors :: Options -> Bool
+ Data.Aeson.Types: unwrapUnaryRecords :: Options -> Bool
Files
- Data/Aeson.hs +15/−0
- Data/Aeson/Encoding/Internal.hs +1/−1
- Data/Aeson/Parser.hs +2/−1
- Data/Aeson/Parser/Internal.hs +34/−14
- Data/Aeson/TH.hs +337/−646
- Data/Aeson/Types.hs +16/−1
- Data/Aeson/Types/FromJSON.hs +27/−10
- Data/Aeson/Types/Internal.hs +3/−0
- Data/Aeson/Types/ToJSON.hs +19/−3
- aeson.cabal +4/−3
- benchmarks/AesonMap.hs +6/−6
- benchmarks/CompareWithJSON.hs +32/−7
- benchmarks/Dates.hs +1/−0
- benchmarks/Typed.hs +3/−0
- benchmarks/Typed/Generic.hs +21/−3
- benchmarks/Typed/Manual.hs +20/−2
- benchmarks/Typed/TH.hs +20/−2
- benchmarks/aeson-benchmarks.cabal +21/−0
- changelog.md +13/−1
- examples/Twitter/Generic.hs +49/−19
- examples/Twitter/Options.hs +33/−0
- examples/Twitter/TH.hs +13/−9
- stack-bench.yaml +10/−1
- stack-lts6.yaml +1/−0
- stack-lts7.yaml +1/−0
- stack-lts8.yaml +2/−1
- stack-lts9.yaml +12/−0
- stack-nightly.yaml +1/−3
- stack-pure-unescape.yaml +1/−0
- tests/Encoders.hs +5/−0
- tests/ErrorMessages.hs +14/−0
- tests/Instances.hs +10/−5
- tests/Properties.hs +2/−1
- tests/SerializationFormatSpec.hs +126/−100
Data/Aeson.hs view
@@ -87,7 +87,22 @@ , genericLiftToEncoding , genericParseJSON , genericLiftParseJSON+ -- ** Generic and TH encoding configuration+ , Options , defaultOptions+ -- *** Options fields+ -- $optionsFields+ , fieldLabelModifier+ , constructorTagModifier+ , allNullaryToStringTag+ , omitNothingFields+ , sumEncoding+ , unwrapUnaryRecords+ , tagSingleConstructors+ -- *** Options utilities+ , SumEncoding(..)+ , camelTo2+ , defaultTaggedObject -- * Inspecting @'Value's@ , withObject
Data/Aeson/Encoding/Internal.hs view
@@ -81,7 +81,7 @@ -- ^ Acquire the underlying bytestring builder. } deriving (Typeable) --- | Often used synonnym for 'Encoding''.+-- | Often used synonym for 'Encoding''. type Encoding = Encoding' Value -- | Make Encoding from Builder.
Data/Aeson/Parser.hs view
@@ -33,6 +33,7 @@ json , value , jstring+ , scientific -- * Strict parsers -- $strict , json'@@ -46,7 +47,7 @@ import Prelude () -import Data.Aeson.Parser.Internal (decodeStrictWith, decodeWith, eitherDecodeStrictWith, eitherDecodeWith, json, json', jstring, value, value')+import Data.Aeson.Parser.Internal (decodeStrictWith, decodeWith, eitherDecodeStrictWith, eitherDecodeWith, json, json', jstring, scientific, value, value') -- $lazy --
Data/Aeson/Parser/Internal.hs view
@@ -23,6 +23,8 @@ json, jsonEOF , value , jstring+ , jstring_+ , scientific -- * Strict parsers , json', jsonEOF' , value'@@ -53,8 +55,9 @@ import Data.Aeson.Parser.Unescape (unescapeText) #if MIN_VERSION_ghc_prim(0,3,1)-import GHC.Base (Int#, (==#), isTrue#, word2Int#)+import GHC.Base (Int#, (==#), isTrue#, word2Int#, orI#, andI#) import GHC.Word (Word8(W8#))+import qualified Data.Text.Encoding as TE #endif #define BACKSLASH 92@@ -207,23 +210,39 @@ jstring_ :: Parser Text {-# INLINE jstring_ #-} jstring_ = {-# SCC "jstring_" #-} do+#if MIN_VERSION_ghc_prim(0,3,1)+ (s, S _ escaped) <- A.runScanner startState go <* A.anyWord8+ -- We escape only if there are+ -- non-ascii (over 7bit) characters or backslash present.+ --+ -- Note: if/when text will have fast ascii -> text conversion+ -- (e.g. uses utf8 encoding) we can have further speedup.+ if isTrue# escaped+ then case unescapeText s of+ Right r -> return r+ Left err -> fail $ show err+ else return (TE.decodeUtf8 s)+ where+ startState = S 0# 0#+ go (S skip escaped) (W8# c)+ | isTrue# skip = Just (S 0# escaped')+ | isTrue# (w ==# 34#) = Nothing -- double quote+ | otherwise = Just (S skip' escaped')+ where+ w = word2Int# c+ skip' = w ==# 92# -- backslash+ escaped' = escaped+ `orI#` (w `andI#` 0x80# ==# 0x80#) -- c >= 0x80+ `orI#` skip'+ `orI#` (w `andI#` 0x1f# ==# w) -- c < 0x20++data S = S Int# Int#+#else s <- A.scan startState go <* A.anyWord8 case unescapeText s of Right r -> return r Left err -> fail $ show err where-#if MIN_VERSION_ghc_prim(0,3,1)- startState = S 0#- go (S a) (W8# c)- | isTrue# a = Just (S 0#)- | isTrue# (word2Int# c ==# 34#) = Nothing -- double quote- | otherwise = let a' = word2Int# c ==# 92# -- backslash- in Just (S a')--data S = S Int#--- This hint will no longer trigger once hlint > 1.9.41 is released.-{-# ANN S ("HLint: ignore Use newtype instead of data" :: String) #-}-#else startState = False go a c | a = Just False@@ -317,7 +336,7 @@ then fail "leading zero" else return (B.foldl' step 0 digits) -{-# INLINE scientific #-}+-- | Parse a JSON number. scientific :: Parser Scientific scientific = do let minus = 45@@ -347,3 +366,4 @@ (A.satisfy (\ex -> ex == littleE || ex == bigE) *> fmap (Sci.scientific signedCoeff . (e +)) (signed decimal)) <|> return (Sci.scientific signedCoeff e)+{-# INLINE scientific #-}
Data/Aeson/TH.hs view
@@ -130,7 +130,7 @@ #if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0) import Data.List (nub) #endif-import Data.List (find, foldl', genericLength , intercalate , intersperse, partition, union)+import Data.List (foldl', genericLength , intercalate , intersperse, partition, union) import Data.List.NonEmpty ((<|), NonEmpty((:|))) import Data.Map (Map) import Data.Maybe (catMaybes, fromMaybe, mapMaybe)@@ -140,7 +140,7 @@ #else import Language.Haskell.TH #endif-import Language.Haskell.TH.Syntax (VarStrictType)+import Language.Haskell.TH.Datatype #if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0)) import Language.Haskell.TH.Lib (starK) #endif@@ -152,8 +152,8 @@ import qualified Data.Aeson.Encoding.Internal as E import qualified Data.Foldable as F (all) import qualified Data.HashMap.Strict as H (lookup, toList)-import qualified Data.List.NonEmpty as NE (drop, length, reverse, splitAt)-import qualified Data.Map as M (fromList, findWithDefault, keys, lookup , singleton, size)+import qualified Data.List.NonEmpty as NE (length, reverse)+import qualified Data.Map as M (fromList, keys, lookup , singleton, size) 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)@@ -322,32 +322,36 @@ -- ^ The ToJSON variant being derived. -> Options -- ^ Encoding options.- -> [Con]+ -> [Type]+ -- ^ The types from the data type/data family instance declaration+ -> [ConstructorInfo] -- ^ Constructors for which to generate JSON generating code. -> Q Exp -consToValue _ _ [] = error $ "Data.Aeson.TH.consToValue: "- ++ "Not a single constructor given!"+consToValue _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "+ ++ "Not a single constructor given!" -consToValue jc opts cons = do+consToValue jc opts vars cons = do value <- newName "value" tjs <- newNameList "_tj" $ arityInt jc tjls <- newNameList "_tjl" $ arityInt jc let zippedTJs = zip tjs tjls interleavedTJs = interleave tjs tjls+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars+ tvMap = M.fromList $ zip lastTyVars zippedTJs lamE (map varP $ interleavedTJs ++ [value]) $- caseE (varE value) (matches zippedTJs)+ caseE (varE value) (matches tvMap) where- matches tjs = case cons of+ matches tvMap = case cons of -- A single constructor is directly encoded. The constructor itself may be -- forgotten.- [con] | not (tagSingleConstructors opts) -> [argsToValue jc tjs opts False con]+ [con] | not (tagSingleConstructors opts) -> [argsToValue jc tvMap opts False con] _ | allNullaryToStringTag opts && all isNullary cons -> [ match (conP conName []) (normalB $ conStr opts conName) [] | con <- cons- , let conName = getConName con+ , let conName = constructorName con ]- | otherwise -> [argsToValue jc tjs opts True con | con <- cons]+ | otherwise -> [argsToValue jc tvMap opts True con | con <- cons] conStr :: Options -> Name -> Q Exp conStr opts = appE [|String|] . conTxt opts@@ -365,42 +369,47 @@ -- ^ The ToJSON variant being derived. -> Options -- ^ Encoding options.- -> [Con]+ -> [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 _ _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "+ ++ "Not a single constructor given!" -consToEncoding jc opts cons = do+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 zippedTEs)+ caseE (varE value) (matches tvMap) where- matches tes = case cons of+ matches tvMap = case cons of -- A single constructor is directly encoded. The constructor itself may be -- forgotten.- [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tes opts False con]+ [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 = getConName con+ , let conName = constructorName con ]- | otherwise -> [argsToEncoding jc tes opts True con | con <- cons]+ | otherwise -> [argsToEncoding jc tvMap opts True con | con <- cons] encStr :: Options -> Name -> Q Exp encStr opts = appE [|E.text|] . conTxt opts -- | If constructor is nullary.-isNullary :: Con -> Bool-isNullary (NormalC _ []) = True+isNullary :: ConstructorInfo -> Bool+isNullary ConstructorInfo { constructorVariant = NormalConstructor+ , constructorFields = tys } = null tys isNullary _ = False sumToValue :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp@@ -423,16 +432,19 @@ | otherwise = exp -- | Generates code to generate the JSON encoding of a single constructor.-argsToValue :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match+argsToValue :: JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match -- Polyadic constructors with special case for unary constructors.-argsToValue jc tjs opts multiCons (NormalC conName ts) = do- (argTys, tvMap) <- reifyConTys jc tjs conName- let len = length ts+argsToValue 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+ | (arg, argTy) <- zip args argTys' ] of -- Single argument is directly converted. [e] -> return e@@ -454,69 +466,77 @@ (varE 'V.create `appE` doE (newMV:stmts++[ret])) match (conP conName $ map varP args)- (normalB $ sumToValue opts multiCons (null ts) conName js)+ (normalB $ sumToValue opts multiCons (null argTys') conName js) [] -- Records.-argsToValue jc tjs opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of- (True,True,[(_,st,ty)]) -> argsToValue jc tjs opts multiCons (NormalC conName [(st,ty)])- _ -> do- (argTys, tvMap) <- reifyConTys jc tjs conName- args <- newNameList "arg" $ length ts- let exp = [|A.object|] `appE` pairs+argsToValue 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+ (info{constructorVariant = NormalConstructor})+ _ -> do+ argTys' <- mapM resolveTypeSynonyms argTys+ args <- newNameList "arg" $ length argTys'+ let exp = [|A.object|] `appE` pairs - pairs | omitNothingFields opts = infixApp maybeFields- [|(++)|]- restFields- | otherwise = listE $ map toPair argCons+ pairs | omitNothingFields opts = infixApp maybeFields+ [|(++)|]+ restFields+ | otherwise = listE $ map toPair argCons - argCons = zip3 args argTys ts+ argCons = zip3 args argTys' fields - maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)+ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes) - restFields = listE $ map toPair rest+ restFields = listE $ map toPair rest - (maybes, rest) = partition isMaybe argCons+ (maybes, rest) = partition isMaybe argCons - maybeToPair (arg, argTy, (field, _, _)) =- infixApp ([|keyValuePairWith|]- `appE` dispatchToJSON jc conName tvMap argTy- `appE` toFieldName field)- [|(<$>)|]- (varE arg)+ maybeToPair (arg, argTy, field) =+ infixApp ([|keyValuePairWith|]+ `appE` dispatchToJSON jc conName tvMap argTy+ `appE` toFieldName field)+ [|(<$>)|]+ (varE arg) - toPair (arg, argTy, (field, _, _)) =- [|keyValuePairWith|]- `appE` dispatchToJSON jc conName tvMap argTy- `appE` toFieldName field- `appE` varE arg+ toPair (arg, argTy, field) =+ [|keyValuePairWith|]+ `appE` dispatchToJSON jc conName tvMap argTy+ `appE` toFieldName field+ `appE` varE arg - toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field+ toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field - 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- ) []+ 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+ ) [] -- Infix constructors.-argsToValue jc tjs opts multiCons (InfixC _ conName _) = do- ([alTy, arTy], tvMap) <- reifyConTys jc tjs conName+argsToValue jc tvMap opts multiCons+ ConstructorInfo { constructorName = conName+ , constructorVariant = InfixConstructor+ , constructorFields = argTys } = do+ [alTy, arTy] <- mapM resolveTypeSynonyms argTys al <- newName "argL" ar <- newName "argR" match (infixP (varP al) conName (varP ar))@@ -528,22 +548,10 @@ ] ) []--- Existentially quantified constructors.-argsToValue jc tjs opts multiCons (ForallC _ _ con) =- argsToValue jc tjs opts multiCons con -#if MIN_VERSION_template_haskell(2,11,0)--- GADTs.-argsToValue jc tjs opts multiCons (GadtC conNames ts _) =- argsToValue jc tjs opts multiCons $ NormalC (head conNames) ts--argsToValue jc tjs opts multiCons (RecGadtC conNames ts _) =- argsToValue jc tjs opts multiCons $ RecC (head conNames) ts-#endif--isMaybe :: (a, b, (c, d, Type)) -> Bool-isMaybe (_, _, (_, _, AppT (ConT t) _)) = t == ''Maybe-isMaybe _ = False+isMaybe :: (a, Type, b) -> Bool+isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe+isMaybe _ = False (<^>) :: ExpQ -> ExpQ -> ExpQ (<^>) a b = infixApp a [|(E.><)|] b@@ -583,14 +591,16 @@ | otherwise = exp -- | Generates code to generate the JSON encoding of a single constructor.-argsToEncoding :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match+argsToEncoding :: JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match -- Polyadic constructors with special case for unary constructors.-argsToEncoding jc tes opts multiCons (NormalC conName ts) = do- (argTys, tvMap) <- reifyConTys jc tes conName- let len = length ts- args <- newNameList "arg" len- js <- case zip args argTys of+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_ |] @@ -604,73 +614,81 @@ | (x,xTy) <- es ])) match (conP conName $ map varP args)- (normalB $ sumToEncoding opts multiCons (null ts) conName js)+ (normalB $ sumToEncoding opts multiCons (null argTys') conName js) [] -- Records.-argsToEncoding jc tes opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of- (True,True,[(_,st,ty)]) -> argsToEncoding jc tes opts multiCons (NormalC conName [(st,ty)])- _ -> do- args <- newNameList "arg" $ length ts- (argTys, tvMap) <- reifyConTys jc tes conName- let exp = object objBody+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)+ objBody = [|E.econcat|] `appE`+ ([|intersperse E.comma|] `appE` pairs)+ pairs | omitNothingFields opts = infixApp maybeFields+ [|(++)|]+ restFields+ | otherwise = listE (map toPair argCons) - argCons = zip3 args argTys ts+ argCons = zip3 args argTys' fields - maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)+ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes) - restFields = listE (map toPair rest)+ restFields = listE (map toPair rest) - (maybes, rest) = partition isMaybe argCons+ (maybes, rest) = partition isMaybe argCons - maybeToPair (arg, argTy, (field, _, _)) =- infixApp- (infixApp- (infixE- (Just $ toFieldName field <^> [|E.colon|])- [|(E.><)|]- Nothing)- [|(.)|]- (dispatchToEncoding jc conName tvMap argTy))- [|(<$>)|]- (varE arg)+ maybeToPair (arg, argTy, field) =+ infixApp+ (infixApp+ (infixE+ (Just $ toFieldName field <^> [|E.colon|])+ [|(E.><)|]+ Nothing)+ [|(.)|]+ (dispatchToEncoding jc conName tvMap argTy))+ [|(<$>)|]+ (varE arg) - toPair (arg, argTy, (field, _, _)) =- toFieldName field- <:> dispatchToEncoding jc conName tvMap argTy- `appE` varE arg+ toPair (arg, argTy, field) =+ toFieldName field+ <:> dispatchToEncoding jc conName tvMap argTy+ `appE` varE arg - toFieldName field = [|E.text|] `appE`- ([|T.pack|] `appE` fieldLabelExp opts field)+ toFieldName field = [|E.text|] `appE`+ ([|T.pack|] `appE` fieldLabelExp opts field) - 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- ) []+ 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+ ) [] -- Infix constructors.-argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do+argsToEncoding jc tvMap opts multiCons+ ConstructorInfo { constructorName = conName+ , constructorVariant = InfixConstructor+ , constructorFields = argTys } = do al <- newName "argL" ar <- newName "argR"- ([alTy,arTy], tvMap) <- reifyConTys jc tes conName+ [alTy,arTy] <- mapM resolveTypeSynonyms argTys match (infixP (varP al) conName (varP ar)) ( normalB $ sumToEncoding opts multiCons False conName@@ -680,19 +698,7 @@ ]) ) []--- Existentially quantified constructors.-argsToEncoding jc tes opts multiCons (ForallC _ _ con) =- argsToEncoding jc tes opts multiCons con -#if MIN_VERSION_template_haskell(2,11,0)--- GADTs.-argsToEncoding jc tes opts multiCons (GadtC conNames ts _) =- argsToEncoding jc tes opts multiCons $ NormalC (head conNames) ts--argsToEncoding jc tes opts multiCons (RecGadtC conNames ts _) =- argsToEncoding jc tes opts multiCons $ RecC (head conNames) ts-#endif- -------------------------------------------------------------------------------- -- FromJSON --------------------------------------------------------------------------------@@ -775,33 +781,41 @@ -- ^ Name of the type to which the constructors belong. -> Options -- ^ Encoding options- -> [Con]+ -> [Type]+ -- ^ The types from the data type/data family instance declaration+ -> [ConstructorInfo] -- ^ Constructors for which to generate JSON parsing code. -> Q Exp -consFromJSON _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "- ++ "Not a single constructor given!"+consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "+ ++ "Not a single constructor given!" -consFromJSON jc tName opts cons = do+consFromJSON jc tName opts vars cons = do value <- newName "value" pjs <- newNameList "_pj" $ arityInt jc pjls <- newNameList "_pjl" $ arityInt jc let zippedPJs = zip pjs pjls interleavedPJs = interleave pjs pjls- lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value zippedPJs+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars+ tvMap = M.fromList $ zip lastTyVars zippedPJs+ lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap where- lamExpr value pjs = case cons of+ checkExi tvMap con = checkExistentialContext jc tvMap+ (constructorContext con)+ (constructorName con)++ lamExpr value tvMap = case cons of [con] | not (tagSingleConstructors opts)- -> parseArgs jc pjs tName opts con (Right value)+ -> checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right value) _ | sumEncoding opts == UntaggedValue- -> parseUntaggedValue pjs cons value+ -> parseUntaggedValue tvMap cons value | otherwise -> caseE (varE value) $ if allNullaryToStringTag opts && all isNullary cons then allNullaryMatches- else mixedMatches pjs+ else mixedMatches tvMap allNullaryMatches = [ do txt <- newName "txt"@@ -815,7 +829,7 @@ ) ([|pure|] `appE` conE conName) | con <- cons- , let conName = getConName con+ , let conName = constructorName con ] ++ [ liftM2 (,)@@ -836,13 +850,13 @@ [] ] - mixedMatches pjs =+ mixedMatches tvMap = case sumEncoding opts of TaggedObject {tagFieldName, contentsFieldName} ->- parseObject $ parseTaggedObject pjs tagFieldName contentsFieldName+ parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName UntaggedValue -> error "UntaggedValue: Should be handled already" ObjectWithSingleField ->- parseObject $ parseObjectWithSingleField pjs+ parseObject $ parseObjectWithSingleField tvMap TwoElemArray -> [ do arr <- newName "array" match (conP 'Array [varP arr])@@ -850,7 +864,7 @@ [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr) [|(==)|] (litE $ integerL 2))- (parse2ElemArray pjs arr)+ (parse2ElemArray tvMap arr) , liftM2 (,) (normalG [|otherwise|]) ([|not2ElemArray|] `appE` litE (stringL $ show tName)@@ -881,20 +895,24 @@ [] ] - parseTaggedObject pjs typFieldName valFieldName obj = do+ parseTaggedObject tvMap typFieldName valFieldName obj = do conKey <- newName "conKey" doE [ bindS (varP conKey) (infixApp (varE obj) [|(.:)|] ([|T.pack|] `appE` stringE typFieldName))- , noBindS $ parseContents pjs conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject+ , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject ] - parseUntaggedValue pjs cons' conVal =+ parseUntaggedValue tvMap cons' conVal = foldr1 (\e e' -> infixApp e [|(<|>)|] e')- (map (\x -> parseValue pjs x conVal) cons')+ (map (\x -> parseValue tvMap x conVal) cons') - parseValue _pjs (NormalC conName []) conVal = do+ parseValue _tvMap+ ConstructorInfo { constructorName = conName+ , constructorVariant = NormalConstructor+ , constructorFields = [] }+ conVal = do str <- newName "str" caseE (varE conVal) [ match (conP 'String [varP str])@@ -907,11 +925,11 @@ [] , matchFailed tName conName "String" ]- parseValue pjs con conVal =- parseArgs jc pjs tName opts con (Right conVal)+ parseValue tvMap con conVal =+ checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right conVal) - parse2ElemArray pjs arr = do+ parse2ElemArray tvMap arr = do conKey <- newName "conKey" conVal <- newName "conVal" let letIx n ix =@@ -926,7 +944,7 @@ (caseE (varE conKey) [ do txt <- newName "txt" match (conP 'String [varP txt])- (normalB $ parseContents pjs+ (normalB $ parseContents tvMap txt (Right conVal) 'conNotFoundFail2ElemArray@@ -943,12 +961,12 @@ ] ) - parseObjectWithSingleField pjs obj = do+ parseObjectWithSingleField tvMap obj = do conKey <- newName "conKey" conVal <- newName "conVal" caseE ([e|H.toList|] `appE` varE obj) [ match (listP [tupP [varP conKey, varP conVal]])- (normalB $ parseContents pjs conKey (Right conVal) 'conNotFoundFailObjectSingleField)+ (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField) [] , do other <- newName "other" match (varP other)@@ -959,7 +977,7 @@ [] ] - parseContents pjs conKey contents errorFun =+ parseContents tvMap conKey contents errorFun = caseE (varE conKey) [ match wildP ( guardedB $@@ -967,7 +985,8 @@ [|(==)|] ([|T.pack|] `appE` conNameExp opts con)- e <- parseArgs jc pjs tName opts con contents+ e <- checkExi tvMap con $+ parseArgs jc tvMap tName opts con contents return (g, e) | con <- cons ]@@ -980,7 +999,7 @@ . stringL . constructorTagModifier opts . nameBase- . getConName+ . constructorName ) cons ) `appE` ([|T.unpack|] `appE` varE conKey)@@ -1029,10 +1048,10 @@ -> Options -> Name -> Name- -> [VarStrictType]+ -> [Name] -> Name -> ExpQ-parseRecord jc tvMap argTys opts tName conName ts obj =+parseRecord jc tvMap argTys opts tName conName fields obj = foldl' (\a b -> infixApp a [|(<*>)|] b) (infixApp (conE conName) [|(<$>)|] x) xs@@ -1044,7 +1063,7 @@ `appE` varE obj `appE` ( [|T.pack|] `appE` fieldLabelExp opts field )- | ((field, _, _), argTy) <- zip ts argTys+ | (field, argTy) <- zip fields argTys ] getValField :: Name -> String -> [MatchQ] -> Q Exp@@ -1063,67 +1082,82 @@ -- | Generates code to parse the JSON encoding of a single constructor. parseArgs :: JSONClass -- ^ The FromJSON variant being derived.- -> [(Name, Name)] -- ^ The names of the encoding/decoding function arguments.+ -> TyVarMap -- ^ Maps the last type variables to their decoding+ -- function arguments. -> Name -- ^ Name of the type to which the constructor belongs. -> Options -- ^ Encoding options.- -> Con -- ^ Constructor for which to generate JSON parsing code.+ -> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code. -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or -- Right valName -> Q Exp -- Nullary constructors.-parseArgs jc pjs _ _ (NormalC conName []) (Left _) = do- ([], _) <- reifyConTys jc pjs conName- [|pure|] `appE` conE conName-parseArgs jc pjs tName _ (NormalC conName []) (Right valName) = do- ([], _) <- reifyConTys jc pjs conName- caseE (varE valName) $ parseNullaryMatches tName conName+parseArgs _ _ _ _+ ConstructorInfo { constructorName = conName+ , constructorVariant = NormalConstructor+ , constructorFields = [] }+ (Left _) =+ [|pure|] `appE` conE conName+parseArgs _ _ tName _+ ConstructorInfo { constructorName = conName+ , constructorVariant = NormalConstructor+ , constructorFields = [] }+ (Right valName) =+ caseE (varE valName) $ parseNullaryMatches tName conName -- Unary constructors.-parseArgs jc pjs _ _ (NormalC conName [_]) contents = do- ([argTy], tvMap) <- reifyConTys jc pjs conName- matchCases contents $ parseUnaryMatches jc tvMap argTy conName+parseArgs jc tvMap _ _+ ConstructorInfo { constructorName = conName+ , constructorVariant = NormalConstructor+ , constructorFields = [argTy] }+ contents = do+ argTy' <- resolveTypeSynonyms argTy+ matchCases contents $ parseUnaryMatches jc tvMap argTy' conName -- Polyadic constructors.-parseArgs jc pjs tName _ (NormalC conName ts) contents = do- (argTys, tvMap) <- reifyConTys jc pjs conName- let len = genericLength ts- matchCases contents $ parseProduct jc tvMap argTys tName conName len+parseArgs jc tvMap tName _+ ConstructorInfo { constructorName = conName+ , constructorVariant = NormalConstructor+ , constructorFields = argTys }+ contents = do+ argTys' <- mapM resolveTypeSynonyms argTys+ let len = genericLength argTys'+ matchCases contents $ parseProduct jc tvMap argTys' tName conName len -- Records.-parseArgs jc pjs tName opts (RecC conName ts) (Left (_, obj)) = do- (argTys, tvMap) <- reifyConTys jc pjs conName- parseRecord jc tvMap argTys opts tName conName ts obj-parseArgs jc pjs tName opts (RecC conName ts) (Right valName) = case (unwrapUnaryRecords opts,ts) of- (True,[(_,st,ty)])-> parseArgs jc pjs tName opts (NormalC conName [(st,ty)]) (Right valName)- _ -> do- obj <- newName "recObj"- (argTys, tvMap) <- reifyConTys jc pjs conName- caseE (varE valName)- [ match (conP 'Object [varP obj]) (normalB $- parseRecord jc tvMap argTys opts tName conName ts obj) []- , matchFailed tName conName "Object"- ]+parseArgs jc tvMap tName opts+ ConstructorInfo { constructorName = conName+ , constructorVariant = RecordConstructor fields+ , constructorFields = argTys }+ (Left (_, obj)) = do+ argTys' <- mapM resolveTypeSynonyms argTys+ parseRecord jc tvMap argTys' opts tName conName fields obj+parseArgs jc tvMap tName opts+ info@ConstructorInfo { constructorName = conName+ , constructorVariant = RecordConstructor fields+ , constructorFields = argTys }+ (Right valName) =+ case (unwrapUnaryRecords opts,argTys) of+ (True,[_])-> parseArgs jc tvMap tName opts+ (info{constructorVariant = NormalConstructor})+ (Right valName)+ _ -> do+ obj <- newName "recObj"+ argTys' <- mapM resolveTypeSynonyms argTys+ caseE (varE valName)+ [ match (conP 'Object [varP obj]) (normalB $+ parseRecord jc tvMap argTys' opts tName conName fields obj) []+ , matchFailed tName conName "Object"+ ] -- Infix constructors. Apart from syntax these are the same as -- polyadic constructors.-parseArgs jc pjs tName _ (InfixC _ conName _) contents = do- (argTys, tvMap) <- reifyConTys jc pjs conName- matchCases contents $ parseProduct jc tvMap argTys tName conName 2---- Existentially quantified constructors. We ignore the quantifiers--- and proceed with the contained constructor.-parseArgs jc pjs tName opts (ForallC _ _ con) contents =- parseArgs jc pjs tName opts con contents--#if MIN_VERSION_template_haskell(2,11,0)--- GADTs. We ignore the refined return type and proceed as if it were a--- NormalC or RecC.-parseArgs jc pjs tName opts (GadtC conNames ts _) contents =- parseArgs jc pjs tName opts (NormalC (head conNames) ts) contents--parseArgs jc pjs tName opts (RecGadtC conNames ts _) contents =- parseArgs jc pjs tName opts (RecC (head conNames) ts) contents-#endif+parseArgs jc tvMap tName _+ ConstructorInfo { constructorName = conName+ , constructorVariant = InfixConstructor+ , constructorFields = argTys }+ contents = do+ argTys' <- mapM resolveTypeSynonyms argTys+ matchCases contents $ parseProduct jc tvMap argTys' tName conName 2 -- | Generates code to parse the JSON encoding of an n-ary -- constructor.@@ -1278,7 +1312,8 @@ liftM2 (++) (dtj opts name) (dfj opts name) -- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@.-deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Con] -> Q Exp)]+deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type]+ -> [ConstructorInfo] -> Q Exp)] -- ^ The class methods and the functions which derive them. -> JSONClass -- ^ The class for which to generate an instance.@@ -1288,27 +1323,30 @@ -- ^ Name of the type for which to generate a class instance -- declaration. -> Q [Dec]-deriveJSONClass consFuns jc opts name =- withType name $ \name' ctxt tvbs cons mbTys ->- (:[]) <$> fromCons name' ctxt tvbs cons mbTys- where- fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec- fromCons name' ctxt tvbs cons mbTys = do+deriveJSONClass consFuns jc opts name = do+ info <- reifyDatatype name+ case info of+ DatatypeInfo { datatypeContext = ctxt+ , datatypeName = parentName+ , datatypeVars = vars+ , datatypeVariant = variant+ , datatypeCons = cons+ } -> do (instanceCxt, instanceType)- <- buildTypeInstance name' jc ctxt tvbs mbTys- instanceD (return instanceCxt)- (return instanceType)- (methodDecs name' cons)-- methodDecs :: Name -> [Con] -> [Q Dec]- methodDecs name' cons = flip map consFuns $ \(jf, jfMaker) ->+ <- buildTypeInstance parentName jc ctxt vars variant+ (:[]) <$> instanceD (return instanceCxt)+ (return instanceType)+ (methodDecs parentName vars cons)+ where+ methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]+ methodDecs parentName vars cons = flip map consFuns $ \(jf, jfMaker) -> funD (jsonFunValName jf (arity jc)) [ clause []- (normalB $ jfMaker jc name' opts cons)+ (normalB $ jfMaker jc parentName opts vars cons) [] ] -mkFunCommon :: (JSONClass -> Name -> Options -> [Con] -> Q Exp)+mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp) -- ^ The function which derives the expression. -> JSONClass -- ^ Which class's method is being derived.@@ -1317,15 +1355,20 @@ -> Name -- ^ Name of the encoded type. -> Q Exp-mkFunCommon consFun jc opts name = withType name fromCons- where- fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp- fromCons name' ctxt tvbs cons mbTys = do- -- We force buildTypeInstance here since it performs some checks for whether- -- or not the provided datatype's kind matches the derived method's- -- typeclass, and produces errors if it can't.- !_ <- buildTypeInstance name' jc ctxt tvbs mbTys- consFun jc name' opts cons+mkFunCommon consFun jc opts name = do+ info <- reifyDatatype name+ case info of+ DatatypeInfo { datatypeContext = ctxt+ , datatypeName = parentName+ , datatypeVars = vars+ , datatypeVariant = variant+ , datatypeCons = cons+ } -> do+ -- We force buildTypeInstance here since it performs some checks for whether+ -- or not the provided datatype's kind matches the derived method's+ -- typeclass, and produces errors if it can't.+ !_ <- buildTypeInstance parentName jc ctxt vars variant+ consFun jc parentName opts vars cons dispatchFunByType :: JSONClass -> JSONFun@@ -1380,190 +1423,24 @@ -- Utility functions -------------------------------------------------------------------------------- --- | Boilerplate for top level splices.------ The given 'Name' must meet one of two criteria:------ 1. It must be the name of a type constructor of a plain data type or newtype.--- 2. It must be the name of a data family instance or newtype instance constructor.---- Any other value will result in an exception.-withType :: Name- -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)- -- ^ Function that generates the actual code. Will be applied- -- to the datatype/data family 'Name', datatype context, type- -- variable binders and constructors extracted from the given- -- 'Name'. If the 'Name' is from a data family instance- -- constructor, it will also have its instantiated types;- -- otherwise, it will be 'Nothing'.- -> Q a- -- ^ Resulting value in the 'Q'uasi monad.-withType name f = do- info <- reify name- case info of- TyConI dec ->- case dec of-#if MIN_VERSION_template_haskell(2,11,0)- DataD ctxt _ tvbs _ cons _ -> f name ctxt tvbs cons Nothing- NewtypeD ctxt _ tvbs _ con _ -> f name ctxt tvbs [con] Nothing-#else- DataD ctxt _ tvbs cons _ -> f name ctxt tvbs cons Nothing- NewtypeD ctxt _ tvbs con _ -> f name ctxt tvbs [con] Nothing-#endif- other -> fail $ ns ++ "Unsupported type: " ++ show other-#if MIN_VERSION_template_haskell(2,11,0)- DataConI _ _ parentName -> do-#else- DataConI _ _ parentName _ -> do-#endif- parentInfo <- reify parentName- case parentInfo of-#if MIN_VERSION_template_haskell(2,11,0)- FamilyI (DataFamilyD _ tvbs _) decs ->-#else- FamilyI (FamilyD DataFam _ tvbs _) decs ->-#endif- let instDec = flip find decs $ \dec -> case dec of-#if MIN_VERSION_template_haskell(2,11,0)- DataInstD _ _ _ _ cons _ -> any ((name ==) . getConName) cons- NewtypeInstD _ _ _ _ con _ -> name == getConName con-#else- DataInstD _ _ _ cons _ -> any ((name ==) . getConName) cons- NewtypeInstD _ _ _ con _ -> name == getConName con-#endif- _ -> error $ ns ++ "Must be a data or newtype instance."- in case instDec of-#if MIN_VERSION_template_haskell(2,11,0)- Just (DataInstD ctxt _ instTys _ cons _) -> f parentName ctxt tvbs cons $ Just instTys- Just (NewtypeInstD ctxt _ instTys _ con _) -> f parentName ctxt tvbs [con] $ Just instTys-#else- Just (DataInstD ctxt _ instTys cons _) -> f parentName ctxt tvbs cons $ Just instTys- Just (NewtypeInstD ctxt _ instTys con _) -> f parentName ctxt tvbs [con] $ Just instTys-#endif- _ -> fail $ ns ++- "Could not find data or newtype instance constructor."- _ -> fail $ ns ++ "Data constructor " ++ show name ++- " is not from a data family instance constructor."-#if MIN_VERSION_template_haskell(2,11,0)- FamilyI DataFamilyD{} _ ->-#else- FamilyI (FamilyD DataFam _ _ _) _ ->-#endif- fail $ ns ++- "Cannot use a data family name. Use a data family instance constructor instead."- _ -> fail $ ns ++ "I need the name of a plain data type constructor, "- ++ "or a data family instance constructor."- where- ns :: String- ns = "Data.Aeson.TH.withType: "---- | Infer the context and instance head needed for a FromJSON or ToJSON instance.+-- For the given Types, generate an instance context and head. buildTypeInstance :: Name -- ^ The type constructor or data family name -> JSONClass -- ^ The typeclass to derive -> Cxt -- ^ The datatype context- -> [TyVarBndr]- -- ^ The type variables from the data type/data family declaration- -> Maybe [Type]- -- ^ 'Just' the types used to instantiate a data family instance,- -- or 'Nothing' if it's a plain data type+ -> [Type]+ -- ^ The types to instantiate the instance with+ -> DatatypeVariant+ -- ^ Are we dealing with a data family instance or not -> Q (Cxt, Type)- -- ^ The resulting 'Cxt' and 'Type' to use in a class instance--- Plain data type/newtype case-buildTypeInstance tyConName jc dataCxt tvbs Nothing =- let varTys :: [Type]- varTys = map tvbToType tvbs- in buildTypeInstanceFromTys tyConName jc dataCxt varTys False--- Data family instance case------ The CPP is present to work around a couple of annoying old GHC bugs.--- See Note [Polykinded data families in Template Haskell]-buildTypeInstance dataFamName jc dataCxt tvbs (Just instTysAndKinds) = do-#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)- let instTys :: [Type]- instTys = zipWith stealKindForType tvbs instTysAndKinds-#else- let kindVarNames :: [Name]- kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs-- numKindVars :: Int- numKindVars = length kindVarNames-- givenKinds, givenKinds' :: [Kind]- givenTys :: [Type]- (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds- givenKinds' = map sanitizeStars givenKinds-- -- A GHC 7.6-specific bug requires us to replace all occurrences of- -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.- -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.- sanitizeStars :: Kind -> Kind- sanitizeStars = go- where- go :: Kind -> Kind- go (AppT t1 t2) = AppT (go t1) (go t2)- go (SigT t k) = SigT (go t) (go k)- go (ConT n) | n == starKindName = StarT- go t = t-- -- It's quite awkward to import * from GHC.Prim, so we'll just- -- hack our way around it.- starKindName :: Name- starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"-- -- If we run this code with GHC 7.8, we might have to generate extra type- -- variables to compensate for any type variables that Template Haskell- -- eta-reduced away.- -- See Note [Polykinded data families in Template Haskell]- xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)-- let xTys :: [Type]- xTys = map VarT xTypeNames- -- ^ Because these type variables were eta-reduced away, we can only- -- determine their kind by using stealKindForType. Therefore, we mark- -- them as VarT to ensure they will be given an explicit kind annotation- -- (and so the kind inference machinery has the right information).-- substNamesWithKinds :: [(Name, Kind)] -> Type -> Type- substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks-- -- The types from the data family instance might not have explicit kind- -- annotations, which the kind machinery needs to work correctly. To- -- compensate, we use stealKindForType to explicitly annotate any- -- types without kind annotations.- instTys :: [Type]- instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))- -- Note that due to a GHC 7.8-specific bug- -- (see Note [Polykinded data families in Template Haskell]),- -- there may be more kind variable names than there are kinds- -- to substitute. But this is OK! If a kind is eta-reduced, it- -- means that is was not instantiated to something more specific,- -- so we need not substitute it. Using stealKindForType will- -- grab the correct kind.- $ zipWith stealKindForType tvbs (givenTys ++ xTys)-#endif- buildTypeInstanceFromTys dataFamName jc dataCxt instTys True---- For the given Types, generate an instance context and head.-buildTypeInstanceFromTys :: Name- -- ^ The type constructor or data family name- -> JSONClass- -- ^ The typeclass to derive- -> Cxt- -- ^ The datatype context- -> [Type]- -- ^ The types to instantiate the instance with- -> Bool- -- ^ True if it's a data family, False otherwise- -> Q (Cxt, Type)-buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do+buildTypeInstance tyConName jc dataCxt varTysOrig variant = do -- Make sure to expand through type/kind synonyms! Otherwise, the -- eta-reduction check might get tripped up over type variables in a -- synonym that are actually dropped. -- (See GHC Trac #11416 for a scenario where this actually happened.)- varTysExp <- mapM expandSyn varTysOrig+ varTysExp <- mapM resolveTypeSynonyms varTysOrig let remainingLength :: Int remainingLength = length varTysOrig - arityInt jc@@ -1593,7 +1470,7 @@ -- All of the type variables mentioned in the dropped types -- (post-synonym expansion) droppedTyVarNames :: [Name]- droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst+ droppedTyVarNames = freeVariables droppedTysExpSubst -- If any of the dropped types were polykinded, ensure that they are of kind * -- after substituting * for the dropped kind variables. If not, throw an error.@@ -1634,6 +1511,13 @@ map (substNamesWithKindStar (droppedKindVarNames `union` kvNames')) $ take remainingLength varTysOrig + isDataFamily :: Bool+ isDataFamily = case variant of+ Datatype -> False+ Newtype -> False+ DataInstance -> True+ NewtypeInstance -> True+ remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation -- of the isDataFamily check.@@ -1687,55 +1571,6 @@ jcConstraint = jsonClassName . JSONClass (direction jc) {--Note [Polykinded data families in Template Haskell]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In order to come up with the correct instance context and head for an instance, e.g.,-- instance C a => C (Data a) where ...--We need to know the exact types and kinds used to instantiate the instance. For-plain old datatypes, this is simple: every type must be a type variable, and-Template Haskell reliably tells us the type variables and their kinds.--Doing the same for data families proves to be much harder for three reasons:--1. On any version of Template Haskell, it may not tell you what an instantiated- type's kind is. For instance, in the following data family instance:-- data family Fam (f :: * -> *) (a :: *)- data instance Fam f a-- Then if we use TH's reify function, it would tell us the TyVarBndrs of the- data family declaration are:-- [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]-- and the instantiated types of the data family instance are:-- [VarT f1,VarT a1]-- We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we- have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the- kind is in case an instantiated type isn't a SigT, so we use the stealKindForType- function to ensure all of the instantiated types are SigTs before passing them- to buildTypeInstanceFromTys.-2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of- the specified kinds of a data family instance efore any of the instantiated- types. Fortunately, this is easy to deal with: you simply count the number of- distinct kind variables in the data family declaration, take that many elements- from the front of the Types list of the data family instance, substitute the- kind variables with their respective instantiated kinds (which you took earlier),- and proceed as normal.-3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template- Haskell might not even list all of the Types of a data family instance, since- they are eta-reduced away! And yes, kinds can be eta-reduced too.-- The simplest workaround is to count how many instantiated types are missing from- the list and generate extra type variables to use in their place. Luckily, we- needn't worry much if its kind was eta-reduced away, since using stealKindForType- will get it back.- Note [Kind signatures in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1813,50 +1648,14 @@ and perform kind substitution as in the other cases. -} --- Determines the types of a constructor's arguments as well as the last type--- parameters (mapped to their encoding/decoding functions), expanding through--- any type synonyms.------ The type parameters are determined on a constructor-by-constructor basis since--- they may be refined to be particular types in a GADT.-reifyConTys :: JSONClass- -> [(Name, Name)]- -> Name- -> Q ([Type], TyVarMap)-reifyConTys jc tpjs conName = do- info <- reify conName- (ctxt, uncTy) <- case info of- DataConI _ ty _-#if !(MIN_VERSION_template_haskell(2,11,0))- _-#endif- -> fmap uncurryTy (expandSyn ty)- _ -> error "Must be a data constructor"- let (argTys, [resTy]) = NE.splitAt (NE.length uncTy - 1) uncTy- unapResTy = unapplyTy resTy- -- If one of the last type variables is refined to a particular type- -- (i.e., not truly polymorphic), we mark it with Nothing and filter- -- it out later, since we only apply encoding/decoding functions to- -- arguments of a type that it (1) one of the last type variables,- -- and (2) of a truly polymorphic type.- jArity = arityInt jc- mbTvNames = map varTToNameMaybe $- NE.drop (NE.length unapResTy - jArity) unapResTy- -- We use M.fromList to ensure that if there are any duplicate type- -- variables (as can happen in a GADT), the rightmost type variable gets- -- associated with the show function.- --- -- See Note [Matching functions with GADT type variables]- tvMap = M.fromList- . catMaybes -- Drop refined types- $ zipWith (\mbTvName tpj ->- fmap (\tvName -> (tvName, tpj)) mbTvName)- mbTvNames tpjs- if (any (`predMentionsName` M.keys tvMap) ctxt- || M.size tvMap < jArity)- && not (allowExQuant jc)- then existentialContextError conName- else return (argTys, tvMap)+checkExistentialContext :: JSONClass -> TyVarMap -> Cxt -> Name+ -> Q a -> Q a+checkExistentialContext jc tvMap ctxt conName q =+ if (any (`predMentionsName` M.keys tvMap) ctxt+ || M.size tvMap < arityInt jc)+ && not (allowExQuant jc)+ then existentialContextError conName+ else q {- Note [Matching functions with GADT type variables]@@ -1896,24 +1695,6 @@ -- are the function arguments of types (b -> Value) and ([b] -> Value). type TyVarMap = Map Name (Name, Name) --- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.-stealKindForType :: TyVarBndr -> Type -> Type-stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)-stealKindForType _ t = t---- | Extracts the kind from a type variable binder.-tvbKind :: TyVarBndr -> Kind-#if MIN_VERSION_template_haskell(2,8,0)-tvbKind (PlainTV _ ) = StarT-#else-tvbKind (PlainTV _ ) = StarK-#endif-tvbKind (KindedTV _ k) = k--tvbToType :: TyVarBndr -> Type-tvbToType (PlainTV n) = VarT n-tvbToType (KindedTV n k) = SigT (VarT n) k- -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{} = True@@ -1938,27 +1719,6 @@ newNameList :: String -> Int -> Q [Name] newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]] --- Gets all of the type/kind variable names mentioned somewhere in a Type.-tyVarNamesOfType :: Type -> [Name]-tyVarNamesOfType = go- where- go :: Type -> [Name]- go (AppT t1 t2) = go t1 ++ go t2- go (SigT t _k) = go t-#if MIN_VERSION_template_haskell(2,8,0)- ++ go _k-#endif- go (VarT n) = [n]- go _ = []---- | Gets all of the type/kind variable names mentioned somewhere in a Kind.-tyVarNamesOfKind :: Kind -> [Name]-#if MIN_VERSION_template_haskell(2,8,0)-tyVarNamesOfKind = tyVarNamesOfType-#else-tyVarNamesOfKind _ = [] -- There are no kind variables-#endif- -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form -- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or -- kind variables.@@ -1966,7 +1726,7 @@ hasKindVarChain kindArrows t = let uk = uncurryKind (tyKind t) in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk- then Just (concatMap tyVarNamesOfKind uk)+ then Just (concatMap freeVariables uk) else Nothing -- | If a Type is a SigT, returns its kind signature. Otherwise, return *.@@ -1986,17 +1746,6 @@ varTToName :: Type -> Name varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe --- | Extracts the name from a constructor.-getConName :: Con -> Name-getConName (NormalC name _) = name-getConName (RecC name _) = name-getConName (InfixC _ name _) = name-getConName (ForallC _ _ con) = getConName con-#if MIN_VERSION_template_haskell(2,11,0)-getConName (GadtC names _ _) = head names-getConName (RecGadtC names _ _) = head names-#endif- interleave :: [a] -> [a] -> [a] interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s interleave _ _ = []@@ -2128,12 +1877,12 @@ #endif -- | Makes a string literal expression from a constructor's name.-conNameExp :: Options -> Con -> Q Exp+conNameExp :: Options -> ConstructorInfo -> Q Exp conNameExp opts = litE . stringL . constructorTagModifier opts . nameBase- . getConName+ . constructorName -- | Creates a string literal expression from a record field label. fieldLabelExp :: Options -- ^ Encoding options@@ -2178,73 +1927,15 @@ -- Expanding type synonyms ------------------------------------------------------------------------------- --- | Expands all type synonyms in a type. Written by Dan Rosén in the--- @genifunctors@ package (licensed under BSD3).-expandSyn :: Type -> Q Type-expandSyn (ForallT tvs ctx t) = ForallT tvs ctx <$> expandSyn t-expandSyn t@AppT{} = expandSynApp t []-expandSyn t@ConT{} = expandSynApp t []-expandSyn (SigT t k) = do t' <- expandSyn t- k' <- expandSynKind k- return (SigT t' k')-expandSyn t = return t--expandSynKind :: Kind -> Q Kind-#if MIN_VERSION_template_haskell(2,8,0)-expandSynKind = expandSyn-#else-expandSynKind = return -- There are no kind synonyms to deal with-#endif--expandSynApp :: Type -> [Type] -> Q Type-expandSynApp (AppT t1 t2) ts = do- t2' <- expandSyn t2- expandSynApp t1 (t2':ts)-expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts-expandSynApp t@(ConT n) ts = do- info <- reify n- case info of- TyConI (TySynD _ tvs rhs) ->- let (ts', ts'') = splitAt (length tvs) ts- subs = mkSubst tvs ts'- rhs' = substType subs rhs- in expandSynApp rhs' ts''- _ -> return $ foldl' AppT t ts-expandSynApp t ts = do- t' <- expandSyn t- return $ foldl' AppT t' ts--type TypeSubst = Map Name Type-type KindSubst = Map Name Kind--mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst-mkSubst vs ts =- let vs' = map un vs- un (PlainTV v) = v- un (KindedTV v _) = v- in M.fromList $ zip vs' ts--substType :: TypeSubst -> Type -> Type-substType subs (ForallT v c t) = ForallT v c $ substType subs t-substType subs t@(VarT n) = M.findWithDefault t n subs-substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2)-substType subs (SigT t k) = SigT (substType subs t)-#if MIN_VERSION_template_haskell(2,8,0)- (substType subs k)-#else- k-#endif-substType _ t = t--substKind :: KindSubst -> Type -> Type+applySubstitutionKind :: Map Name Kind -> Type -> Type #if MIN_VERSION_template_haskell(2,8,0)-substKind = substType+applySubstitutionKind = applySubstitution #else-substKind _ t = t -- There are no kind variables!+applySubstitutionKind _ t = t #endif substNameWithKind :: Name -> Kind -> Type -> Type-substNameWithKind n k = substKind (M.singleton n k)+substNameWithKind n k = applySubstitutionKind (M.singleton n k) substNamesWithKindStar :: [Name] -> Type -> Type substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns
Data/Aeson/Types.hs view
@@ -104,7 +104,19 @@ , listParser -- * Generic and TH encoding configuration- , Options(..)+ , Options++ -- ** Options fields+ -- $optionsFields+ , fieldLabelModifier+ , constructorTagModifier+ , allNullaryToStringTag+ , omitNothingFields+ , sumEncoding+ , unwrapUnaryRecords+ , tagSingleConstructors++ -- ** Options utilities , SumEncoding(..) , camelTo , camelTo2@@ -124,3 +136,6 @@ foldable :: (Foldable t, ToJSON a) => t a -> Encoding foldable = toEncoding . toList {-# INLINE foldable #-}++-- $optionsFields+-- The functions here are in fact record fields of the 'Options' type.
Data/Aeson/Types/FromJSON.hs view
@@ -101,7 +101,7 @@ import Data.Scientific (Scientific) import Data.Tagged (Tagged(..)) import Data.Text (Text, pack, unpack)-import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)+import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) import Data.Time.Format (parseTime) import Data.Time.Locale.Compat (defaultTimeLocale) import Data.Traversable as Tr (sequence)@@ -109,6 +109,7 @@ import Data.Version (Version, parseVersion) import Data.Word (Word16, Word32, Word64, Word8) import Foreign.Storable (Storable)+import Foreign.C.Types (CTime (..)) import GHC.Generics import Numeric.Natural (Natural) import Text.ParserCombinators.ReadP (readP_to_S)@@ -188,7 +189,7 @@ parseIntegralFromScientific expected s = case Scientific.floatingOrInteger s :: Either Double a of Right x -> pure x- Left _ -> fail $ "Floating number specified for " ++ expected ++ ": " ++ show s+ Left _ -> fail $ "expected " ++ expected ++ ", encountered floating number " ++ show s {-# INLINE parseIntegralFromScientific #-} parseIntegral :: Integral a => String -> Value -> Parser a@@ -1273,16 +1274,20 @@ fromJSONKey = FromJSONKeyTextParser $ parseIntegralText "Integer" instance FromJSON Natural where- parseJSON = withScientific "Natural" $ \s ->- if Scientific.coefficient s < 0- then fail $ "Expected a Natural number but got the negative number: " <> show s- else pure $ truncate s+ parseJSON value = do+ integer :: Integer <- parseIntegral "Natural" value+ if integer < 0 then+ fail $ "expected Natural, encountered negative number " <> show integer+ else+ pure $ fromIntegral integer instance FromJSONKey Natural where- fromJSONKey = FromJSONKeyTextParser $ \t -> parseScientificText t >>= \s ->- if Scientific.coefficient s < 0- then fail $ "Expected a Natural number but got the negative number: " <> show s- else pure $ truncate s+ fromJSONKey = FromJSONKeyTextParser $ \text -> do+ integer :: Integer <- parseIntegralText "Natural" text+ if integer < 0 then+ fail $ "expected Natural, encountered negative number " <> show integer+ else+ pure $ fromIntegral integer instance FromJSON Int8 where parseJSON = parseBoundedIntegral "Int8"@@ -1347,6 +1352,9 @@ instance FromJSONKey Word64 where fromJSONKey = FromJSONKeyTextParser $ parseBoundedIntegralText "Word64" +instance FromJSON CTime where+ parseJSON = fmap CTime . parseJSON+ {-# INLINE parseJSON #-} instance FromJSON Text where parseJSON = withText "Text" pure@@ -1702,6 +1710,15 @@ -- @1e1000000000@. instance FromJSON NominalDiffTime where parseJSON = withScientific "NominalDiffTime" $ pure . realToFrac+ {-# INLINE parseJSON #-}+++-- | /WARNING:/ Only parse lengths of time from trusted input+-- since an attacker could easily fill up the memory of the target+-- system by specifying a scientific number with a big exponent like+-- @1e1000000000@.+instance FromJSON DiffTime where+ parseJSON = withScientific "DiffTime" $ pure . realToFrac {-# INLINE parseJSON #-} -------------------------------------------------------------------------------
Data/Aeson/Types/Internal.hs view
@@ -531,6 +531,9 @@ -------------------------------------------------------------------------------- -- | Options that specify how to encode\/decode your datatype to\/from JSON.+--+-- Options can be set using record syntax on 'defaultOptions' with the fields+-- below. data Options = Options { fieldLabelModifier :: String -> String -- ^ Function applied to field labels.
Data/Aeson/Types/ToJSON.hs view
@@ -20,6 +20,7 @@ #endif #include "overlapping-compat.h"+#include "incoherent-compat.h" -- TODO: Drop this when we remove support for Data.Attoparsec.Number {-# OPTIONS_GHC -fno-warn-deprecations #-}@@ -83,13 +84,14 @@ import Data.Scientific (Scientific) import Data.Tagged (Tagged(..)) import Data.Text (Text, pack)-import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)+import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) import Data.Time.Format (FormatTime, formatTime) import Data.Time.Locale.Compat (defaultTimeLocale) import Data.Vector (Vector) import Data.Version (Version, showVersion) import Data.Word (Word16, Word32, Word64, Word8) import Foreign.Storable (Storable)+import Foreign.C.Types (CTime (..)) import GHC.Generics import Numeric.Natural (Natural) import qualified Data.Aeson.Encoding as E@@ -1009,7 +1011,7 @@ recordToPairs = fieldToPair {-# INLINE recordToPairs #-} -instance OVERLAPPING_+instance INCOHERENT_ ( Selector s , GToJSON enc arity (K1 i (Maybe a)) , GKeyValue enc pairs@@ -1365,7 +1367,6 @@ toJSONKey = toJSONKeyTextEnc E.int64Text {-# INLINE toJSONKey #-} - instance ToJSON Word where toJSON = Number . fromIntegral {-# INLINE toJSON #-}@@ -1425,7 +1426,13 @@ toJSONKey = toJSONKeyTextEnc E.word64Text {-# INLINE toJSONKey #-} +instance ToJSON CTime where+ toJSON (CTime i) = toJSON i+ {-# INLINE toJSON #-} + toEncoding (CTime i) = toEncoding i+ {-# INLINE toEncoding #-}+ instance ToJSON Text where toJSON = String {-# INLINE toJSON #-}@@ -1910,7 +1917,16 @@ . E.encodingToLazyByteString {-# INLINE stringEncoding #-} + instance ToJSON NominalDiffTime where+ toJSON = Number . realToFrac+ {-# INLINE toJSON #-}++ toEncoding = E.scientific . realToFrac+ {-# INLINE toEncoding #-}+++instance ToJSON DiffTime where toJSON = Number . realToFrac {-# INLINE toJSON #-}
aeson.cabal view
@@ -1,5 +1,5 @@ name: aeson-version: 1.2.1.0+version: 1.2.2.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON@@ -93,6 +93,7 @@ Data.Aeson.Encoding.Internal Data.Aeson.Internal Data.Aeson.Internal.Time+ Data.Aeson.Parser.Internal -- Deprecated modules exposed-modules:@@ -101,7 +102,6 @@ other-modules: Data.Aeson.Encoding.Builder Data.Aeson.Internal.Functions- Data.Aeson.Parser.Internal Data.Aeson.Parser.Unescape Data.Aeson.Parser.Time Data.Aeson.Types.FromJSON@@ -125,6 +125,7 @@ tagged >=0.8.3 && <0.9, template-haskell >= 2.7, text >= 1.1.1.0,+ th-abstraction >= 0.2.2 && < 0.3, time >= 1.1.1.4, time-locale-compat >= 0.1.1 && < 0.2, unordered-containers >= 0.2.5.0 && < 0.3,@@ -198,7 +199,7 @@ build-depends: HUnit,- QuickCheck >= 2.8 && <2.9.3,+ QuickCheck >= 2.8 && <2.11, aeson, integer-logarithms >= 1 && <1.1, attoparsec,
benchmarks/AesonMap.hs view
@@ -160,7 +160,7 @@ , bench "Identity" $ nf (decodeHMB proxyT1) val , bench "Coerce" $ nf (decodeHMB proxyT2) val , bench "Parser" $ nf (decodeHMB proxyT3) val- , bench "aeson-0.11" $ nf (decodeHMA proxyText) val+ , bench "aeson-hackage" $ nf (decodeHMA proxyText) val , bench "Tagged Text" $ nf (decodeHMB $ proxyTagged proxyText) val , bench "Tagged Identity" $ nf (decodeHMB $ proxyTagged proxyT1) val , bench "Tagged Coerce" $ nf (decodeHMB $ proxyTagged proxyT2) val@@ -172,11 +172,11 @@ -> LBS.ByteString -> Benchmark benchDecodeMap name val = bgroup name- [ bench "Text" $ nf (decodeMapB proxyText) val- , bench "Identity" $ nf (decodeMapB proxyT1) val- , bench "Coerce" $ nf (decodeMapB proxyT2) val- , bench "Parser" $ nf (decodeMapB proxyT3) val- , bench "aeson-0.11" $ nf (decodeMapA proxyText) val+ [ bench "Text" $ nf (decodeMapB proxyText) val+ , bench "Identity" $ nf (decodeMapB proxyT1) val+ , bench "Coerce" $ nf (decodeMapB proxyT2) val+ , bench "Parser" $ nf (decodeMapB proxyT3) val+ , bench "aeson-hackage" $ nf (decodeMapA proxyText) val ] benchEncodeHM
benchmarks/CompareWithJSON.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where@@ -10,8 +11,11 @@ import Control.DeepSeq (NFData(rnf)) import Criterion.Main import Data.Maybe (fromMaybe)-import qualified Data.Aeson as A-import qualified Data.Aeson.Text as A+import qualified "aeson-benchmarks" Data.Aeson as A+import qualified "aeson-benchmarks" Data.Aeson.Text as A+import qualified "aeson-benchmarks" Data.Aeson.Parser.Internal as I+import qualified "aeson" Data.Aeson as B+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB@@ -41,6 +45,19 @@ decodeA' :: BL.ByteString -> A.Value decodeA' s = fromMaybe (error "fail to parse via Aeson") $ A.decode' s +decodeAS :: BS.ByteString -> A.Value+decodeAS s = fromMaybe (error "fail to parse via Aeson") $ A.decodeStrict' s++decodeB :: BL.ByteString -> B.Value+decodeB s = fromMaybe (error "fail to parse via Aeson") $ B.decode s++decodeBS :: BS.ByteString -> B.Value+decodeBS s = fromMaybe (error "fail to parse via Aeson") $ B.decodeStrict' s++decodeIP :: BL.ByteString -> A.Value+decodeIP s = fromMaybe (error "fail to parse via Parser.decodeWith") $+ I.decodeWith I.jsonEOF A.fromJSON s+ encodeJ :: J.JSValue -> BL.ByteString encodeJ = toLazyByteString . fromString . J.encode @@ -55,19 +72,27 @@ let enFile = "json-data/twitter100.json" jpFile = "json-data/jp100.json" enA <- BL.readFile enFile+ enS <- BS.readFile enFile enJ <- readFile enFile jpA <- BL.readFile jpFile+ jpS <- BS.readFile jpFile jpJ <- readFile jpFile defaultMain [ bgroup "decode" [ bgroup "en" [- bench "aeson/lazy" $ nf decodeA enA- , bench "aeson/strict" $ nf decodeA' enA- , bench "json" $ nf decodeJ enJ+ bench "aeson/lazy" $ nf decodeA enA+ , bench "aeson/strict" $ nf decodeA' enA+ , bench "aeson/stricter" $ nf decodeAS enS+ , bench "aeson/hackage" $ nf decodeB enA+ , bench "aeson/hackage'" $ nf decodeBS enS+ , bench "aeson/parser" $ nf decodeIP enA+ , bench "json" $ nf decodeJ enJ ] , bgroup "jp" [- bench "aeson" $ nf decodeA jpA- , bench "json" $ nf decodeJ jpJ+ bench "aeson" $ nf decodeA jpA+ , bench "aeson/stricter" $ nf decodeAS jpS+ , bench "aeson/hackage" $ nf decodeB jpA+ , bench "json" $ nf decodeJ jpJ ] ] , bgroup "encode" [
benchmarks/Dates.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fsimpl-tick-factor=0 #-} module Main (main) where import Prelude ()
benchmarks/Typed.hs view
@@ -13,4 +13,7 @@ Generic.benchmarks , Manual.benchmarks , TH.benchmarks+ , Generic.decodeBenchmarks+ , Manual.decodeBenchmarks+ , TH.decodeBenchmarks ]
benchmarks/Typed/Generic.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE PackageImports #-}-module Typed.Generic (benchmarks) where+module Typed.Generic (benchmarks, decodeBenchmarks) where import Prelude () import Prelude.Compat@@ -7,7 +7,7 @@ import "aeson" Data.Aeson hiding (Result) import Criterion import Data.ByteString.Lazy as L-import Twitter.TH+import Twitter.Generic import Typed.Common import qualified "aeson-benchmarks" Data.Aeson as B @@ -26,7 +26,7 @@ benchmarks :: Benchmark benchmarks = env ((,) <$> load "json-data/twitter100.json" <*> load "json-data/jp100.json") $ \ ~(twitter100, jp100) ->- bgroup "generic" [+ bgroup "encodeGeneric" [ bgroup "direct" [ bench "twitter100" $ nf encodeDirectB twitter100 , bench "jp100" $ nf encodeDirectB jp100@@ -38,5 +38,23 @@ , bench "jp100" $ nf encodeViaValueB jp100 , bench "twitter100 baseline" $ nf encodeViaValueA twitter100 , bench "jp100 baseline" $ nf encodeViaValueA jp100+ ]+ ]++decodeDirectA :: L.ByteString -> Maybe Result+decodeDirectA = decode++decodeDirectB :: L.ByteString -> Maybe Result+decodeDirectB = B.decode++decodeBenchmarks :: Benchmark+decodeBenchmarks =+ env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) ->+ bgroup "decodeGeneric"+ [ bgroup "direct"+ [ bench "twitter100" $ nf decodeDirectB twitter100+ , bench "jp100" $ nf decodeDirectB jp100+ , bench "twitter100 baseline" $ nf decodeDirectA twitter100+ , bench "jp100 baseline" $ nf decodeDirectA jp100 ] ]
benchmarks/Typed/Manual.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE PackageImports #-}-module Typed.Manual (benchmarks) where+module Typed.Manual (benchmarks, decodeBenchmarks) where import Prelude () import Prelude.Compat@@ -26,7 +26,7 @@ benchmarks :: Benchmark benchmarks = env ((,) <$> load "json-data/twitter100.json" <*> load "json-data/jp100.json") $ \ ~(twitter100, jp100) ->- bgroup "manual" [+ bgroup "encodeManual" [ bgroup "direct" [ bench "twitter100" $ nf encodeDirectB twitter100 , bench "jp100" $ nf encodeDirectB jp100@@ -38,5 +38,23 @@ , bench "jp100" $ nf encodeViaValueB jp100 , bench "twitter100 baseline" $ nf encodeViaValueA twitter100 , bench "jp100 baseline" $ nf encodeViaValueA jp100+ ]+ ]++decodeDirectA :: L.ByteString -> Maybe Result+decodeDirectA = decode++decodeDirectB :: L.ByteString -> Maybe Result+decodeDirectB = B.decode++decodeBenchmarks :: Benchmark+decodeBenchmarks =+ env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) ->+ bgroup "decodeManual"+ [ bgroup "direct"+ [ bench "twitter100" $ nf decodeDirectB twitter100+ , bench "jp100" $ nf decodeDirectB jp100+ , bench "twitter100 baseline" $ nf decodeDirectA twitter100+ , bench "jp100 baseline" $ nf decodeDirectA jp100 ] ]
benchmarks/Typed/TH.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE PackageImports #-}-module Typed.TH (benchmarks) where+module Typed.TH (benchmarks, decodeBenchmarks) where import Prelude () import Prelude.Compat@@ -26,7 +26,7 @@ benchmarks :: Benchmark benchmarks = env ((,) <$> load "json-data/twitter100.json" <*> load "json-data/jp100.json") $ \ ~(twitter100, jp100) ->- bgroup "th" [+ bgroup "encodeTH" [ bgroup "direct" [ bench "twitter100" $ nf encodeDirectB twitter100 , bench "jp100" $ nf encodeDirectB jp100@@ -38,5 +38,23 @@ , bench "jp100" $ nf encodeViaValueA jp100 , bench "twitter100 baseline" $ nf encodeViaValueB twitter100 , bench "jp100 baseline" $ nf encodeViaValueB jp100+ ]+ ]++decodeDirectA :: L.ByteString -> Maybe Result+decodeDirectA = decode++decodeDirectB :: L.ByteString -> Maybe Result+decodeDirectB = B.decode++decodeBenchmarks :: Benchmark+decodeBenchmarks =+ env ((,) <$> L.readFile "json-data/twitter100.json" <*> L.readFile "json-data/jp100.json") $ \ ~(twitter100, jp100) ->+ bgroup "decodeTH"+ [ bgroup "direct"+ [ bench "twitter100" $ nf decodeDirectB twitter100+ , bench "jp100" $ nf decodeDirectB jp100+ , bench "twitter100 baseline" $ nf decodeDirectA twitter100+ , bench "jp100 baseline" $ nf decodeDirectA jp100 ] ]
benchmarks/aeson-benchmarks.cabal view
@@ -10,6 +10,7 @@ manual: False library+ default-language: Haskell2010 hs-source-dirs: .. . ../ffi ../pure ../attoparsec-iso8601 c-sources: ../cbits/unescape_string.c exposed-modules:@@ -54,6 +55,7 @@ tagged >=0.8.3 && <0.9, template-haskell >= 2.4, text >= 1.1.1.0,+ th-abstraction >= 0.2.2 && < 0.3, time, transformers, unordered-containers >= 0.2.3.0,@@ -82,6 +84,13 @@ main-is: Compare.hs hs-source-dirs: ../examples . ghc-options: -Wall -O2 -rtsopts+ other-modules:+ Compare.BufferBuilder+ Compare.JsonBench+ Compare.JsonBuilder+ Twitter+ Twitter.Manual+ Typed.Common build-depends: aeson-benchmarks, base,@@ -115,6 +124,16 @@ -- We must help ourself in situations when there is both -- aeson and aeson-benchmakrs cpp-options: -DHAS_BOTH_AESON_AND_BENCHMARKS+ other-modules:+ Twitter+ Twitter.Generic+ Twitter.Manual+ Twitter.Options+ Twitter.TH+ Typed.Common+ Typed.Generic+ Typed.Manual+ Typed.TH build-depends: aeson, aeson-benchmarks,@@ -135,7 +154,9 @@ executable aeson-benchmark-compare-with-json main-is: CompareWithJSON.hs ghc-options: -Wall -O2 -rtsopts+ cpp-options: -DHAS_BOTH_AESON_AND_BENCHMARKS build-depends:+ aeson, aeson-benchmarks, base, base-compat,
changelog.md view
@@ -1,6 +1,18 @@ 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.1.0+### 1.2.2.0++* Add `FromJSON` and `ToJSON` instances for+ * `DiffTime`, thanks to Víctor López Juan.+ * `CTime`, thanks to Daniel Díaz.+* Fix handling of fractions when parsing Natural, thanks to Yuriy Syrovetskiy.+* Change text in error messages for Integral types to make them follow the common pattern, thanks to Yuriy Syrovetskiy.+* Add missing `INCOHERENT` pragma for `RecordToPair`, thanks to Xia Li-yao.+* Everything related to `Options` is now exported from `Data.Aeson`, thanks to Xia Li-yao.+* Optimizations to not escape text in clear cases, thanks to Oleg Grenrus.+* Some documentation fixes, thanks to Phil de Joux & Xia Li-yao.++### 1.2.1.0 * Add `parserThrowError` and `parserCatchError` combinators, thanks to Oleg Grenrus.
examples/Twitter/Generic.hs view
@@ -1,7 +1,12 @@ -- Use GHC generics to automatically generate good instances.+ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +#ifdef HAS_BOTH_AESON_AND_BENCHMARKS+{-# LANGUAGE PackageImports #-}+#endif+ module Twitter.Generic ( Metadata(..)@@ -11,39 +16,64 @@ ) where import Prelude ()-import Prelude.Compat+import Prelude.Compat () import Twitter+import Twitter.Options #ifndef HAS_BOTH_AESON_AND_BENCHMARKS-import Data.Aeson (ToJSON, FromJSON)+import Data.Aeson (ToJSON (..), FromJSON (..), genericToJSON, genericToEncoding, genericParseJSON) #else-import "aeson" Data.Aeson (ToJSON, FromJSON)+import "aeson" Data.Aeson (ToJSON (..), FromJSON (..), genericToJSON, genericToEncoding, genericParseJSON) import qualified "aeson-benchmarks" Data.Aeson as B #endif -instance ToJSON Metadata-instance FromJSON Metadata+instance ToJSON Metadata where+ toJSON = genericToJSON twitterOptions+ toEncoding = genericToEncoding twitterOptions+instance FromJSON Metadata where+ parseJSON = genericParseJSON twitterOptions -instance ToJSON Geo-instance FromJSON Geo+instance ToJSON Geo where+ toJSON = genericToJSON twitterOptions+ toEncoding = genericToEncoding twitterOptions+instance FromJSON Geo where+ parseJSON = genericParseJSON twitterOptions -instance ToJSON Story-instance FromJSON Story+instance ToJSON Story where+ toJSON = genericToJSON twitterOptions+ toEncoding = genericToEncoding twitterOptions+instance FromJSON Story where+ parseJSON = genericParseJSON twitterOptions -instance ToJSON Result-instance FromJSON Result+instance ToJSON Result where+ toJSON = genericToJSON twitterOptions+ toEncoding = genericToEncoding twitterOptions+instance FromJSON Result where+ parseJSON = genericParseJSON twitterOptions #ifdef HAS_BOTH_AESON_AND_BENCHMARKS-instance B.ToJSON Metadata-instance B.FromJSON Metadata+instance B.ToJSON Metadata where+ toJSON = B.genericToJSON btwitterOptions+ toEncoding = B.genericToEncoding btwitterOptions+instance B.FromJSON Metadata where+ parseJSON = B.genericParseJSON btwitterOptions -instance B.ToJSON Geo-instance B.FromJSON Geo+instance B.ToJSON Geo where+ toJSON = B.genericToJSON btwitterOptions+ toEncoding = B.genericToEncoding btwitterOptions+instance B.FromJSON Geo where+ parseJSON = B.genericParseJSON btwitterOptions -instance B.ToJSON Story-instance B.FromJSON Story+instance B.ToJSON Story where+ toJSON = B.genericToJSON btwitterOptions+ toEncoding = B.genericToEncoding btwitterOptions+instance B.FromJSON Story where+ parseJSON = B.genericParseJSON btwitterOptions -instance B.ToJSON Result-instance B.FromJSON Result+instance B.ToJSON Result where+ toJSON = B.genericToJSON btwitterOptions+ toEncoding = B.genericToEncoding btwitterOptions+instance B.FromJSON Result where+ parseJSON = B.genericParseJSON btwitterOptions #endif
+ examples/Twitter/Options.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}++#ifdef HAS_BOTH_AESON_AND_BENCHMARKS+{-# LANGUAGE PackageImports #-}+#endif++module Twitter.Options (module Twitter.Options) where++#ifndef HAS_BOTH_AESON_AND_BENCHMARKS+import Data.Aeson+import Data.Aeson.Types+#else+import "aeson" Data.Aeson+import "aeson" Data.Aeson.Types+import qualified "aeson-benchmarks" Data.Aeson as B+import qualified "aeson-benchmarks" Data.Aeson.Types as B+#endif++twitterOptions :: Options+twitterOptions = defaultOptions+ { fieldLabelModifier = \x -> case x of+ "id_" -> "id"+ _ -> x+ }++#ifdef HAS_BOTH_AESON_AND_BENCHMARKS+btwitterOptions :: B.Options+btwitterOptions = B.defaultOptions+ { B.fieldLabelModifier = \x -> case x of+ "id_" -> "id"+ _ -> x+ }+#endif
examples/Twitter/TH.hs view
@@ -1,10 +1,13 @@ -- Use Template Haskell to generate good instances. {-# LANGUAGE CPP #-}-{-# LANGUAGE PackageImports #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +#ifdef HAS_BOTH_AESON_AND_BENCHMARKS+{-# LANGUAGE PackageImports #-}+#endif+ module Twitter.TH ( Metadata(..)@@ -16,6 +19,7 @@ import Prelude () import Twitter+import Twitter.Options #ifndef HAS_BOTH_AESON_AND_BENCHMARKS import Data.Aeson.TH@@ -24,14 +28,14 @@ import qualified "aeson-benchmarks" Data.Aeson.TH as B #endif -$(deriveJSON defaultOptions ''Metadata)-$(deriveJSON defaultOptions ''Geo)-$(deriveJSON defaultOptions ''Story)-$(deriveJSON defaultOptions ''Result)+$(deriveJSON twitterOptions ''Metadata)+$(deriveJSON twitterOptions ''Geo)+$(deriveJSON twitterOptions ''Story)+$(deriveJSON twitterOptions ''Result) #ifdef HAS_BOTH_AESON_AND_BENCHMARKS-$(B.deriveJSON B.defaultOptions ''Metadata)-$(B.deriveJSON B.defaultOptions ''Geo)-$(B.deriveJSON B.defaultOptions ''Story)-$(B.deriveJSON B.defaultOptions ''Result)+$(B.deriveJSON btwitterOptions ''Metadata)+$(B.deriveJSON btwitterOptions ''Geo)+$(B.deriveJSON btwitterOptions ''Story)+$(B.deriveJSON btwitterOptions ''Result) #endif
stack-bench.yaml view
@@ -1,6 +1,15 @@ resolver: lts-8.5+# We use aeson in the snapshot to+# - avoid recompilation of criterion+# - compare against it+# - '.'+#+# Also we use separate working directory to avoid "unregistering aeson"+# caused recompilations+work-dir: .stack-work-bench packages:-- '.' - benchmarks extra-deps:+- aeson-1.2.1.0 - quickcheck-instances-0.3.14+- th-abstraction-0.2.2.0
stack-lts6.yaml view
@@ -8,6 +8,7 @@ - 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 flags: flags:
stack-lts7.yaml view
@@ -5,6 +5,7 @@ extra-deps: - integer-logarithms-1 - quickcheck-instances-0.3.14+- th-abstraction-0.2.2.0 flags: aeson: fast: true
stack-lts8.yaml view
@@ -1,9 +1,10 @@-resolver: lts-8.1+resolver: lts-8.5 packages: - '.' - attoparsec-iso8601 extra-deps: - quickcheck-instances-0.3.14+- th-abstraction-0.2.2.0 flags: aeson: fast: true
+ stack-lts9.yaml view
@@ -0,0 +1,12 @@+resolver: lts-9.3+packages:+- '.'+- attoparsec-iso8601+extra-deps:+- quickcheck-instances-0.3.16+- QuickCheck-2.10.0.1+flags:+ aeson:+ fast: true+ attoparsec-iso8601:+ fast: true
stack-nightly.yaml view
@@ -1,9 +1,7 @@-resolver: nightly-2017-03-25+resolver: nightly-2017-09-04 packages: - '.' - attoparsec-iso8601-extra-deps:-- quickcheck-instances-0.3.14 flags: aeson: fast: true
stack-pure-unescape.yaml view
@@ -3,6 +3,7 @@ - '.' extra-deps: - quickcheck-instances-0.3.14+- th-abstraction-0.2.2.0 flags: aeson: fast: true
tests/Encoders.hs view
@@ -252,6 +252,11 @@ incoherentInstancesNeededParseJSONString = case () of _ | True -> $(mkParseJSON defaultOptions ''IncoherentInstancesNeeded) | False -> genericParseJSON defaultOptions++incoherentInstancesNeededToJSON :: ToJSON a => IncoherentInstancesNeeded a -> Value+incoherentInstancesNeededToJSON = case () of+ _ | True -> $(mkToJSON defaultOptions ''IncoherentInstancesNeeded)+ | False -> genericToJSON defaultOptions #endif -------------------------------------------------------------------------------
tests/ErrorMessages.hs view
@@ -12,6 +12,7 @@ import Data.Aeson (FromJSON(..), eitherDecode) import Data.Proxy (Proxy(..)) import Instances ()+import Numeric.Natural (Natural) import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, assertFailure, assertEqual)@@ -22,6 +23,8 @@ tests = [ testCase "Int" int+ , testCase "Integer" integer+ , testCase "Natural" natural , testCase "String" string , testCase "HashMap" hashMap ]@@ -33,6 +36,17 @@ t "[]" $ expected "Int" "Array" t "{}" $ expected "Int" "Object" t "null" $ expected "Int" "Null"++integer :: Assertion+integer = do+ let t = test (Proxy :: Proxy Integer)+ t "44.44" $ expected "Integer" "floating number 44.44"++natural :: Assertion+natural = do+ let t = test (Proxy :: Proxy Natural)+ t "44.44" $ expected "Natural" "floating number 44.44"+ t "-50" $ expected "Natural" "negative number -50" string :: Assertion string = do
tests/Instances.hs view
@@ -14,8 +14,6 @@ import Control.Monad import Data.Aeson.Types import Data.Function (on)-import Data.Functor.Compose (Compose (..))-import Data.Proxy (Proxy(..)) import Data.Time (ZonedTime(..), TimeZone(..)) import Data.Time.Clock (UTCTime(..)) import Functions@@ -32,6 +30,11 @@ 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)@@ -188,14 +191,16 @@ arbitrary = fromInteger . abs <$> arbitrary #endif +#if !MIN_VERSION_QuickCheck(2,10,0) instance Arbitrary (Proxy a) where arbitrary = pure Proxy -instance Arbitrary a => Arbitrary (DList.DList a) where- arbitrary = DList.fromList <$> arbitrary- 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
tests/Properties.hs view
@@ -27,7 +27,7 @@ import Data.Ratio (Ratio) import Data.Sequence (Seq) import Data.Tagged (Tagged)-import Data.Time (Day, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)+import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) import Data.Version (Version) import Encoders import Instances ()@@ -248,6 +248,7 @@ , testProperty "UTCTime" $ roundTripEq (undefined :: UTCTime) , testProperty "ZonedTime" $ roundTripEq (undefined :: ZonedTime) , testProperty "NominalDiffTime" $ roundTripEq (undefined :: NominalDiffTime)+ , testProperty "DiffTime" $ roundTripEq (undefined :: DiffTime) , testProperty "Version" $ roundTripEq (undefined :: Version) , testProperty "Natural" $ roundTripEq (undefined :: Natural) , testProperty "Proxy" $ roundTripEq (undefined :: Proxy Int)
tests/SerializationFormatSpec.hs view
@@ -22,6 +22,7 @@ import Data.Aeson (FromJSON(..), decode, encode, genericParseJSON, genericToEncoding, genericToJSON) import Data.Aeson.Types (Options(..), SumEncoding(..), ToJSON(..), defaultOptions) import Data.Fixed (Pico)+import Data.Foldable (for_, toList) import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) import Data.Functor.Product (Product(..))@@ -65,122 +66,134 @@ jsonExamples :: [Example] jsonExamples = [- Example "Either Left" "{\"Left\":1}" (Left 1 :: Either Int Int)- , Example "Either Right" "{\"Right\":1}" (Right 1 :: Either Int Int)- , Example "Nothing" "null" (Nothing :: Maybe Int)- , Example "Just" "1" (Just 1 :: Maybe Int)- , Example "Proxy Int" "null" (Proxy :: Proxy Int)- , Example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)+ example "Either Left" "{\"Left\":1}" (Left 1 :: Either Int Int)+ , example "Either Right" "{\"Right\":1}" (Right 1 :: Either Int Int)+ , example "Nothing" "null" (Nothing :: Maybe Int)+ , example "Just" "1" (Just 1 :: Maybe Int)+ , example "Proxy Int" "null" (Proxy :: Proxy Int)+ , example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int) #if __GLASGOW_HASKELL__ >= 708 -- Test Tagged instance is polykinded- , Example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)+ , example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int) #endif- , Example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)- , Example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))- , Example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)- , Example "Seq" "[1,2,3]" (Seq.fromList [1, 2, 3] :: Seq.Seq Int)- , Example "DList" "[1,2,3]" (DList.fromList [1, 2, 3] :: DList.DList Int)- , Example "()" "[]" ()+ , example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)+ , example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))+ , example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)+ , example "Seq" "[1,2,3]" (Seq.fromList [1, 2, 3] :: Seq.Seq Int)+ , example "DList" "[1,2,3]" (DList.fromList [1, 2, 3] :: DList.DList Int)+ , example "()" "[]" () - , Example "HashMap Int Int" "{\"0\":1,\"2\":3}" (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)- , Example "Map Int Int" "{\"0\":1,\"2\":3}" (M.fromList [(0,1),(2,3)] :: M.Map Int Int)- , Example "Map (Tagged Int Int) Int" "{\"0\":1,\"2\":3}" (M.fromList [(Tagged 0,1),(Tagged 2,3)] :: M.Map (Tagged Int Int) Int)- , Example "Map [Int] Int" "[[[0],1],[[2],3]]" (M.fromList [([0],1),([2],3)] :: M.Map [Int] Int)- , Example "Map [Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [("ab",1),("cd",3)] :: M.Map String Int)- , Example "Map [I Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [(map pure "ab",1),(map pure "cd",3)] :: M.Map [I Char] Int)+ , Example "HashMap Int Int"+ [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]+ (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)+ , Example "Map Int Int"+ [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]+ (M.fromList [(0,1),(2,3)] :: M.Map Int Int)+ , Example "Map (Tagged Int Int) Int"+ [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]+ (M.fromList [(Tagged 0,1),(Tagged 2,3)] :: M.Map (Tagged Int Int) Int)+ , example "Map [Int] Int"+ "[[[0],1],[[2],3]]"+ (M.fromList [([0],1),([2],3)] :: M.Map [Int] Int)+ , Example "Map [Char] Int"+ [ "{\"ab\":1,\"cd\":3}", "{\"cd\":3,\"ab\":1}" ]+ (M.fromList [("ab",1),("cd",3)] :: M.Map String Int)+ , Example "Map [I Char] Int"+ [ "{\"ab\":1,\"cd\":3}", "{\"cd\":3,\"ab\":1}" ]+ (M.fromList [(map pure "ab",1),(map pure "cd",3)] :: M.Map [I Char] Int) - , Example "nan :: Double" "null" (Approx $ 0/0 :: Approx Double)+ , example "nan :: Double" "null" (Approx $ 0/0 :: Approx Double) - , Example "Ordering LT" "\"LT\"" LT- , Example "Ordering EQ" "\"EQ\"" EQ- , Example "Ordering GT" "\"GT\"" GT+ , example "Ordering LT" "\"LT\"" LT+ , example "Ordering EQ" "\"EQ\"" EQ+ , example "Ordering GT" "\"GT\"" GT - , Example "Float" "3.14" (3.14 :: Float)- , Example "Pico" "3.14" (3.14 :: Pico)- , Example "Scientific" "3.14" (3.14 :: Scientific)+ , example "Float" "3.14" (3.14 :: Float)+ , example "Pico" "3.14" (3.14 :: Pico)+ , example "Scientific" "3.14" (3.14 :: Scientific) - , Example "UUID" "\"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"" $ UUID.fromWords+ , example "UUID" "\"c2cc10e1-57d6-4b6f-9899-38d972112d8c\"" $ UUID.fromWords 0xc2cc10e1 0x57d64b6f 0x989938d9 0x72112d8c - , Example "Set Int" "[1,2,3]" (Set.fromList [3, 2, 1] :: Set.Set Int)- , Example "IntSet" "[1,2,3]" (IntSet.fromList [3, 2, 1])- , Example "IntMap" "[[1,2],[3,4]]" (IntMap.fromList [(3,4), (1,2)] :: IntMap.IntMap Int)- , Example "Vector" "[1,2,3]" (Vector.fromList [1, 2, 3] :: Vector.Vector Int)- , Example "HashSet Int" "[1,2,3]" (HashSet.fromList [3, 2, 1] :: HashSet.HashSet Int)- , Example "Tree Int" "[1,[[2,[[3,[]],[4,[]]]],[5,[]]]]" (let n = Tree.Node in n 1 [n 2 [n 3 [], n 4 []], n 5 []] :: Tree.Tree Int)+ , example "Set Int" "[1,2,3]" (Set.fromList [3, 2, 1] :: Set.Set Int)+ , example "IntSet" "[1,2,3]" (IntSet.fromList [3, 2, 1])+ , example "IntMap" "[[1,2],[3,4]]" (IntMap.fromList [(3,4), (1,2)] :: IntMap.IntMap Int)+ , example "Vector" "[1,2,3]" (Vector.fromList [1, 2, 3] :: Vector.Vector Int)+ , example "HashSet Int" "[1,2,3]" (HashSet.fromList [3, 2, 1] :: HashSet.HashSet Int)+ , example "Tree Int" "[1,[[2,[[3,[]],[4,[]]]],[5,[]]]]" (let n = Tree.Node in n 1 [n 2 [n 3 [], n 4 []], n 5 []] :: Tree.Tree Int) -- Three separate cases, as ordering in HashMap is not defined- , Example "HashMap Float Int, NaN" "{\"NaN\":1}" (Approx $ HM.singleton (0/0) 1 :: Approx (HM.HashMap Float Int))- , Example "HashMap Float Int, Infinity" "{\"Infinity\":1}" (HM.singleton (1/0) 1 :: HM.HashMap Float Int)- , Example "HashMap Float Int, +Infinity" "{\"-Infinity\":1}" (HM.singleton (negate 1/0) 1 :: HM.HashMap Float Int)+ , example "HashMap Float Int, NaN" "{\"NaN\":1}" (Approx $ HM.singleton (0/0) 1 :: Approx (HM.HashMap Float Int))+ , example "HashMap Float Int, Infinity" "{\"Infinity\":1}" (HM.singleton (1/0) 1 :: HM.HashMap Float Int)+ , example "HashMap Float Int, +Infinity" "{\"-Infinity\":1}" (HM.singleton (negate 1/0) 1 :: HM.HashMap Float Int) -- Functors- , Example "Identity Int" "1" (pure 1 :: Identity Int)+ , example "Identity Int" "1" (pure 1 :: Identity Int) - , Example "Identity Char" "\"x\"" (pure 'x' :: Identity Char)- , Example "Identity String" "\"foo\"" (pure "foo" :: Identity String)- , Example "[Identity Char]" "\"xy\"" ([pure 'x', pure 'y'] :: [Identity Char])+ , example "Identity Char" "\"x\"" (pure 'x' :: Identity Char)+ , example "Identity String" "\"foo\"" (pure "foo" :: Identity String)+ , example "[Identity Char]" "\"xy\"" ([pure 'x', pure 'y'] :: [Identity Char]) - , Example "Maybe Char" "\"x\"" (pure 'x' :: Maybe Char)- , Example "Maybe String" "\"foo\"" (pure "foo" :: Maybe String)- , Example "Maybe [Identity Char]" "\"xy\"" (pure [pure 'x', pure 'y'] :: Maybe [Identity Char])+ , example "Maybe Char" "\"x\"" (pure 'x' :: Maybe Char)+ , example "Maybe String" "\"foo\"" (pure "foo" :: Maybe String)+ , example "Maybe [Identity Char]" "\"xy\"" (pure [pure 'x', pure 'y'] :: Maybe [Identity Char]) - , Example "Day; year >= 1000" "\"1999-10-12\"" (fromGregorian 1999 10 12)- , Example "Day; year > 0 && < 1000" "\"0500-03-04\"" (fromGregorian 500 3 4)- , Example "Day; year == 0" "\"0000-02-20\"" (fromGregorian 0 2 20)- , Example "Day; year < 0" "\"-0234-01-01\"" (fromGregorian (-234) 1 1)- , Example "Day; year < -1000" "\"-1234-01-01\"" (fromGregorian (-1234) 1 1)+ , example "Day; year >= 1000" "\"1999-10-12\"" (fromGregorian 1999 10 12)+ , example "Day; year > 0 && < 1000" "\"0500-03-04\"" (fromGregorian 500 3 4)+ , example "Day; year == 0" "\"0000-02-20\"" (fromGregorian 0 2 20)+ , example "Day; year < 0" "\"-0234-01-01\"" (fromGregorian (-234) 1 1)+ , example "Day; year < -1000" "\"-1234-01-01\"" (fromGregorian (-1234) 1 1) - , Example "Product I Maybe Int" "[1,2]" (Pair (pure 1) (pure 2) :: Product I Maybe Int)- , Example "Product I Maybe Int" "[1,null]" (Pair (pure 1) Nothing :: Product I Maybe Int)- , Example "Product I [] Char" "[\"a\",\"foo\"]" (Pair (pure 'a') "foo" :: Product I [] Char)+ , example "Product I Maybe Int" "[1,2]" (Pair (pure 1) (pure 2) :: Product I Maybe Int)+ , example "Product I Maybe Int" "[1,null]" (Pair (pure 1) Nothing :: Product I Maybe Int)+ , example "Product I [] Char" "[\"a\",\"foo\"]" (Pair (pure 'a') "foo" :: Product I [] Char) - , Example "Sum I [] Int: InL" "{\"InL\":1}" (InL (pure 1) :: Sum I [] Int)- , Example "Sum I [] Int: InR" "{\"InR\":[1,2]}" (InR [1, 2] :: Sum I [] Int)- , Example "Sum I [] Char: InR" "{\"InR\":\"foo\"}" (InR "foo" :: Sum I [] Char)+ , example "Sum I [] Int: InL" "{\"InL\":1}" (InL (pure 1) :: Sum I [] Int)+ , example "Sum I [] Int: InR" "{\"InR\":[1,2]}" (InR [1, 2] :: Sum I [] Int)+ , example "Sum I [] Char: InR" "{\"InR\":\"foo\"}" (InR "foo" :: Sum I [] Char) - , Example "Compose I I Int" "1" (pure 1 :: Compose I I Int)- , Example "Compose I [] Int" "[1]" (pure 1 :: Compose I [] Int)- , Example "Compose [] I Int" "[1]" (pure 1 :: Compose [] I Int)- , Example "Compose [] [] Int" "[[1]]" (pure 1 :: Compose [] [] Int)+ , example "Compose I I Int" "1" (pure 1 :: Compose I I Int)+ , example "Compose I [] Int" "[1]" (pure 1 :: Compose I [] Int)+ , example "Compose [] I Int" "[1]" (pure 1 :: Compose [] I Int)+ , example "Compose [] [] Int" "[[1]]" (pure 1 :: Compose [] [] Int) - , Example "Compose I I Char" "\"x\"" (pure 'x' :: Compose I I Char)- , Example "Compose I [] Char" "\"x\"" (pure 'x' :: Compose I [] Char)- , Example "Compose [] I Char" "\"x\"" (pure 'x' :: Compose [] I Char)- , Example "Compose [] [] Char" "[\"x\"]" (pure 'x' :: Compose [] [] Char)+ , example "Compose I I Char" "\"x\"" (pure 'x' :: Compose I I Char)+ , example "Compose I [] Char" "\"x\"" (pure 'x' :: Compose I [] Char)+ , example "Compose [] I Char" "\"x\"" (pure 'x' :: Compose [] I Char)+ , example "Compose [] [] Char" "[\"x\"]" (pure 'x' :: Compose [] [] Char) - , Example "Compose3 I I I Char" "\"x\"" (pure 'x' :: Compose3 I I I Char)- , Example "Compose3 I I [] Char" "\"x\"" (pure 'x' :: Compose3 I I [] Char)- , Example "Compose3 I [] I Char" "\"x\"" (pure 'x' :: Compose3 I [] I Char)- , Example "Compose3 I [] [] Char" "[\"x\"]" (pure 'x' :: Compose3 I [] [] Char)- , Example "Compose3 [] I I Char" "\"x\"" (pure 'x' :: Compose3 [] I I Char)- , Example "Compose3 [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3 [] I [] Char)- , Example "Compose3 [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3 [] [] I Char)- , Example "Compose3 [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3 [] [] [] Char)+ , example "Compose3 I I I Char" "\"x\"" (pure 'x' :: Compose3 I I I Char)+ , example "Compose3 I I [] Char" "\"x\"" (pure 'x' :: Compose3 I I [] Char)+ , example "Compose3 I [] I Char" "\"x\"" (pure 'x' :: Compose3 I [] I Char)+ , example "Compose3 I [] [] Char" "[\"x\"]" (pure 'x' :: Compose3 I [] [] Char)+ , example "Compose3 [] I I Char" "\"x\"" (pure 'x' :: Compose3 [] I I Char)+ , example "Compose3 [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3 [] I [] Char)+ , example "Compose3 [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3 [] [] I Char)+ , example "Compose3 [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3 [] [] [] Char) - , Example "Compose3' I I I Char" "\"x\"" (pure 'x' :: Compose3' I I I Char)- , Example "Compose3' I I [] Char" "\"x\"" (pure 'x' :: Compose3' I I [] Char)- , Example "Compose3' I [] I Char" "\"x\"" (pure 'x' :: Compose3' I [] I Char)- , Example "Compose3' I [] [] Char" "[\"x\"]" (pure 'x' :: Compose3' I [] [] Char)- , Example "Compose3' [] I I Char" "\"x\"" (pure 'x' :: Compose3' [] I I Char)- , Example "Compose3' [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3' [] I [] Char)- , Example "Compose3' [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3' [] [] I Char)- , Example "Compose3' [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3' [] [] [] Char)+ , example "Compose3' I I I Char" "\"x\"" (pure 'x' :: Compose3' I I I Char)+ , example "Compose3' I I [] Char" "\"x\"" (pure 'x' :: Compose3' I I [] Char)+ , example "Compose3' I [] I Char" "\"x\"" (pure 'x' :: Compose3' I [] I Char)+ , example "Compose3' I [] [] Char" "[\"x\"]" (pure 'x' :: Compose3' I [] [] Char)+ , example "Compose3' [] I I Char" "\"x\"" (pure 'x' :: Compose3' [] I I Char)+ , example "Compose3' [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3' [] I [] Char)+ , example "Compose3' [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3' [] [] I Char)+ , example "Compose3' [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3' [] [] [] Char) - , Example "MyEither Int String: Left" "42" (MyLeft 42 :: MyEither Int String)- , Example "MyEither Int String: Right" "\"foo\"" (MyRight "foo" :: MyEither Int String)+ , example "MyEither Int String: Left" "42" (MyLeft 42 :: MyEither Int String)+ , example "MyEither Int String: Right" "\"foo\"" (MyRight "foo" :: MyEither Int String) -- newtypes from Monoid/Semigroup- , Example "Monoid.Dual Int" "2" (pure 2 :: Monoid.Dual Int)- , Example "Monoid.First Int" "2" (pure 2 :: Monoid.First Int)- , Example "Monoid.Last Int" "2" (pure 2 :: Monoid.Last Int)- , Example "Semigroup.Min Int" "2" (pure 2 :: Semigroup.Min Int)- , Example "Semigroup.Max Int" "2" (pure 2 :: Semigroup.Max Int)- , Example "Semigroup.First Int" "2" (pure 2 :: Semigroup.First Int)- , Example "Semigroup.Last Int" "2" (pure 2 :: Semigroup.Last Int)- , Example "Semigroup.WrappedMonoid Int" "2" (Semigroup.WrapMonoid 2 :: Semigroup.WrappedMonoid Int)- , Example "Semigroup.Option Just" "2" (pure 2 :: Semigroup.Option Int)- , Example "Semigroup.Option Nothing" "null" (Semigroup.Option (Nothing :: Maybe Bool))+ , example "Monoid.Dual Int" "2" (pure 2 :: Monoid.Dual Int)+ , example "Monoid.First Int" "2" (pure 2 :: Monoid.First Int)+ , example "Monoid.Last Int" "2" (pure 2 :: Monoid.Last Int)+ , example "Semigroup.Min Int" "2" (pure 2 :: Semigroup.Min Int)+ , example "Semigroup.Max Int" "2" (pure 2 :: Semigroup.Max Int)+ , example "Semigroup.First Int" "2" (pure 2 :: Semigroup.First Int)+ , example "Semigroup.Last Int" "2" (pure 2 :: Semigroup.Last Int)+ , example "Semigroup.WrappedMonoid Int" "2" (Semigroup.WrapMonoid 2 :: Semigroup.WrappedMonoid Int)+ , example "Semigroup.Option Just" "2" (pure 2 :: Semigroup.Option Int)+ , example "Semigroup.Option Nothing" "null" (Semigroup.Option (Nothing :: Maybe Bool)) ] jsonEncodingExamples :: [Example]@@ -188,9 +201,9 @@ [ -- Maybe serialising is lossy -- https://github.com/bos/aeson/issues/376- Example "Just Nothing" "null" (Just Nothing :: Maybe (Maybe Int))+ example "Just Nothing" "null" (Just Nothing :: Maybe (Maybe Int)) -- infinities cannot be recovered, null is decoded as NaN- , Example "inf :: Double" "null" (Approx $ 1/0 :: Approx Double)+ , example "inf :: Double" "null" (Approx $ 1/0 :: Approx Double) ] jsonDecodingExamples :: [Example]@@ -214,11 +227,15 @@ data Example where Example :: (Eq a, Show a, ToJSON a, FromJSON a)- => String -> L.ByteString -> a -> Example+ => String -> [L.ByteString] -> a -> Example -- empty bytestring will fail, any p [] == False MaybeExample :: (Eq a, Show a, FromJSON a) => String -> L.ByteString -> Maybe a -> Example +example :: (Eq a, Show a, ToJSON a, FromJSON a)+ => String -> L.ByteString -> a -> Example+example n bs x = Example n [bs] x+ data MyEither a b = MyLeft a | MyRight b deriving (Generic, Show, Eq) @@ -230,16 +247,25 @@ parseJSON = genericParseJSON defaultOptions { sumEncoding = UntaggedValue } assertJsonExample :: Example -> Test-assertJsonExample (Example name bs val) = testCase name $ do- assertEqual "encode" bs (encode val)- assertEqual "encode/via value" bs (encode $ toJSON val)- assertEqual "decode" (Just val) (decode bs)+assertJsonExample (Example name bss val) = testCase name $ do+ assertSomeEqual "encode" bss (encode val)+ assertSomeEqual "encode/via value" bss (encode $ toJSON val)+ for_ bss $ \bs ->+ assertEqual "decode" (Just val) (decode bs) assertJsonExample (MaybeExample name bs mval) = testCase name $ assertEqual "decode" mval (decode bs) assertJsonEncodingExample :: Example -> Test-assertJsonEncodingExample (Example name bs val) = testCase name $ do- assertEqual "encode" bs (encode val)- assertEqual "encode/via value" bs (encode $ toJSON val)+assertJsonEncodingExample (Example name bss val) = testCase name $ do+ assertSomeEqual "encode" bss (encode val)+ assertSomeEqual "encode/via value" bss (encode $ toJSON val) assertJsonEncodingExample (MaybeExample name _ _) = testCase name $ assertFailure "cannot encode MaybeExample"++assertSomeEqual :: (Eq a, Show a, Foldable f) => String -> f a -> a -> IO ()+assertSomeEqual preface expected actual+ | actual `elem` expected = return ()+ | otherwise = assertFailure $ preface+ ++ ": expecting one of " ++ show (toList expected)+ ++ ", got " ++ show actual+