diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs index 4d43a67c..c1300b50 100644 --- a/src/Data/Aeson/TH.hs +++ b/src/Data/Aeson/TH.hs @@ -5,6 +5,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TupleSections #-} {-| Module: Data.Aeson.TH @@ -115,7 +116,7 @@ module Data.Aeson.TH import Data.Aeson.Internal.Prelude import Data.Char (ord) -import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..), object) +import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..)) import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject) import Data.Aeson.Types.Internal ((), JSONPathElement(Key)) import Data.Aeson.Types.ToJSON (fromPairs, pair) @@ -414,8 +415,10 @@ sumToValue letInsert target opts multiCons nullary conName value pairs content = pairs contentsFieldName in fromPairsE target $ if nullary then tag else infixApp tag [|(Monoid.<>)|] content - ObjectWithSingleField -> - objectE letInsert target [(conString opts conName, value)] + ObjectWithSingleField {tagFieldName_} -> + objectE letInsert target $ addTag [(conString opts conName, value)] + where + addTag = maybe id (\tfn -> ((tfn, bool target True) :)) tagFieldName_ UntaggedValue | nullary -> conStr target opts conName UntaggedValue -> value | otherwise = value @@ -507,6 +510,10 @@ infixr 6 <^> (<%>) a b = a <^> [|E.comma|] <^> b infixr 4 <%> +bool :: ToJSONFun -> Bool -> ExpQ +bool Encoding v = [|E.bool v|] +bool Value v = [|Bool v|] + -- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value'). array :: ToJSONFun -> [ExpQ] -> ExpQ array Encoding [] = [|E.emptyArray_|] @@ -720,8 +727,8 @@ consFromJSON jc tName opts instTys cons = do TaggedObject {tagFieldName, contentsFieldName} -> parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName UntaggedValue -> error "UntaggedValue: Should be handled already" - ObjectWithSingleField -> - parseObject $ parseObjectWithSingleField tvMap + ObjectWithSingleField tagFieldName_ -> + parseObject $ parseObjectWithSingleField tagFieldName_ tvMap TwoElemArray -> [ do arr <- newName "array" match (conP 'Array [varP arr]) @@ -827,21 +834,50 @@ consFromJSON jc tName opts instTys cons = do ] ) - parseObjectWithSingleField tvMap obj = do - conKey <- newName "conKeyZ" - conVal <- newName "conValZ" - caseE ([e|KM.toList|] `appE` varE obj) - [ match (listP [tupP [varP conKey, varP conVal]]) - (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField [|Key.fromString|] [|Key.toString|]) - [] - , do other <- newName "other" - match (varP other) - (normalB $ [|wrongPairCountFail|] + parseObjectWithSingleField tagFieldName_ tvMap obj = + caseE ([e|KM.toList|] `appE` varE obj) $ + case tagFieldName_ of + Just tfn -> [match1Tuple, match2Tuple tfn, matchOther] + Nothing -> [match1Tuple, matchOther] + where + parseKey key val = parseContents tvMap key (Right val) 'conNotFoundFailObjectSingleField [|Key.fromString|] [|Key.toString|] + match1Tuple = do + conKey <- newName "conKeyZ" + conVal <- newName "conValZ" + match (listP [tupP [varP conKey, varP conVal]]) + (normalB $ parseKey conKey conVal) + [] + match2Tuple tfn = do + key1 <- newName "keyZ1" + val1 <- newName "valZ1" + key2 <- newName "keyZ2" + val2 <- newName "valZ2" + match (listP [tupP [varP key1, varP val1], tupP [varP key2, varP val2]]) + ( guardedB + [ liftM2 (,) (owsfTag key1 val1) (parseKey key2 val2) + , liftM2 (,) (owsfTag key2 val2) (parseKey key1 val1) + , liftM2 (,) (normalG [e|otherwise|]) + ([|wrongPairCountFailTagged|] `appE` litE (stringL $ show tName) - `appE` ([|show . length|] `appE` varE other) - ) - [] - ] + `appE` litE (stringL tfn) + `appE` litE (stringL "2") + ) + ] + ) + [] + where + owsfTag key val = + normalG $ varE '(&&) + `appE` (varE '(==) `appE` ([|Key.toString|] `appE` varE key) `appE` stringE tfn) + `appE` (varE '(==) `appE` varE val `appE` [|Bool True|]) + matchOther = do + other <- newName "other" + match (varP other) + (normalB $ [|wrongPairCountFail|] + `appE` litE (stringL $ show tName) + `appE` ([|show . length|] `appE` varE other) + ) + [] parseContents tvMap conKey contents errorFun pack unpack= caseE (varE conKey) @@ -1181,6 +1217,11 @@ wrongPairCountFail t n = fail $ printf "When parsing %s expected an Object with a single tag/contents pair but got %s pairs." t n +wrongPairCountFailTagged :: String -> String -> String -> Parser fail +wrongPairCountFailTagged t tfn n = + fail $ printf "When parsing %s expected an Object with a single tag/contents pair and an optional tag %s, but got %s pairs." + t tfn n + noStringFail :: String -> String -> Parser fail noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index f01e0f2c..305bfc4f 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} @@ -1215,14 +1216,26 @@ parseNonAllNullarySum p@(tname :* opts :* _) = ", but found tag " ++ show tag cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String]) - ObjectWithSingleField -> + ObjectWithSingleField {tagFieldName_} -> withObject tname $ \obj -> case KM.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 (KM.size obj) ++ " pairs" + [(tag, v)] -> parseTag tag v + [(tag1, v1), (tag2, v2)] -> case tagFieldName_ of + Just tfn + | owsfTag tag1 v1 -> parseTag tag2 v2 + | owsfTag tag2 v2 -> parseTag tag1 v1 + | otherwise -> + contextType tname . fail $ + "expected an Object with a single pair and an optional tag " <> tfn <> ", but found " ++ + show (KM.size obj) ++ " pairs" + where + owsfTag tag v = Key.toString tag == tfn && v == Bool True + Nothing -> badObj obj + _ -> badObj obj where + parseTag tag v = maybe (badTag tag) ( Key tag) $ parsePair (tag :* p) v + badObj obj = contextType tname . fail $ + "expected an Object with a single pair, but found " ++ + show (KM.size obj) ++ " pairs" badTag tag = failWith_ $ \cnames -> "expected an Object with a single pair where the tag is one of " ++ show cnames ++ ", but found tag " ++ show tag diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs index 200e7fd1..f094ccc4 100644 --- a/src/Data/Aeson/Types/Internal.hs +++ b/src/Data/Aeson/Types/Internal.hs @@ -792,7 +792,7 @@ data SumEncoding = -- -- /Note:/ Only the last error is kept when decoding, so in the case of -- malformed JSON, only an error for the last constructor will be reported. - | ObjectWithSingleField + | ObjectWithSingleField {tagFieldName_ :: Maybe String} -- ^ A constructor will be encoded to an object with a single -- field named after the constructor tag (modified by the -- 'constructorTagModifier') which maps to the encoded contents of diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs index 1fabc07c..bfa1acf3 100644 --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/src/Data/Aeson/Types/ToJSON.hs @@ -967,7 +967,7 @@ nonAllNullarySumToJSON opts targs = TaggedObject{..} -> taggedObject opts targs (Key.fromString tagFieldName) (Key.fromString contentsFieldName) - ObjectWithSingleField -> + ObjectWithSingleField {} -> (unTagged :: Tagged ObjectWithSingleField enc -> enc) . sumToJSON' opts targs @@ -1278,13 +1278,19 @@ instance {-# OVERLAPPABLE #-} (GToJSON' Encoding arity a) => EncodeProduct arity instance ( GToJSON' enc arity a , ConsToJSON enc arity a , FromPairs enc pairs - , KeyValuePair enc pairs + , KeyValuePair enc pairs + , BoolEnc enc , Constructor c ) => SumToJSON' ObjectWithSingleField enc arity (C1 c a) where sumToJSON' opts targs = - Tagged . fromPairs . (typ `pair`) . gToJSON opts targs + Tagged . fromPairs . addTag . (typ `pair`) . gToJSON opts targs where + addTag = case sumEncoding opts of + ObjectWithSingleField {tagFieldName_ = Just tfn} -> + let p = pair (Key.fromString tfn) (boolEnc @enc True) + in (p <>) + _ -> id typ = Key.fromString $ constructorTagModifier opts $ conName (undefined :: t c a p) {-# INLINE sumToJSON' #-} @@ -2880,3 +2886,14 @@ instance (v ~ Value) => KeyValuePair v (DList Pair) where instance (e ~ Encoding) => KeyValuePair e Series where pair = E.pair {-# INLINE pair #-} + +class BoolEnc enc where + boolEnc :: Bool -> enc + +instance BoolEnc Value where + boolEnc = Bool + {-# INLINE boolEnc #-} + +instance BoolEnc Encoding where + boolEnc = E.bool + {-# INLINE boolEnc #-} diff --git a/tests/Encoders.hs b/tests/Encoders.hs index 783c8e5d..885785e3 100644 --- a/tests/Encoders.hs +++ b/tests/Encoders.hs @@ -61,6 +61,16 @@ thNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary thNullaryParseJSONObjectWithSingleField = $(mkParseJSON optsObjectWithSingleField ''Nullary) +thNullaryToJSONObjectWithSingleFieldTagged :: Nullary -> Value +thNullaryToJSONObjectWithSingleFieldTagged = $(mkToJSON optsObjectWithSingleFieldTagged ''Nullary) + +thNullaryToEncodingObjectWithSingleFieldTagged :: Nullary -> Encoding +thNullaryToEncodingObjectWithSingleFieldTagged = $(mkToEncoding optsObjectWithSingleFieldTagged ''Nullary) + +thNullaryParseJSONObjectWithSingleFieldTagged :: Value -> Parser Nullary +thNullaryParseJSONObjectWithSingleFieldTagged = $(mkParseJSON optsObjectWithSingleFieldTagged ''Nullary) + + thNullaryToJSONOWSFRejectUnknown :: Nullary -> Value thNullaryToJSONOWSFRejectUnknown = $(mkToJSON optsOWSFRejectUnknown ''Nullary) @@ -131,6 +141,16 @@ gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField +gNullaryToJSONObjectWithSingleFieldTagged :: Nullary -> Value +gNullaryToJSONObjectWithSingleFieldTagged = genericToJSON optsObjectWithSingleFieldTagged + +gNullaryToEncodingObjectWithSingleFieldTagged :: Nullary -> Encoding +gNullaryToEncodingObjectWithSingleFieldTagged = genericToEncoding optsObjectWithSingleFieldTagged + +gNullaryParseJSONObjectWithSingleFieldTagged :: Value -> Parser Nullary +gNullaryParseJSONObjectWithSingleFieldTagged = genericParseJSON optsObjectWithSingleFieldTagged + + gNullaryToJSONOWSFRejectUnknown :: Nullary -> Value gNullaryToJSONOWSFRejectUnknown = genericToJSON optsOWSFRejectUnknown @@ -243,6 +263,22 @@ thSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a thSomeTypeLiftParseJSONObjectWithSingleField = $(mkLiftParseJSON optsObjectWithSingleField ''SomeType) +thSomeTypeToJSONObjectWithSingleFieldTagged :: SomeType Int -> Value +thSomeTypeToJSONObjectWithSingleFieldTagged = $(mkToJSON optsObjectWithSingleFieldTagged ''SomeType) + +thSomeTypeToEncodingObjectWithSingleFieldTagged :: SomeType Int -> Encoding +thSomeTypeToEncodingObjectWithSingleFieldTagged = $(mkToEncoding optsObjectWithSingleFieldTagged ''SomeType) + +thSomeTypeParseJSONObjectWithSingleFieldTagged :: Value -> Parser (SomeType Int) +thSomeTypeParseJSONObjectWithSingleFieldTagged = $(mkParseJSON optsObjectWithSingleFieldTagged ''SomeType) + +thSomeTypeLiftToJSONObjectWithSingleFieldTagged :: LiftToJSON SomeType a +thSomeTypeLiftToJSONObjectWithSingleFieldTagged = $(mkLiftToJSON optsObjectWithSingleFieldTagged ''SomeType) + +thSomeTypeLiftParseJSONObjectWithSingleFieldTagged :: LiftParseJSON SomeType a +thSomeTypeLiftParseJSONObjectWithSingleFieldTagged = $(mkLiftParseJSON optsObjectWithSingleFieldTagged ''SomeType) + + gSomeTypeToJSON2ElemArray :: SomeType Int -> Value gSomeTypeToJSON2ElemArray = genericToJSON opts2ElemArray @@ -300,6 +336,22 @@ gSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a gSomeTypeLiftParseJSONObjectWithSingleField = genericLiftParseJSON optsObjectWithSingleField +gSomeTypeToJSONObjectWithSingleFieldTagged :: SomeType Int -> Value +gSomeTypeToJSONObjectWithSingleFieldTagged = genericToJSON optsObjectWithSingleFieldTagged + +gSomeTypeToEncodingObjectWithSingleFieldTagged :: SomeType Int -> Encoding +gSomeTypeToEncodingObjectWithSingleFieldTagged = genericToEncoding optsObjectWithSingleFieldTagged + +gSomeTypeParseJSONObjectWithSingleFieldTagged :: Value -> Parser (SomeType Int) +gSomeTypeParseJSONObjectWithSingleFieldTagged = genericParseJSON optsObjectWithSingleFieldTagged + +gSomeTypeLiftToJSONObjectWithSingleFieldTagged :: LiftToJSON SomeType a +gSomeTypeLiftToJSONObjectWithSingleFieldTagged = genericLiftToJSON optsObjectWithSingleFieldTagged + +gSomeTypeLiftParseJSONObjectWithSingleFieldTagged :: LiftParseJSON SomeType a +gSomeTypeLiftParseJSONObjectWithSingleFieldTagged = genericLiftParseJSON optsObjectWithSingleFieldTagged + + gSomeTypeToJSONOmitNothingFields :: SomeType Int -> Value gSomeTypeToJSONOmitNothingFields = genericToJSON optsOmitNothingFields diff --git a/tests/Options.hs b/tests/Options.hs index 2f636dad..fe98e47a 100644 --- a/tests/Options.hs +++ b/tests/Options.hs @@ -31,20 +31,27 @@ optsTaggedObject = optsDefault optsObjectWithSingleField :: Options optsObjectWithSingleField = optsDefault { allNullaryToStringTag = False - , sumEncoding = ObjectWithSingleField + , sumEncoding = ObjectWithSingleField Nothing } +optsObjectWithSingleFieldTagged :: Options +optsObjectWithSingleFieldTagged = optsDefault + { allNullaryToStringTag = False + , sumEncoding = ObjectWithSingleField (Just "_tag") + } + + optsOWSFRejectUnknown :: Options optsOWSFRejectUnknown = optsDefault { allNullaryToStringTag = False , rejectUnknownFields = True - , sumEncoding = ObjectWithSingleField + , sumEncoding = ObjectWithSingleField Nothing } optsOWSFNullaryToObject :: Options optsOWSFNullaryToObject = optsDefault { allNullaryToStringTag = False - , sumEncoding = ObjectWithSingleField + , sumEncoding = ObjectWithSingleField Nothing , nullaryToObject = True } @@ -52,7 +59,7 @@ optsOWSFNullaryToObjectRejectUnknown :: Options optsOWSFNullaryToObjectRejectUnknown = optsDefault { allNullaryToStringTag = False , rejectUnknownFields = True - , sumEncoding = ObjectWithSingleField + , sumEncoding = ObjectWithSingleField Nothing , nullaryToObject = True } diff --git a/tests/PropertyGeneric.hs b/tests/PropertyGeneric.hs index 09b0368e..6eac6554 100644 --- a/tests/PropertyGeneric.hs +++ b/tests/PropertyGeneric.hs @@ -32,7 +32,8 @@ genericTests = testProperty "string" (toParseJSON gNullaryParseJSONString gNullaryToJSONString) , testProperty "2ElemArray" (toParseJSON gNullaryParseJSON2ElemArray gNullaryToJSON2ElemArray) , testProperty "TaggedObject" (toParseJSON gNullaryParseJSONTaggedObject gNullaryToJSONTaggedObject) - , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleField gNullaryToJSONObjectWithSingleField) + , testProperty "ObjectWithSingleField" (toParseJSON gNullaryParseJSONObjectWithSingleFieldTagged gNullaryToJSONObjectWithSingleFieldTagged) + , testProperty "ObjectWithSingleField Tagged" (toParseJSON gNullaryParseJSONObjectWithSingleFieldTagged gNullaryToJSONObjectWithSingleFieldTagged) ] ] , testGroup "EitherTextInt" [ @@ -47,10 +48,12 @@ genericTests = testProperty "2ElemArray" (toParseJSON gSomeTypeParseJSON2ElemArray gSomeTypeToJSON2ElemArray) , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject) , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField) + , testProperty "ObjectWithSingleField Tagged" (toParseJSON gSomeTypeParseJSONObjectWithSingleFieldTagged gSomeTypeToJSONObjectWithSingleFieldTagged) , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray) , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject) , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField) + , testProperty "ObjectWithSingleField Tagged unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleFieldTagged gSomeTypeLiftToJSONObjectWithSingleFieldTagged) ] ] , testGroup "OneConstructor" [ diff --git a/tests/PropertyTH.hs b/tests/PropertyTH.hs index 9c2e090f..2aebb531 100644 --- a/tests/PropertyTH.hs +++ b/tests/PropertyTH.hs @@ -34,6 +34,7 @@ templateHaskellTests = , testProperty "2ElemArray" (toParseJSON thNullaryParseJSON2ElemArray thNullaryToJSON2ElemArray) , testProperty "TaggedObject" (toParseJSON thNullaryParseJSONTaggedObject thNullaryToJSONTaggedObject) , testProperty "ObjectWithSingleField" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField) + , testProperty "ObjectWithSingleField Tagged" (toParseJSON thNullaryParseJSONObjectWithSingleField thNullaryToJSONObjectWithSingleField) ] ] , testGroup "EitherTextInt" [ @@ -48,10 +49,12 @@ templateHaskellTests = testProperty "2ElemArray" (toParseJSON thSomeTypeParseJSON2ElemArray thSomeTypeToJSON2ElemArray) , testProperty "TaggedObject" (toParseJSON thSomeTypeParseJSONTaggedObject thSomeTypeToJSONTaggedObject) , testProperty "ObjectWithSingleField" (toParseJSON thSomeTypeParseJSONObjectWithSingleField thSomeTypeToJSONObjectWithSingleField) + , testProperty "ObjectWithSingleField Tagged" (toParseJSON thSomeTypeParseJSONObjectWithSingleFieldTagged thSomeTypeToJSONObjectWithSingleFieldTagged) , testProperty "2ElemArray unary" (toParseJSON1 thSomeTypeLiftParseJSON2ElemArray thSomeTypeLiftToJSON2ElemArray) , testProperty "TaggedObject unary" (toParseJSON1 thSomeTypeLiftParseJSONTaggedObject thSomeTypeLiftToJSONTaggedObject) , testProperty "ObjectWithSingleField unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleField thSomeTypeLiftToJSONObjectWithSingleField) + , testProperty "ObjectWithSingleField Tagged unary" (toParseJSON1 thSomeTypeLiftParseJSONObjectWithSingleFieldTagged thSomeTypeLiftToJSONObjectWithSingleFieldTagged) ] ] diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs index 278d2ee1..74725b67 100644 --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -71,6 +71,7 @@ import UnitTests.KeyMapInsertWith import UnitTests.MonadFix import UnitTests.NoThunks import UnitTests.NullaryConstructors (nullaryConstructors) +import UnitTests.SomeType (someTypeTests) import UnitTests.OptionalFields (optionalFields) import UnitTests.UTCTime @@ -542,6 +543,7 @@ tests = testGroup "unit" [ , hashableLaws , testGroup "Object construction" $ fmap (testCase "-") objectConstruction , testGroup "Nullary constructors" $ fmap (testCase "-") nullaryConstructors + , testGroup "SomeType unit tests" $ fmap (testCase "-") someTypeTests , fromJSONKeyTests , optionalFields , testCase "PR #455" pr455 diff --git a/tests/UnitTests/NullaryConstructors.hs b/tests/UnitTests/NullaryConstructors.hs index 4d3c051b..58c04518 100644 --- a/tests/UnitTests/NullaryConstructors.hs +++ b/tests/UnitTests/NullaryConstructors.hs @@ -62,6 +62,10 @@ nullaryConstructors = , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{}}") , ISuccess C1 @=? parse thNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{\"extra\":1}}") , ISuccess C1 @=? parse gNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{\"extra\":1}}") + , thErrTag @=? parse thNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{},\"_tag\":true}") + , gErrTag @=? parse gNullaryParseJSONOWSFNullaryToObject (dec "{\"c1\":{},\"_tag\":true}") + , ISuccess C1 @=? parse thNullaryParseJSONObjectWithSingleFieldTagged (dec "{\"c1\":[],\"_tag\":true}") + , ISuccess C1 @=? parse gNullaryParseJSONObjectWithSingleFieldTagged (dec "{\"c1\":[],\"_tag\":true}") -- Make sure that the old `"contents" : []` is still allowed (and also `"contents" : {}`) , ISuccess C1 @=? parse thNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}") , ISuccess C1 @=? parse gNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}") @@ -97,3 +101,5 @@ nullaryConstructors = gErrArray = IError [Key "c1"] "parsing Types.Nullary(C1) failed, expected Object, but encountered Array" thErrUnknown = IError [] "When parsing the constructor C1 of type Types.Nullary expected an empty Object but got Object of size 1." gErrUnknown = IError [Key "c1"] "parsing Types.Nullary(C1) failed, expected an empty Object but encountered Object of size 1" + thErrTag = IError [] "When parsing Types.Nullary expected an Object with a single tag/contents pair but got 2 pairs." + gErrTag = IError [] "parsing Types.Nullary failed, expected an Object with a single pair, but found 2 pairs" diff --git a/tests/UnitTests/SomeType.hs b/tests/UnitTests/SomeType.hs new file mode 100644 index 00000000..ee237444 --- /dev/null +++ b/tests/UnitTests/SomeType.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module UnitTests.SomeType + ( + someTypeTests + ) where + +import Prelude.Compat + +import Data.Aeson (decode, eitherDecode, fromEncoding, Value) +import Data.Aeson.Types (Parser, IResult (..), iparse) +import Data.ByteString.Builder (toLazyByteString) +import Data.Maybe (fromJust) +import Encoders +import Test.Tasty.HUnit ((@=?), Assertion) +import Types +import qualified Data.ByteString.Lazy.Char8 as L + +-- data SomeType a = Nullary +-- | Unary Int +-- | Product String (Maybe Char) a +-- | Record { testOne :: Double +-- , testTwo :: Maybe Bool +-- , testThree :: Maybe a +-- } +-- | List [a] +-- deriving (Eq, Show) + +someTypeTests :: [Assertion] +someTypeTests = + [ dec "{\"nullary\":[]}" @=? thSomeTypeToJSONObjectWithSingleField Nullary + , dec "{\"nullary\":[]}" @=? gSomeTypeToJSONObjectWithSingleField Nullary + , dec "{\"unary\":1}" @=? thSomeTypeToJSONObjectWithSingleField (Unary 1) + , dec "{\"unary\":1}" @=? gSomeTypeToJSONObjectWithSingleField (Unary 1) + , dec "{\"product\":[\"a\",\"b\",1]}" @=? thSomeTypeToJSONObjectWithSingleField (Product "a" (Just 'b') 1) + , dec "{\"product\":[\"a\",\"b\",1]}" @=? gSomeTypeToJSONObjectWithSingleField (Product "a" (Just 'b') 1) + , dec "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null}}" @=? thSomeTypeToJSONObjectWithSingleField (Record 1 Nothing Nothing) + , dec "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null}}" @=? gSomeTypeToJSONObjectWithSingleField (Record 1 Nothing Nothing) + , dec "{\"nullary\":[],\"_tag\":true}" @=? thSomeTypeToJSONObjectWithSingleFieldTagged Nullary + , dec "{\"nullary\":[],\"_tag\":true}" @=? gSomeTypeToJSONObjectWithSingleFieldTagged Nullary + , dec "{\"unary\":1,\"_tag\":true}" @=? thSomeTypeToJSONObjectWithSingleFieldTagged (Unary 1) + , dec "{\"unary\":1,\"_tag\":true}" @=? gSomeTypeToJSONObjectWithSingleFieldTagged (Unary 1) + , dec "{\"product\":[\"a\",\"b\",1],\"_tag\":true}" @=? thSomeTypeToJSONObjectWithSingleFieldTagged (Product "a" (Just 'b') 1) + , dec "{\"product\":[\"a\",\"b\",1],\"_tag\":true}" @=? gSomeTypeToJSONObjectWithSingleFieldTagged (Product "a" (Just 'b') 1) + , dec "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null},\"_tag\":true}" @=? thSomeTypeToJSONObjectWithSingleFieldTagged (Record 1 Nothing Nothing) + , dec "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null},\"_tag\":true}" @=? gSomeTypeToJSONObjectWithSingleFieldTagged (Record 1 Nothing Nothing) + + , decE "{\"unary\":1}" @=? enc (thSomeTypeToEncodingObjectWithSingleField (Unary 1)) + , decE "{\"unary\":1}" @=? enc (gSomeTypeToEncodingObjectWithSingleField (Unary 1)) + , decE "{\"nullary\":[]}" @=? enc (thSomeTypeToEncodingObjectWithSingleField Nullary) + , decE "{\"nullary\":[]}" @=? enc (gSomeTypeToEncodingObjectWithSingleField Nullary) + , decE "{\"product\":[\"a\",\"b\",1]}" @=? enc (thSomeTypeToEncodingObjectWithSingleField (Product "a" (Just 'b') 1)) + , decE "{\"product\":[\"a\",\"b\",1]}" @=? enc (gSomeTypeToEncodingObjectWithSingleField (Product "a" (Just 'b') 1)) + , decE "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null}}" @=? enc (thSomeTypeToEncodingObjectWithSingleField (Record 1 Nothing Nothing)) + , decE "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null}}" @=? enc (gSomeTypeToEncodingObjectWithSingleField (Record 1 Nothing Nothing)) + , decE "{\"nullary\":[],\"_tag\":true}" @=? enc (thSomeTypeToEncodingObjectWithSingleFieldTagged Nullary) + , decE "{\"nullary\":[],\"_tag\":true}" @=? enc (gSomeTypeToEncodingObjectWithSingleFieldTagged Nullary) + , decE "{\"unary\":1,\"_tag\":true}" @=? enc (thSomeTypeToEncodingObjectWithSingleFieldTagged (Unary 1)) + , decE "{\"unary\":1,\"_tag\":true}" @=? enc (gSomeTypeToEncodingObjectWithSingleFieldTagged (Unary 1)) + , decE "{\"product\":[\"a\",\"b\",1],\"_tag\":true}" @=? enc (thSomeTypeToEncodingObjectWithSingleFieldTagged (Product "a" (Just 'b') 1)) + , decE "{\"product\":[\"a\",\"b\",1],\"_tag\":true}" @=? enc (gSomeTypeToEncodingObjectWithSingleFieldTagged (Product "a" (Just 'b') 1)) + , decE "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null},\"_tag\":true}" @=? enc (thSomeTypeToEncodingObjectWithSingleFieldTagged (Record 1 Nothing Nothing)) + , decE "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null},\"_tag\":true}" @=? enc (gSomeTypeToEncodingObjectWithSingleFieldTagged (Record 1 Nothing Nothing)) + + , ISuccess Nullary @=? parse thSomeTypeParseJSONObjectWithSingleField (dec "{\"nullary\":[]}") + , ISuccess Nullary @=? parse gSomeTypeParseJSONObjectWithSingleField (dec "{\"nullary\":[]}") + , ISuccess (Unary 1) @=? parse thSomeTypeParseJSONObjectWithSingleField (dec "{\"unary\":1}") + , ISuccess (Unary 1) @=? parse gSomeTypeParseJSONObjectWithSingleField (dec "{\"unary\":1}") + , ISuccess (Product "a" (Just 'b') 1) @=? parse thSomeTypeParseJSONObjectWithSingleField (dec "{\"product\":[\"a\",\"b\",1]}") + , ISuccess (Product "a" (Just 'b') 1) @=? parse gSomeTypeParseJSONObjectWithSingleField (dec "{\"product\":[\"a\",\"b\",1]}") + , ISuccess (Record 1 Nothing Nothing) @=? parse thSomeTypeParseJSONObjectWithSingleField (dec "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null}}") + , ISuccess (Record 1 Nothing Nothing) @=? parse gSomeTypeParseJSONObjectWithSingleField (dec "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null}}") + + , ISuccess Nullary @=? parse thSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"nullary\":[],\"_tag\":true}") + , ISuccess Nullary @=? parse gSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"nullary\":[],\"_tag\":true}") + , ISuccess Nullary @=? parse thSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"nullary\":[]}") + , ISuccess Nullary @=? parse gSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"nullary\":[]}") + , ISuccess (Unary 1) @=? parse thSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"unary\":1,\"_tag\":true}") + , ISuccess (Unary 1) @=? parse gSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"unary\":1,\"_tag\":true}") + , ISuccess (Unary 1) @=? parse thSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"unary\":1}") + , ISuccess (Unary 1) @=? parse gSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"unary\":1}") + , ISuccess (Product "a" (Just 'b') 1) @=? parse thSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"product\":[\"a\",\"b\",1],\"_tag\":true}") + , ISuccess (Product "a" (Just 'b') 1) @=? parse gSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"product\":[\"a\",\"b\",1],\"_tag\":true}") + , ISuccess (Product "a" (Just 'b') 1) @=? parse thSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"product\":[\"a\",\"b\",1]}") + , ISuccess (Product "a" (Just 'b') 1) @=? parse gSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"product\":[\"a\",\"b\",1]}") + , ISuccess (Record 1 Nothing Nothing) @=? parse thSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null},\"_tag\":true}") + , ISuccess (Record 1 Nothing Nothing) @=? parse gSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null},\"_tag\":true}") + , ISuccess (Record 1 Nothing Nothing) @=? parse thSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null}}") + , ISuccess (Record 1 Nothing Nothing) @=? parse gSomeTypeParseJSONObjectWithSingleFieldTagged (dec "{\"record\":{\"testone\":1,\"testtwo\":null,\"testthree\":null}}") + ] + where + enc = eitherDecode . toLazyByteString . fromEncoding + dec :: L.ByteString -> Value + dec = fromJust . decode + decE :: L.ByteString -> Either String Value + decE = eitherDecode + parse :: (a -> Parser b) -> a -> IResult b + parse parsejson v = iparse parsejson v