aeson 1.4.2.0 → 1.4.3.0
raw patch · 24 files changed
+1533/−961 lines, 24 filesdep +Diffdep +tasty-goldendep ~QuickCheckdep ~th-abstractionPVP ok
version bump matches the API change (PVP)
Dependencies added: Diff, tasty-golden
Dependency ranges changed: QuickCheck, th-abstraction
API changes (from Hackage documentation)
+ Data.Aeson: (<?>) :: Parser a -> JSONPathElement -> Parser a
+ Data.Aeson: parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
+ Data.Aeson: type JSONPath = [JSONPathElement]
+ Data.Aeson.Types: prependFailure :: String -> Parser a -> Parser a
+ Data.Aeson.Types: unexpected :: Value -> Parser a
Files
- Data/Aeson.hs +5/−2
- Data/Aeson/Parser/Internal.hs +11/−6
- Data/Aeson/TH.hs +28/−20
- Data/Aeson/Types.hs +2/−0
- Data/Aeson/Types/Class.hs +1/−0
- Data/Aeson/Types/FromJSON.hs +554/−327
- Data/Aeson/Types/Generic.hs +10/−0
- Data/Aeson/Types/Internal.hs +10/−0
- aeson.cabal +13/−4
- benchmarks/aeson-benchmarks.cabal +1/−1
- changelog.md +14/−0
- tests/DataFamilies/Properties.hs +2/−1
- tests/Encoders.hs +10/−0
- tests/ErrorMessages.hs +172/−44
- tests/PropUtils.hs +208/−0
- tests/Properties.hs +10/−528
- tests/PropertyGeneric.hs +124/−0
- tests/PropertyKeys.hs +43/−0
- tests/PropertyRTFunctors.hs +51/−0
- tests/PropertyRoundTrip.hs +67/−0
- tests/PropertyTH.hs +130/−0
- tests/UnitTests.hs +5/−28
- tests/golden/generic.expected +40/−0
- tests/golden/simple.expected +22/−0
Data/Aeson.hs view
@@ -63,6 +63,8 @@ , fromJSON , ToJSON(..) , KeyValue(..)+ , (<?>)+ , JSONPath -- ** Keys for maps , ToJSONKey(..) , ToJSONKeyFunction(..)@@ -129,15 +131,16 @@ -- * Parsing , json , json'+ , parseIndexedJSON ) where import Prelude.Compat -import Data.Aeson.Types.FromJSON (ifromJSON)+import Data.Aeson.Types.FromJSON (ifromJSON, parseIndexedJSON) 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 (JSONPath, formatError, (<?>)) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L
Data/Aeson/Parser/Internal.hs view
@@ -123,9 +123,9 @@ -- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert' -- and it's much faster because it's doing in place update to the 'HashMap'! loop acc = do- k <- str <* skipSpace <* char ':'- v <- val <* skipSpace- ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_CURLY+ k <- (str A.<?> "object key") <* skipSpace <* (char ':' A.<?> "':'")+ v <- (val A.<?> "object value") <* skipSpace+ ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_CURLY) A.<?> "',' or '}'" let acc' = (k, v) : acc if ch == COMMA then skipSpace >> loop acc'@@ -149,8 +149,8 @@ else loop [] 1 where loop acc !len = do- v <- val <* skipSpace- ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_SQUARE+ v <- (val A.<?> "json list value") <* skipSpace+ ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_SQUARE) A.<?> "',' or ']'" if ch == COMMA then skipSpace >> loop (v:acc) (len+1) else return (Vector.reverse (Vector.fromListN len (v:acc)))@@ -275,7 +275,12 @@ L.Done _ v -> case to v of ISuccess a -> Right a IError path msg -> Left (path, msg)- L.Fail _ _ msg -> Left ([], msg)+ L.Fail _ ctx msg -> Left ([], buildMsg ctx msg)+ where+ buildMsg :: [String] -> String -> String+ buildMsg [] msg = msg+ buildMsg (expectation:_) msg =+ msg ++ ". Expecting " ++ expectation {-# INLINE eitherDecodeWith #-} eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString
Data/Aeson/TH.hs view
@@ -334,13 +334,13 @@ consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: " ++ "Not a single constructor given!" -consToValue target jc opts vars cons = do+consToValue target jc opts instTys 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+ lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys tvMap = M.fromList $ zip lastTyVars zippedTJs lamE (map varP $ interleavedTJs ++ [value]) $ caseE (varE value) (matches tvMap)@@ -672,13 +672,13 @@ consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: " ++ "Not a single constructor given!" -consFromJSON jc tName opts vars cons = do+consFromJSON jc tName opts instTys cons = do value <- newName "value" pjs <- newNameList "_pj" $ arityInt jc pjls <- newNameList "_pjl" $ arityInt jc let zippedPJs = zip pjs pjls interleavedPJs = interleave pjs pjls- lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars+ lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys tvMap = M.fromList $ zip lastTyVars zippedPJs lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap @@ -1209,23 +1209,27 @@ deriveJSONClass consFuns jc opts name = do info <- reifyDatatype name case info of- DatatypeInfo { datatypeContext = ctxt- , datatypeName = parentName- , datatypeVars = vars- , datatypeVariant = variant- , datatypeCons = cons+ DatatypeInfo { datatypeContext = ctxt+ , datatypeName = parentName+#if MIN_VERSION_th_abstraction(0,3,0)+ , datatypeInstTypes = instTys+#else+ , datatypeVars = instTys+#endif+ , datatypeVariant = variant+ , datatypeCons = cons } -> do (instanceCxt, instanceType)- <- buildTypeInstance parentName jc ctxt vars variant+ <- buildTypeInstance parentName jc ctxt instTys variant (:[]) <$> instanceD (return instanceCxt) (return instanceType)- (methodDecs parentName vars cons)+ (methodDecs parentName instTys cons) where methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]- methodDecs parentName vars cons = flip map consFuns $ \(jf, jfMaker) ->+ methodDecs parentName instTys cons = flip map consFuns $ \(jf, jfMaker) -> funD (jsonFunValName jf (arity jc)) [ clause []- (normalB $ jfMaker jc parentName opts vars cons)+ (normalB $ jfMaker jc parentName opts instTys cons) [] ] @@ -1241,17 +1245,21 @@ mkFunCommon consFun jc opts name = do info <- reifyDatatype name case info of- DatatypeInfo { datatypeContext = ctxt- , datatypeName = parentName- , datatypeVars = vars- , datatypeVariant = variant- , datatypeCons = cons+ DatatypeInfo { datatypeContext = ctxt+ , datatypeName = parentName+#if MIN_VERSION_th_abstraction(0,3,0)+ , datatypeInstTypes = instTys+#else+ , datatypeVars = instTys+#endif+ , 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+ !_ <- buildTypeInstance parentName jc ctxt instTys variant+ consFun jc parentName opts instTys cons dispatchFunByType :: JSONClass -> JSONFun
Data/Aeson/Types.hs view
@@ -26,6 +26,7 @@ -- * Convenience types and functions , DotNetTime(..) , typeMismatch+ , unexpected -- * Type conversion , Parser , Result(..)@@ -37,6 +38,7 @@ , ToJSON(..) , KeyValue(..) , modifyFailure+ , prependFailure , parserThrowError , parserCatchError
Data/Aeson/Types/Class.hs view
@@ -79,6 +79,7 @@ , fromJSON , ifromJSON , typeMismatch+ , unexpected , parseField , parseFieldMaybe , parseFieldMaybe'
Data/Aeson/Types/FromJSON.hs view
@@ -61,12 +61,14 @@ , fromJSON , ifromJSON , typeMismatch+ , unexpected , parseField , parseFieldMaybe , parseFieldMaybe' , explicitParseField , explicitParseFieldMaybe , explicitParseFieldMaybe'+ , parseIndexedJSON -- ** Operators , (.:) , (.:?)@@ -79,8 +81,8 @@ import Prelude.Compat -import Control.Applicative ((<|>), Const(..))-import Control.Monad ((<=<), zipWithM)+import Control.Applicative ((<|>), Const(..), liftA2)+import Control.Monad (zipWithM) import Data.Aeson.Internal.Functions (mapKey) import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF) import Data.Aeson.Types.Generic@@ -170,7 +172,7 @@ parseIndexedJSONPair :: (Value -> Parser a) -> (Value -> Parser b) -> Int -> Value -> Parser (a, b) parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx where- p = withArray "(k,v)" $ \ab ->+ p = withArray "(k, v)" $ \ab -> let n = V.length ab in if n == 2 then (,) <$> parseJSONElemAtIndex keyParser 0 ab@@ -183,33 +185,33 @@ parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) <?> Index idx parseRealFloat :: RealFloat a => String -> Value -> Parser a-parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s-parseRealFloat _ Null = pure (0/0)-parseRealFloat expected v = typeMismatch expected v+parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s+parseRealFloat _ Null = pure (0/0)+parseRealFloat name v = prependContext name (unexpected v) {-# INLINE parseRealFloat #-} -parseIntegralFromScientific :: forall a. Integral a => String -> Scientific -> Parser a-parseIntegralFromScientific expected s =+parseIntegralFromScientific :: forall a. Integral a => Scientific -> Parser a+parseIntegralFromScientific s = case Scientific.floatingOrInteger s :: Either Double a of Right x -> pure x- Left _ -> fail $ "expected " ++ expected ++ ", encountered floating number " ++ show s+ Left _ -> fail $ "unexpected floating number " ++ show s {-# INLINE parseIntegralFromScientific #-} parseIntegral :: Integral a => String -> Value -> Parser a-parseIntegral expected =- withBoundedScientific expected $ parseIntegralFromScientific expected+parseIntegral name =+ prependContext name . withBoundedScientific' parseIntegralFromScientific {-# INLINE parseIntegral #-} -parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => String -> Scientific -> Parser a-parseBoundedIntegralFromScientific expected s = maybe- (fail $ expected ++ " is either floating or will cause over or underflow: " ++ show s)+parseBoundedIntegralFromScientific :: (Bounded a, Integral a) => Scientific -> Parser a+parseBoundedIntegralFromScientific s = maybe+ (fail $ "value is either floating or will cause over or underflow " ++ show s) pure (Scientific.toBoundedInteger s) {-# INLINE parseBoundedIntegralFromScientific #-} parseBoundedIntegral :: (Bounded a, Integral a) => String -> Value -> Parser a-parseBoundedIntegral expected =- withScientific expected $ parseBoundedIntegralFromScientific expected+parseBoundedIntegral name =+ prependContext name . withScientific' parseBoundedIntegralFromScientific {-# INLINE parseBoundedIntegral #-} parseScientificText :: Text -> Parser Scientific@@ -219,18 +221,20 @@ . T.encodeUtf8 parseIntegralText :: Integral a => String -> Text -> Parser a-parseIntegralText expected t- = parseScientificText t- >>= rejectLargeExponent- >>= parseIntegralFromScientific expected+parseIntegralText name t =+ prependContext name $+ parseScientificText t+ >>= rejectLargeExponent+ >>= parseIntegralFromScientific where rejectLargeExponent :: Scientific -> Parser Scientific- rejectLargeExponent s = withBoundedScientific expected pure (Number s)+ rejectLargeExponent s = withBoundedScientific' pure (Number s) {-# INLINE parseIntegralText #-} parseBoundedIntegralText :: (Bounded a, Integral a) => String -> Text -> Parser a-parseBoundedIntegralText expected t =- parseScientificText t >>= parseBoundedIntegralFromScientific expected+parseBoundedIntegralText name t =+ prependContext name $+ parseScientificText t >>= parseBoundedIntegralFromScientific parseOptionalFieldWith :: (Value -> Parser (Maybe a)) -> Object -> Text -> Parser (Maybe a)@@ -290,15 +294,22 @@ -- -- The basic ways to signal a failed conversion are as follows: ----- * 'empty' and 'mzero' work, but are terse and uninformative;+-- * 'fail' yields a custom error message: it is the recommended way of+-- reporting a failure; ----- * 'fail' yields a custom error message;+-- * 'Control.Applicative.empty' (or 'Control.Monad.mzero') is uninformative:+-- use it when the error is meant to be caught by some @('<|>')@; ----- * 'typeMismatch' produces an informative message for cases when the--- value encountered is not of the expected type.+-- * 'typeMismatch' can be used to report a failure when the encountered value+-- is not of the expected JSON type; 'unexpected' is an appropriate alternative+-- when more than one type may be expected, or to keep the expected type+-- implicit. ----- An example type and instance using 'typeMismatch':+-- 'prependFailure' (or 'modifyFailure') add more information to a parser's+-- error messages. --+-- An example type and instance using 'typeMismatch' and 'prependFailure':+-- -- @ -- \-- Allow ourselves to write 'Text' literals. -- {-\# LANGUAGE OverloadedStrings #-}@@ -311,13 +322,15 @@ -- '<*>' v '.:' \"y\" -- -- \-- We do not expect a non-'Object' value here.--- \-- We could use 'mzero' to fail, but 'typeMismatch'+-- \-- We could use 'Control.Applicative.empty' to fail, but 'typeMismatch' -- \-- gives a much more informative error message.--- 'parseJSON' invalid = 'typeMismatch' \"Coord\" invalid+-- 'parseJSON' invalid =+-- 'prependFailure' "parsing Coord failed, "+-- ('typeMismatch' \"Object\" invalid) -- @ -- -- For this common case of only being concerned with a single--- type of JSON value, the functions 'withObject', 'withNumber', etc.+-- type of JSON value, the functions 'withObject', 'withScientific', etc. -- are provided. Their use is to be preferred when possible, since -- they are more terse. Using 'withObject', we can rewrite the above instance -- (assuming the same language extension and data type) as:@@ -356,7 +369,7 @@ -- @ -- -- The default implementation will be equivalent to--- @parseJSON = 'genericParseJSON' 'defaultOptions'@; If you need different+-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different -- options, you can customize the generic decoding by defining: -- -- @@@ -374,13 +387,11 @@ parseJSON = genericParseJSON defaultOptions parseJSONList :: Value -> Parser [a]- parseJSONList (Array a)- = zipWithM (parseIndexedJSON parseJSON) [0..]+ parseJSONList = withArray "[]" $ \a ->+ zipWithM (parseIndexedJSON parseJSON) [0..] . V.toList $ a - parseJSONList v = typeMismatch "[a]" v- ------------------------------------------------------------------------------- -- Classes and types for map keys -------------------------------------------------------------------------------@@ -496,27 +507,40 @@ -- | Fail parsing due to a type mismatch, with a descriptive message. ----- Example usage:+-- The following wrappers should generally be prefered:+-- 'withObject', 'withArray', 'withText', 'withBool'. ----- @--- instance FromJSON Coord where--- parseJSON ('Object' v) = {- type matches, life is good -}--- parseJSON wat = 'typeMismatch' \"Coord\" wat--- @-typeMismatch :: String -- ^ The name of the type you are trying to parse.+-- ==== Error message example+--+-- > typeMismatch "Object" (String "oops")+-- > -- Error: "expected Object, but encountered String"+typeMismatch :: String -- ^ The name of the JSON type being parsed+ -- (@\"Object\"@, @\"Array\"@, @\"String\"@, @\"Number\"@,+ -- @\"Boolean\"@, or @\"Null\"@). -> Value -- ^ The actual value encountered. -> Parser a typeMismatch expected actual =- fail $ "expected " ++ expected ++ ", encountered " ++ name- where- name = case actual of- Object _ -> "Object"- Array _ -> "Array"- String _ -> "String"- Number _ -> "Number"- Bool _ -> "Boolean"- Null -> "Null"+ fail $ "expected " ++ expected ++ ", but encountered " ++ typeOf actual +-- | Fail parsing due to a type mismatch, when the expected types are implicit.+--+-- ==== Error message example+--+-- > unexpected (String "oops")+-- > -- Error: "unexpected String"+unexpected :: Value -> Parser a+unexpected actual = fail $ "unexpected " ++ typeOf actual++-- | JSON type of a value, name of the head constructor.+typeOf :: Value -> String+typeOf v = case v of+ Object _ -> "Object"+ Array _ -> "Array"+ String _ -> "String"+ Number _ -> "Number"+ Bool _ -> "Boolean"+ Null -> "Null"+ ------------------------------------------------------------------------------- -- Lifings of FromJSON and ToJSON to unary and binary type constructors -------------------------------------------------------------------------------@@ -596,9 +620,8 @@ -> (Value -> Parser b) -> (Value -> Parser [b]) -> Value -> Parser [f a b]- liftParseJSONList2 fa ga fb gb v = case v of- Array vals -> fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals)- _ -> typeMismatch "[a]" v+ liftParseJSONList2 fa ga fb gb = withArray "[]" $ \vals ->+ fmap V.toList (V.mapM (liftParseJSON2 fa ga fb gb) vals) -- | Lift the standard 'parseJSON' function through the type constructor. parseJSON2 :: (FromJSON2 f, FromJSON a, FromJSON b) => Value -> Parser (f a b)@@ -612,7 +635,7 @@ -- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'. listParser :: (Value -> Parser a) -> Value -> Parser [a] listParser f (Array xs) = fmap V.toList (V.mapM f xs)-listParser _ v = typeMismatch "[a]" v+listParser _ v = typeMismatch "Array" v {-# INLINE listParser #-} -------------------------------------------------------------------------------@@ -630,59 +653,127 @@ -- Functions ------------------------------------------------------------------------------- --- | @'withObject' expected f value@ applies @f@ to the 'Object' when @value@--- is an 'Object' and fails using @'typeMismatch' expected@ otherwise.+-- | Add context to a failure message, indicating the name of the structure+-- being parsed.+--+-- > prependContext "MyType" (fail "[error message]")+-- > -- Error: "parsing MyType failed, [error message]"+prependContext :: String -> Parser a -> Parser a+prependContext name = prependFailure ("parsing " ++ name ++ " failed, ")++-- | @'withObject' name f value@ applies @f@ to the 'Object' when @value@+-- is an 'Data.Aeson.Object' and fails otherwise.+--+-- ==== Error message example+--+-- > withObject "MyType" f (String "oops")+-- > -- Error: "parsing MyType failed, expected Object, but encountered String" withObject :: String -> (Object -> Parser a) -> Value -> Parser a-withObject _ f (Object obj) = f obj-withObject expected _ v = typeMismatch expected v+withObject _ f (Object obj) = f obj+withObject name _ v = prependContext name (typeMismatch "Object" v) {-# INLINE withObject #-} --- | @'withText' expected f value@ applies @f@ to the 'Text' when @value@ is a--- 'String' and fails using @'typeMismatch' expected@ otherwise.+-- | @'withText' name f value@ applies @f@ to the 'Text' when @value@ is a+-- 'Data.Aeson.String' and fails otherwise.+--+-- ==== Error message example+--+-- > withText "MyType" f Null+-- > -- Error: "parsing MyType failed, expected String, but encountered Null" withText :: String -> (Text -> Parser a) -> Value -> Parser a-withText _ f (String txt) = f txt-withText expected _ v = typeMismatch expected v+withText _ f (String txt) = f txt+withText name _ v = prependContext name (typeMismatch "String" v) {-# INLINE withText #-} -- | @'withArray' expected f value@ applies @f@ to the 'Array' when @value@ is--- an 'Array' and fails using @'typeMismatch' expected@ otherwise.+-- an 'Data.Aeson.Array' and fails otherwise.+--+-- ==== Error message example+--+-- > withArray "MyType" f (String "oops")+-- > -- Error: "parsing MyType failed, expected Array, but encountered String" withArray :: String -> (Array -> Parser a) -> Value -> Parser a-withArray _ f (Array arr) = f arr-withArray expected _ v = typeMismatch expected v+withArray _ f (Array arr) = f arr+withArray name _ v = prependContext name (typeMismatch "Array" v) {-# INLINE withArray #-} --- | @'withScientific' expected f value@ applies @f@ to the 'Scientific' number--- when @value@ is a 'Number' and fails using @'typeMismatch' expected@+-- | @'withScientific' name f value@ applies @f@ to the 'Scientific' number+-- when @value@ is a 'Data.Aeson.Number' and fails using 'typeMismatch' -- otherwise.--- .+-- -- /Warning/: If you are converting from a scientific to an unbounded -- type such as 'Integer' you may want to add a restriction on the -- size of the exponent (see 'withBoundedScientific') to prevent -- malicious input from filling up the memory of the target system.+--+-- ==== Error message example+--+-- > withScientific "MyType" f (String "oops")+-- > -- Error: "parsing MyType failed, expected Number, but encountered String" withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a-withScientific _ f (Number scientific) = f scientific-withScientific expected _ v = typeMismatch expected v+withScientific _ f (Number scientific) = f scientific+withScientific name _ v = prependContext name (typeMismatch "Number" v) {-# INLINE withScientific #-} --- | @'withBoundedScientific' expected f value@ applies @f@ to the 'Scientific' number--- when @value@ is a 'Number' and fails using @'typeMismatch' expected@--- otherwise.+-- | A variant of 'withScientific' which doesn't use 'prependContext', so that+-- such context can be added separately in a way that also applies when the+-- continuation @f :: Scientific -> Parser a@ fails. ----- The conversion will also fail with a @'typeMismatch' if the--- 'Scientific' exponent is larger than 1024.+-- /Warning/: If you are converting from a scientific to an unbounded+-- type such as 'Integer' you may want to add a restriction on the+-- size of the exponent (see 'withBoundedScientific') to prevent+-- malicious input from filling up the memory of the target system.+--+-- ==== Error message examples+--+-- > withScientific' f (String "oops")+-- > -- Error: "unexpected String"+-- >+-- > prependContext "MyType" (withScientific' f (String "oops"))+-- > -- Error: "parsing MyType failed, unexpected String"+withScientific' :: (Scientific -> Parser a) -> Value -> Parser a+withScientific' f v = case v of+ Number n -> f n+ _ -> typeMismatch "Number" v+{-# INLINE withScientific' #-}++-- | @'withBoundedScientific' name f value@ applies @f@ to the 'Scientific' number+-- when @value@ is a 'Number' with exponent less than or equal to 1024. withBoundedScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a-withBoundedScientific _ f v@(Number scientific) =- if base10Exponent scientific > 1024- then typeMismatch "a number with exponent <= 1024" v- else f scientific-withBoundedScientific expected _ v = typeMismatch expected v+withBoundedScientific name f v = withBoundedScientific_ (prependContext name) f v {-# INLINE withBoundedScientific #-} +-- | A variant of 'withBoundedScientific' which doesn't use 'prependContext',+-- so that such context can be added separately in a way that also applies+-- when the continuation @f :: Scientific -> Parser a@ fails.+withBoundedScientific' :: (Scientific -> Parser a) -> Value -> Parser a+withBoundedScientific' f v = withBoundedScientific_ id f v+{-# INLINE withBoundedScientific' #-}++-- | 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+ 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"+withBoundedScientific_ whenFail _ v =+ whenFail (typeMismatch "Number" v)+{-# INLINE withBoundedScientific_ #-}+ -- | @'withBool' expected f value@ applies @f@ to the 'Bool' when @value@ is a--- 'Bool' and fails using @'typeMismatch' expected@ otherwise.+-- 'Boolean' and fails otherwise.+--+-- ==== Error message example+--+-- > withBool "MyType" f (String "oops")+-- > -- Error: "parsing MyType failed, expected Boolean, but encountered String" withBool :: String -> (Bool -> Parser a) -> Value -> Parser a-withBool _ f (Bool arr) = f arr-withBool expected _ v = typeMismatch expected v+withBool _ f (Bool arr) = f arr+withBool name _ v = prependContext name (typeMismatch "Boolean" v) {-# INLINE withBool #-} -- | Decode a nested JSON-encoded string.@@ -692,7 +783,7 @@ where eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON eitherFormatError = either (Left . uncurry formatError) Right-withEmbeddedJSON name _ v = typeMismatch name v+withEmbeddedJSON name _ v = prependContext name (typeMismatch "String" v) {-# INLINE withEmbeddedJSON #-} -- | Convert a value from JSON, failing if the types do not match.@@ -807,6 +898,27 @@ -- parsed value: gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs +-- Information for error messages++type TypeName = String+type ConName = String++-- | Add the name of the type being parsed to a parser's error messages.+contextType :: TypeName -> Parser a -> Parser a+contextType = prependContext++-- | Add the name of the constructor being parsed to a parser's error messages.+contextCons :: ConName -> TypeName -> Parser a -> Parser a+contextCons cname tname = prependContext (showCons cname tname)++-- | Render a constructor as @\"MyType(MyConstructor)\"@.+showCons :: ConName -> TypeName -> String+showCons cname tname = tname ++ "(" ++ cname ++ ")"++--------------------------------------------------------------------------------++-- Parsing single fields+ instance (FromJSON a) => GFromJSON arity (K1 i a) where -- Constant values are decoded using their FromJSON instance: gParseJSON _opts _ = fmap K1 . parseJSON@@ -821,93 +933,107 @@ -- FromJSON1 instance: gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl -instance GFromJSON arity U1 where- -- Empty constructors are expected to be encoded as an empty array:- gParseJSON _opts _ v- | isEmptyArray v = pure U1- | otherwise = typeMismatch "unit constructor (U1)" v+instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where+ -- If an occurrence of the last type parameter is nested inside two+ -- composed types, it is decoded by using the outermost type's FromJSON1+ -- instance to generically decode the innermost type:+ gParseJSON opts fargs =+ let gpj = gParseJSON opts fargs in+ fmap Comp1 . liftParseJSON gpj (listParser gpj) +--------------------------------------------------------------------------------++instance (GFromJSON' arity a, Datatype d) => GFromJSON arity (D1 d a) where+ -- Meta-information, which is not handled elsewhere, is just added to the+ -- parsed value:+ gParseJSON opts fargs = fmap M1 . gParseJSON' (tname :* opts :* fargs)+ where+ tname = moduleName proxy ++ "." ++ datatypeName proxy+ proxy = undefined :: M1 _i d _f _p++-- | 'GFromJSON', after unwrapping the 'D1' constructor, now carrying the data+-- type's name.+class GFromJSON' arity f where+ gParseJSON' :: TypeName :* Options :* FromArgs arity a+ -> Value+ -> Parser (f a)++-- | Single constructor. instance ( ConsFromJSON arity a , AllNullary (C1 c a) allNullary , ParseSum arity (C1 c a) allNullary- ) => GFromJSON arity (D1 d (C1 c a)) where+ , Constructor c+ ) => GFromJSON' arity (C1 c a) where -- The option 'tagSingleConstructors' determines whether to wrap -- a single-constructor type.- gParseJSON opts fargs+ gParseJSON' p@(_ :* opts :* _) | tagSingleConstructors opts- = fmap M1- . (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))- . parseSum opts fargs- | otherwise = fmap M1 . fmap M1 . consParseJSON opts fargs--instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where- -- Constructors need to be decoded differently depending on whether they're- -- a record or not. This distinction is made by consParseJSON:- gParseJSON opts fargs = fmap M1 . consParseJSON opts fargs--instance ( FromProduct arity a, FromProduct arity b- , ProductSize a, ProductSize b- ) => GFromJSON arity (a :*: b) where- -- Products are expected to be encoded to an array. Here we check whether we- -- got an array of the same size as the product, then parse each of the- -- product's elements using parseProduct:- gParseJSON opts fargs = withArray "product (:*:)" $ \arr ->- let lenArray = V.length arr- lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)- productSize in- if lenArray == lenProduct- then parseProduct opts fargs arr 0 lenProduct- else fail $ "When expecting a product of " ++ show lenProduct ++- " values, encountered an Array of " ++ show lenArray ++- " elements instead"+ = (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))+ . parseSum p+ | otherwise = fmap M1 . consParseJSON (cname :* p)+ where+ cname = conName (undefined :: M1 _i c _f _p) -instance ( AllNullary (a :+: b) allNullary- , ParseSum arity (a :+: b) allNullary- ) => GFromJSON arity (a :+: b) where+-- | Multiple constructors.+instance ( AllNullary (a :+: b) allNullary+ , ParseSum arity (a :+: b) allNullary+ ) => GFromJSON' arity (a :+: b) where -- If all constructors of a sum datatype are nullary and the -- 'allNullaryToStringTag' option is set they are expected to be -- encoded as strings. This distinction is made by 'parseSum':- gParseJSON opts fargs =- (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->- Parser ((a :+: b) d))- . parseSum opts fargs--instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where- -- If an occurrence of the last type parameter is nested inside two- -- composed types, it is decoded by using the outermost type's FromJSON1- -- instance to generically decode the innermost type:- gParseJSON opts fargs =- let gpj = gParseJSON opts fargs in- fmap Comp1 . liftParseJSON gpj (listParser gpj)+ gParseJSON' p =+ (unTagged :: Tagged allNullary (Parser ((a :+: b) _d)) ->+ Parser ((a :+: b) _d))+ . parseSum p -------------------------------------------------------------------------------- class ParseSum arity f allNullary where- parseSum :: Options -> FromArgs arity a- -> Value -> Tagged allNullary (Parser (f a))+ parseSum :: TypeName :* Options :* FromArgs arity a+ -> Value+ -> Tagged allNullary (Parser (f a)) -instance ( SumFromString f+instance ( ConstructorNames f+ , SumFromString f , FromPair arity f , FromTaggedObject arity f , FromUntaggedValue arity f ) => ParseSum arity f True where- parseSum opts fargs- | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts- | otherwise = Tagged . parseNonAllNullarySum opts fargs+ parseSum p@(tname :* opts :* _)+ | allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts+ | otherwise = Tagged . parseNonAllNullarySum p -instance ( FromPair arity f+instance ( ConstructorNames f+ , FromPair arity f , FromTaggedObject arity f , FromUntaggedValue arity f ) => ParseSum arity f False where- parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs+ parseSum p = Tagged . parseNonAllNullarySum p -------------------------------------------------------------------------------- -parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)-parseAllNullarySum opts = withText "Text" $ \key ->- maybe (notFound key) return $- parseSumFromString opts key+parseAllNullarySum :: (SumFromString f, ConstructorNames f)+ => TypeName -> Options -> Value -> Parser (f a)+parseAllNullarySum tname opts =+ withText tname $ \tag ->+ maybe (badTag tag) return $+ parseSumFromString opts tag+ where+ badTag tag = failWithCTags tname opts $ \cnames ->+ "expected one of the tags " ++ show cnames +++ ", but found tag " ++ show tag +-- | Fail with an informative error message about a mismatched tag.+-- The error message is parameterized by the list of expected tags,+-- to be inferred from the result type of the parser.+failWithCTags+ :: forall f a. ConstructorNames f+ => TypeName -> Options -> ([String] -> String) -> Parser (f a)+failWithCTags tname opts f =+ contextType tname . fail $ f cnames+ where+ cnames = unTagged2 (constructorTags opts :: Tagged2 f [String])+ class SumFromString f where parseSumFromString :: Options -> Text -> Maybe (f a) @@ -920,243 +1046,339 @@ | otherwise = Nothing where name = pack $ constructorTagModifier opts $- conName (undefined :: t c U1 p)+ conName (undefined :: M1 _i c _f _p) +-- | List of all constructor tags.+constructorTags :: ConstructorNames a => Options -> Tagged2 a [String]+constructorTags opts =+ fmap DList.toList (constructorNames' (constructorTagModifier opts))++-- | List of all constructor names of an ADT, after a given conversion+-- function. (Better inlining.)+class ConstructorNames a where+ constructorNames' :: (String -> t) -> Tagged2 a (DList.DList t)++instance (ConstructorNames a, ConstructorNames b) => ConstructorNames (a :+: b) where+ constructorNames' = liftA2 append constructorNames' constructorNames'+ where+ append+ :: Tagged2 a (DList.DList t)+ -> Tagged2 b (DList.DList t)+ -> Tagged2 (a :+: b) (DList.DList t)+ append (Tagged2 xs) (Tagged2 ys) = Tagged2 (DList.append xs ys)++instance Constructor c => ConstructorNames (C1 c a) where+ constructorNames' f = Tagged2 (pure (f cname))+ where+ cname = conName (undefined :: M1 _i c _f _p)+ -------------------------------------------------------------------------------- parseNonAllNullarySum :: ( FromPair arity f , FromTaggedObject arity f , FromUntaggedValue arity f- ) => Options -> FromArgs arity c+ , ConstructorNames f+ ) => TypeName :* Options :* FromArgs arity c -> Value -> Parser (f c)-parseNonAllNullarySum opts fargs =+parseNonAllNullarySum p@(tname :* opts :* _) = case sumEncoding opts of TaggedObject{..} ->- withObject "Object" $ \obj -> do- tag <- obj .: pack tagFieldName- fromMaybe (notFound tag) $- parseFromTaggedObject opts fargs contentsFieldName obj tag+ withObject tname $ \obj -> do+ tag <- contextType tname $ obj .: tagKey+ fromMaybe (badTag tag <?> Key tagKey) $+ parseFromTaggedObject (tag :* contentsFieldName :* p) obj+ where+ tagKey = pack tagFieldName+ badTag tag = failWith_ $ \cnames ->+ "expected tag field to be one of " ++ show cnames +++ ", but found tag " ++ show tag ObjectWithSingleField ->- withObject "Object" $ \obj ->- case H.toList obj of- [pair@(tag, _)] -> fromMaybe (notFound tag) $- parsePair opts fargs pair- _ -> fail "Object doesn't have a single field"+ withObject tname $ \obj -> case H.toList obj of+ [(tag, v)] -> maybe (badTag tag) (<?> Key tag) $+ parsePair (tag :* p) v+ _ -> contextType tname . fail $+ "expected an Object with a single pair, but found " +++ show (H.size obj) ++ " pairs"+ where+ badTag tag = failWith_ $ \cnames ->+ "expected an Object with a single pair where the tag is one of " +++ show cnames ++ ", but found tag " ++ show tag TwoElemArray ->- withArray "Array" $ \arr ->- if V.length arr == 2- then case V.unsafeIndex arr 0 of- String tag -> fromMaybe (notFound tag) $- parsePair opts fargs (tag, V.unsafeIndex arr 1)- _ -> fail "First element is not a String"- else fail "Array doesn't have 2 elements"+ withArray tname $ \arr -> case V.length arr of+ 2 | String tag <- V.unsafeIndex arr 0 ->+ maybe (badTag tag <?> Index 0) (<?> Index 1) $+ parsePair (tag :* p) (V.unsafeIndex arr 1)+ | otherwise ->+ contextType tname $+ fail "tag element is not a String" <?> Index 0+ len -> contextType tname . fail $+ "expected a 2-element Array, but encountered an Array of length " +++ show len+ where+ badTag tag = failWith_ $ \cnames ->+ "expected tag of the 2-element Array to be one of " +++ show cnames ++ ", but found tag " ++ show tag - UntaggedValue -> parseUntaggedValue opts fargs+ UntaggedValue -> parseUntaggedValue p+ where+ failWith_ = failWithCTags tname opts -------------------------------------------------------------------------------- class FromTaggedObject arity f where- parseFromTaggedObject :: Options -> FromArgs arity a- -> String -> Object- -> Text -> Maybe (Parser (f a))+ -- The first two components of the parameter tuple are: the constructor tag+ -- to match against, and the contents field name.+ parseFromTaggedObject+ :: Text :* String :* TypeName :* Options :* FromArgs arity a+ -> Object+ -> Maybe (Parser (f a)) instance ( FromTaggedObject arity a, FromTaggedObject arity b) => FromTaggedObject arity (a :+: b) where- parseFromTaggedObject opts fargs contentsFieldName obj tag =- (fmap L1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag) <|>- (fmap R1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag)+ parseFromTaggedObject p obj =+ (fmap L1 <$> parseFromTaggedObject p obj) <|>+ (fmap R1 <$> parseFromTaggedObject p obj) -instance ( FromTaggedObject' arity f+instance ( IsRecord f isRecord+ , FromTaggedObject' arity f isRecord , Constructor c ) => FromTaggedObject arity (C1 c f) where- parseFromTaggedObject opts fargs contentsFieldName obj tag- | tag == name = Just $ M1 <$> parseFromTaggedObject'- opts fargs contentsFieldName obj- | otherwise = Nothing- where- name = pack $ constructorTagModifier opts $- conName (undefined :: t c f p)+ parseFromTaggedObject (tag :* contentsFieldName :* p@(_ :* opts :* _))+ | tag == tag'+ = Just . fmap M1 .+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .+ parseFromTaggedObject' (contentsFieldName :* cname :* p)+ | otherwise = const Nothing+ where+ tag' = pack $ constructorTagModifier opts cname+ cname = conName (undefined :: M1 _i c _f _p) -------------------------------------------------------------------------------- -class FromTaggedObject' arity f where- parseFromTaggedObject' :: Options -> FromArgs arity a -> String- -> Object -> Parser (f a)--class FromTaggedObject'' arity f isRecord where- parseFromTaggedObject'' :: Options -> FromArgs arity a -> String- -> Object -> Tagged isRecord (Parser (f a))--instance ( IsRecord f isRecord- , FromTaggedObject'' arity f isRecord- ) => FromTaggedObject' arity f where- parseFromTaggedObject' opts fargs contentsFieldName =- (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .- parseFromTaggedObject'' opts fargs contentsFieldName+class FromTaggedObject' arity f isRecord where+ -- The first component of the parameter tuple is the contents field name.+ parseFromTaggedObject'+ :: String :* ConName :* TypeName :* Options :* FromArgs arity a+ -> Object -> Tagged isRecord (Parser (f a)) -instance (FromRecord arity f) => FromTaggedObject'' arity f True where- parseFromTaggedObject'' opts fargs _ =- Tagged . parseRecord opts fargs+instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where+ -- Records are unpacked in the tagged object+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p -instance (GFromJSON arity f) => FromTaggedObject'' arity f False where- parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .- (gParseJSON opts fargs <=< (.: pack contentsFieldName))+instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where+ -- Nonnullary nonrecords are encoded in the contents field+ parseFromTaggedObject' p obj = Tagged $ do+ contents <- contextCons cname tname (obj .: key)+ consParseJSON p' contents <?> Key key+ where+ key = pack contentsFieldName+ contentsFieldName :* p'@(cname :* tname :* _) = p -instance OVERLAPPING_ FromTaggedObject'' arity U1 False where- parseFromTaggedObject'' _ _ _ _ = Tagged (pure U1)+instance OVERLAPPING_ FromTaggedObject' arity U1 False where+ -- Nullary constructors don't need a contents field+ parseFromTaggedObject' _ _ = Tagged (pure U1) -------------------------------------------------------------------------------- +-- | Constructors need to be decoded differently depending on whether they're+-- a record or not. This distinction is made by 'ConsParseJSON'. class ConsFromJSON arity f where- consParseJSON :: Options -> FromArgs arity a- -> Value -> Parser (f a)+ consParseJSON+ :: ConName :* TypeName :* Options :* FromArgs arity a+ -> Value -> Parser (f a) class ConsFromJSON' arity f isRecord where- consParseJSON' :: Options -> FromArgs arity a- -> Value -> Tagged isRecord (Parser (f a))+ consParseJSON'+ :: ConName :* TypeName :* Options :* FromArgs arity a+ -> Value -> Tagged isRecord (Parser (f a)) instance ( IsRecord f isRecord , ConsFromJSON' arity f isRecord ) => ConsFromJSON arity f where- consParseJSON opts fargs =+ consParseJSON p = (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))- . consParseJSON' opts fargs+ . consParseJSON' p instance OVERLAPPING_- ( GFromJSON arity a, FromRecord arity (S1 s a)+ ( GFromJSON arity a, RecordFromJSON arity (S1 s a) ) => ConsFromJSON' arity (S1 s a) True where- consParseJSON' opts fargs- | unwrapUnaryRecords opts = Tagged . gParseJSON opts fargs- | otherwise = Tagged . withObject "unary record" (parseRecord opts fargs)+ consParseJSON' p@(cname :* tname :* opts :* fargs)+ | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p) -instance FromRecord arity f => ConsFromJSON' arity f True where- consParseJSON' opts fargs =- Tagged . withObject "record (:*:)" (parseRecord opts fargs)+instance RecordFromJSON arity f => ConsFromJSON' arity f True where+ consParseJSON' p@(cname :* tname :* _) =+ Tagged . withObject (showCons cname tname) (recordParseJSON p) -instance GFromJSON arity f => ConsFromJSON' arity f False where- consParseJSON' opts fargs = Tagged . gParseJSON opts fargs+instance OVERLAPPING_+ ConsFromJSON' arity U1 False where+ -- Empty constructors are expected to be encoded as an empty array:+ consParseJSON' (cname :* tname :* _) v =+ Tagged . contextCons cname tname $ case v of+ Array a | V.null a -> pure U1+ | otherwise -> fail_ a+ _ -> typeMismatch "Array" v+ where+ fail_ a = fail $+ "expected an empty Array, but encountered an Array of length " +++ show (V.length a) +instance OVERLAPPING_+ GFromJSON arity f => ConsFromJSON' arity (S1 s f) False where+ consParseJSON' (_ :* _ :* opts :* fargs) =+ Tagged . fmap M1 . gParseJSON opts fargs++instance (ProductFromJSON arity f, ProductSize f+ ) => ConsFromJSON' arity f False where+ consParseJSON' p = Tagged . productParseJSON0 p+ -------------------------------------------------------------------------------- -class FromRecord arity f where- parseRecord :: Options -> FromArgs arity a- -> Object -> Parser (f a)+class RecordFromJSON arity f where+ recordParseJSON+ :: ConName :* TypeName :* Options :* FromArgs arity a+ -> Object -> Parser (f a) -instance ( FromRecord arity a- , FromRecord arity b- ) => FromRecord arity (a :*: b) where- parseRecord opts fargs obj =- (:*:) <$> parseRecord opts fargs obj- <*> parseRecord opts fargs 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) =>- FromRecord arity (S1 s a) where- parseRecord opts fargs =- (<?> Key label) . gParseJSON opts fargs <=< (.: label)- where- label = pack . fieldLabelModifier opts $ selName (undefined :: t s a p)+ 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+ label = pack $ fieldLabelModifier opts sname+ sname = selName (undefined :: M1 _i s _f _p) instance INCOHERENT_ (Selector s, FromJSON a) =>- FromRecord arity (S1 s (K1 i (Maybe a))) where- parseRecord opts _ obj = M1 . K1 <$> obj .:? pack label- where- label = fieldLabelModifier opts $- selName (undefined :: t s (K1 i (Maybe a)) p)+ 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) =>- FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where- parseRecord opts fargs obj = wrap <$> parseRecord opts fargs 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)) -------------------------------------------------------------------------------- -class FromProduct arity f where- parseProduct :: Options -> FromArgs arity a+productParseJSON0+ :: forall f arity a. (ProductFromJSON arity f, ProductSize f)+ => ConName :* TypeName :* Options :* FromArgs arity a+ -> Value -> Parser (f a)+ -- Products are expected to be encoded to an array. Here we check whether we+ -- got an array of the same size as the product, then parse each of the+ -- product's elements using productParseJSON:+productParseJSON0 p@(cname :* tname :* _ :* _) =+ withArray (showCons cname tname) $ \arr ->+ let lenArray = V.length arr+ lenProduct = (unTagged2 :: Tagged2 f Int -> Int)+ productSize in+ if lenArray == lenProduct+ then productParseJSON p arr 0 lenProduct+ else contextCons cname tname $+ fail $ "expected an Array of length " ++ show lenProduct +++ ", but encountered an Array of length " ++ show lenArray++--++class ProductFromJSON arity f where+ productParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a -> Array -> Int -> Int -> Parser (f a) -instance ( FromProduct arity a- , FromProduct arity b- ) => FromProduct arity (a :*: b) where- parseProduct opts fargs arr ix len =- (:*:) <$> parseProduct opts fargs arr ix lenL- <*> parseProduct opts fargs arr ixR lenR+instance ( ProductFromJSON arity a+ , ProductFromJSON arity b+ ) => ProductFromJSON arity (a :*: b) where+ productParseJSON p arr ix len =+ (:*:) <$> productParseJSON p arr ix lenL+ <*> productParseJSON p arr ixR lenR where lenL = len `unsafeShiftR` 1 ixR = ix + lenL lenR = len - lenL -instance (GFromJSON arity a) => FromProduct arity (S1 s a) where- parseProduct opts fargs arr ix _ =- gParseJSON opts fargs $ V.unsafeIndex arr ix+instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where+ productParseJSON (_ :* _ :* opts :* fargs) arr ix _ =+ M1 <$> gParseJSON opts fargs (V.unsafeIndex arr ix) <?> Index ix -------------------------------------------------------------------------------- class FromPair arity f where- parsePair :: Options -> FromArgs arity a- -> Pair -> Maybe (Parser (f a))+ -- The first component of the parameter tuple is the tag to match.+ parsePair :: Text :* TypeName :* Options :* FromArgs arity a+ -> Value+ -> Maybe (Parser (f a)) instance ( FromPair arity a , FromPair arity b ) => FromPair arity (a :+: b) where- parsePair opts fargs pair = (fmap L1 <$> parsePair opts fargs pair) <|>- (fmap R1 <$> parsePair opts fargs pair)+ parsePair p pair =+ (fmap L1 <$> parsePair p pair) <|>+ (fmap R1 <$> parsePair p pair) instance ( Constructor c- , GFromJSON arity a , ConsFromJSON arity a ) => FromPair arity (C1 c a) where- parsePair opts fargs (tag, value)- | tag == tag' = Just $ gParseJSON opts fargs value+ parsePair (tag :* p@(_ :* opts :* _)) v+ | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v | otherwise = Nothing- where- tag' = pack $ constructorTagModifier opts $- conName (undefined :: t c a p)+ where+ tag' = pack $ constructorTagModifier opts cname+ cname = conName (undefined :: M1 _i c _a _p) -------------------------------------------------------------------------------- class FromUntaggedValue arity f where- parseUntaggedValue :: Options -> FromArgs arity a- -> Value -> Parser (f a)+ parseUntaggedValue :: TypeName :* Options :* FromArgs arity a+ -> Value+ -> Parser (f a) instance ( FromUntaggedValue arity a , FromUntaggedValue arity b ) => FromUntaggedValue arity (a :+: b) where- parseUntaggedValue opts fargs value =- L1 <$> parseUntaggedValue opts fargs value <|>- R1 <$> parseUntaggedValue opts fargs value+ parseUntaggedValue p value =+ L1 <$> parseUntaggedValue p value <|>+ R1 <$> parseUntaggedValue p value instance OVERLAPPABLE_- ( GFromJSON arity a- , ConsFromJSON arity a+ ( ConsFromJSON arity a+ , Constructor c ) => FromUntaggedValue arity (C1 c a) where- parseUntaggedValue = gParseJSON+ parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)+ where+ cname = conName (undefined :: M1 _i c _f _p) instance OVERLAPPING_ ( Constructor c ) => FromUntaggedValue arity (C1 c U1) where- parseUntaggedValue opts _ (String s)- | s == pack (constructorTagModifier opts (conName (undefined :: t c U1 p))) =- pure $ M1 U1- | otherwise =- fail $ "Invalid tag: " ++ unpack s- parseUntaggedValue _ _ v = typeMismatch (conName (undefined :: t c U1 p)) v-------------------------------------------------------------------------------------notFound :: Text -> Parser a-notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"-{-# INLINE notFound #-}+ parseUntaggedValue (tname :* opts :* _) v =+ contextCons cname tname $ case v of+ String tag+ | tag == tag' -> pure $ M1 U1+ | otherwise -> fail_ tag+ _ -> typeMismatch "String" v+ where+ tag' = pack $ constructorTagModifier opts cname+ cname = conName (undefined :: M1 _i c _f _p)+ fail_ tag = fail $+ "expected tag " ++ show tag' ++ ", but found tag " ++ show tag ------------------------------------------------------------------------------- -- Instances@@ -1219,14 +1441,15 @@ {-# INLINE parseJSON #-} instance FromJSON Bool where- parseJSON = withBool "Bool" pure+ parseJSON (Bool b) = pure b+ parseJSON v = typeMismatch "Bool" v {-# INLINE parseJSON #-} instance FromJSONKey Bool where fromJSONKey = FromJSONKeyTextParser $ \t -> case t of "true" -> pure True "false" -> pure False- _ -> fail $ "Cannot parse key into Bool: " ++ T.unpack t+ _ -> fail $ "cannot parse key " ++ show t ++ " into Bool" instance FromJSON Ordering where parseJSON = withText "Ordering" $ \s ->@@ -1234,25 +1457,30 @@ "LT" -> return LT "EQ" -> return EQ "GT" -> return GT- _ -> fail "Parsing Ordering value failed: expected \"LT\", \"EQ\", or \"GT\""+ _ -> fail $ "parsing Ordering failed, unexpected " ++ show s +++ " (expected \"LT\", \"EQ\", or \"GT\")" instance FromJSON () where parseJSON = withArray "()" $ \v -> if V.null v then pure ()- else fail "Expected an empty array"+ else prependContext "()" $ fail "expected an empty array" {-# INLINE parseJSON #-} instance FromJSON Char where- parseJSON = withText "Char" $ \t ->- if T.compareLength t 1 == EQ- then pure $ T.head t- else fail "Expected a string of length 1"+ parseJSON = withText "Char" parseChar {-# INLINE parseJSON #-} - parseJSONList = withText "String" $ pure . T.unpack+ parseJSONList (String s) = pure (T.unpack s)+ parseJSONList v = typeMismatch "String" v {-# INLINE parseJSONList #-} +parseChar :: Text -> Parser Char+parseChar t =+ if T.compareLength t 1 == EQ+ then pure $ T.head t+ else prependContext "Char" $ fail "expected a string of length 1"+ instance FromJSON Double where parseJSON = parseRealFloat "Double" {-# INLINE parseJSON #-}@@ -1289,7 +1517,7 @@ -- newtype 'Scientific' and provide your own instance using -- 'withScientific' if you want to allow larger inputs. instance HasResolution a => FromJSON (Fixed a) where- parseJSON = withBoundedScientific "Fixed" $ pure . realToFrac+ parseJSON = prependContext "Fixed" . withBoundedScientific' (pure . realToFrac) {-# INLINE parseJSON #-} instance FromJSON Int where@@ -1312,20 +1540,21 @@ instance FromJSON Natural where parseJSON value = do- integer :: Integer <- parseIntegral "Natural" value- if integer < 0 then- fail $ "expected Natural, encountered negative number " <> show integer- else- pure $ fromIntegral integer+ integer <- parseIntegral "Natural" value+ parseNatural integer instance FromJSONKey Natural where 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+ integer <- parseIntegralText "Natural" text+ parseNatural integer +parseNatural :: Integer -> Parser Natural+parseNatural integer =+ if integer < 0 then+ fail $ "parsing Natural failed, unexpected negative number " <> show integer+ else+ pure $ fromIntegral integer+ instance FromJSON Int8 where parseJSON = parseBoundedIntegral "Int8" {-# INLINE parseJSON #-}@@ -1421,17 +1650,17 @@ where go [(v,[])] = return v go (_ : xs) = go xs- go _ = fail "could not parse Version"+ go _ = fail "parsing Version failed" ------------------------------------------------------------------------------- -- semigroups NonEmpty ------------------------------------------------------------------------------- instance FromJSON1 NonEmpty where- liftParseJSON p _ = withArray "NonEmpty a" $+ liftParseJSON p _ = withArray "NonEmpty" $ (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList where- ne [] = fail "Expected a NonEmpty but got an empty list"+ ne [] = fail "parsing NonEmpty failed, unpexpected empty list" ne (x:xs) = pure (x :| xs) {-# INLINE liftParseJSON #-} @@ -1452,7 +1681,7 @@ ------------------------------------------------------------------------------- instance FromJSON1 DList.DList where- liftParseJSON p _ = withArray "DList a" $+ liftParseJSON p _ = withArray "DList" $ fmap DList.fromList . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList {-# INLINE liftParseJSON #-}@@ -1529,7 +1758,7 @@ inr = "InR" liftParseJSON _ _ _ = fail $- "expected an object with a single property " +++ "parsing Sum failed, expected an object with a single property " ++ "where the property key should be either " ++ "\"InL\" or \"InR\"" {-# INLINE liftParseJSON #-}@@ -1543,7 +1772,7 @@ ------------------------------------------------------------------------------- instance FromJSON1 Seq.Seq where- liftParseJSON p _ = withArray "Seq a" $+ liftParseJSON p _ = withArray "Seq" $ fmap Seq.fromList . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList {-# INLINE liftParseJSON #-}@@ -1577,13 +1806,13 @@ instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where liftParseJSON p _ = case fromJSONKey of- FromJSONKeyCoerce _-> withObject "Map k v" $+ FromJSONKeyCoerce _ -> withObject "Map" $ fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)- FromJSONKeyText f -> withObject "Map k v" $+ FromJSONKeyText f -> withObject "Map" $ fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)- FromJSONKeyTextParser f -> withObject "Map k v" $+ FromJSONKeyTextParser f -> withObject "Map" $ H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)- FromJSONKeyValue f -> withArray "Map k v" $ \arr ->+ FromJSONKeyValue f -> withArray "Map" $ \arr -> fmap M.fromList . Tr.sequence . zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr {-# INLINE liftParseJSON #-}@@ -1611,18 +1840,18 @@ instance FromJSON UUID.UUID where parseJSON = withText "UUID" $- maybe (fail "Invalid UUID") pure . UUID.fromText+ maybe (fail "invalid UUID") pure . UUID.fromText instance FromJSONKey UUID.UUID where fromJSONKey = FromJSONKeyTextParser $- maybe (fail "Invalid UUID") pure . UUID.fromText+ maybe (fail "invalid UUID") pure . UUID.fromText ------------------------------------------------------------------------------- -- vector ------------------------------------------------------------------------------- instance FromJSON1 Vector where- liftParseJSON p _ = withArray "Vector a" $+ liftParseJSON p _ = withArray "Vector" $ V.mapM (uncurry $ parseIndexedJSON p) . V.indexed {-# INLINE liftParseJSON #-} @@ -1636,14 +1865,14 @@ {-# INLINE vectorParseJSON #-} instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where- parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"+ parseJSON = vectorParseJSON "Data.Vector.Storable.Vector" instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where- parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"+ parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector" {-# INLINE parseJSON #-} instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where- parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"+ parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector" {-# INLINE parseJSON #-} -------------------------------------------------------------------------------@@ -1657,13 +1886,13 @@ instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where liftParseJSON p _ = case fromJSONKey of- FromJSONKeyCoerce _ -> withObject "HashMap ~Text v" $+ FromJSONKeyCoerce _ -> withObject "HashMap ~Text" $ uc . H.traverseWithKey (\k v -> p v <?> Key k)- FromJSONKeyText f -> withObject "HashMap k v" $+ FromJSONKeyText f -> withObject "HashMap" $ fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)- FromJSONKeyTextParser f -> withObject "HashMap k v" $+ FromJSONKeyTextParser f -> withObject "HashMap" $ H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)- FromJSONKeyValue f -> withArray "Map k v" $ \arr ->+ FromJSONKeyValue f -> withArray "Map" $ \arr -> fmap H.fromList . Tr.sequence . zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr where@@ -1900,14 +2129,15 @@ instance FromJSON1 Proxy where {-# INLINE liftParseJSON #-}- liftParseJSON _ _ Null = pure Proxy- liftParseJSON _ _ v = typeMismatch "Proxy" v+ liftParseJSON _ _ = fromNull "Proxy" Proxy instance FromJSON (Proxy a) where {-# INLINE parseJSON #-}- parseJSON Null = pure Proxy- parseJSON v = typeMismatch "Proxy" v+ parseJSON = fromNull "Proxy" Proxy +fromNull :: String -> a -> Value -> Parser a+fromNull _ a Null = pure a+fromNull c _ v = prependContext c (typeMismatch "Null" v) instance FromJSON2 Tagged where liftParseJSON2 _ _ p _ = fmap Tagged . p@@ -1934,10 +2164,7 @@ instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSONKey (a,b,c,d) instance FromJSONKey Char where- fromJSONKey = FromJSONKeyTextParser $ \t ->- if T.length t == 1- then return (T.index t 0)- else typeMismatch "Expected Char but String didn't contain exactly one character" (String t)+ fromJSONKey = FromJSONKeyTextParser parseChar fromJSONKeyList = FromJSONKeyText T.unpack instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where
Data/Aeson/Types/Generic.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}@@ -35,6 +36,7 @@ , Zero , One , ProductSize(..)+ , (:*)(..) ) where import Prelude.Compat@@ -75,6 +77,7 @@ instance AllNullary U1 True newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}+ deriving Functor -------------------------------------------------------------------------------- @@ -107,3 +110,10 @@ instance ProductSize (S1 s a) where productSize = Tagged2 1++--------------------------------------------------------------------------------++-- | Simple extensible tuple type to simplify passing around many parameters.+data a :* b = a :* b++infixr 1 :*
Data/Aeson/Types/Internal.hs view
@@ -45,6 +45,7 @@ , parseEither , parseMaybe , modifyFailure+ , prependFailure , parserThrowError , parserCatchError , formatError@@ -512,6 +513,15 @@ modifyFailure :: (String -> String) -> Parser a -> Parser a modifyFailure f (Parser p) = Parser $ \path kf ks -> p path (\p' m -> kf p' (f m)) ks++-- | If the inner 'Parser' failed, prepend the given string to the failure+-- message.+--+-- @+-- 'prependFailure' s = 'modifyFailure' (s '++')+-- @+prependFailure :: String -> Parser a -> Parser a+prependFailure = modifyFailure . (++) -- | Throw a parser error with an additional path. --
aeson.cabal view
@@ -1,5 +1,5 @@ name: aeson-version: 1.4.2.0+version: 1.4.3.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON@@ -42,6 +42,7 @@ include/*.h tests/JSONTestSuite/test_parsing/*.json tests/JSONTestSuite/test_transform/*.json+ tests/golden/*.expected pure/Data/Aeson/Parser/*.hs flag developer@@ -151,7 +152,7 @@ dlist >= 0.8.0.4 && < 0.9, hashable >= 1.2.7.0 && < 1.3, scientific >= 0.3.6.2 && < 0.4,- th-abstraction >= 0.2.8.0 && < 0.3,+ th-abstraction >= 0.2.8.0 && < 0.4, time-locale-compat >= 0.1.1.5 && < 0.2, uuid-types >= 1.0.3 && < 1.1, vector >= 0.12.0.1 && < 0.13@@ -197,24 +198,31 @@ Functions Instances Options+ PropUtils Properties+ PropertyGeneric+ PropertyKeys+ PropertyRoundTrip+ PropertyRTFunctors+ PropertyTH SerializationFormatSpec Types UnitTests UnitTests.NullaryConstructors build-depends:- QuickCheck >= 2.10.0.1 && < 2.12,+ QuickCheck >= 2.10.0.1 && < 2.13, aeson, integer-logarithms >= 1 && <1.1, attoparsec, base, base-compat,- base-orphans >= 0.5.3 && <0.8,+ base-orphans >= 0.5.3 && <0.9, base16-bytestring, containers, directory, dlist,+ Diff, filepath, generic-deriving >= 1.10 && < 1.13, ghc-prim >= 0.2,@@ -223,6 +231,7 @@ tagged, template-haskell, tasty,+ tasty-golden, tasty-hunit, tasty-quickcheck, text,
benchmarks/aeson-benchmarks.cabal view
@@ -45,7 +45,7 @@ tagged >=0.8.3 && <0.9, template-haskell >= 2.4, text >= 1.2.3,- th-abstraction >= 0.2.2 && < 0.3,+ th-abstraction >= 0.2.2 && < 0.4, time, transformers, unordered-containers >= 0.2.3.0,
changelog.md view
@@ -1,5 +1,19 @@ 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.3.0+* Improve error messages for FromJSON in existing instances and GHC Generic implementation. Thanks to Xia Li-Yao & Igor Pashev.+* Tweak error-reporting combinators and their documentation. Thanks to Xia Li-Yao.+ * `typeMismatch` is now about comparing JSON types (i.e., the expected and actual names of the Value constructor).+ * `withObject` and other `with*` combinators now also mention the JSON types they expect+ * New `unexpected` and `prependFailure` combinators.+* Add `Contravariant` `ToJSONKeyFunction` instance. Thanks to Oleg Grenrus.+* Add `KeyValue` instance for `Object`. Thanks to Robert Hensing.+* Improve performance when parsing certain large numbers, thanks to Oleg Grenrus.+* Add `Data.Aeson.QQ.Simple` - A limited version of aeson-qq. Thanks to Oleg Grenrus.+* Exposes internal helper functions like `<?>`, `JSONPath`, and `parseIndexedJSON` from `Data.Aeson` module. Thanks to Abid Uzair.+* Better error messages when there are syntax errors parsing objects and arrays. Thanks to Fintan Halpenny.+* Support building with `th-abstraction-0.3.0.0` or later. Thanks to Ryan Scott.+ ### 1.4.2.0 * Add `Data.Aeson.QQ.Simple` which is a simpler version of the `aeson-qq` package, it does not support interpolation, thanks to Oleg Grenrus.
tests/DataFamilies/Properties.hs view
@@ -7,7 +7,8 @@ import DataFamilies.Encoders import DataFamilies.Instances ()-import Properties hiding (tests)+import PropUtils+ import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty)
tests/Encoders.hs view
@@ -414,3 +414,13 @@ gOneConstructorParseJSONTagged :: Value -> Parser OneConstructor gOneConstructorParseJSONTagged = genericParseJSON optsTagSingleConstructors++--------------------------------------------------------------------------------+-- Product2 encoders/decoders+--------------------------------------------------------------------------------++thProduct2ParseJSON :: Value -> Parser (Product2 Int Bool)+thProduct2ParseJSON = $(mkParseJSON defaultOptions ''Product2)++gProduct2ParseJSON :: Value -> Parser (Product2 Int Bool)+gProduct2ParseJSON = genericParseJSON defaultOptions
tests/ErrorMessages.hs view
@@ -9,62 +9,190 @@ import Prelude.Compat -import Data.Aeson (FromJSON(..), eitherDecode)+import Data.Aeson (FromJSON(..), Value, json)+import Data.Aeson.Types (Parser)+import Data.Aeson.Parser (eitherDecodeWith)+import Data.Aeson.Internal (formatError, iparse)+import Data.Algorithm.Diff (Diff(..), getGroupedDiff) import Data.Proxy (Proxy(..))+import Data.Semigroup ((<>))+import Data.Sequence (Seq) import Instances () import Numeric.Natural (Natural)-import Test.Tasty (TestTree)-import Test.Tasty.HUnit (Assertion, assertFailure, assertEqual, testCase)+import Test.Tasty (TestTree, TestName)+import Test.Tasty.Golden.Advanced (goldenTest) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.HashMap.Strict as HM +import Encoders+import Types+ tests :: [TestTree] tests =- [- testCase "Int" int- , testCase "Integer" integer- , testCase "Natural" natural- , testCase "String" string- , testCase "HashMap" hashMap- ]+ [ aesonGoldenTest "simple" "tests/golden/simple.expected" output+ , aesonGoldenTest "generic" "tests/golden/generic.expected" (outputGeneric G)+ ] -int :: Assertion-int = do- let t = test (Proxy :: Proxy Int)- t "\"\"" $ expected "Int" "String"- t "[]" $ expected "Int" "Array"- t "{}" $ expected "Int" "Object"- t "null" $ expected "Int" "Null"+output :: Output+output = concat+ [ testFor "Int" (Proxy :: Proxy Int)+ [ "\"\""+ , "[]"+ , "{}"+ , "null"+ ] -integer :: Assertion-integer = do- let t = test (Proxy :: Proxy Integer)- t "44.44" $ expected "Integer" "floating number 44.44"+ , testFor "Integer" (Proxy :: Proxy Integer)+ [ "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"+ , testFor "Natural" (Proxy :: Proxy Natural)+ [ "44.44"+ , "-50"+ ] -string :: Assertion-string = do- let t = test (Proxy :: Proxy String)- t "1" $ expected "String" "Number"- t "[]" $ expected "String" "Array"- t "{}" $ expected "String" "Object"- t "null" $ expected "String" "Null"+ , testFor "String" (Proxy :: Proxy String)+ [ "1"+ , "[]"+ , "{}"+ , "null"+ ] -hashMap :: Assertion-hashMap = do- let t = test (Proxy :: Proxy (HM.HashMap String Int))- t "\"\"" $ expected "HashMap k v" "String"- t "[]" $ expected "HashMap k v" "Array"+ , testFor "HashMap" (Proxy :: Proxy (HM.HashMap String Int))+ [ "\"\""+ , "[]"+ ] -expected :: String -> String -> String-expected ex enc = "Error in $: expected " ++ ex ++ ", encountered " ++ enc+ -- issue #356+ , testFor "Either" (Proxy :: Proxy (Int, Either (Int, Bool) ()))+ [ "[1,{\"Left\":[2,3]}]"+ ] -test :: forall a proxy . (FromJSON a, Show a) => proxy a -> L.ByteString -> String -> Assertion-test _ v msg = case eitherDecode v of- Left e -> assertEqual "Invalid error message" msg e- Right (x :: a) -> assertFailure $ "Expected parsing to fail but it suceeded with: " ++ show x+ -- issue #358+ , testFor "Seq" (Proxy :: Proxy (Seq Int))+ [ "[0,1,true]"+ ]+ ]++data Choice = TH | G++outputGeneric :: Choice -> Output+outputGeneric choice = concat+ [ testWith "OneConstructor"+ (select+ thOneConstructorParseJSONDefault+ gOneConstructorParseJSONDefault)+ [ "\"X\""+ , "[0]"+ ]++ , testWith "Nullary"+ (select+ thNullaryParseJSONString+ gNullaryParseJSONString)+ [ "\"X\""+ , "[]"+ ]++ , testWithSomeType "SomeType (tagged)"+ (select+ thSomeTypeParseJSONTaggedObject+ gSomeTypeParseJSONTaggedObject)+ [ "{\"tag\": \"unary\", \"contents\": true}"+ , "{\"tag\": \"unary\"}"+ , "{\"tag\": \"record\"}"+ , "{\"tag\": \"record\", \"testone\": true, \"testtwo\": null, \"testthree\": null}"+ , "{\"tag\": \"X\"}"+ , "{}"+ , "[]"+ ]++ , testWithSomeType "SomeType (single-field)"+ (select+ thSomeTypeParseJSONObjectWithSingleField+ gSomeTypeParseJSONObjectWithSingleField)+ [ "{\"unary\": {}}"+ , "{\"unary\": []}"+ , "{\"X\": []}"+ , "{\"record\": {}, \"W\":{}}"+ , "{}"+ , "[]"+ , "{\"unary\""+ , "{\"unary\":"+ , "{\"unary\":1"+ ]++ , testWithSomeType "SomeType (two-element array)"+ (select+ thSomeTypeParseJSON2ElemArray+ gSomeTypeParseJSON2ElemArray)+ [ "[\"unary\", true]"+ , "[\"record\", null]"+ , "[\"X\", 0]"+ , "[null, 0]"+ , "[]"+ , "{}"+ , "[1"+ , "[1,"+ ]++ , testWith "EitherTextInt"+ (select+ thEitherTextIntParseJSONUntaggedValue+ gEitherTextIntParseJSONUntaggedValue)+ [ "\"X\""+ , "[]"+ ]++ , testWith "Product2 Int Bool"+ (select+ thProduct2ParseJSON+ gProduct2ParseJSON)+ [ "[1, null]"+ , "[]"+ , "{}"+ ]+ ]+ where+ select a b = case choice of+ TH -> a+ G -> b++-- Test infrastructure++type Output = [String]++outputLine :: String -> Output+outputLine = pure++aesonGoldenTest :: TestName -> FilePath -> Output -> TestTree+aesonGoldenTest name ref out = goldenTest name (L.readFile ref) act cmp upd+ where+ act = pure (L.pack (unlines out))+ upd = L.writeFile ref+ cmp x y | x == y = return Nothing+ cmp x y = return $ Just $ unlines $+ concatMap f (getGroupedDiff (L.lines x) (L.lines y))+ where+ f (First xs) = map (cons3 '-' . L.unpack) xs+ f (Second ys) = map (cons3 '+' . L.unpack) ys+ -- we print unchanged lines too. It shouldn't be a problem while we have+ -- reasonably small examples+ f (Both xs _) = map (cons3 ' ' . L.unpack) xs+ -- we add three characters, so the changed lines are easier to spot+ cons3 c cs = c : c : c : ' ' : cs++testWith :: Show a => String -> (Value -> Parser a) -> [L.ByteString] -> Output+testWith name parser ts =+ outputLine name <>+ foldMap (\s ->+ case eitherDecodeWith json (iparse parser) s of+ Left err -> outputLine $ uncurry formatError err+ Right a -> outputLine $ show a) ts++testFor :: forall a proxy. (FromJSON a, Show a)+ => String -> proxy a -> [L.ByteString] -> Output+testFor name _ = testWith name (parseJSON :: Value -> Parser a)++testWithSomeType :: String -> (Value -> Parser (SomeType Int)) -> [L.ByteString] -> Output+testWithSomeType = testWith
+ tests/PropUtils.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module PropUtils (module PropUtils) where++import Prelude.Compat++import Data.Aeson (eitherDecode, encode)+import Data.Aeson.Encoding (encodingToLazyByteString)+import Data.Aeson.Internal (IResult(..), formatError, ifromJSON, iparse)+import qualified Data.Aeson.Internal as I+import Data.Aeson.Parser (value)+import Data.Aeson.Types+import Data.HashMap.Strict (HashMap)+import Data.Hashable (Hashable)+import Data.Int (Int8)+import Data.Map (Map)+import Data.Time (ZonedTime)+import Encoders+import Instances ()+import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample)+import Types+import qualified Data.Attoparsec.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.HashMap.Strict as H+import qualified Data.Map as Map+import qualified Data.Text as T+import qualified Data.Vector as V+++encodeDouble :: Double -> Double -> Property+encodeDouble num denom+ | isInfinite d || isNaN d = encode d === "null"+ | otherwise = (read . L.unpack . encode) d === d+ where d = num / denom++encodeInteger :: Integer -> Property+encodeInteger i = encode i === L.pack (show i)++toParseJSON :: (Eq a, Show a) =>+ (Value -> Parser a) -> (a -> Value) -> a -> Property+toParseJSON parsejson tojson x =+ case iparse parsejson . tojson $ x of+ IError path msg -> failure "parse" (formatError path msg) x+ ISuccess x' -> x === x'++toParseJSON1+ :: (Eq (f Int), Show (f Int))+ => (forall a. LiftParseJSON f a)+ -> (forall a. LiftToJSON f a)+ -> f Int+ -> Property+toParseJSON1 parsejson1 tojson1 = toParseJSON parsejson tojson+ where+ parsejson = parsejson1 parseJSON (listParser parseJSON)+ tojson = tojson1 toJSON (listValue toJSON)++roundTripEnc :: (FromJSON a, ToJSON a, Show a) =>+ (a -> a -> Property) -> a -> a -> Property+roundTripEnc eq _ i =+ case fmap ifromJSON . L.parse value . encode $ i of+ L.Done _ (ISuccess v) -> v `eq` i+ L.Done _ (IError path err) -> failure "fromJSON" (formatError path err) i+ L.Fail _ _ err -> failure "parse" err i++roundTripNoEnc :: (FromJSON a, ToJSON a, Show a) =>+ (a -> a -> Property) -> a -> a -> Property+roundTripNoEnc eq _ i =+ case ifromJSON . toJSON $ i of+ (ISuccess v) -> v `eq` i+ (IError path err) -> failure "fromJSON" (formatError path err) i++roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property+roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y++-- We test keys by encoding HashMap and Map with it+roundTripKey+ :: (Ord a, Hashable a, FromJSONKey a, ToJSONKey a, Show a)+ => a -> HashMap a Int -> Map a Int -> Property+roundTripKey _ h m = roundTripEq h h .&&. roundTripEq m m++infix 4 ==~+(==~) :: (ApproxEq a, Show a) => a -> a -> Property+x ==~ y =+ counterexample (show x ++ " /= " ++ show y) (x =~ y)++toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a, Show a) => a -> Property+toFromJSON x = case ifromJSON (toJSON x) of+ IError path err -> failure "fromJSON" (formatError path err) x+ ISuccess x' -> x === x'++modifyFailureProp :: String -> String -> Bool+modifyFailureProp orig added =+ result == Error (added ++ orig)+ where+ parser = const $ modifyFailure (added ++) $ fail orig+ result :: Result ()+ result = parse parser ()++parserThrowErrorProp :: String -> Property+parserThrowErrorProp msg =+ result === Error msg+ where+ parser = const $ parserThrowError [] msg+ result :: Result ()+ result = parse parser ()++-- | Tests (also) that we catch the JSONPath and it has elements in the right order.+parserCatchErrorProp :: [String] -> String -> Property+parserCatchErrorProp path msg =+ result === Success ([I.Key "outer", I.Key "inner"] ++ jsonPath, msg)+ where+ parser = parserCatchError outer (curry pure)++ outer = inner I.<?> I.Key "outer"+ inner = parserThrowError jsonPath msg I.<?> I.Key "inner"++ result :: Result (I.JSONPath, String)+ result = parse (const parser) ()++ jsonPath = map (I.Key . T.pack) path++-- | Perform a structural comparison of the results of two encoding+-- methods. Compares decoded values to account for HashMap-driven+-- variation in JSON object key ordering.+sameAs :: (a -> Value) -> (a -> Encoding) -> a -> Property+sameAs toVal toEnc v =+ counterexample (show s) $+ eitherDecode s === Right (toVal v)+ where+ s = encodingToLazyByteString (toEnc v)++sameAs1+ :: (forall a. LiftToJSON f a)+ -> (forall a. LiftToEncoding f a)+ -> f Int+ -> Property+sameAs1 toVal1 toEnc1 v = lhs === rhs+ where+ rhs = Right $ toVal1 toJSON (listValue toJSON) v+ lhs = eitherDecode . encodingToLazyByteString $+ toEnc1 toEncoding (listEncoding toEncoding) v++sameAs1Agree+ :: ToJSON a+ => (f a -> Encoding)+ -> (forall b. LiftToEncoding f b)+ -> f a+ -> Property+sameAs1Agree toEnc toEnc1 v = rhs === lhs+ where+ rhs = encodingToLazyByteString $ toEnc v+ lhs = encodingToLazyByteString $ toEnc1 toEncoding (listEncoding toEncoding) v++type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()+type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)++--------------------------------------------------------------------------------+-- Value properties+--------------------------------------------------------------------------------++-- | Add the formatted @Value@ to the printed counterexample when the property+-- fails.+checkValue :: Testable a => (Value -> a) -> Value -> Property+checkValue prop v = counterexample (L.unpack (encode v)) (prop v)++isString :: Value -> Bool+isString (String _) = True+isString _ = False++is2ElemArray :: Value -> Bool+is2ElemArray (Array v) = V.length v == 2 && isString (V.head v)+is2ElemArray _ = False++isTaggedObjectValue :: Value -> Bool+isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&+ "contents" `H.member` obj+isTaggedObjectValue _ = False++isNullaryTaggedObject :: Value -> Bool+isNullaryTaggedObject obj = isTaggedObject' obj && isObjectWithSingleField obj++isTaggedObject :: Value -> Property+isTaggedObject = checkValue isTaggedObject'++isTaggedObject' :: Value -> Bool+isTaggedObject' (Object obj) = "tag" `H.member` obj+isTaggedObject' _ = False++isObjectWithSingleField :: Value -> Bool+isObjectWithSingleField (Object obj) = H.size obj == 1+isObjectWithSingleField _ = False++-- | is untaggedValue of EitherTextInt+isUntaggedValueETI :: Value -> Bool+isUntaggedValueETI (String s)+ | s == "nonenullary" = True+isUntaggedValueETI (Bool _) = True+isUntaggedValueETI (Number _) = True+isUntaggedValueETI (Array a) = length a == 2+isUntaggedValueETI _ = False++isEmptyArray :: Value -> Property+isEmptyArray = checkValue isEmptyArray'++isEmptyArray' :: Value -> Bool+isEmptyArray' = (Array mempty ==)
tests/Properties.hs view
@@ -1,231 +1,18 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-} -- For arbitrary Compose {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} module Properties (module Properties) where import Prelude.Compat -import Control.Applicative (Const)-import Data.Aeson (eitherDecode, encode)-import Data.Aeson.Encoding (encodingToLazyByteString)-import Data.Aeson.Internal (IResult(..), formatError, ifromJSON, iparse)-import qualified Data.Aeson.Internal as I-import Data.Aeson.Parser (value)-import Data.Aeson.Types-import Data.DList (DList)-import Data.Functor.Compose (Compose (..))-import Data.HashMap.Strict (HashMap)-import Data.Hashable (Hashable)-import Data.Int (Int8)-import Data.List.NonEmpty (NonEmpty)-import Data.Map (Map)-import Data.Proxy (Proxy)-import Data.Ratio (Ratio)-import Data.Semigroup (Option(..))-import Data.Sequence (Seq)-import Data.Tagged (Tagged)-import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)-import Data.Version (Version)-import Encoders import Instances ()-import Numeric.Natural (Natural) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty)-import Test.QuickCheck (Arbitrary(..), Property, Testable, (===), (.&&.), counterexample)-import Types-import qualified Data.Attoparsec.Lazy as L-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.HashMap.Strict as H-import qualified Data.Map as Map-import qualified Data.Text as T-import qualified Data.Text.Lazy as LT-import qualified Data.UUID.Types as UUID-import qualified Data.Vector as V--encodeDouble :: Double -> Double -> Property-encodeDouble num denom- | isInfinite d || isNaN d = encode d === "null"- | otherwise = (read . L.unpack . encode) d === d- where d = num / denom--encodeInteger :: Integer -> Property-encodeInteger i = encode i === L.pack (show i)--toParseJSON :: (Eq a, Show a) =>- (Value -> Parser a) -> (a -> Value) -> a -> Property-toParseJSON parsejson tojson x =- case iparse parsejson . tojson $ x of- IError path msg -> failure "parse" (formatError path msg) x- ISuccess x' -> x === x'--toParseJSON1- :: (Eq (f Int), Show (f Int))- => (forall a. LiftParseJSON f a)- -> (forall a. LiftToJSON f a)- -> f Int- -> Property-toParseJSON1 parsejson1 tojson1 = toParseJSON parsejson tojson- where- parsejson = parsejson1 parseJSON (listParser parseJSON)- tojson = tojson1 toJSON (listValue toJSON)--roundTripEnc :: (FromJSON a, ToJSON a, Show a) =>- (a -> a -> Property) -> a -> a -> Property-roundTripEnc eq _ i =- case fmap ifromJSON . L.parse value . encode $ i of- L.Done _ (ISuccess v) -> v `eq` i- L.Done _ (IError path err) -> failure "fromJSON" (formatError path err) i- L.Fail _ _ err -> failure "parse" err i--roundTripNoEnc :: (FromJSON a, ToJSON a, Show a) =>- (a -> a -> Property) -> a -> a -> Property-roundTripNoEnc eq _ i =- case ifromJSON . toJSON $ i of- (ISuccess v) -> v `eq` i- (IError path err) -> failure "fromJSON" (formatError path err) i--roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property-roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y---- We test keys by encoding HashMap and Map with it-roundTripKey- :: (Ord a, Hashable a, FromJSONKey a, ToJSONKey a, Show a)- => a -> HashMap a Int -> Map a Int -> Property-roundTripKey _ h m = roundTripEq h h .&&. roundTripEq m m--infix 4 ==~-(==~) :: (ApproxEq a, Show a) => a -> a -> Property-x ==~ y =- counterexample (show x ++ " /= " ++ show y) (x =~ y)--toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a, Show a) => a -> Property-toFromJSON x = case ifromJSON (toJSON x) of- IError path err -> failure "fromJSON" (formatError path err) x- ISuccess x' -> x === x'--modifyFailureProp :: String -> String -> Bool-modifyFailureProp orig added =- result == Error (added ++ orig)- where- parser = const $ modifyFailure (added ++) $ fail orig- result :: Result ()- result = parse parser ()--parserThrowErrorProp :: String -> Property-parserThrowErrorProp msg =- result === Error msg- where- parser = const $ parserThrowError [] msg- result :: Result ()- result = parse parser ()---- | Tests (also) that we catch the JSONPath and it has elements in the right order.-parserCatchErrorProp :: [String] -> String -> Property-parserCatchErrorProp path msg =- result === Success ([I.Key "outer", I.Key "inner"] ++ jsonPath, msg)- where- parser = parserCatchError outer (curry pure)-- outer = inner I.<?> I.Key "outer"- inner = parserThrowError jsonPath msg I.<?> I.Key "inner"-- result :: Result (I.JSONPath, String)- result = parse (const parser) ()-- jsonPath = map (I.Key . T.pack) path---- | Perform a structural comparison of the results of two encoding--- methods. Compares decoded values to account for HashMap-driven--- variation in JSON object key ordering.-sameAs :: (a -> Value) -> (a -> Encoding) -> a -> Property-sameAs toVal toEnc v =- counterexample (show s) $- eitherDecode s === Right (toVal v)- where- s = encodingToLazyByteString (toEnc v)--sameAs1- :: (forall a. LiftToJSON f a)- -> (forall a. LiftToEncoding f a)- -> f Int- -> Property-sameAs1 toVal1 toEnc1 v = lhs === rhs- where- rhs = Right $ toVal1 toJSON (listValue toJSON) v- lhs = eitherDecode . encodingToLazyByteString $- toEnc1 toEncoding (listEncoding toEncoding) v--sameAs1Agree- :: ToJSON a- => (f a -> Encoding)- -> (forall b. LiftToEncoding f b)- -> f a- -> Property-sameAs1Agree toEnc toEnc1 v = rhs === lhs- where- rhs = encodingToLazyByteString $ toEnc v- lhs = encodingToLazyByteString $ toEnc1 toEncoding (listEncoding toEncoding) v--type P6 = Product6 Int Bool String (Approx Double) (Int, Approx Double) ()-type S4 = Sum4 Int8 ZonedTime T.Text (Map.Map String Int)------------------------------------------------------------------------------------- Value properties------------------------------------------------------------------------------------- | Add the formatted @Value@ to the printed counterexample when the property--- fails.-checkValue :: Testable a => (Value -> a) -> Value -> Property-checkValue prop v = counterexample (L.unpack (encode v)) (prop v)--isString :: Value -> Bool-isString (String _) = True-isString _ = False--is2ElemArray :: Value -> Bool-is2ElemArray (Array v) = V.length v == 2 && isString (V.head v)-is2ElemArray _ = False--isTaggedObjectValue :: Value -> Bool-isTaggedObjectValue (Object obj) = "tag" `H.member` obj &&- "contents" `H.member` obj-isTaggedObjectValue _ = False--isNullaryTaggedObject :: Value -> Bool-isNullaryTaggedObject obj = isTaggedObject' obj && isObjectWithSingleField obj--isTaggedObject :: Value -> Property-isTaggedObject = checkValue isTaggedObject'--isTaggedObject' :: Value -> Bool-isTaggedObject' (Object obj) = "tag" `H.member` obj-isTaggedObject' _ = False--isObjectWithSingleField :: Value -> Bool-isObjectWithSingleField (Object obj) = H.size obj == 1-isObjectWithSingleField _ = False---- | is untaggedValue of EitherTextInt-isUntaggedValueETI :: Value -> Bool-isUntaggedValueETI (String s)- | s == "nonenullary" = True-isUntaggedValueETI (Bool _) = True-isUntaggedValueETI (Number _) = True-isUntaggedValueETI (Array a) = length a == 2-isUntaggedValueETI _ = False--isEmptyArray :: Value -> Property-isEmptyArray = checkValue isEmptyArray'--isEmptyArray' :: Value -> Bool-isEmptyArray' = (Array mempty ==)-----------------------------------------------------------------------------------+import Test.QuickCheck (Property)+import PropUtils+import PropertyGeneric+import PropertyKeys+import PropertyRoundTrip+import PropertyTH tests :: TestTree@@ -234,98 +21,8 @@ testProperty "encodeDouble" encodeDouble , testProperty "encodeInteger" encodeInteger ]- , testGroup "roundTrip" [- testProperty "Bool" $ roundTripEq True- , testProperty "Double" $ roundTripEq (1 :: Approx Double)- , testProperty "Int" $ roundTripEq (1 :: Int)- , testProperty "NonEmpty Char" $ roundTripEq (undefined :: NonEmpty Char)- , testProperty "Integer" $ roundTripEq (1 :: Integer)- , testProperty "String" $ roundTripEq ("" :: String)- , testProperty "Text" $ roundTripEq T.empty- , testProperty "Lazy Text" $ roundTripEq LT.empty- , testProperty "Foo" $ roundTripEq (undefined :: Foo)- , testProperty "Day" $ roundTripEq (undefined :: Day)- , testProperty "BCE Day" $ roundTripEq (undefined :: BCEDay)- , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)- , testProperty "LocalTime" $ roundTripEq (undefined :: LocalTime)- , testProperty "TimeOfDay" $ roundTripEq (undefined :: TimeOfDay)- , 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)- , testProperty "Tagged" $ roundTripEq (undefined :: Tagged Int Char)- , testProperty "Const" $ roundTripEq (undefined :: Const Int Char)- , testProperty "DList" $ roundTripEq (undefined :: DList Int)- , testProperty "Seq" $ roundTripEq (undefined :: Seq Int)- , testProperty "Rational" $ roundTripEq (undefined :: Rational)- , testProperty "Ratio Int" $ roundTripEq (undefined :: Ratio Int)- , testProperty "UUID" $ roundTripEq UUID.nil- , testGroup "functors"- [ testProperty "Identity Char" $ roundTripEq (undefined :: I Int)-- , testProperty "Identity Char" $ roundTripEq (undefined :: I Char)- , testProperty "Identity [Char]" $ roundTripEq (undefined :: I String)- , testProperty "[Identity Char]" $ roundTripEq (undefined :: [I Char])-- , testProperty "Compose I I Int" $ roundTripEq (undefined :: LogScaled (Compose I I Int))- , testProperty "Compose [] I Int" $ roundTripEq (undefined :: LogScaled (Compose [] I Int))- , testProperty "Compose I [] Int" $ roundTripEq (undefined :: LogScaled (Compose I [] Int))- , testProperty "Compose [] [] Int" $ roundTripEq (undefined :: LogScaled (Compose [] [] Int))-- , testProperty "Compose I I Char" $ roundTripEq (undefined :: LogScaled (Compose I I Char))- , testProperty "Compose [] I Char" $ roundTripEq (undefined :: LogScaled (Compose [] I Char))- , testProperty "Compose I [] Char" $ roundTripEq (undefined :: LogScaled (Compose I [] Char))- , testProperty "Compose [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose [] [] Char))-- , testProperty "Compose3 I I I Char" $ roundTripEq (undefined :: LogScaled (Compose3 I I I Char))- , testProperty "Compose3 I [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3 I [] I Char))- , testProperty "Compose3 I I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 I I [] Char))- , testProperty "Compose3 I [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 I [] [] Char))- , testProperty "Compose3 [] I I Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] I I Char))- , testProperty "Compose3 [] [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] [] I Char))- , testProperty "Compose3 [] I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] I [] Char))- , testProperty "Compose3 [] [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] [] [] Char))-- , testProperty "Compose3' I I I Char" $ roundTripEq (undefined :: LogScaled (Compose3' I I I Char))- , testProperty "Compose3' I [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3' I [] I Char))- , testProperty "Compose3' I I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' I I [] Char))- , testProperty "Compose3' I [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' I [] [] Char))- , testProperty "Compose3' [] I I Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] I I Char))- , testProperty "Compose3' [] [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] [] I Char))- , testProperty "Compose3' [] I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] I [] Char))- , testProperty "Compose3' [] [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] [] [] Char))- ]- , testGroup "ghcGenerics" [- testProperty "OneConstructor" $ roundTripEq OneConstructor- , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)- , testProperty "Product6" $ roundTripEq (undefined :: P6)- , testProperty "Sum4" $ roundTripEq (undefined :: S4)- ]- ]- , testGroup "roundTrip Key"- [ testProperty "Bool" $ roundTripKey True- , testProperty "Text" $ roundTripKey (undefined :: T.Text)- , testProperty "String" $ roundTripKey (undefined :: String)- , testProperty "Int" $ roundTripKey (undefined :: Int)- , testProperty "[Text]" $ roundTripKey (undefined :: LogScaled [T.Text])- , testProperty "(Int,Char)" $ roundTripKey (undefined :: (Int,Char))- , testProperty "Integer" $ roundTripKey (undefined :: Integer)- , 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- ]+ , roundTripTests+ , keysTests , testGroup "toFromJSON" [ testProperty "Integer" (toFromJSON :: Integer -> Property) , testProperty "Double" (toFromJSON :: Double -> Property)@@ -338,221 +35,6 @@ , testProperty "parserThrowError" parserThrowErrorProp , testProperty "parserCatchError" parserCatchErrorProp ]- , testGroup "generic" [- testGroup "toJSON" [- testGroup "Nullary" [- testProperty "string" (isString . gNullaryToJSONString)- , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)- , testProperty "TaggedObject" (isNullaryTaggedObject . gNullaryToJSONTaggedObject)- , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)- , testGroup "roundTrip" [- testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)- , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)- , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject)- , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)- ]- ]- , testGroup "EitherTextInt" [- testProperty "UntaggedValue" (isUntaggedValueETI . gEitherTextIntToJSONUntaggedValue)- , testProperty "roundtrip" (toParseJSON gEitherTextIntParseJSONUntaggedValue gEitherTextIntToJSONUntaggedValue)- ]- , testGroup "SomeType" [- testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)- , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)- , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gSomeTypeToJSONObjectWithSingleField)- , testGroup "roundTrip" [- testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray gSomeTypeToJSON2ElemArray)- , 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" [- testProperty "default" (isEmptyArray . gOneConstructorToJSONDefault)- , testProperty "Tagged" (isTaggedObject . gOneConstructorToJSONTagged)- , testGroup "roundTrip" [- testProperty "default" (toParseJSON gOneConstructorParseJSONDefault gOneConstructorToJSONDefault)- , testProperty "Tagged" (toParseJSON gOneConstructorParseJSONTagged gOneConstructorToJSONTagged)- ]- ]- , testGroup "OptionField" [- testProperty "like Maybe" $- \x -> gOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)- , testProperty "roundTrip" (toParseJSON gOptionFieldParseJSON gOptionFieldToJSON)- ]- ]- , testGroup "toEncoding" [- testProperty "NullaryString" $- gNullaryToJSONString `sameAs` gNullaryToEncodingString- , testProperty "Nullary2ElemArray" $- gNullaryToJSON2ElemArray `sameAs` gNullaryToEncoding2ElemArray- , testProperty "NullaryTaggedObject" $- gNullaryToJSONTaggedObject `sameAs` gNullaryToEncodingTaggedObject- , testProperty "NullaryObjectWithSingleField" $- gNullaryToJSONObjectWithSingleField `sameAs`- gNullaryToEncodingObjectWithSingleField- -- , testProperty "ApproxUnwrap" $- -- gApproxToJSONUnwrap `sameAs` gApproxToEncodingUnwrap- , testProperty "ApproxDefault" $- gApproxToJSONDefault `sameAs` gApproxToEncodingDefault-- , testProperty "EitherTextInt UntaggedValue" $- gEitherTextIntToJSONUntaggedValue `sameAs` gEitherTextIntToEncodingUntaggedValue-- , 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-- , testProperty "OneConstructorDefault" $- gOneConstructorToJSONDefault `sameAs` gOneConstructorToEncodingDefault- , testProperty "OneConstructorTagged" $- gOneConstructorToJSONTagged `sameAs` gOneConstructorToEncodingTagged-- , testProperty "OptionField" $- gOptionFieldToJSON `sameAs` gOptionFieldToEncoding- ]- ]- , testGroup "template-haskell" [- testGroup "toJSON" [- testGroup "Nullary" [- testProperty "string" (isString . thNullaryToJSONString)- , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)- , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)- , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)-- , testGroup "roundTrip" [- testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)- , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)- , testProperty "TaggedObject" (toParseJSON thNullaryParseJSONTaggedObject thNullaryToJSONTaggedObject)- , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)- ]- ]- , testGroup "EitherTextInt" [- testProperty "UntaggedValue" (isUntaggedValueETI . thEitherTextIntToJSONUntaggedValue)- , testProperty "roundtrip" (toParseJSON thEitherTextIntParseJSONUntaggedValue thEitherTextIntToJSONUntaggedValue)- ]- , testGroup "SomeType" [- testProperty "2ElemArray" (is2ElemArray . thSomeTypeToJSON2ElemArray)- , testProperty "TaggedObject" (isTaggedObject . thSomeTypeToJSONTaggedObject)- , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thSomeTypeToJSONObjectWithSingleField)- , testGroup "roundTrip" [- testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray thSomeTypeToJSON2ElemArray)- , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)- , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)-- , testProperty "2ElemArray unary" (toParseJSON1 thSomeTypeLiftParseJSON2ElemArray thSomeTypeLiftToJSON2ElemArray)- , testProperty "TaggedObject unary" (toParseJSON1 thSomeTypeLiftParseJSONTaggedObject thSomeTypeLiftToJSONTaggedObject)- , testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField)-- ]- ]- , testGroup "Approx" [- testProperty "string" (isString . thApproxToJSONUnwrap)- , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)- , testGroup "roundTrip" [- testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)- , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)- ]- ]- , testGroup "GADT" [- testProperty "string" (isString . thGADTToJSONUnwrap)- , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)- , testGroup "roundTrip" [- testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)- , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)- ]- ]- , testGroup "OneConstructor" [- testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)- , testProperty "Tagged" (isTaggedObject . thOneConstructorToJSONTagged)- , testGroup "roundTrip" [- testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)- , testProperty "Tagged" (toParseJSON thOneConstructorParseJSONTagged thOneConstructorToJSONTagged)- ]- ]- , testGroup "OptionField" [- testProperty "like Maybe" $- \x -> thOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)- , testProperty "roundTrip" (toParseJSON thOptionFieldParseJSON thOptionFieldToJSON)- ]- ]- , testGroup "toEncoding" [- testProperty "NullaryString" $- thNullaryToJSONString `sameAs` thNullaryToEncodingString- , testProperty "Nullary2ElemArray" $- thNullaryToJSON2ElemArray `sameAs` thNullaryToEncoding2ElemArray- , testProperty "NullaryTaggedObject" $- thNullaryToJSONTaggedObject `sameAs` thNullaryToEncodingTaggedObject- , testProperty "NullaryObjectWithSingleField" $- thNullaryToJSONObjectWithSingleField `sameAs`- thNullaryToEncodingObjectWithSingleField- , testProperty "ApproxUnwrap" $- thApproxToJSONUnwrap `sameAs` thApproxToEncodingUnwrap- , testProperty "ApproxDefault" $- thApproxToJSONDefault `sameAs` thApproxToEncodingDefault-- , testProperty "EitherTextInt UntaggedValue" $- thEitherTextIntToJSONUntaggedValue `sameAs` thEitherTextIntToEncodingUntaggedValue-- , testProperty "SomeType2ElemArray" $- thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray- , testProperty "SomeType2ElemArray unary" $- thSomeTypeLiftToJSON2ElemArray `sameAs1` thSomeTypeLiftToEncoding2ElemArray- , testProperty "SomeType2ElemArray unary agree" $- thSomeTypeToEncoding2ElemArray `sameAs1Agree` thSomeTypeLiftToEncoding2ElemArray-- , testProperty "SomeTypeTaggedObject" $- thSomeTypeToJSONTaggedObject `sameAs` thSomeTypeToEncodingTaggedObject- , testProperty "SomeTypeTaggedObject unary" $- thSomeTypeLiftToJSONTaggedObject `sameAs1` thSomeTypeLiftToEncodingTaggedObject- , testProperty "SomeTypeTaggedObject unary agree" $- thSomeTypeToEncodingTaggedObject `sameAs1Agree` thSomeTypeLiftToEncodingTaggedObject-- , testProperty "SomeTypeObjectWithSingleField" $- thSomeTypeToJSONObjectWithSingleField `sameAs` thSomeTypeToEncodingObjectWithSingleField- , testProperty "SomeTypeObjectWithSingleField unary" $- thSomeTypeLiftToJSONObjectWithSingleField `sameAs1` thSomeTypeLiftToEncodingObjectWithSingleField- , testProperty "SomeTypeObjectWithSingleField unary agree" $- thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField-- , testProperty "OneConstructorDefault" $- thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault- , testProperty "OneConstructorTagged" $- thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged-- , testProperty "OptionField" $- thOptionFieldToJSON `sameAs` thOptionFieldToEncoding- ]- ]+ , genericTests+ , templateHaskellTests ]
+ tests/PropertyGeneric.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}++module PropertyGeneric ( genericTests ) where++import Prelude.Compat++import Data.Semigroup (Option(..))+import Encoders+import Instances ()+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck ( (===) )+import Types+import PropUtils+++genericTests :: TestTree+genericTests =+ testGroup "generic" [+ testGroup "toJSON" [+ testGroup "Nullary" [+ testProperty "string" (isString . gNullaryToJSONString)+ , testProperty "2ElemArray" (is2ElemArray . gNullaryToJSON2ElemArray)+ , testProperty "TaggedObject" (isNullaryTaggedObject . gNullaryToJSONTaggedObject)+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gNullaryToJSONObjectWithSingleField)+ , testGroup "roundTrip" [+ testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString)+ , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray)+ , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject)+ , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField)+ ]+ ]+ , testGroup "EitherTextInt" [+ testProperty "UntaggedValue" (isUntaggedValueETI . gEitherTextIntToJSONUntaggedValue)+ , testProperty "roundtrip" (toParseJSON gEitherTextIntParseJSONUntaggedValue gEitherTextIntToJSONUntaggedValue)+ ]+ , testGroup "SomeType" [+ testProperty "2ElemArray" (is2ElemArray . gSomeTypeToJSON2ElemArray)+ , testProperty "TaggedObject" (isTaggedObject . gSomeTypeToJSONTaggedObject)+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . gSomeTypeToJSONObjectWithSingleField)+ , testGroup "roundTrip" [+ testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray gSomeTypeToJSON2ElemArray)+ , 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" [+ testProperty "default" (isEmptyArray . gOneConstructorToJSONDefault)+ , testProperty "Tagged" (isTaggedObject . gOneConstructorToJSONTagged)+ , testGroup "roundTrip" [+ testProperty "default" (toParseJSON gOneConstructorParseJSONDefault gOneConstructorToJSONDefault)+ , testProperty "Tagged" (toParseJSON gOneConstructorParseJSONTagged gOneConstructorToJSONTagged)+ ]+ ]+ , testGroup "OptionField" [+ testProperty "like Maybe" $+ \x -> gOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)+ , testProperty "roundTrip" (toParseJSON gOptionFieldParseJSON gOptionFieldToJSON)+ ]+ ]+ , testGroup "toEncoding" [+ testProperty "NullaryString" $+ gNullaryToJSONString `sameAs` gNullaryToEncodingString+ , testProperty "Nullary2ElemArray" $+ gNullaryToJSON2ElemArray `sameAs` gNullaryToEncoding2ElemArray+ , testProperty "NullaryTaggedObject" $+ gNullaryToJSONTaggedObject `sameAs` gNullaryToEncodingTaggedObject+ , testProperty "NullaryObjectWithSingleField" $+ gNullaryToJSONObjectWithSingleField `sameAs`+ gNullaryToEncodingObjectWithSingleField+ -- , testProperty "ApproxUnwrap" $+ -- gApproxToJSONUnwrap `sameAs` gApproxToEncodingUnwrap+ , testProperty "ApproxDefault" $+ gApproxToJSONDefault `sameAs` gApproxToEncodingDefault++ , testProperty "EitherTextInt UntaggedValue" $+ gEitherTextIntToJSONUntaggedValue `sameAs` gEitherTextIntToEncodingUntaggedValue++ , 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++ , testProperty "OneConstructorDefault" $+ gOneConstructorToJSONDefault `sameAs` gOneConstructorToEncodingDefault+ , testProperty "OneConstructorTagged" $+ gOneConstructorToJSONTagged `sameAs` gOneConstructorToEncodingTagged++ , testProperty "OptionField" $+ gOptionFieldToJSON `sameAs` gOptionFieldToEncoding+ ]+ ]
+ tests/PropertyKeys.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}++module PropertyKeys ( keysTests ) where++import Prelude.Compat++import Data.Time (Day, LocalTime, TimeOfDay, UTCTime)+import Data.Version (Version)+import Instances ()+import Numeric.Natural (Natural)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Types+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.UUID.Types as UUID+import PropUtils+++keysTests :: TestTree+keysTests =+ testGroup "roundTrip Key"+ [ testProperty "Bool" $ roundTripKey True+ , testProperty "Text" $ roundTripKey (undefined :: T.Text)+ , testProperty "String" $ roundTripKey (undefined :: String)+ , testProperty "Int" $ roundTripKey (undefined :: Int)+ , testProperty "[Text]" $ roundTripKey (undefined :: LogScaled [T.Text])+ , testProperty "(Int,Char)" $ roundTripKey (undefined :: (Int,Char))+ , testProperty "Integer" $ roundTripKey (undefined :: Integer)+ , 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/PropertyRTFunctors.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE NoImplicitPrelude #-}++module PropertyRTFunctors ( roundTripFunctorsTests ) where++import Prelude.Compat++import Data.Functor.Compose (Compose (..))+import Instances ()+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Types+import PropUtils+++roundTripFunctorsTests :: TestTree+roundTripFunctorsTests =+ testGroup "functors"+ [ testProperty "Identity Char" $ roundTripEq (undefined :: I Int)++ , testProperty "Identity Char" $ roundTripEq (undefined :: I Char)+ , testProperty "Identity [Char]" $ roundTripEq (undefined :: I String)+ , testProperty "[Identity Char]" $ roundTripEq (undefined :: [I Char])++ , testProperty "Compose I I Int" $ roundTripEq (undefined :: LogScaled (Compose I I Int))+ , testProperty "Compose [] I Int" $ roundTripEq (undefined :: LogScaled (Compose [] I Int))+ , testProperty "Compose I [] Int" $ roundTripEq (undefined :: LogScaled (Compose I [] Int))+ , testProperty "Compose [] [] Int" $ roundTripEq (undefined :: LogScaled (Compose [] [] Int))++ , testProperty "Compose I I Char" $ roundTripEq (undefined :: LogScaled (Compose I I Char))+ , testProperty "Compose [] I Char" $ roundTripEq (undefined :: LogScaled (Compose [] I Char))+ , testProperty "Compose I [] Char" $ roundTripEq (undefined :: LogScaled (Compose I [] Char))+ , testProperty "Compose [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose [] [] Char))++ , testProperty "Compose3 I I I Char" $ roundTripEq (undefined :: LogScaled (Compose3 I I I Char))+ , testProperty "Compose3 I [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3 I [] I Char))+ , testProperty "Compose3 I I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 I I [] Char))+ , testProperty "Compose3 I [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 I [] [] Char))+ , testProperty "Compose3 [] I I Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] I I Char))+ , testProperty "Compose3 [] [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] [] I Char))+ , testProperty "Compose3 [] I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] I [] Char))+ , testProperty "Compose3 [] [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3 [] [] [] Char))++ , testProperty "Compose3' I I I Char" $ roundTripEq (undefined :: LogScaled (Compose3' I I I Char))+ , testProperty "Compose3' I [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3' I [] I Char))+ , testProperty "Compose3' I I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' I I [] Char))+ , testProperty "Compose3' I [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' I [] [] Char))+ , testProperty "Compose3' [] I I Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] I I Char))+ , testProperty "Compose3' [] [] I Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] [] I Char))+ , testProperty "Compose3' [] I [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] I [] Char))+ , testProperty "Compose3' [] [] [] Char" $ roundTripEq (undefined :: LogScaled (Compose3' [] [] [] Char))+ ]
+ tests/PropertyRoundTrip.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE NoImplicitPrelude #-}++module PropertyRoundTrip ( roundTripTests ) where++import Prelude.Compat++import Control.Applicative (Const)+import Data.Aeson.Types+import Data.DList (DList)+import Data.List.NonEmpty (NonEmpty)+import Data.Proxy (Proxy)+import Data.Ratio (Ratio)+import Data.Sequence (Seq)+import Data.Tagged (Tagged)+import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)+import Data.Version (Version)+import Instances ()+import Numeric.Natural (Natural)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Types+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.UUID.Types as UUID+import PropUtils+import PropertyRTFunctors+++roundTripTests :: TestTree+roundTripTests =+ testGroup "roundTrip" [+ testProperty "Bool" $ roundTripEq True+ , testProperty "Double" $ roundTripEq (1 :: Approx Double)+ , testProperty "Int" $ roundTripEq (1 :: Int)+ , testProperty "NonEmpty Char" $ roundTripEq (undefined :: NonEmpty Char)+ , testProperty "Integer" $ roundTripEq (1 :: Integer)+ , testProperty "String" $ roundTripEq ("" :: String)+ , testProperty "Text" $ roundTripEq T.empty+ , testProperty "Lazy Text" $ roundTripEq LT.empty+ , testProperty "Foo" $ roundTripEq (undefined :: Foo)+ , testProperty "Day" $ roundTripEq (undefined :: Day)+ , testProperty "BCE Day" $ roundTripEq (undefined :: BCEDay)+ , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)+ , testProperty "LocalTime" $ roundTripEq (undefined :: LocalTime)+ , testProperty "TimeOfDay" $ roundTripEq (undefined :: TimeOfDay)+ , 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)+ , testProperty "Tagged" $ roundTripEq (undefined :: Tagged Int Char)+ , testProperty "Const" $ roundTripEq (undefined :: Const Int Char)+ , testProperty "DList" $ roundTripEq (undefined :: DList Int)+ , testProperty "Seq" $ roundTripEq (undefined :: Seq Int)+ , testProperty "Rational" $ roundTripEq (undefined :: Rational)+ , testProperty "Ratio Int" $ roundTripEq (undefined :: Ratio Int)+ , testProperty "UUID" $ roundTripEq UUID.nil+ , roundTripFunctorsTests+ , testGroup "ghcGenerics" [+ testProperty "OneConstructor" $ roundTripEq OneConstructor+ , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)+ , testProperty "Product6" $ roundTripEq (undefined :: P6)+ , testProperty "Sum4" $ roundTripEq (undefined :: S4)+ ]+ ]
+ tests/PropertyTH.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE NoImplicitPrelude #-}++module PropertyTH ( templateHaskellTests ) where++import Prelude.Compat++import Data.Semigroup (Option(..))+import Encoders+import Instances ()+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck ( (===) )+import Types+import PropUtils+++templateHaskellTests :: TestTree+templateHaskellTests =+ testGroup "template-haskell" [+ testGroup "toJSON" [+ testGroup "Nullary" [+ testProperty "string" (isString . thNullaryToJSONString)+ , testProperty "2ElemArray" (is2ElemArray . thNullaryToJSON2ElemArray)+ , testProperty "TaggedObject" (isNullaryTaggedObject . thNullaryToJSONTaggedObject)+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thNullaryToJSONObjectWithSingleField)++ , testGroup "roundTrip" [+ testProperty "string" (toParseJSON thNullaryParseJSONString thNullaryToJSONString)+ , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray)+ , testProperty "TaggedObject" (toParseJSON thNullaryParseJSONTaggedObject thNullaryToJSONTaggedObject)+ , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField)+ ]+ ]+ , testGroup "EitherTextInt" [+ testProperty "UntaggedValue" (isUntaggedValueETI . thEitherTextIntToJSONUntaggedValue)+ , testProperty "roundtrip" (toParseJSON thEitherTextIntParseJSONUntaggedValue thEitherTextIntToJSONUntaggedValue)+ ]+ , testGroup "SomeType" [+ testProperty "2ElemArray" (is2ElemArray . thSomeTypeToJSON2ElemArray)+ , testProperty "TaggedObject" (isTaggedObject . thSomeTypeToJSONTaggedObject)+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thSomeTypeToJSONObjectWithSingleField)+ , testGroup "roundTrip" [+ testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray thSomeTypeToJSON2ElemArray)+ , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject)+ , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField)++ , testProperty "2ElemArray unary" (toParseJSON1 thSomeTypeLiftParseJSON2ElemArray thSomeTypeLiftToJSON2ElemArray)+ , testProperty "TaggedObject unary" (toParseJSON1 thSomeTypeLiftParseJSONTaggedObject thSomeTypeLiftToJSONTaggedObject)+ , testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField)++ ]+ ]+ , testGroup "Approx" [+ testProperty "string" (isString . thApproxToJSONUnwrap)+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thApproxToJSONDefault)+ , testGroup "roundTrip" [+ testProperty "string" (toParseJSON thApproxParseJSONUnwrap thApproxToJSONUnwrap)+ , testProperty "ObjectWithSingleField" (toParseJSON thApproxParseJSONDefault thApproxToJSONDefault)+ ]+ ]+ , testGroup "GADT" [+ testProperty "string" (isString . thGADTToJSONUnwrap)+ , testProperty "ObjectWithSingleField" (isObjectWithSingleField . thGADTToJSONDefault)+ , testGroup "roundTrip" [+ testProperty "string" (toParseJSON thGADTParseJSONUnwrap thGADTToJSONUnwrap)+ , testProperty "ObjectWithSingleField" (toParseJSON thGADTParseJSONDefault thGADTToJSONDefault)+ ]+ ]+ , testGroup "OneConstructor" [+ testProperty "default" (isEmptyArray . thOneConstructorToJSONDefault)+ , testProperty "Tagged" (isTaggedObject . thOneConstructorToJSONTagged)+ , testGroup "roundTrip" [+ testProperty "default" (toParseJSON thOneConstructorParseJSONDefault thOneConstructorToJSONDefault)+ , testProperty "Tagged" (toParseJSON thOneConstructorParseJSONTagged thOneConstructorToJSONTagged)+ ]+ ]+ , testGroup "OptionField" [+ testProperty "like Maybe" $+ \x -> thOptionFieldToJSON (OptionField (Option x)) === thMaybeFieldToJSON (MaybeField x)+ , testProperty "roundTrip" (toParseJSON thOptionFieldParseJSON thOptionFieldToJSON)+ ]+ ]+ , testGroup "toEncoding" [+ testProperty "NullaryString" $+ thNullaryToJSONString `sameAs` thNullaryToEncodingString+ , testProperty "Nullary2ElemArray" $+ thNullaryToJSON2ElemArray `sameAs` thNullaryToEncoding2ElemArray+ , testProperty "NullaryTaggedObject" $+ thNullaryToJSONTaggedObject `sameAs` thNullaryToEncodingTaggedObject+ , testProperty "NullaryObjectWithSingleField" $+ thNullaryToJSONObjectWithSingleField `sameAs`+ thNullaryToEncodingObjectWithSingleField+ , testProperty "ApproxUnwrap" $+ thApproxToJSONUnwrap `sameAs` thApproxToEncodingUnwrap+ , testProperty "ApproxDefault" $+ thApproxToJSONDefault `sameAs` thApproxToEncodingDefault++ , testProperty "EitherTextInt UntaggedValue" $+ thEitherTextIntToJSONUntaggedValue `sameAs` thEitherTextIntToEncodingUntaggedValue++ , testProperty "SomeType2ElemArray" $+ thSomeTypeToJSON2ElemArray `sameAs` thSomeTypeToEncoding2ElemArray+ , testProperty "SomeType2ElemArray unary" $+ thSomeTypeLiftToJSON2ElemArray `sameAs1` thSomeTypeLiftToEncoding2ElemArray+ , testProperty "SomeType2ElemArray unary agree" $+ thSomeTypeToEncoding2ElemArray `sameAs1Agree` thSomeTypeLiftToEncoding2ElemArray++ , testProperty "SomeTypeTaggedObject" $+ thSomeTypeToJSONTaggedObject `sameAs` thSomeTypeToEncodingTaggedObject+ , testProperty "SomeTypeTaggedObject unary" $+ thSomeTypeLiftToJSONTaggedObject `sameAs1` thSomeTypeLiftToEncodingTaggedObject+ , testProperty "SomeTypeTaggedObject unary agree" $+ thSomeTypeToEncodingTaggedObject `sameAs1Agree` thSomeTypeLiftToEncodingTaggedObject++ , testProperty "SomeTypeObjectWithSingleField" $+ thSomeTypeToJSONObjectWithSingleField `sameAs` thSomeTypeToEncodingObjectWithSingleField+ , testProperty "SomeTypeObjectWithSingleField unary" $+ thSomeTypeLiftToJSONObjectWithSingleField `sameAs1` thSomeTypeLiftToEncodingObjectWithSingleField+ , testProperty "SomeTypeObjectWithSingleField unary agree" $+ thSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` thSomeTypeLiftToEncodingObjectWithSingleField++ , testProperty "OneConstructorDefault" $+ thOneConstructorToJSONDefault `sameAs` thOneConstructorToEncodingDefault+ , testProperty "OneConstructorTagged" $+ thOneConstructorToJSONTagged `sameAs` thOneConstructorToEncodingTagged++ , testProperty "OptionField" $+ thOptionFieldToJSON `sameAs` thOptionFieldToEncoding+ ]+ ]
tests/UnitTests.hs view
@@ -36,7 +36,6 @@ import Data.HashMap.Strict (HashMap) import Data.List (sort) import Data.Maybe (fromMaybe)-import Data.Sequence (Seq) import Data.Scientific (Scientific, scientific) import Data.Tagged (Tagged(..)) import Data.Text (Text)@@ -93,7 +92,6 @@ testCase "example 1" formatErrorExample ] , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark- , testGroup "JSONPath" $ fmap (testCase "-") jsonPath , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws , testGroup "Object construction" $ fmap (testCase "-") objectConstruction , testGroup "Issue #351" $ fmap (testCase "-") issue351@@ -277,27 +275,6 @@ ex3 = "{\"value\": null }" --------------------------------------------------------------------------------- These tests check that JSONPath is tracked correctly--------------------------------------------------------------------------------jsonPath :: [Assertion]-jsonPath = [- -- issue #356- assertEqual "Either"- (Left "Error in $[1].Left[1]: expected Bool, encountered Number")- (eitherDecode "[1,{\"Left\":[2,3]}]"- :: Either String (Int, Either (Int, Bool) ()))- -- issue #358- , assertEqual "Seq a"- (Left "Error in $[2]: expected Int, encountered Boolean")- (eitherDecode "[0,1,true]" :: Either String (Seq Int))- , assertEqual "Wibble"- (Left "Error in $.wibbleInt: expected Int, encountered Boolean")- (eitherDecode "{\"wibbleString\":\"\",\"wibbleInt\":true}"- :: Either String Wibble)- ]-------------------------------------------------------------------------------- -- Check that the hashes of two equal Value are the same ------------------------------------------------------------------------------ @@ -596,25 +573,25 @@ bigIntegerDecoding :: Assertion bigIntegerDecoding = assertEqual "Decoding an Integer with a large exponent should fail"- (Left "Error in $: expected a number with exponent <= 1024, encountered Number")+ (Left "Error in $: parsing Integer failed, found a number with exponent 2000, but it must not be greater than 1024") ((eitherDecode :: L.ByteString -> Either String Integer) "1e2000") bigNaturalDecoding :: Assertion bigNaturalDecoding = assertEqual "Decoding a Natural with a large exponent should fail"- (Left "Error in $: expected a number with exponent <= 1024, encountered Number")- ((eitherDecode :: L.ByteString -> Either String Integer) "1e2000")+ (Left "Error in $: parsing Natural failed, found a number with exponent 2000, but it must not be greater than 1024")+ ((eitherDecode :: L.ByteString -> Either String Natural) "1e2000") bigIntegerKeyDecoding :: Assertion bigIntegerKeyDecoding = assertEqual "Decoding an Integer key with a large exponent should fail"- (Left "Error in $['1e2000']: expected a number with exponent <= 1024, encountered Number")+ (Left "Error in $['1e2000']: parsing Integer failed, found a number with exponent 2000, but it must not be greater than 1024") ((eitherDecode :: L.ByteString -> Either String (HashMap Integer Value)) "{ \"1e2000\": null }") bigNaturalKeyDecoding :: Assertion bigNaturalKeyDecoding = assertEqual "Decoding an Integer key with a large exponent should fail"- (Left "Error in $['1e2000']: expected a number with exponent <= 1024, encountered Number")+ (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 }") deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord
+ tests/golden/generic.expected view
@@ -0,0 +1,40 @@+OneConstructor+Error in $: parsing Types.OneConstructor(OneConstructor) failed, expected Array, but encountered String+Error in $: parsing Types.OneConstructor(OneConstructor) failed, expected an empty Array, but encountered an Array of length 1+Nullary+Error in $: parsing Types.Nullary failed, expected one of the tags ["C1","C2","C3"], but found tag "X"+Error in $: parsing Types.Nullary failed, expected String, but encountered Array+SomeType (tagged)+Error in $.contents: parsing Int failed, expected Number, but encountered Boolean+Error in $: parsing Types.SomeType(Unary) failed, key "contents" not present+Error in $: parsing Types.SomeType(Record) failed, key "testone" not present+Error in $.testone: parsing Double failed, unexpected Boolean+Error in $.tag: parsing Types.SomeType failed, expected tag field to be one of ["nullary","unary","product","record","list"], but found tag "X"+Error in $: parsing Types.SomeType failed, key "tag" not present+Error in $: parsing Types.SomeType failed, expected Object, but encountered Array+SomeType (single-field)+Error in $.unary: parsing Int failed, expected Number, but encountered Object+Error in $.unary: parsing Int failed, expected Number, but encountered Array+Error in $: parsing Types.SomeType failed, expected an Object with a single pair where the tag is one of ["nullary","unary","product","record","list"], but found tag "X"+Error in $: parsing Types.SomeType failed, expected an Object with a single pair, but found 2 pairs+Error in $: parsing Types.SomeType failed, expected an Object with a single pair, but found 0 pairs+Error in $: parsing Types.SomeType failed, expected Object, but encountered Array+Error in $: not enough input. Expecting ':'+Error in $: not enough input. Expecting object value+Error in $: not enough input. Expecting ',' or '}'+SomeType (two-element array)+Error in $[1]: parsing Int failed, expected Number, but encountered Boolean+Error in $[1]: parsing Types.SomeType(Record) failed, expected Object, but encountered Null+Error in $[0]: parsing Types.SomeType failed, expected tag of the 2-element Array to be one of ["nullary","unary","product","record","list"], but found tag "X"+Error in $[0]: parsing Types.SomeType failed, tag element is not a String+Error in $: parsing Types.SomeType failed, expected a 2-element Array, but encountered an Array of length 0+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+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+Product2 Int Bool+Error in $[1]: expected Bool, but encountered Null+Error in $: parsing Types.Product2(Product2) failed, expected an Array of length 2, but encountered an Array of length 0+Error in $: parsing Types.Product2(Product2) failed, expected Array, but encountered Object
+ tests/golden/simple.expected view
@@ -0,0 +1,22 @@+Int+Error in $: parsing Int failed, expected Number, but encountered String+Error in $: parsing Int failed, expected Number, but encountered Array+Error in $: parsing Int failed, expected Number, but encountered Object+Error in $: parsing Int failed, expected Number, but encountered Null+Integer+Error in $: parsing Integer failed, unexpected floating number 44.44+Natural+Error in $: parsing Natural failed, unexpected floating number 44.44+Error in $: parsing Natural failed, unexpected negative number -50+String+Error in $: expected String, but encountered Number+Error in $: expected String, but encountered Array+Error in $: expected String, but encountered Object+Error in $: expected String, but encountered Null+HashMap+Error in $: parsing HashMap failed, expected Object, but encountered String+Error in $: parsing HashMap failed, expected Object, but encountered Array+Either+Error in $[1].Left[1]: expected Bool, but encountered Number+Seq+Error in $[2]: parsing Int failed, expected Number, but encountered Boolean