diff --git a/Data/Aeson.hs b/Data/Aeson.hs --- a/Data/Aeson.hs +++ b/Data/Aeson.hs @@ -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 diff --git a/Data/Aeson/Parser/Internal.hs b/Data/Aeson/Parser/Internal.hs --- a/Data/Aeson/Parser/Internal.hs +++ b/Data/Aeson/Parser/Internal.hs @@ -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 diff --git a/Data/Aeson/TH.hs b/Data/Aeson/TH.hs --- a/Data/Aeson/TH.hs +++ b/Data/Aeson/TH.hs @@ -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 diff --git a/Data/Aeson/Types.hs b/Data/Aeson/Types.hs --- a/Data/Aeson/Types.hs +++ b/Data/Aeson/Types.hs @@ -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 diff --git a/Data/Aeson/Types/Class.hs b/Data/Aeson/Types/Class.hs --- a/Data/Aeson/Types/Class.hs +++ b/Data/Aeson/Types/Class.hs @@ -79,6 +79,7 @@ , fromJSON , ifromJSON , typeMismatch + , unexpected , parseField , parseFieldMaybe , parseFieldMaybe' diff --git a/Data/Aeson/Types/FromJSON.hs b/Data/Aeson/Types/FromJSON.hs --- a/Data/Aeson/Types/FromJSON.hs +++ b/Data/Aeson/Types/FromJSON.hs @@ -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 diff --git a/Data/Aeson/Types/Generic.hs b/Data/Aeson/Types/Generic.hs --- a/Data/Aeson/Types/Generic.hs +++ b/Data/Aeson/Types/Generic.hs @@ -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 :* diff --git a/Data/Aeson/Types/Internal.hs b/Data/Aeson/Types/Internal.hs --- a/Data/Aeson/Types/Internal.hs +++ b/Data/Aeson/Types/Internal.hs @@ -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. -- diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -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, diff --git a/benchmarks/aeson-benchmarks.cabal b/benchmarks/aeson-benchmarks.cabal --- a/benchmarks/aeson-benchmarks.cabal +++ b/benchmarks/aeson-benchmarks.cabal @@ -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, diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/tests/DataFamilies/Properties.hs b/tests/DataFamilies/Properties.hs --- a/tests/DataFamilies/Properties.hs +++ b/tests/DataFamilies/Properties.hs @@ -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) diff --git a/tests/Encoders.hs b/tests/Encoders.hs --- a/tests/Encoders.hs +++ b/tests/Encoders.hs @@ -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 diff --git a/tests/ErrorMessages.hs b/tests/ErrorMessages.hs --- a/tests/ErrorMessages.hs +++ b/tests/ErrorMessages.hs @@ -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 diff --git a/tests/PropUtils.hs b/tests/PropUtils.hs new file mode 100644 --- /dev/null +++ b/tests/PropUtils.hs @@ -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 ==) diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -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 ] diff --git a/tests/PropertyGeneric.hs b/tests/PropertyGeneric.hs new file mode 100644 --- /dev/null +++ b/tests/PropertyGeneric.hs @@ -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 + ] + ] diff --git a/tests/PropertyKeys.hs b/tests/PropertyKeys.hs new file mode 100644 --- /dev/null +++ b/tests/PropertyKeys.hs @@ -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 + ] diff --git a/tests/PropertyRTFunctors.hs b/tests/PropertyRTFunctors.hs new file mode 100644 --- /dev/null +++ b/tests/PropertyRTFunctors.hs @@ -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)) + ] diff --git a/tests/PropertyRoundTrip.hs b/tests/PropertyRoundTrip.hs new file mode 100644 --- /dev/null +++ b/tests/PropertyRoundTrip.hs @@ -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) + ] + ] diff --git a/tests/PropertyTH.hs b/tests/PropertyTH.hs new file mode 100644 --- /dev/null +++ b/tests/PropertyTH.hs @@ -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 + ] + ] diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -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 diff --git a/tests/golden/generic.expected b/tests/golden/generic.expected new file mode 100644 --- /dev/null +++ b/tests/golden/generic.expected @@ -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 diff --git a/tests/golden/simple.expected b/tests/golden/simple.expected new file mode 100644 --- /dev/null +++ b/tests/golden/simple.expected @@ -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