@@ -80,8 +80,8 @@ module Data.Aeson.Types.FromJSON
8080
8181import Prelude.Compat
8282
83−import Control.Applicative ((<|>), Const(..))
84−import Control.Monad ((<=<), zipWithM)
83+import Control.Applicative ((<|>), Const(..), liftA2)
84+import Control.Monad (zipWithM)
8585import Data.Aeson.Internal.Functions (mapKey)
8686import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
8787import Data.Aeson.Types.Generic
@@ -888,6 +888,27 @@ instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where
888888 -- parsed value:
889889 gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs
890890
891+-- Information for error messages
892+
893+type TypeName = String
894+type ConName = String
895+
896+-- | Add the name of the type being parsed to a parser's error messages.
897+contextType :: TypeName -> Parser a -> Parser a
898+contextType = prependContext
899+
900+-- | Add the name of the constructor being parsed to a parser's error messages.
901+contextCons :: ConName -> TypeName -> Parser a -> Parser a
902+contextCons cname tname = prependContext (showCons cname tname)
903+
904+-- | Render a constructor as @\"MyType(MyConstructor)\"@.
905+showCons :: ConName -> TypeName -> String
906+showCons cname tname = tname ++ "(" ++ cname ++ ")"
907+
908+--------------------------------------------------------------------------------
909+
910+-- Parsing single fields
911+
891912instance (FromJSON a) => GFromJSON arity (K1 i a) where
892913 -- Constant values are decoded using their FromJSON instance:
893914 gParseJSON _opts _ = fmap K1 . parseJSON
@@ -902,92 +923,106 @@ instance (FromJSON1 f) => GFromJSON One (Rec1 f) where
902923 -- FromJSON1 instance:
903924 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl
904925
905−instance GFromJSON arity U1 where
906− -- Empty constructors are expected to be encoded as an empty array:
907− gParseJSON _opts _ v
908− | isEmptyArray v = pure U1
909− | otherwise = typeMismatch "unit constructor (U1)" v
926+instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
927+ -- If an occurrence of the last type parameter is nested inside two
928+ -- composed types, it is decoded by using the outermost type's FromJSON1
929+ -- instance to generically decode the innermost type:
930+ gParseJSON opts fargs =
931+ let gpj = gParseJSON opts fargs in
932+ fmap Comp1 . liftParseJSON gpj (listParser gpj)
910933
934+--------------------------------------------------------------------------------
935+
936+instance (GFromJSON' arity a, Datatype d) => GFromJSON arity (D1 d a) where
937+ -- Meta-information, which is not handled elsewhere, is just added to the
938+ -- parsed value:
939+ gParseJSON opts fargs = fmap M1 . gParseJSON' (tname :* opts :* fargs)
940+ where
941+ tname = moduleName proxy ++ "." ++ datatypeName proxy
942+ proxy = undefined :: M1 _i d _f _p
943+
944+-- | 'GFromJSON', after unwrapping the 'D1' constructor, now carrying the data
945+-- type's name.
946+class GFromJSON' arity f where
947+ gParseJSON' :: TypeName :* Options :* FromArgs arity a
948+ -> Value
949+ -> Parser (f a)
950+
951+-- | Single constructor.
911952instance ( ConsFromJSON arity a
912953 , AllNullary (C1 c a) allNullary
913954 , ParseSum arity (C1 c a) allNullary
914− ) => GFromJSON arity (D1 d (C1 c a)) where
955+ , Constructor c
956+ ) => GFromJSON' arity (C1 c a) where
915957 -- The option 'tagSingleConstructors' determines whether to wrap
916958 -- a single-constructor type.
917− gParseJSON opts fargs
959+ gParseJSON' p@(_ :* opts :* _)
918960 | tagSingleConstructors opts
919− = fmap M1
920− . (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))
921− . parseSum opts fargs
922− | otherwise = fmap M1 . fmap M1 . consParseJSON opts fargs
923−
924−instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where
925− -- Constructors need to be decoded differently depending on whether they're
926− -- a record or not. This distinction is made by consParseJSON:
927− gParseJSON opts fargs = fmap M1 . consParseJSON opts fargs
928−
929−instance ( FromProduct arity a, FromProduct arity b
930− , ProductSize a, ProductSize b
931− ) => GFromJSON arity (a :*: b) where
932− -- Products are expected to be encoded to an array. Here we check whether we
933− -- got an array of the same size as the product, then parse each of the
934− -- product's elements using parseProduct:
935− gParseJSON opts fargs = withArray "product (:*:)" $ \arr ->
936− let lenArray = V.length arr
937− lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)
938− productSize in
939− if lenArray == lenProduct
940− then parseProduct opts fargs arr 0 lenProduct
941− else fail $ "When expecting a product of " ++ show lenProduct ++
942− " values, encountered an Array of " ++ show lenArray ++
943− " elements instead"
944−
945−instance ( AllNullary (a :+: b) allNullary
946− , ParseSum arity (a :+: b) allNullary
947− ) => GFromJSON arity (a :+: b) where
961+ = (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))
962+ . parseSum p
963+ | otherwise = fmap M1 . consParseJSON (cname :* p)
964+ where
965+ cname = conName (undefined :: M1 _i c _f _p)
966+
967+-- | Multiple constructors.
968+instance ( AllNullary (a :+: b) allNullary
969+ , ParseSum arity (a :+: b) allNullary
970+ ) => GFromJSON' arity (a :+: b) where
948971 -- If all constructors of a sum datatype are nullary and the
949972 -- 'allNullaryToStringTag' option is set they are expected to be
950973 -- encoded as strings. This distinction is made by 'parseSum':
951− gParseJSON opts fargs =
952− (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->
953− Parser ((a :+: b) d))
954− . parseSum opts fargs
955−
956−instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where
957− -- If an occurrence of the last type parameter is nested inside two
958− -- composed types, it is decoded by using the outermost type's FromJSON1
959− -- instance to generically decode the innermost type:
960− gParseJSON opts fargs =
961− let gpj = gParseJSON opts fargs in
962− fmap Comp1 . liftParseJSON gpj (listParser gpj)
974+ gParseJSON' p =
975+ (unTagged :: Tagged allNullary (Parser ((a :+: b) _d)) ->
976+ Parser ((a :+: b) _d))
977+ . parseSum p
963978
964979--------------------------------------------------------------------------------
965980
966981class ParseSum arity f allNullary where
967− parseSum :: Options -> FromArgs arity a
968− -> Value -> Tagged allNullary (Parser (f a))
982+ parseSum :: TypeName :* Options :* FromArgs arity a
983+ -> Value
984+ -> Tagged allNullary (Parser (f a))
969985
970−instance ( SumFromString f
986+instance ( ConstructorNames f
987+ , SumFromString f
971988 , FromPair arity f
972989 , FromTaggedObject arity f
973990 , FromUntaggedValue arity f
974991 ) => ParseSum arity f True where
975− parseSum opts fargs
976− | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts
977− | otherwise = Tagged . parseNonAllNullarySum opts fargs
992+ parseSum p@(tname :* opts :* _)
993+ | allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts
994+ | otherwise = Tagged . parseNonAllNullarySum p
978995
979−instance ( FromPair arity f
996+instance ( ConstructorNames f
997+ , FromPair arity f
980998 , FromTaggedObject arity f
981999 , FromUntaggedValue arity f
9821000 ) => ParseSum arity f False where
983− parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs
1001+ parseSum p = Tagged . parseNonAllNullarySum p
9841002
9851003--------------------------------------------------------------------------------
9861004
987−parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)
988−parseAllNullarySum opts = withText "Text" $ \key ->
989− maybe (notFound key) return $
990− parseSumFromString opts key
1005+parseAllNullarySum :: (SumFromString f, ConstructorNames f)
1006+ => TypeName -> Options -> Value -> Parser (f a)
1007+parseAllNullarySum tname opts =
1008+ withText tname $ \tag ->
1009+ maybe (badTag tag) return $
1010+ parseSumFromString opts tag
1011+ where
1012+ badTag tag = failWithCTags tname opts $ \cnames ->
1013+ "expected one of the tags " ++ show cnames ++
1014+ ", but found tag " ++ show tag
1015+
1016+-- | Fail with an informative error message about a mismatched tag.
1017+-- The error message is parameterized by the list of expected tags,
1018+-- to be inferred from the result type of the parser.
1019+failWithCTags
1020+ :: forall f a. ConstructorNames f
1021+ => TypeName -> Options -> ([String] -> String) -> Parser (f a)
1022+failWithCTags tname opts f =
1023+ contextType tname . fail $ f cnames
1024+ where
1025+ cnames = unTagged2 (constructorTags opts :: Tagged2 f [String])
9911026
9921027class SumFromString f where
9931028 parseSumFromString :: Options -> Text -> Maybe (f a)
@@ -1001,243 +1036,339 @@ instance (Constructor c) => SumFromString (C1 c U1) where
10011036 | otherwise = Nothing
10021037 where
10031038 name = pack $ constructorTagModifier opts $
1004− conName (undefined :: t c U1 p)
1039+ conName (undefined :: M1 _i c _f _p)
1040+
1041+-- | List of all constructor tags.
1042+constructorTags :: ConstructorNames a => Options -> Tagged2 a [String]
1043+constructorTags opts =
1044+ fmap DList.toList (constructorNames' (constructorTagModifier opts))
1045+
1046+-- | List of all constructor names of an ADT, after a given conversion
1047+-- function. (Better inlining.)
1048+class ConstructorNames a where
1049+ constructorNames' :: (String -> t) -> Tagged2 a (DList.DList t)
1050+
1051+instance (ConstructorNames a, ConstructorNames b) => ConstructorNames (a :+: b) where
1052+ constructorNames' = liftA2 append constructorNames' constructorNames'
1053+ where
1054+ append
1055+ :: Tagged2 a (DList.DList t)
1056+ -> Tagged2 b (DList.DList t)
1057+ -> Tagged2 (a :+: b) (DList.DList t)
1058+ append (Tagged2 xs) (Tagged2 ys) = Tagged2 (DList.append xs ys)
1059+
1060+instance Constructor c => ConstructorNames (C1 c a) where
1061+ constructorNames' f = Tagged2 (pure (f cname))
1062+ where
1063+ cname = conName (undefined :: M1 _i c _f _p)
10051064
10061065--------------------------------------------------------------------------------
10071066
10081067parseNonAllNullarySum :: ( FromPair arity f
10091068 , FromTaggedObject arity f
10101069 , FromUntaggedValue arity f
1011− ) => Options -> FromArgs arity c
1070+ , ConstructorNames f
1071+ ) => TypeName :* Options :* FromArgs arity c
10121072 -> Value -> Parser (f c)
1013−parseNonAllNullarySum opts fargs =
1073+parseNonAllNullarySum p@(tname :* opts :* _) =
10141074 case sumEncoding opts of
10151075 TaggedObject{..} ->
1016− withObject "Object" $ \obj -> do
1017− tag <- obj .: pack tagFieldName
1018− fromMaybe (notFound tag) $
1019− parseFromTaggedObject opts fargs contentsFieldName obj tag
1076+ withObject tname $ \obj -> do
1077+ tag <- contextType tname $ obj .: tagKey
1078+ fromMaybe (badTag tag <?> Key tagKey) $
1079+ parseFromTaggedObject (tag :* contentsFieldName :* p) obj
1080+ where
1081+ tagKey = pack tagFieldName
1082+ badTag tag = failWith_ $ \cnames ->
1083+ "expected tag field to be one of " ++ show cnames ++
1084+ ", but found tag " ++ show tag
10201085
10211086 ObjectWithSingleField ->
1022− withObject "Object" $ \obj ->
1023− case H.toList obj of
1024− [pair@(tag, _)] -> fromMaybe (notFound tag) $
1025− parsePair opts fargs pair
1026− _ -> fail "Object doesn't have a single field"
1087+ withObject tname $ \obj -> case H.toList obj of
1088+ [(tag, v)] -> maybe (badTag tag) (<?> Key tag) $
1089+ parsePair (tag :* p) v
1090+ _ -> contextType tname . fail $
1091+ "expected an Object with a single pair, but found " ++
1092+ show (H.size obj) ++ " pairs"
1093+ where
1094+ badTag tag = failWith_ $ \cnames ->
1095+ "expected an Object with a single pair where the tag is one of " ++
1096+ show cnames ++ ", but found tag " ++ show tag
10271097
10281098 TwoElemArray ->
1029− withArray "Array" $ \arr ->
1030− if V.length arr == 2
1031− then case V.unsafeIndex arr 0 of
1032− String tag -> fromMaybe (notFound tag) $
1033− parsePair opts fargs (tag, V.unsafeIndex arr 1)
1034− _ -> fail "First element is not a String"
1035− else fail "Array doesn't have 2 elements"
1099+ withArray tname $ \arr -> case V.length arr of
1100+ 2 | String tag <- V.unsafeIndex arr 0 ->
1101+ maybe (badTag tag <?> Index 0) (<?> Index 1) $
1102+ parsePair (tag :* p) (V.unsafeIndex arr 1)
1103+ | otherwise ->
1104+ contextType tname $
1105+ fail "tag element is not a String" <?> Index 0
1106+ len -> contextType tname . fail $
1107+ "expected a 2-element Array, but encountered an Array of length " ++
1108+ show len
1109+ where
1110+ badTag tag = failWith_ $ \cnames ->
1111+ "expected tag of the 2-element Array to be one of " ++
1112+ show cnames ++ ", but found tag " ++ show tag
10361113
1037− UntaggedValue -> parseUntaggedValue opts fargs
1114+ UntaggedValue -> parseUntaggedValue p
1115+ where
1116+ failWith_ = failWithCTags tname opts
10381117
10391118--------------------------------------------------------------------------------
10401119
10411120class FromTaggedObject arity f where
1042− parseFromTaggedObject :: Options -> FromArgs arity a
1043− -> String -> Object
1044− -> Text -> Maybe (Parser (f a))
1121+ -- The first two components of the parameter tuple are: the constructor tag
1122+ -- to match against, and the contents field name.
1123+ parseFromTaggedObject
1124+ :: Text :* String :* TypeName :* Options :* FromArgs arity a
1125+ -> Object
1126+ -> Maybe (Parser (f a))
10451127
10461128instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>
10471129 FromTaggedObject arity (a :+: b) where
1048− parseFromTaggedObject opts fargs contentsFieldName obj tag =
1049− (fmap L1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag) <|>
1050− (fmap R1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag)
1130+ parseFromTaggedObject p obj =
1131+ (fmap L1 <$> parseFromTaggedObject p obj) <|>
1132+ (fmap R1 <$> parseFromTaggedObject p obj)
10511133
1052−instance ( FromTaggedObject' arity f
1134+instance ( IsRecord f isRecord
1135+ , FromTaggedObject' arity f isRecord
10531136 , Constructor c
10541137 ) => FromTaggedObject arity (C1 c f) where
1055− parseFromTaggedObject opts fargs contentsFieldName obj tag
1056− | tag == name = Just $ M1 <$> parseFromTaggedObject'
1057− opts fargs contentsFieldName obj
1058− | otherwise = Nothing
1059− where
1060− name = pack $ constructorTagModifier opts $
1061− conName (undefined :: t c f p)
1138+ parseFromTaggedObject (tag :* contentsFieldName :* p@(_ :* opts :* _))
1139+ | tag == tag'
1140+ = Just . fmap M1 .
1141+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
1142+ parseFromTaggedObject' (contentsFieldName :* cname :* p)
1143+ | otherwise = const Nothing
1144+ where
1145+ tag' = pack $ constructorTagModifier opts cname
1146+ cname = conName (undefined :: M1 _i c _f _p)
10621147
10631148--------------------------------------------------------------------------------
10641149
1065−class FromTaggedObject' arity f where
1066− parseFromTaggedObject' :: Options -> FromArgs arity a -> String
1067− -> Object -> Parser (f a)
1068−
1069−class FromTaggedObject'' arity f isRecord where
1070− parseFromTaggedObject'' :: Options -> FromArgs arity a -> String
1071− -> Object -> Tagged isRecord (Parser (f a))
1072−
1073−instance ( IsRecord f isRecord
1074− , FromTaggedObject'' arity f isRecord
1075− ) => FromTaggedObject' arity f where
1076− parseFromTaggedObject' opts fargs contentsFieldName =
1077− (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .
1078− parseFromTaggedObject'' opts fargs contentsFieldName
1079−
1080−instance (FromRecord arity f) => FromTaggedObject'' arity f True where
1081− parseFromTaggedObject'' opts fargs _ =
1082− Tagged . parseRecord opts fargs
1083−
1084−instance (GFromJSON arity f) => FromTaggedObject'' arity f False where
1085− parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .
1086− (gParseJSON opts fargs <=< (.: pack contentsFieldName))
1150+class FromTaggedObject' arity f isRecord where
1151+ -- The first component of the parameter tuple is the contents field name.
1152+ parseFromTaggedObject'
1153+ :: String :* ConName :* TypeName :* Options :* FromArgs arity a
1154+ -> Object -> Tagged isRecord (Parser (f a))
1155+
1156+instance (RecordFromJSON arity f) => FromTaggedObject' arity f True where
1157+ -- Records are unpacked in the tagged object
1158+ parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON p
1159+
1160+instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where
1161+ -- Nonnullary nonrecords are encoded in the contents field
1162+ parseFromTaggedObject' p obj = Tagged $ do
1163+ contents <- contextCons cname tname (obj .: key)
1164+ consParseJSON p' contents <?> Key key
1165+ where
1166+ key = pack contentsFieldName
1167+ contentsFieldName :* p'@(cname :* tname :* _) = p
10871168
1088−instance OVERLAPPING_ FromTaggedObject'' arity U1 False where
1089− parseFromTaggedObject'' _ _ _ _ = Tagged (pure U1)
1169+instance OVERLAPPING_ FromTaggedObject' arity U1 False where
1170+ -- Nullary constructors don't need a contents field
1171+ parseFromTaggedObject' _ _ = Tagged (pure U1)
10901172
10911173--------------------------------------------------------------------------------
10921174
1175+-- | Constructors need to be decoded differently depending on whether they're
1176+-- a record or not. This distinction is made by 'ConsParseJSON'.
10931177class ConsFromJSON arity f where
1094− consParseJSON :: Options -> FromArgs arity a
1095− -> Value -> Parser (f a)
1178+ consParseJSON
1179+ :: ConName :* TypeName :* Options :* FromArgs arity a
1180+ -> Value -> Parser (f a)
10961181
10971182class ConsFromJSON' arity f isRecord where
1098− consParseJSON' :: Options -> FromArgs arity a
1099− -> Value -> Tagged isRecord (Parser (f a))
1183+ consParseJSON'
1184+ :: ConName :* TypeName :* Options :* FromArgs arity a
1185+ -> Value -> Tagged isRecord (Parser (f a))
11001186
11011187instance ( IsRecord f isRecord
11021188 , ConsFromJSON' arity f isRecord
11031189 ) => ConsFromJSON arity f where
1104− consParseJSON opts fargs =
1190+ consParseJSON p =
11051191 (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))
1106− . consParseJSON' opts fargs
1192+ . consParseJSON' p
11071193
11081194instance OVERLAPPING_
1109− ( GFromJSON arity a, FromRecord arity (S1 s a)
1195+ ( GFromJSON arity a, RecordFromJSON arity (S1 s a)
11101196 ) => ConsFromJSON' arity (S1 s a) True where
1111− consParseJSON' opts fargs
1112− | unwrapUnaryRecords opts = Tagged . gParseJSON opts fargs
1113− | otherwise = Tagged . withObject "unary record" (parseRecord opts fargs)
1197+ consParseJSON' p@(cname :* tname :* opts :* fargs)
1198+ | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs
1199+ | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON p)
1200+
1201+instance RecordFromJSON arity f => ConsFromJSON' arity f True where
1202+ consParseJSON' p@(cname :* tname :* _) =
1203+ Tagged . withObject (showCons cname tname) (recordParseJSON p)
1204+
1205+instance OVERLAPPING_
1206+ ConsFromJSON' arity U1 False where
1207+ -- Empty constructors are expected to be encoded as an empty array:
1208+ consParseJSON' (cname :* tname :* _) v =
1209+ Tagged . contextCons cname tname $ case v of
1210+ Array a | V.null a -> pure U1
1211+ | otherwise -> fail_ a
1212+ _ -> typeMismatch "Array" v
1213+ where
1214+ fail_ a = fail $
1215+ "expected an empty Array, but encountered an Array of length " ++
1216+ show (V.length a)
11141217
1115−instance FromRecord arity f => ConsFromJSON' arity f True where
1116− consParseJSON' opts fargs =
1117− Tagged . withObject "record (:*:)" (parseRecord opts fargs)
1218+instance OVERLAPPING_
1219+ GFromJSON arity f => ConsFromJSON' arity (S1 s f) False where
1220+ consParseJSON' (_ :* _ :* opts :* fargs) =
1221+ Tagged . fmap M1 . gParseJSON opts fargs
11181222
1119−instance GFromJSON arity f => ConsFromJSON' arity f False where
1120− consParseJSON' opts fargs = Tagged . gParseJSON opts fargs
1223+instance (ProductFromJSON arity f, ProductSize f
1224+ ) => ConsFromJSON' arity f False where
1225+ consParseJSON' p = Tagged . productParseJSON0 p
11211226
11221227--------------------------------------------------------------------------------
11231228
1124−class FromRecord arity f where
1125− parseRecord :: Options -> FromArgs arity a
1126− -> Object -> Parser (f a)
1229+class RecordFromJSON arity f where
1230+ recordParseJSON
1231+ :: ConName :* TypeName :* Options :* FromArgs arity a
1232+ -> Object -> Parser (f a)
11271233
1128−instance ( FromRecord arity a
1129− , FromRecord arity b
1130− ) => FromRecord arity (a :*: b) where
1131− parseRecord opts fargs obj =
1132− (:*:) <$> parseRecord opts fargs obj
1133− <*> parseRecord opts fargs obj
1234+instance ( RecordFromJSON arity a
1235+ , RecordFromJSON arity b
1236+ ) => RecordFromJSON arity (a :*: b) where
1237+ recordParseJSON p obj =
1238+ (:*:) <$> recordParseJSON p obj
1239+ <*> recordParseJSON p obj
11341240
11351241instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>
1136− FromRecord arity (S1 s a) where
1137− parseRecord opts fargs =
1138− (<?> Key label) . gParseJSON opts fargs <=< (.: label)
1139− where
1140− label = pack . fieldLabelModifier opts $ selName (undefined :: t s a p)
1242+ RecordFromJSON arity (S1 s a) where
1243+ recordParseJSON (cname :* tname :* opts :* fargs) obj = do
1244+ fv <- contextCons cname tname (obj .: label)
1245+ M1 <$> gParseJSON opts fargs fv <?> Key label
1246+ where
1247+ label = pack $ fieldLabelModifier opts sname
1248+ sname = selName (undefined :: M1 _i s _f _p)
11411249
11421250instance INCOHERENT_ (Selector s, FromJSON a) =>
1143− FromRecord arity (S1 s (K1 i (Maybe a))) where
1144− parseRecord opts _ obj = M1 . K1 <$> obj .:? pack label
1145− where
1146− label = fieldLabelModifier opts $
1147− selName (undefined :: t s (K1 i (Maybe a)) p)
1251+ RecordFromJSON arity (S1 s (K1 i (Maybe a))) where
1252+ recordParseJSON (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label
1253+ where
1254+ label = fieldLabelModifier opts sname
1255+ sname = selName (undefined :: M1 _i s _f _p)
11481256
11491257-- Parse an Option like a Maybe.
11501258instance INCOHERENT_ (Selector s, FromJSON a) =>
1151− FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where
1152− parseRecord opts fargs obj = wrap <$> parseRecord opts fargs obj
1259+ RecordFromJSON arity (S1 s (K1 i (Semigroup.Option a))) where
1260+ recordParseJSON p obj = wrap <$> recordParseJSON p obj
11531261 where
11541262 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p
11551263 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))
11561264
11571265--------------------------------------------------------------------------------
11581266
1159−class FromProduct arity f where
1160− parseProduct :: Options -> FromArgs arity a
1267+productParseJSON0
1268+ :: forall f arity a. (ProductFromJSON arity f, ProductSize f)
1269+ => ConName :* TypeName :* Options :* FromArgs arity a
1270+ -> Value -> Parser (f a)
1271+ -- Products are expected to be encoded to an array. Here we check whether we
1272+ -- got an array of the same size as the product, then parse each of the
1273+ -- product's elements using productParseJSON:
1274+productParseJSON0 p@(cname :* tname :* _ :* _) =
1275+ withArray (showCons cname tname) $ \arr ->
1276+ let lenArray = V.length arr
1277+ lenProduct = (unTagged2 :: Tagged2 f Int -> Int)
1278+ productSize in
1279+ if lenArray == lenProduct
1280+ then productParseJSON p arr 0 lenProduct
1281+ else contextCons cname tname $
1282+ fail $ "expected an Array of length " ++ show lenProduct ++
1283+ ", but encountered an Array of length " ++ show lenArray
1284+
1285+--
1286+
1287+class ProductFromJSON arity f where
1288+ productParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a
11611289 -> Array -> Int -> Int
11621290 -> Parser (f a)
11631291
1164−instance ( FromProduct arity a
1165− , FromProduct arity b
1166− ) => FromProduct arity (a :*: b) where
1167− parseProduct opts fargs arr ix len =
1168− (:*:) <$> parseProduct opts fargs arr ix lenL
1169− <*> parseProduct opts fargs arr ixR lenR
1292+instance ( ProductFromJSON arity a
1293+ , ProductFromJSON arity b
1294+ ) => ProductFromJSON arity (a :*: b) where
1295+ productParseJSON p arr ix len =
1296+ (:*:) <$> productParseJSON p arr ix lenL
1297+ <*> productParseJSON p arr ixR lenR
11701298 where
11711299 lenL = len `unsafeShiftR` 1
11721300 ixR = ix + lenL
11731301 lenR = len - lenL
11741302
1175−instance (GFromJSON arity a) => FromProduct arity (S1 s a) where
1176− parseProduct opts fargs arr ix _ =
1177− gParseJSON opts fargs $ V.unsafeIndex arr ix
1303+instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where
1304+ productParseJSON (_ :* _ :* opts :* fargs) arr ix _ =
1305+ M1 <$> gParseJSON opts fargs (V.unsafeIndex arr ix) <?> Index ix
11781306
11791307--------------------------------------------------------------------------------
11801308
11811309class FromPair arity f where
1182− parsePair :: Options -> FromArgs arity a
1183− -> Pair -> Maybe (Parser (f a))
1310+ -- The first component of the parameter tuple is the tag to match.
1311+ parsePair :: Text :* TypeName :* Options :* FromArgs arity a
1312+ -> Value
1313+ -> Maybe (Parser (f a))
11841314
11851315instance ( FromPair arity a
11861316 , FromPair arity b
11871317 ) => FromPair arity (a :+: b) where
1188− parsePair opts fargs pair = (fmap L1 <$> parsePair opts fargs pair) <|>
1189− (fmap R1 <$> parsePair opts fargs pair)
1318+ parsePair p pair =
1319+ (fmap L1 <$> parsePair p pair) <|>
1320+ (fmap R1 <$> parsePair p pair)
11901321
11911322instance ( Constructor c
1192− , GFromJSON arity a
11931323 , ConsFromJSON arity a
11941324 ) => FromPair arity (C1 c a) where
1195− parsePair opts fargs (tag, value)
1196− | tag == tag' = Just $ gParseJSON opts fargs value
1325+ parsePair (tag :* p@(_ :* opts :* _)) v
1326+ | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v
11971327 | otherwise = Nothing
1198− where
1199− tag' = pack $ constructorTagModifier opts $
1200− conName (undefined :: t c a p)
1328+ where
1329+ tag' = pack $ constructorTagModifier opts cname
1330+ cname = conName (undefined :: M1 _i c _a _p)
12011331
12021332--------------------------------------------------------------------------------
12031333
12041334class FromUntaggedValue arity f where
1205− parseUntaggedValue :: Options -> FromArgs arity a
1206− -> Value -> Parser (f a)
1335+ parseUntaggedValue :: TypeName :* Options :* FromArgs arity a
1336+ -> Value
1337+ -> Parser (f a)
12071338
12081339instance
12091340 ( FromUntaggedValue arity a
12101341 , FromUntaggedValue arity b
12111342 ) => FromUntaggedValue arity (a :+: b)
12121343 where
1213− parseUntaggedValue opts fargs value =
1214− L1 <$> parseUntaggedValue opts fargs value <|>
1215− R1 <$> parseUntaggedValue opts fargs value
1344+ parseUntaggedValue p value =
1345+ L1 <$> parseUntaggedValue p value <|>
1346+ R1 <$> parseUntaggedValue p value
12161347
12171348instance OVERLAPPABLE_
1218− ( GFromJSON arity a
1219− , ConsFromJSON arity a
1349+ ( ConsFromJSON arity a
1350+ , Constructor c
12201351 ) => FromUntaggedValue arity (C1 c a)
12211352 where
1222− parseUntaggedValue = gParseJSON
1353+ parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)
1354+ where
1355+ cname = conName (undefined :: M1 _i c _f _p)
12231356
12241357instance OVERLAPPING_
12251358 ( Constructor c )
12261359 => FromUntaggedValue arity (C1 c U1)
12271360 where
1228− parseUntaggedValue opts _ (String s)
1229− | s == pack (constructorTagModifier opts (conName (undefined :: t c U1 p))) =
1230− pure $ M1 U1
1231− | otherwise =
1232− fail $ "Invalid tag: " ++ unpack s
1233− parseUntaggedValue _ _ v = typeMismatch (conName (undefined :: t c U1 p)) v
1234−
1235−
1236−--------------------------------------------------------------------------------
1237−
1238−notFound :: Text -> Parser a
1239−notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"
1240−{-# INLINE notFound #-}
1361+ parseUntaggedValue (tname :* opts :* _) v =
1362+ contextCons cname tname $ case v of
1363+ String tag
1364+ | tag == tag' -> pure $ M1 U1
1365+ | otherwise -> fail_ tag
1366+ _ -> typeMismatch "String" v
1367+ where
1368+ tag' = pack $ constructorTagModifier opts cname
1369+ cname = conName (undefined :: M1 _i c _f _p)
1370+ fail_ tag = fail $
1371+ "expected tag " ++ show tag' ++ ", but found tag " ++ show tag
12411372
12421373-------------------------------------------------------------------------------
12431374-- Instances