aeson 1.4.6.0 → 1.4.7.0
raw patch · 25 files changed
+487/−324 lines, 25 filesdep +base-compat-batteriesdep ~attoparsecdep ~basedep ~base-compatPVP ok
version bump matches the API change (PVP)
Dependencies added: base-compat-batteries
Dependency ranges changed: attoparsec, base, base-compat, base-orphans, bytestring, containers, dlist, generic-deriving, semigroups, template-haskell, th-abstraction, transformers, transformers-compat
API changes (from Hackage documentation)
+ Data.Aeson.Types: parseFail :: String -> Parser a
+ Data.Aeson.Types: rejectUnknownFields :: Options -> Bool
Files
- Data/Aeson.hs +3/−3
- Data/Aeson/Compat.hs +0/−16
- Data/Aeson/Encoding/Builder.hs +0/−1
- Data/Aeson/Encoding/Internal.hs +0/−1
- Data/Aeson/Parser/Internal.hs +44/−45
- Data/Aeson/TH.hs +65/−52
- Data/Aeson/Text.hs +0/−1
- Data/Aeson/Types.hs +2/−0
- Data/Aeson/Types/FromJSON.hs +75/−63
- Data/Aeson/Types/Internal.hs +39/−15
- Data/Aeson/Types/ToJSON.hs +3/−43
- aeson.cabal +8/−14
- attoparsec-iso8601/Data/Attoparsec/Time/Internal.hs +3/−38
- benchmarks/aeson-benchmarks.cabal +0/−1
- changelog.md +60/−0
- tests/Encoders.hs +25/−6
- tests/ErrorMessages.hs +26/−0
- tests/Instances.hs +1/−4
- tests/Options.hs +11/−0
- tests/PropertyGeneric.hs +0/−8
- tests/PropertyKeys.hs +0/−3
- tests/SerializationFormatSpec.hs +0/−4
- tests/Types.hs +0/−2
- tests/UnitTests.hs +114/−4
- tests/golden/generic.expected +8/−0
Data/Aeson.hs view
@@ -149,7 +149,7 @@ import Data.Aeson.Encoding (encodingToLazyByteString) import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, eitherDecodeWith, eitherDecodeStrictWith, jsonEOF, json, jsonEOF', json') import Data.Aeson.Types-import Data.Aeson.Types.Internal (JSONPath, formatError, (<?>))+import Data.Aeson.Types.Internal (formatError) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L @@ -257,7 +257,7 @@ -- | Like 'decodeFileStrict' but returns an error message when decoding fails. eitherDecodeFileStrict :: (FromJSON a) => FilePath -> IO (Either String a) eitherDecodeFileStrict =- fmap (eitherFormatError . eitherDecodeStrictWith jsonEOF ifromJSON) . B.readFile+ fmap eitherDecodeStrict . B.readFile {-# INLINE eitherDecodeFileStrict #-} -- | Like 'decode'' but returns an error message when decoding fails.@@ -274,7 +274,7 @@ -- | Like 'decodeFileStrict'' but returns an error message when decoding fails. eitherDecodeFileStrict' :: (FromJSON a) => FilePath -> IO (Either String a) eitherDecodeFileStrict' =- fmap (eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON) . B.readFile+ fmap eitherDecodeStrict' . B.readFile {-# INLINE eitherDecodeFileStrict' #-} -- $use
− Data/Aeson/Compat.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE CPP #-}--module Data.Aeson.Compat- (- fromStrict- ) where--import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L--fromStrict :: S.ByteString -> L.ByteString-#if MIN_VERSION_bytestring(0, 9, 2)-fromStrict = L.fromChunks . (:[])-#else-fromStrict = L.fromStrict-#endif
Data/Aeson/Encoding/Builder.hs view
@@ -44,7 +44,6 @@ import Data.ByteString.Builder.Prim as BP import Data.ByteString.Builder.Scientific (scientificBuilder) import Data.Char (chr, ord)-import Data.Semigroup ((<>)) import Data.Scientific (Scientific, base10Exponent, coefficient) import Data.Text.Encoding (encodeUtf8BuilderEscaped) import Data.Time (UTCTime(..))
Data/Aeson/Encoding/Internal.hs view
@@ -63,7 +63,6 @@ import Data.ByteString.Builder (Builder, char7, toLazyByteString) import Data.Int import Data.Scientific (Scientific)-import Data.Semigroup (Semigroup ((<>))) import Data.Text (Text) import Data.Time (Day, LocalTime, TimeOfDay, UTCTime, ZonedTime) import Data.Typeable (Typeable)
Data/Aeson/Parser/Internal.hs view
@@ -2,12 +2,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-#if MIN_VERSION_ghc_prim(0,3,1)-{-# LANGUAGE MagicHash #-}-#endif #if __GLASGOW_HASKELL__ <= 710 && __GLASGOW_HASKELL__ >= 706 -- Work around a compiler bug-{-# OPTIONS_GHC -fsimpl-tick-factor=200 #-}+{-# OPTIONS_GHC -fsimpl-tick-factor=300 #-} #endif -- | -- Module: Data.Aeson.Parser.Internal@@ -58,8 +55,10 @@ import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string) import Data.Function (fix) import Data.Functor.Compat (($>))+import Data.Bits (testBit) import Data.Scientific (Scientific) import Data.Text (Text)+import qualified Data.Text.Encoding as TE import Data.Vector (Vector) import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse) import qualified Data.Attoparsec.ByteString as A@@ -67,16 +66,13 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as C+import qualified Data.ByteString.Builder as B import qualified Data.HashMap.Strict as H import qualified Data.Scientific as Sci import Data.Aeson.Parser.Unescape (unescapeText) -#if MIN_VERSION_ghc_prim(0,3,1)-import GHC.Base (Int#, (==#), isTrue#, word2Int#, orI#, andI#)-import GHC.Word (Word8(W8#))-import qualified Data.Text.Encoding as TE-#endif- #define BACKSLASH 92 #define CLOSE_CURLY 125 #define CLOSE_SQUARE 93@@ -323,37 +319,20 @@ -- | Parse a string without a leading quote. 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+jstring_ = do+ s <- A.takeWhile (\w -> w /= DOUBLE_QUOTE && w /= BACKSLASH && not (testBit w 7))+ let txt = TE.decodeUtf8 s+ w <- A.peekWord8+ case w of+ Nothing -> fail "string without end"+ Just DOUBLE_QUOTE -> A.anyWord8 $> txt+ _ -> jstringSlow s -data S = S Int# Int#-#else+jstringSlow :: B.ByteString -> Parser Text+{-# INLINE jstringSlow #-}+jstringSlow s' = {-# SCC "jstringSlow" #-} do s <- A.scan startState go <* A.anyWord8- case unescapeText s of+ case unescapeText (B.append s' s) of Right r -> return r Left err -> fail $ show err where@@ -364,7 +343,6 @@ | otherwise = let a' = c == backslash in Just a' where backslash = BACKSLASH-#endif decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a decodeWith p to s =@@ -390,13 +368,34 @@ L.Done _ v -> case to v of ISuccess a -> Right a IError path msg -> Left (path, msg)- L.Fail _ ctx msg -> Left ([], buildMsg ctx msg)+ L.Fail notparsed ctx msg -> Left ([], buildMsg notparsed ctx msg) where- buildMsg :: [String] -> String -> String- buildMsg [] msg = msg- buildMsg (expectation:_) msg =- msg ++ ". Expecting " ++ expectation+ buildMsg :: L.ByteString -> [String] -> String -> String+ buildMsg notYetParsed [] msg = msg ++ formatErrorLine notYetParsed+ buildMsg notYetParsed (expectation:_) msg =+ msg ++ ". Expecting " ++ expectation ++ formatErrorLine notYetParsed {-# INLINE eitherDecodeWith #-}++-- | Grab the first 100 bytes from the non parsed portion and+-- format to get nicer error messages+formatErrorLine :: L.ByteString -> String+formatErrorLine bs =+ C.unpack .+ -- if formatting results in empty ByteString just return that+ -- otherwise construct the error message with the bytestring builder+ (\bs' ->+ if BSL.null bs'+ then BSL.empty+ else+ B.toLazyByteString $+ B.stringUtf8 " at '" <> B.lazyByteString bs' <> B.stringUtf8 "'"+ ) .+ -- if newline is present cut at that position+ BSL.takeWhile (10 /=) .+ -- remove spaces, CR's, tabs, backslashes and quotes characters+ BSL.filter (`notElem` [9, 13, 32, 34, 47, 92]) .+ -- take 100 bytes+ BSL.take 100 $ bs eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString -> Either (JSONPath, String) a
Data/Aeson/TH.hs view
@@ -116,8 +116,11 @@ , mkLiftParseJSON2 ) where -import Prelude.Compat+import Prelude.Compat hiding (fail) +-- We don't have MonadFail Q, so we should use `fail` from real `Prelude`+import Prelude (fail)+ import Control.Applicative ((<|>)) import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..)) import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)@@ -135,22 +138,15 @@ import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import qualified Data.Monoid as Monoid import Data.Set (Set)-#if MIN_VERSION_template_haskell(2,8,0) import Language.Haskell.TH hiding (Arity)-#else-import Language.Haskell.TH-#endif 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 #if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0)) import Language.Haskell.TH.Syntax (mkNameG_tc) #endif import Text.Printf (printf) 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.HashMap.Strict as H (difference, fromList, keys, lookup, toList) import qualified Data.List.NonEmpty as NE (length, reverse) import qualified Data.Map as M (fromList, keys, lookup , singleton, size) import qualified Data.Semigroup as Semigroup (Option(..))@@ -929,12 +925,32 @@ -> Name -> [Name] -> Name+ -> Bool -> ExpQ-parseRecord jc tvMap argTys opts tName conName fields obj =+parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =+ (if rejectUnknownFields opts+ then infixApp checkUnknownRecords [|(>>)|]+ else id) $ foldl' (\a b -> infixApp a [|(<*>)|] b) (infixApp (conE conName) [|(<$>)|] x) xs where+ tagFieldNameAppender =+ if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id+ knownFields = appE [|H.fromList|] $ listE $+ map (\knownName -> tupE [appE [|T.pack|] $ litE $ stringL knownName, [|()|]]) $+ tagFieldNameAppender $ map nameBase fields+ checkUnknownRecords =+ caseE (appE [|H.keys|] $ infixApp (varE obj) [|H.difference|] knownFields)+ [ match (listP []) (normalB [|return ()|]) []+ , newName "unknownFields" >>=+ \unknownFields -> match (varP unknownFields)+ (normalB $ appE [|fail|] $ infixApp+ (litE (stringL "Unknown fields: "))+ [|(++)|]+ (appE [|show|] (varE unknownFields)))+ []+ ] x:xs = [ [|lookupField|] `appE` dispatchParseJSON jc conName tvMap argTy `appE` litE (stringL $ show tName)@@ -1009,7 +1025,7 @@ , constructorFields = argTys } (Left (_, obj)) = do argTys' <- mapM resolveTypeSynonyms argTys- parseRecord jc tvMap argTys' opts tName conName fields obj+ parseRecord jc tvMap argTys' opts tName conName fields obj True parseArgs jc tvMap tName opts info@ConstructorInfo { constructorName = conName , constructorVariant = RecordConstructor fields@@ -1024,7 +1040,7 @@ argTys' <- mapM resolveTypeSynonyms argTys caseE (varE valName) [ match (conP 'Object [varP obj]) (normalB $- parseRecord jc tvMap argTys' opts tName conName fields obj) []+ parseRecord jc tvMap argTys' opts tName conName fields obj False) [] , matchFailed tName conName "Object" ] @@ -1291,9 +1307,8 @@ tyVarNames :: [Name] tyVarNames = M.keys tvMap - itf <- isTyFamily tyCon- if any (`mentionsName` tyVarNames) lhsArgs- || itf && any (`mentionsName` tyVarNames) tyArgs+ itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs+ if any (`mentionsName` tyVarNames) lhsArgs || itf then outOfPlaceTyVarError jc conName else if any (`mentionsName` tyVarNames) rhsArgs then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs)@@ -1590,21 +1605,13 @@ -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{} = True-#if MIN_VERSION_template_haskell(2,8,0) hasKindStar (SigT _ StarT) = True-#else-hasKindStar (SigT _ StarK) = True-#endif hasKindStar _ = False -- Returns True is a kind is equal to *, or if it is a kind variable. isStarOrVar :: Kind -> Bool-#if MIN_VERSION_template_haskell(2,8,0) isStarOrVar StarT = True isStarOrVar VarT{} = True-#else-isStarOrVar StarK = True-#endif isStarOrVar _ = False -- Generate a list of fresh names with a common prefix, and numbered suffixes.@@ -1652,21 +1659,44 @@ isTyVar (SigT t _) = isTyVar t isTyVar _ = False --- | Is the given type a type family constructor (and not a data family constructor)?-isTyFamily :: Type -> Q Bool-isTyFamily (ConT n) = do- info <- reify n- return $ case info of+-- | Detect if a Name in a list of provided Names occurs as an argument to some+-- type family. This makes an effort to exclude /oversaturated/ arguments to+-- type families. For instance, if one declared the following type family:+--+-- @+-- type family F a :: Type -> Type+-- @+--+-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,+-- but not @b@.+isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool+isInTypeFamilyApp names tyFun tyArgs =+ case tyFun of+ ConT tcName -> go tcName+ _ -> return False+ where+ go :: Name -> Q Bool+ go tcName = do+ info <- reify tcName+ case info of #if MIN_VERSION_template_haskell(2,11,0)- FamilyI OpenTypeFamilyD{} _ -> True+ FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _+ -> withinFirstArgs bndrs+ FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _+ -> withinFirstArgs bndrs #else- FamilyI (FamilyD TypeFam _ _ _) _ -> True-#endif-#if MIN_VERSION_template_haskell(2,9,0)- FamilyI ClosedTypeFamilyD{} _ -> True+ FamilyI (FamilyD TypeFam _ bndrs _) _+ -> withinFirstArgs bndrs+ FamilyI (ClosedTypeFamilyD _ bndrs _ _) _+ -> withinFirstArgs bndrs #endif- _ -> False-isTyFamily _ = return False+ _ -> return False+ where+ withinFirstArgs :: [a] -> Q Bool+ withinFirstArgs bndrs =+ let firstArgs = take (length bndrs) tyArgs+ argFVs = freeVariables firstArgs+ in return $ any (`elem` argFVs) names -- | Peel off a kind signature from a Type (if it has one). unSigT :: Type -> Type@@ -1692,9 +1722,7 @@ go :: Type -> [Name] -> Bool go (AppT t1 t2) names = go t1 names || go t2 names go (SigT t _k) names = go t names-#if MIN_VERSION_template_haskell(2,8,0) || go _k names-#endif go (VarT n) names = n `elem` names go _ _ = False @@ -1750,23 +1778,14 @@ -- | Like uncurryType, except on a kind level. uncurryKind :: Kind -> NonEmpty Kind-#if MIN_VERSION_template_haskell(2,8,0) uncurryKind = snd . uncurryTy-#else-uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2-uncurryKind k = k :| []-#endif createKindChain :: Int -> Kind createKindChain = go starK where go :: Kind -> Int -> Kind go k 0 = k-#if MIN_VERSION_template_haskell(2,8,0) go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)-#else- go k !n = go (ArrowK StarK k) (n - 1)-#endif -- | Makes a string literal expression from a constructor's name. conNameExp :: Options -> ConstructorInfo -> Q Exp@@ -1820,11 +1839,7 @@ ------------------------------------------------------------------------------- applySubstitutionKind :: Map Name Kind -> Type -> Type-#if MIN_VERSION_template_haskell(2,8,0) applySubstitutionKind = applySubstitution-#else-applySubstitutionKind _ t = t-#endif substNameWithKind :: Name -> Kind -> Type -> Type substNameWithKind n k = applySubstitutionKind (M.singleton n k)@@ -1988,9 +2003,7 @@ canRealizeKindStar :: Type -> StarKindStatus canRealizeKindStar t = case t of _ | hasKindStar t -> KindStar-#if MIN_VERSION_template_haskell(2,8,0) SigT _ (VarT k) -> IsKindVar k-#endif _ -> NotKindStar -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.
Data/Aeson/Text.hs view
@@ -26,7 +26,6 @@ import Data.Aeson.Types (Value(..), ToJSON(..)) import Data.Aeson.Encoding (encodingToLazyByteString)-import Data.Semigroup ((<>)) import Data.Scientific (FPFormat(..), Scientific, base10Exponent) import Data.Text.Lazy.Builder import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)
Data/Aeson/Types.hs view
@@ -35,6 +35,7 @@ , parse , parseEither , parseMaybe+ , parseFail , ToJSON(..) , KeyValue(..) , modifyFailure@@ -124,6 +125,7 @@ , sumEncoding , unwrapUnaryRecords , tagSingleConstructors+ , rejectUnknownFields -- ** Options utilities , SumEncoding(..)
Data/Aeson/Types/FromJSON.hs view
@@ -7,16 +7,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif- #include "incoherent-compat.h" #include "overlapping-compat.h" @@ -98,7 +96,6 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe)-import Data.Semigroup ((<>)) import Data.Proxy (Proxy(..)) import Data.Ratio ((%), Ratio) import Data.Scientific (Scientific, base10Exponent)@@ -120,9 +117,9 @@ import Numeric.Natural (Natural) import Text.ParserCombinators.ReadP (readP_to_S) import Unsafe.Coerce (unsafeCoerce)-import qualified Data.Aeson.Compat as Compat import qualified Data.Aeson.Parser.Time as Time import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)+import qualified Data.ByteString.Lazy as L import qualified Data.DList as DList import qualified Data.HashMap.Strict as H import qualified Data.HashSet as HashSet@@ -157,18 +154,8 @@ import qualified Data.Primitive.PrimArray as PM #endif -#ifndef HAS_COERCIBLE-#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)-#endif -#if HAS_COERCIBLE import Data.Coerce (Coercible, coerce)-coerce' :: Coercible a b => a -> b-coerce' = coerce-#else-coerce' :: a -> b-coerce' = unsafeCoerce-#endif parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a parseIndexedJSON p idx value = p value <?> Index idx@@ -440,11 +427,7 @@ -- At the moment this type is intentionally not exported. 'FromJSONKeyFunction' -- can be inspected, but cannot be constructed. data CoerceText a where-#if HAS_COERCIBLE CoerceText :: Coercible Text a => CoerceText a-#else- CoerceText :: CoerceText a-#endif -- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the -- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'@@ -464,7 +447,7 @@ -- | Only law abiding up to interpretation instance Functor FromJSONKeyFunction where- fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce) fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f) fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f) fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)@@ -478,9 +461,7 @@ -- -- On pre GHC 7.8 this is unconstrainted function. fromJSONKeyCoerce ::-#if HAS_COERCIBLE Coercible Text a =>-#endif FromJSONKeyFunction a fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText @@ -488,29 +469,18 @@ -- -- See note on 'fromJSONKeyCoerce'. coerceFromJSONKeyFunction ::-#if HAS_COERCIBLE Coercible a b =>-#endif FromJSONKeyFunction a -> FromJSONKeyFunction b-#if HAS_COERCIBLE coerceFromJSONKeyFunction = coerce-#else-coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText-coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)-coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)-coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)-#endif {-# RULES "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a). fmap id x = x #-}-#if HAS_COERCIBLE {-# RULES "FromJSONKeyCoerce: fmap coerce" forall x . fmap coerce x = coerceFromJSONKeyFunction x #-}-#endif -- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'. mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b@@ -797,13 +767,13 @@ -- | A variant of 'withBoundedScientific_' parameterized by a function to apply -- to the 'Parser' in case of failure. withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a-withBoundedScientific_ whenFail f v@(Number scientific) =- if exponent > 1024+withBoundedScientific_ whenFail f (Number scientific) =+ if exp10 > 1024 then whenFail (fail msg) else f scientific where- exponent = base10Exponent scientific- msg = "found a number with exponent " ++ show exponent ++ ", but it must not be greater than 1024"+ exp10 = base10Exponent scientific+ msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024" withBoundedScientific_ whenFail _ v = whenFail (typeMismatch "Number" v) {-# INLINE withBoundedScientific_ #-}@@ -823,7 +793,7 @@ -- | Decode a nested JSON-encoded string. withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a withEmbeddedJSON _ innerParser (String txt) =- either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)+ either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt) where eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON eitherFormatError = either (Left . uncurry formatError) Right@@ -1230,9 +1200,9 @@ :: String :* ConName :* TypeName :* Options :* FromArgs arity a -> Object -> Tagged isRecord (Parser (f a)) -instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where+instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where -- Records are unpacked in the tagged object- parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p) instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where -- Nonnullary nonrecords are encoded in the contents field@@ -1273,11 +1243,11 @@ ) => ConsFromJSON' arity (S1 s a) True where consParseJSON' p@(cname :* tname :* opts :* fargs) | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs- | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p)+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p)) instance RecordFromJSON arity f => ConsFromJSON' arity f True where consParseJSON' p@(cname :* tname :* _) =- Tagged . withObject (showCons cname tname) (recordParseJSON p)+ Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p)) instance OVERLAPPING_ ConsFromJSON' arity U1 False where@@ -1303,21 +1273,55 @@ -------------------------------------------------------------------------------- +class FieldNames f where+ fieldNames :: f a -> [Text] -> [Text]++instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where+ fieldNames _ =+ fieldNames (undefined :: a x) .+ fieldNames (undefined :: b y)++instance (Selector s) => FieldNames (S1 s f) where+ fieldNames _ = (pack (selName (undefined :: M1 _i s _f _p)) :)+ class RecordFromJSON arity f where recordParseJSON+ :: Bool :* ConName :* TypeName :* Options :* FromArgs arity a+ -> Object -> Parser (f a)++instance ( FieldNames f+ , RecordFromJSON' arity f+ ) => RecordFromJSON arity f where+ recordParseJSON (fromTaggedSum :* p@(cname :* tname :* opts :* _)) =+ \obj -> checkUnknown obj >> recordParseJSON' p obj+ where+ knownFields :: H.HashMap Text ()+ knownFields = H.fromList $ map (,()) $+ fieldNames (undefined :: f a)+ [pack (tagFieldName (sumEncoding opts)) | fromTaggedSum]+ checkUnknown =+ if not (rejectUnknownFields opts)+ then \_ -> return ()+ else \obj -> case H.keys (H.difference obj knownFields) of+ [] -> return ()+ unknownFields -> contextCons cname tname $+ fail ("unknown fields: " ++ show unknownFields)++class RecordFromJSON' arity f where+ recordParseJSON' :: ConName :* TypeName :* Options :* FromArgs arity a -> Object -> Parser (f a) -instance ( RecordFromJSON arity a- , RecordFromJSON arity b- ) => RecordFromJSON arity (a :*: b) where- recordParseJSON p obj =- (:*:) <$> recordParseJSON p obj- <*> recordParseJSON p obj+instance ( RecordFromJSON' arity a+ , RecordFromJSON' arity b+ ) => RecordFromJSON' arity (a :*: b) where+ recordParseJSON' p obj =+ (:*:) <$> recordParseJSON' p obj+ <*> recordParseJSON' p obj instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>- RecordFromJSON arity (S1 s a) where- recordParseJSON (cname :* tname :* opts :* fargs) obj = do+ RecordFromJSON' arity (S1 s a) where+ recordParseJSON' (cname :* tname :* opts :* fargs) obj = do fv <- contextCons cname tname (obj .: label) M1 <$> gParseJSON opts fargs fv <?> Key label where@@ -1325,16 +1329,16 @@ sname = selName (undefined :: M1 _i s _f _p) instance INCOHERENT_ (Selector s, FromJSON a) =>- RecordFromJSON arity (S1 s (K1 i (Maybe a))) where- recordParseJSON (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label+ RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where+ recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label where label = fieldLabelModifier opts sname sname = selName (undefined :: M1 _i s _f _p) -- Parse an Option like a Maybe. instance INCOHERENT_ (Selector s, FromJSON a) =>- RecordFromJSON arity (S1 s (K1 i (Semigroup.Option a))) where- recordParseJSON p obj = wrap <$> recordParseJSON p obj+ RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where+ recordParseJSON' p obj = wrap <$> recordParseJSON' p obj where wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))@@ -1571,12 +1575,22 @@ _ -> Scientific.toRealFloat <$> parseScientificText t instance (FromJSON a, Integral a) => FromJSON (Ratio a) where- parseJSON = withObject "Rational" $ \obj -> do- numerator <- obj .: "numerator"- denominator <- obj .: "denominator"- if denominator == 0- then fail "Ratio denominator was 0"- else pure $ numerator % denominator+ parseJSON (Number x)+ | exp10 <= 1024+ , exp10 >= -1024 = return $! realToFrac x+ | otherwise = prependContext "Ratio" $ fail msg+ where+ exp10 = base10Exponent x+ msg = "found a number with exponent " ++ show exp10+ ++ ", but it must not be greater than 1024 or less than -1024"+ parseJSON o = objParser o+ where+ objParser = withObject "Rational" $ \obj -> do+ numerator <- obj .: "numerator"+ denominator <- obj .: "denominator"+ if denominator == 0+ then fail "Ratio denominator was 0"+ else pure $ numerator % denominator {-# INLINE parseJSON #-} -- | This instance includes a bounds check to prevent maliciously@@ -1991,7 +2005,6 @@ -- primitive ------------------------------------------------------------------------------- -#if MIN_VERSION_base(4,7,0) instance FromJSON a => FromJSON (PM.Array a) where -- note: we could do better than this if vector exposed the data -- constructor in Data.Vector.@@ -2007,7 +2020,6 @@ #if !MIN_VERSION_primitive(0,7,0) instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where parseJSON = fmap Exts.fromList . parseJSON-#endif #endif #endif
Data/Aeson/Types/Internal.hs view
@@ -44,6 +44,7 @@ , parse , parseEither , parseMaybe+ , parseFail , modifyFailure , prependFailure , parserThrowError@@ -64,6 +65,7 @@ , sumEncoding , unwrapUnaryRecords , tagSingleConstructors+ , rejectUnknownFields ) , SumEncoding(..)@@ -93,7 +95,6 @@ import Data.Hashable (Hashable(..)) import Data.List (intercalate) import Data.Scientific (Scientific)-import Data.Semigroup (Semigroup((<>))) import Data.String (IsString(..)) import Data.Text (Text, pack, unpack) import Data.Time (UTCTime)@@ -341,6 +342,10 @@ mappend = (<>) {-# INLINE mappend #-} +-- | Raise a parsing failure with some custom message.+parseFail :: String -> Parser a+parseFail = fail+ apP :: Parser (a -> b) -> Parser a -> Parser b apP d e = do b <- d@@ -580,41 +585,53 @@ -- the constructor tag. If 'False' the encoding will always -- follow the `sumEncoding`. , omitNothingFields :: Bool- -- ^ If 'True' record fields with a 'Nothing' value will be- -- omitted from the resulting object. If 'False' the resulting+ -- ^ If 'True', record fields with a 'Nothing' value will be+ -- omitted from the resulting object. If 'False', the resulting -- object will include those fields mapping to @null@. --+ -- Note that this /does not/ affect parsing: 'Maybe' fields are+ -- optional regardless of the value of 'omitNothingFields', subject+ -- to the note below.+ -- -- === Note -- -- Setting 'omitNothingFields' to 'True' only affects fields which are of- -- type 'Maybe' /uniformly/ in the 'ToJSON' or 'FromJSON' instance. In- -- particular, if the type of a field is declared as a type variable, it+ -- type 'Maybe' /uniformly/ in the 'ToJSON' instance.+ -- In particular, if the type of a field is declared as a type variable, it -- will not be omitted from the JSON object, unless the field is -- specialized upfront in the instance. --+ -- The same holds for 'Maybe' fields being optional in the 'FromJSON' instance.+ -- -- ==== __Example__ -- -- The generic instance for the following type @Fruit@ depends on whether -- the instance head is @Fruit a@ or @Fruit (Maybe a)@. -- -- @- -- data Fruit a =+ -- data Fruit a = Fruit -- { apples :: a -- A field whose type is a type variable. -- , oranges :: 'Maybe' Int- -- }- --- -- options :: 'Options'- -- options = 'defaultOptions' { 'omitNothingFields' = 'True' }+ -- } deriving 'Generic' -- -- -- apples required, oranges optional -- -- Even if 'Data.Aeson.fromJSON' is then specialized to (Fruit ('Maybe' a)).- -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit a) where- -- 'Data.Aeson.fromJSON' = 'Data.Aeson.genericFromJSON' options+ -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit a) -- -- -- apples optional, oranges optional -- -- In this instance, the field apples is uniformly of type ('Maybe' a).- -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit ('Maybe' a)) where- -- 'Data.Aeson.fromJSON' = 'Data.Aeson.genericFromJSON' options+ -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit ('Maybe' a))+ --+ -- options :: 'Options'+ -- options = 'defaultOptions' { 'omitNothingFields' = 'True' }+ --+ -- -- apples always present in the output, oranges is omitted if 'Nothing'+ -- instance 'Data.Aeson.ToJSON' a => 'Data.Aeson.ToJSON' (Fruit a) where+ -- 'Data.Aeson.toJSON' = 'Data.Aeson.genericToJSON' options+ --+ -- -- both apples and oranges are omitted if 'Nothing'+ -- instance 'Data.Aeson.ToJSON' a => 'Data.Aeson.ToJSON' (Fruit ('Maybe' a)) where+ -- 'Data.Aeson.toJSON' = 'Data.Aeson.genericToJSON' options -- @ , sumEncoding :: SumEncoding -- ^ Specifies how to encode constructors of a sum datatype.@@ -624,10 +641,14 @@ , tagSingleConstructors :: Bool -- ^ Encode types with a single constructor as sums, -- so that `allNullaryToStringTag` and `sumEncoding` apply.+ , rejectUnknownFields :: Bool+ -- ^ Applies only to 'Data.Aeson.FromJSON' instances. If a field appears in+ -- the parsed object map, but does not appear in the target object, parsing+ -- will fail, with an error message indicating which fields were unknown. } instance Show Options where- show (Options f c a o s u t) =+ show (Options f c a o s u t r) = "Options {" ++ intercalate ", " [ "fieldLabelModifier =~ " ++ show (f "exampleField")@@ -637,6 +658,7 @@ , "sumEncoding = " ++ show s , "unwrapUnaryRecords = " ++ show u , "tagSingleConstructors = " ++ show t+ , "rejectUnknownFields = " ++ show r ] ++ "}" @@ -718,6 +740,7 @@ -- , 'sumEncoding' = 'defaultTaggedObject' -- , 'unwrapUnaryRecords' = False -- , 'tagSingleConstructors' = False+-- , 'rejectUnknownFields' = False -- } -- @ defaultOptions :: Options@@ -729,6 +752,7 @@ , sumEncoding = defaultTaggedObject , unwrapUnaryRecords = False , tagSingleConstructors = False+ , rejectUnknownFields = False } -- | Default 'TaggedObject' 'SumEncoding' options:
Data/Aeson/Types/ToJSON.hs view
@@ -8,15 +8,12 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 706-{-# LANGUAGE PolyKinds #-}-#endif- #include "overlapping-compat.h" #include "incoherent-compat.h" @@ -82,7 +79,6 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty(..))-import Data.Semigroup ((<>)) import Data.Proxy (Proxy(..)) import Data.Ratio (Ratio, denominator, numerator) import Data.Scientific (Scientific)@@ -103,7 +99,6 @@ import Numeric.Natural (Natural) import qualified Data.Aeson.Encoding as E import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding)-import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.DList as DList import qualified Data.HashMap.Strict as H@@ -144,14 +139,6 @@ import qualified Data.Primitive.PrimArray as PM #endif -#if !(MIN_VERSION_bytestring(0,10,0))-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Marshal.Utils (copyBytes)-import Foreign.Ptr (plusPtr)-import qualified Data.ByteString.Internal as S-import qualified Data.ByteString.Lazy.Internal as L-#endif- toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b) {-# INLINE toJSONPair #-}@@ -515,7 +502,7 @@ -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm tot = T.dropAround (== '"') . T.decodeLatin1- . lazyToStrictByteString+ . L.toStrict . E.encodingToLazyByteString . e @@ -1982,7 +1969,6 @@ -- primitive ------------------------------------------------------------------------------- -#if MIN_VERSION_base(4,7,0) instance ToJSON a => ToJSON (PM.Array a) where -- note: we could do better than this if vector exposed the data -- constructor in Data.Vector.@@ -2004,7 +1990,6 @@ toEncoding = toEncoding . Exts.toList #endif #endif-#endif ------------------------------------------------------------------------------- -- time@@ -2054,7 +2039,7 @@ stringEncoding = String . T.dropAround (== '"') . T.decodeLatin1- . lazyToStrictByteString+ . L.toStrict . E.encodingToLazyByteString {-# INLINE stringEncoding #-} @@ -2860,31 +2845,6 @@ {-# INLINE toJSON #-} toEncoding = toEncoding2 {-# INLINE toEncoding #-}------------------------------------------------------------------------------------ pre-bytestring-0.10 compatibility----------------------------------------------------------------------------------{-# INLINE lazyToStrictByteString #-}-lazyToStrictByteString :: L.ByteString -> S.ByteString-#if MIN_VERSION_bytestring(0,10,0)-lazyToStrictByteString = L.toStrict-#else-lazyToStrictByteString = packChunks---- packChunks is taken from the blaze-builder package.---- | Pack the chunks of a lazy bytestring into a single strict bytestring.-packChunks :: L.ByteString -> S.ByteString-packChunks lbs =- S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs)- where- copyChunks L.Empty _pf = return ()- copyChunks (L.Chunk (S.PS fpbuf o l) lbs') pf = do- withForeignPtr fpbuf $ \pbuf ->- copyBytes pf (pbuf `plusPtr` o) l- copyChunks lbs' (pf `plusPtr` l)-#endif --------------------------------------------------------------------------------
aeson.cabal view
@@ -1,5 +1,5 @@ name: aeson-version: 1.4.6.0+version: 1.4.7.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON@@ -88,7 +88,6 @@ Data.Aeson.Encode other-modules:- Data.Aeson.Compat Data.Aeson.Encoding.Builder Data.Aeson.Internal.Functions Data.Aeson.Parser.Unescape@@ -103,11 +102,12 @@ -- GHC bundled libs build-depends:- base >= 4.5.0.0 && < 5,- containers >= 0.4.2.1 && < 0.7,+ base >= 4.7.0.0 && < 5,+ bytestring >= 0.10.4.0 && < 0.11,+ containers >= 0.5.5.1 && < 0.7, deepseq >= 1.3.0.0 && < 1.5, ghc-prim >= 0.2 && < 0.6,- template-haskell >= 2.7.0.0 && < 2.16,+ template-haskell >= 2.9.0.0 && < 2.16, text >= 1.2.3.0 && < 1.3, time >= 1.4 && < 1.10 @@ -116,14 +116,8 @@ -- Compat build-depends:- base-compat >= 0.9.1 && < 0.12,- time-compat >= 1.9.2.2 && < 1.10-- if flag(bytestring-builder)- build-depends: bytestring >= 0.9.2.1 && < 0.10.4,- bytestring-builder >= 0.10.4 && < 1- else- build-depends: bytestring >= 0.10.4 && < 0.11+ base-compat-batteries >= 0.10.0 && < 0.12,+ time-compat >= 1.9.2.2 && < 1.10 if !impl(ghc >= 8.6) build-depends:@@ -227,7 +221,7 @@ dlist, Diff >= 0.4 && < 0.5, filepath,- generic-deriving >= 1.10 && < 1.13,+ generic-deriving >= 1.10 && < 1.14, ghc-prim >= 0.2, hashable >= 1.2.4.0, scientific,
attoparsec-iso8601/Data/Attoparsec/Time/Internal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} -- | -- Module: Data.Aeson.Internal.Time@@ -19,50 +18,16 @@ import Prelude.Compat +import Data.Fixed (Fixed(MkFixed), Pico) import Data.Int (Int64)-import Data.Time-import Unsafe.Coerce (unsafeCoerce)--#if MIN_VERSION_time(1,6,0)--import Data.Time.Clock (diffTimeToPicoseconds)--#endif--#if MIN_VERSION_base(4,7,0)--import Data.Fixed (Pico, Fixed(MkFixed))--#else--import Data.Fixed (Pico)--#endif--#if !MIN_VERSION_time(1,6,0)--diffTimeToPicoseconds :: DiffTime -> Integer-diffTimeToPicoseconds = unsafeCoerce--#endif--#if MIN_VERSION_base(4,7,0)+import Data.Time (TimeOfDay(..))+import Data.Time.Clock.Compat toPico :: Integer -> Pico toPico = MkFixed fromPico :: Pico -> Integer fromPico (MkFixed i) = i--#else--toPico :: Integer -> Pico-toPico = unsafeCoerce--fromPico :: Pico -> Integer-fromPico = unsafeCoerce--#endif -- | Like TimeOfDay, but using a fixed-width integer for seconds. data TimeOfDay64 = TOD {-# UNPACK #-} !Int
benchmarks/aeson-benchmarks.cabal view
@@ -72,7 +72,6 @@ exposed-modules: Data.Aeson- Data.Aeson.Compat Data.Aeson.Encoding Data.Aeson.Encoding.Builder Data.Aeson.Encoding.Internal
changelog.md view
@@ -1,5 +1,65 @@ 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.4.7.0++Long overdue release (once again), so there's quite a bit of stuff+included even though it's a "minor" release. Big thanks to all the+contributors, the project would not exist without you!++Special thanks to Oleg Grenrus and Xia Li-Yao for reviewing tons+of stuff.++New stuff:++* Add `rejectUnknownFields` to Options which rejects unknown fields on+ deserialization. Useful to find errors during development, but+ enabling this should be considered a breaking change as previously+ accepted inputs may now be rejected. Thanks to rmanne.++```+instance FromJSON Foo where+ parseJSON = gParseJSON defaultOptions { rejectUnknownFields = True }+```++* `FromJSON` instance of `Ratio a` now parses numbers in addtion to+ standard `{numerator=..., denumerator=...}` encoding. Thanks to+ Aleksey Khudyakov.++* Add more information to parse errors, including a sample of the+ surrounding text. Hopefully this will lead to less "Failed to read:+ satisfy" confusion! Thanks to Sasha Bogicevic. We expect some+ downstream test suites to break because of this, apologies in+ advance. Hopefully you will like the improvement anyway :-)++* Add `parseFail` to `Data.Aeson.Types`. `parseFail = fail` but+ doesn't require users to know about `MonadFail`. Thanks to Colin+ Woodbury.++* Make Template Haskell type family detection smarter when deriving+ `ToJSON1` instances, thanks to Ryan Scott.++* Optimize string parsing for the common case of strings without+ escapes, thanks to Yuras.+++Misc:++* Clean up compiler warnings and switch from base-compat to+ base-compat-batteries. Thanks to Colin Woodbury & Oleg Grenrus.++* Clarification & fixes to documentation regarding treatment of Maybe fields, thanks to Roman Cheplyaka.++* Add documentation for internal development workflows. Thanks to Guru+ Devanla.++* Drop support for GHC < 7.8. We've chosen to support older GHCs as+ long as it doesn't prevent us from adding new features, but now it+ does! Thanks to Oleg Grenrus for the patch.++* Allow generic-deriving 1.13 in test suite.++* Some DRY fixes thanks to Mark Fajkus.+ ### 1.4.6.0 * Provide a clearer error message when a required tagKey for a constructor is missing, thanks to Guru Devanla.
tests/Encoders.hs view
@@ -188,7 +188,6 @@ gSomeTypeParseJSON2ElemArray :: Value -> Parser (SomeType Int) gSomeTypeParseJSON2ElemArray = genericParseJSON opts2ElemArray -#if __GLASGOW_HASKELL__ >= 706 gSomeTypeLiftToEncoding2ElemArray :: LiftToEncoding SomeType a gSomeTypeLiftToEncoding2ElemArray = genericLiftToEncoding opts2ElemArray @@ -197,7 +196,6 @@ gSomeTypeLiftParseJSON2ElemArray :: LiftParseJSON SomeType a gSomeTypeLiftParseJSON2ElemArray = genericLiftParseJSON opts2ElemArray-#endif gSomeTypeToJSONTaggedObject :: SomeType Int -> Value@@ -209,7 +207,6 @@ gSomeTypeParseJSONTaggedObject :: Value -> Parser (SomeType Int) gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject -#if __GLASGOW_HASKELL__ >= 706 gSomeTypeLiftToEncodingTaggedObject :: LiftToEncoding SomeType a gSomeTypeLiftToEncodingTaggedObject = genericLiftToEncoding optsTaggedObject @@ -218,7 +215,6 @@ gSomeTypeLiftParseJSONTaggedObject :: LiftParseJSON SomeType a gSomeTypeLiftParseJSONTaggedObject = genericLiftParseJSON optsTaggedObject-#endif gSomeTypeToJSONObjectWithSingleField :: SomeType Int -> Value@@ -230,7 +226,6 @@ gSomeTypeParseJSONObjectWithSingleField :: Value -> Parser (SomeType Int) gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField -#if __GLASGOW_HASKELL__ >= 706 gSomeTypeLiftToEncodingObjectWithSingleField :: LiftToEncoding SomeType a gSomeTypeLiftToEncodingObjectWithSingleField = genericLiftToEncoding optsObjectWithSingleField @@ -239,7 +234,6 @@ gSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a gSomeTypeLiftParseJSONObjectWithSingleField = genericLiftParseJSON optsObjectWithSingleField-#endif gSomeTypeToJSONOmitNothingFields :: SomeType Int -> Value@@ -247,6 +241,31 @@ gSomeTypeToEncodingOmitNothingFields :: SomeType Int -> Encoding gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields+++thSomeTypeParseJSONRejectUnknownFields :: Value -> Parser (SomeType Int)+thSomeTypeParseJSONRejectUnknownFields = $(mkParseJSON optsRejectUnknownFields ''SomeType)++gSomeTypeParseJSONRejectUnknownFields :: Value -> Parser (SomeType Int)+gSomeTypeParseJSONRejectUnknownFields = genericParseJSON optsRejectUnknownFields+++--------------------------------------------------------------------------------+-- Foo decoders+--------------------------------------------------------------------------------++thFooParseJSONRejectUnknownFields :: Value -> Parser Foo+thFooParseJSONRejectUnknownFields = $(mkParseJSON optsRejectUnknownFields ''Foo)++gFooParseJSONRejectUnknownFields :: Value -> Parser Foo+gFooParseJSONRejectUnknownFields = genericParseJSON optsRejectUnknownFields+++thFooParseJSONRejectUnknownFieldsTagged :: Value -> Parser Foo+thFooParseJSONRejectUnknownFieldsTagged = $(mkParseJSON optsRejectUnknownFieldsTagged ''Foo)++gFooParseJSONRejectUnknownFieldsTagged :: Value -> Parser Foo+gFooParseJSONRejectUnknownFieldsTagged = genericParseJSON optsRejectUnknownFieldsTagged --------------------------------------------------------------------------------
tests/ErrorMessages.hs view
@@ -136,6 +136,29 @@ , "[1," ] + , testWithSomeType "SomeType (reject unknown fields)"+ (select+ thSomeTypeParseJSONRejectUnknownFields+ gSomeTypeParseJSONRejectUnknownFields)+ [ "{\"tag\": \"record\", \"testOne\": 1.0, \"testZero\": 1}"+ , "{\"testZero\": 1}"+ , "{\"tag\": \"record\", \"testone\": true, \"testtwo\": null, \"testthree\": null}"+ ]++ , testWithFoo "Foo (reject unknown fields)"+ (select+ thFooParseJSONRejectUnknownFields+ gFooParseJSONRejectUnknownFields)+ [ "{\"tag\": \"foo\"}"+ ]++ , testWithFoo "Foo (reject unknown fields, tagged single)"+ (select+ thFooParseJSONRejectUnknownFieldsTagged+ gFooParseJSONRejectUnknownFieldsTagged)+ [ "{\"tag\": \"foo\", \"unknownField\": 0}"+ ]+ , testWith "EitherTextInt" (select thEitherTextIntParseJSONUntaggedValue@@ -196,3 +219,6 @@ testWithSomeType :: String -> (Value -> Parser (SomeType Int)) -> [L.ByteString] -> Output testWithSomeType = testWith++testWithFoo :: String -> (Value -> Parser Foo) -> [L.ByteString] -> Output+testWithFoo = testWith
tests/Instances.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-}@@ -25,14 +24,12 @@ import Data.Orphans () import Test.QuickCheck.Instances ()-#if MIN_VERSION_base(4,7,0) import Data.Hashable.Time ()-#endif -- "System" types. instance Arbitrary DotNetTime where- arbitrary = DotNetTime `liftM` arbitrary+ arbitrary = DotNetTime `fmap` arbitrary shrink = map DotNetTime . shrink . fromDotNetTime -- | Compare timezone part only on 'timeZoneMinutes'
tests/Options.hs view
@@ -55,3 +55,14 @@ { fieldLabelModifier = const "field" , omitNothingFields = True }++optsRejectUnknownFields :: Options+optsRejectUnknownFields = optsDefault+ { rejectUnknownFields = True+ }++optsRejectUnknownFieldsTagged :: Options+optsRejectUnknownFieldsTagged = optsDefault+ { rejectUnknownFields = True+ , tagSingleConstructors = True+ }
tests/PropertyGeneric.hs view
@@ -44,11 +44,9 @@ , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject) , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField) -#if __GLASGOW_HASKELL__ >= 706 , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray) , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject) , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField)-#endif ] ] , testGroup "OneConstructor" [@@ -85,30 +83,24 @@ , testProperty "SomeType2ElemArray" $ gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray-#if __GLASGOW_HASKELL__ >= 706 , testProperty "SomeType2ElemArray unary" $ gSomeTypeLiftToJSON2ElemArray `sameAs1` gSomeTypeLiftToEncoding2ElemArray , testProperty "SomeType2ElemArray unary agree" $ gSomeTypeToEncoding2ElemArray `sameAs1Agree` gSomeTypeLiftToEncoding2ElemArray-#endif , testProperty "SomeTypeTaggedObject" $ gSomeTypeToJSONTaggedObject `sameAs` gSomeTypeToEncodingTaggedObject-#if __GLASGOW_HASKELL__ >= 706 , testProperty "SomeTypeTaggedObject unary" $ gSomeTypeLiftToJSONTaggedObject `sameAs1` gSomeTypeLiftToEncodingTaggedObject , testProperty "SomeTypeTaggedObject unary agree" $ gSomeTypeToEncodingTaggedObject `sameAs1Agree` gSomeTypeLiftToEncodingTaggedObject-#endif , testProperty "SomeTypeObjectWithSingleField" $ gSomeTypeToJSONObjectWithSingleField `sameAs` gSomeTypeToEncodingObjectWithSingleField-#if __GLASGOW_HASKELL__ >= 706 , testProperty "SomeTypeObjectWithSingleField unary" $ gSomeTypeLiftToJSONObjectWithSingleField `sameAs1` gSomeTypeLiftToEncodingObjectWithSingleField , testProperty "SomeTypeObjectWithSingleField unary agree" $ gSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` gSomeTypeLiftToEncodingObjectWithSingleField-#endif , testProperty "SomeTypeOmitNothingFields" $ gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields
tests/PropertyKeys.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} module PropertyKeys ( keysTests ) where@@ -31,12 +30,10 @@ , testProperty "Natural" $ roundTripKey (undefined :: Natural) , testProperty "Float" $ roundTripKey (undefined :: Float) , testProperty "Double" $ roundTripKey (undefined :: Double)-#if MIN_VERSION_base(4,7,0) , testProperty "Day" $ roundTripKey (undefined :: Day) , testProperty "LocalTime" $ roundTripKey (undefined :: LocalTime) , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay) , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)-#endif , testProperty "Version" $ roundTripKey (undefined :: Version) , testProperty "Lazy Text" $ roundTripKey (undefined :: LT.Text) , testProperty "UUID" $ roundTripKey UUID.nil
tests/SerializationFormatSpec.hs view
@@ -3,9 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DataKinds #-}-#endif ------------------------------------------------------------------------------ -- These tests assert that the JSON serialization doesn't change by accident.@@ -77,10 +75,8 @@ , 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)-#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)
tests/Types.hs view
@@ -119,9 +119,7 @@ deriving instance Generic (Approx a) deriving instance Generic Nullary deriving instance Generic (SomeType a)-#if __GLASGOW_HASKELL__ >= 706 deriving instance Generic1 SomeType-#endif deriving instance Generic OptionField deriving instance Generic EitherTextInt
tests/UnitTests.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE QuasiQuotes #-} -- For Data.Aeson.Types.camelTo@@ -33,15 +34,15 @@ ( json, jsonLast, jsonAccum, jsonNoDup , json', jsonLast', jsonAccum', jsonNoDup') import Data.Aeson.Types- ( Options(..), Result(Success), ToJSON(..), Value(Array, Bool, Null, Object)- , camelTo, camelTo2, defaultOptions, formatPath, formatRelativePath- , omitNothingFields, parse)+ ( Options(..), Result(Success, Error), ToJSON(..)+ , Value(Array, Bool, Null, Number, Object, String), camelTo, camelTo2+ , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse) import Data.Attoparsec.ByteString (Parser, parseOnly) import Data.Char (toUpper) import Data.Either.Compat (isLeft, isRight) import Data.Hashable (hash) import Data.HashMap.Strict (HashMap)-import Data.List (sort)+import Data.List (sort, isSuffixOf) import Data.Maybe (fromMaybe) import Data.Scientific (Scientific, scientific) import Data.Tagged (Tagged(..))@@ -112,8 +113,12 @@ , testGroup "SingleMaybeField" singleMaybeField , testCase "withEmbeddedJSON" withEmbeddedJSONTest , testCase "SingleFieldCon" singleFieldCon+ , testGroup "UnknownFields" unknownFields , testGroup "Ordering of object keys" keyOrdering , testCase "Ratio with denominator 0" ratioDenominator0+ , testCase "Rational parses number" rationalNumber+ , testCase "Big rational" bigRationalDecoding+ , testCase "Small rational" smallRationalDecoding , testCase "Big scientific exponent" bigScientificExponent , testCase "Big integer decoding" bigIntegerDecoding , testCase "Big natural decading" bigNaturalDecoding@@ -536,6 +541,7 @@ ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}" ++ ", unwrapUnaryRecords = False" ++ ", tagSingleConstructors = False"+ ++ ", rejectUnknownFields = False" ++ "}") (show defaultOptions) @@ -580,6 +586,79 @@ singleFieldCon = assertEqual "fromJSON" (Right (SingleFieldCon 0)) (eitherDecode "0") +newtype UnknownFields = UnknownFields { knownField :: Int }+ deriving (Eq, Show, Generic)+newtype UnknownFieldsTag = UnknownFieldsTag { tag :: Int }+ deriving (Eq, Show, Generic)+newtype UnknownFieldsUnaryTagged = UnknownFieldsUnaryTagged { knownFieldUnaryTagged :: Int }+ deriving (Eq, Show, Generic)+data UnknownFieldsSum+ = UnknownFields1 { knownField1 :: Int }+ | UnknownFields2 { knownField2 :: Int }+ deriving (Eq, Show, Generic)++unknownFields :: [TestTree]+unknownFields = concat+ [ testsUnary+ "unary-unknown"+ (object [("knownField", Number 1), ("unknownField", Number 1)])+ (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFields)+ , testsUnary+ "unary-unknown-tag"+ (object [("knownField", Number 1), ("tag", String "UnknownFields")])+ (Error "nknown fields: [\"tag\"]" :: Result UnknownFields)+ , testsUnaryTag+ "unary-explicit-tag"+ (object [("tag", Number 1)])+ (Success $ UnknownFieldsTag 1)+ , testsSum+ "sum-tag"+ (object [("knownField1", Number 1), ("tag", String "UnknownFields1")])+ (Success $ UnknownFields1 1)+ , testsSum+ "sum-unknown-in-branch"+ (object [("knownField1", Number 1), ("knownField2", Number 1), ("tag", String "UnknownFields1")])+ (Error "nknown fields: [\"knownField2\"]" :: Result UnknownFieldsSum)+ , testsSum+ "sum-unknown"+ (object [("knownField1", Number 1), ("unknownField", Number 1), ("tag", String "UnknownFields1")])+ (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFieldsSum)+ , testsTagged+ "unary-tagged"+ (object [("knownFieldUnaryTagged", Number 1), ("tag", String "UnknownFieldsUnaryTagged")])+ (Success $ UnknownFieldsUnaryTagged 1)+ , -- Just a case to verify that the tag isn't optional, this is likely already tested by other unit tests+ testsTagged+ "unary-tagged-notag"+ (object [("knownFieldUnaryTagged", Number 1)])+ (Error "key \"tag\" not found" :: Result UnknownFieldsUnaryTagged)+ , testsTagged+ "unary-tagged-unknown"+ (object [ ("knownFieldUnaryTagged", Number 1), ("unknownField", Number 1)+ , ("tag", String "UnknownFieldsUnaryTagged")])+ (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFieldsUnaryTagged)+ ]+ where+ opts = defaultOptions{rejectUnknownFields=True}+ taggedOpts = opts{tagSingleConstructors=True}+ assertApprox :: (Show a, Eq a) => Result a -> Result a -> IO ()+ assertApprox (Error expected) (Error actual) | expected `isSuffixOf` actual = return ()+ assertApprox expected actual = assertEqual "fromJSON" expected actual+ testsBase :: (Show a, Eq a) => (Value -> Result a) -> (Value -> Result a)+ -> String -> Value -> Result a -> [TestTree]+ testsBase th g name value expected =+ [ testCase (name ++ "-th") $ assertApprox expected (th value)+ , testCase (name ++ "-generic") $ assertApprox expected (g value)+ ]+ testsUnary :: String -> Value -> Result UnknownFields -> [TestTree]+ testsUnary = testsBase fromJSON (parse (genericParseJSON opts))+ testsUnaryTag :: String -> Value -> Result UnknownFieldsTag -> [TestTree]+ testsUnaryTag = testsBase fromJSON (parse (genericParseJSON opts))+ testsSum :: String -> Value -> Result UnknownFieldsSum -> [TestTree]+ testsSum = testsBase fromJSON (parse (genericParseJSON opts))+ testsTagged :: String -> Value -> Result UnknownFieldsUnaryTagged -> [TestTree]+ testsTagged = testsBase fromJSON (parse (genericParseJSON taggedOpts))+ testParser :: (Eq a, Show a) => String -> Parser a -> S.ByteString -> Either String a -> TestTree testParser name json_ s expected =@@ -620,6 +699,25 @@ (Left "Error in $: Ratio denominator was 0") (eitherDecode "{ \"numerator\": 1, \"denominator\": 0 }" :: Either String Rational) +rationalNumber :: Assertion+rationalNumber =+ assertEqual "Ratio with denominator 0"+ (Right 1.37)+ (eitherDecode "1.37" :: Either String Rational)++bigRationalDecoding :: Assertion+bigRationalDecoding =+ assertEqual "Decoding an Integer with a large exponent should fail"+ (Left "Error in $: parsing Ratio failed, found a number with exponent 2000, but it must not be greater than 1024 or less than -1024")+ ((eitherDecode :: L.ByteString -> Either String Rational) "1e2000")++smallRationalDecoding :: Assertion+smallRationalDecoding =+ assertEqual "Decoding an Integer with a large exponent should fail"+ (Left "Error in $: parsing Ratio failed, found a number with exponent -2000, but it must not be greater than 1024 or less than -1024")+ ((eitherDecode :: L.ByteString -> Either String Rational) "1e-2000")++ bigScientificExponent :: Assertion bigScientificExponent = assertEqual "Encoding an integral scientific with a large exponent should normalize it"@@ -650,9 +748,21 @@ (Left "Error in $['1e2000']: found a number with exponent 2000, but it must not be greater than 1024") ((eitherDecode :: L.ByteString -> Either String (HashMap Natural Value)) "{ \"1e2000\": null }") +-- A regression test for: https://github.com/bos/aeson/issues/757+type family Fam757 :: * -> *+type instance Fam757 = Maybe+newtype Newtype757 a = MkNewtype757 (Fam757 a)+ deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord deriveToJSON defaultOptions ''Foo deriveToJSON1 defaultOptions ''Foo deriveJSON defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} ''SingleMaybeField++deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFields+deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsTag+deriveJSON defaultOptions{tagSingleConstructors=True,rejectUnknownFields=True} ''UnknownFieldsUnaryTagged+deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsSum++deriveToJSON1 defaultOptions ''Newtype757
tests/golden/generic.expected view
@@ -31,6 +31,14 @@ Error in $: parsing Types.SomeType failed, expected Array, but encountered Object Error in $: not enough input. Expecting ',' or ']' Error in $: not enough input. Expecting json list value+SomeType (reject unknown fields)+Error in $: parsing Types.SomeType(Record) failed, unknown fields: ["testZero"]+Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found+Error in $: parsing Types.SomeType(Record) failed, unknown fields: ["testtwo","testone","testthree"]+Foo (reject unknown fields)+Error in $: parsing Types.Foo(Foo) failed, unknown fields: ["tag"]+Foo (reject unknown fields, tagged single)+Error in $: parsing Types.Foo(Foo) failed, unknown fields: ["unknownField"] EitherTextInt Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected tag "nonenullary", but found tag "X" Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected String, but encountered Array