@@ -918,67 +918,30 @@ typeMismatch expected actual =
918918
919919#ifdef GENERICS
920920--------------------------------------------------------------------------------
921−-- Generic toJSON and fromJSON
921+-- Generic toJSON
922922
923923class GToJSON f where
924924 gToJSON :: f a -> Value
925925
926−class GFromJSON f where
927− gParseJSON :: Value -> Parser (f a)
928−
929−--------------------------------------------------------------------------------
930−
931926instance (GToJSON a) => GToJSON (M1 i c a) where
932927 gToJSON = gToJSON . unM1
933928
934−instance (GFromJSON a) => GFromJSON (M1 i c a) where
935− gParseJSON = fmap M1 . gParseJSON
936−
937−--------------------------------------------------------------------------------
938−
939929instance (ToJSON a) => GToJSON (K1 i a) where
940930 gToJSON = toJSON . unK1
941931
942−instance (FromJSON a) => GFromJSON (K1 i a) where
943− gParseJSON = fmap K1 . parseJSON
944−
945−--------------------------------------------------------------------------------
946−
947932instance GToJSON U1 where
948933 gToJSON _ = emptyArray
949934
950−instance GFromJSON U1 where
951− gParseJSON v
952− | isEmptyArray v = pure U1
953− | otherwise = typeMismatch "unary constructor (U1)" v
954−
955−--------------------------------------------------------------------------------
956−
957935instance (ConsToJSON a) => GToJSON (C1 c a) where
958936 gToJSON = consToJSON . unM1
959937
960−instance (ConsFromJSON a) => GFromJSON (C1 c a) where
961− gParseJSON = fmap M1 . consParseJSON
962−
963−--------------------------------------------------------------------------------
964−
965938instance (GProductToValues a, GProductToValues b) => GToJSON (a :*: b) where
966939 gToJSON = toJSON . toList . gProductToValues
967940
968−instance (GFromProduct a, GFromProduct b) => GFromJSON (a :*: b) where
969− gParseJSON (Array arr) = gParseProduct arr
970− gParseJSON v = typeMismatch "product (:*:)" v
971−
972−--------------------------------------------------------------------------------
973−
974941instance (GObject a, GObject b) => GToJSON (a :+: b) where
975942 gToJSON (L1 x) = Object $ gObject x
976943 gToJSON (R1 x) = Object $ gObject x
977944
978−instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
979− gParseJSON (Object (M.toList -> [keyVal])) = gParseSum keyVal
980− gParseJSON v = typeMismatch "sum (:+:)" v
981−
982945--------------------------------------------------------------------------------
983946
984947class ConsToJSON f where consToJSON :: f a -> Value
@@ -995,6 +958,68 @@ instance GToJSON f => ConsToJSON' False f where
995958
996959--------------------------------------------------------------------------------
997960
961+class GRecordToObject f where
962+ gRecordToObject :: f a -> Object
963+
964+instance (GRecordToObject a, GRecordToObject b) => GRecordToObject (a :*: b) where
965+ gRecordToObject (a :*: b) = gRecordToObject a `M.union` gRecordToObject b
966+
967+instance (Selector s, GToJSON a) => GRecordToObject (S1 s a) where
968+ gRecordToObject m1 = M.singleton (pack (selName m1)) (gToJSON (unM1 m1))
969+
970+--------------------------------------------------------------------------------
971+
972+class GProductToValues f where
973+ gProductToValues :: f a -> DList Value
974+
975+instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
976+ gProductToValues (a :*: b) = gProductToValues a `append` gProductToValues b
977+
978+instance (GToJSON a) => GProductToValues a where
979+ gProductToValues = singleton . gToJSON
980+
981+--------------------------------------------------------------------------------
982+
983+class GObject f where
984+ gObject :: f a -> Object
985+
986+instance (GObject a, GObject b) => GObject (a :+: b) where
987+ gObject (L1 x) = gObject x
988+ gObject (R1 x) = gObject x
989+
990+instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where
991+ gObject m1 = M.singleton (pack (conName m1)) (gToJSON m1)
992+
993+--------------------------------------------------------------------------------
994+-- Generic parseJSON
995+
996+class GFromJSON f where
997+ gParseJSON :: Value -> Parser (f a)
998+
999+instance (GFromJSON a) => GFromJSON (M1 i c a) where
1000+ gParseJSON = fmap M1 . gParseJSON
1001+
1002+instance (FromJSON a) => GFromJSON (K1 i a) where
1003+ gParseJSON = fmap K1 . parseJSON
1004+
1005+instance GFromJSON U1 where
1006+ gParseJSON v
1007+ | isEmptyArray v = pure U1
1008+ | otherwise = typeMismatch "unit constructor (U1)" v
1009+
1010+instance (ConsFromJSON a) => GFromJSON (C1 c a) where
1011+ gParseJSON = fmap M1 . consParseJSON
1012+
1013+instance (GFromProduct a, GFromProduct b) => GFromJSON (a :*: b) where
1014+ gParseJSON (Array arr) = gParseProduct arr
1015+ gParseJSON v = typeMismatch "product (:*:)" v
1016+
1017+instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
1018+ gParseJSON (Object (M.toList -> [keyVal])) = gParseSum keyVal
1019+ gParseJSON v = typeMismatch "sum (:+:)" v
1020+
1021+--------------------------------------------------------------------------------
1022+
9981023class ConsFromJSON f where consParseJSON :: Value -> Parser (f a)
9991024class ConsFromJSON' b f where consParseJSON' :: Tagged b (Value -> Parser (f a))
10001025
@@ -1012,21 +1037,6 @@ instance (GFromJSON f) => ConsFromJSON' False f where
10121037
10131038--------------------------------------------------------------------------------
10141039
1015−newtype Tagged s b = Tagged {unTagged :: b}
1016−
1017−data True
1018−data False
1019−
1020−class IsRecord (f :: * -> *) b | f -> b
1021−
1022−instance (IsRecord f b) => IsRecord (f :*: g) b
1023−instance IsRecord (M1 S NoSelector f) False
1024−instance (IsRecord f b) => IsRecord (M1 S c f) b
1025−instance IsRecord (K1 i c) True
1026−instance IsRecord U1 False
1027−
1028−--------------------------------------------------------------------------------
1029−
10301040class GFromRecord f where
10311041 gParseRecord :: Object -> Parser (f a)
10321042
@@ -1042,28 +1052,6 @@ instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
10421052
10431053--------------------------------------------------------------------------------
10441054
1045−class GRecordToObject f where
1046− gRecordToObject :: f a -> Object
1047−
1048−instance (GRecordToObject a, GRecordToObject b) => GRecordToObject (a :*: b) where
1049− gRecordToObject (a :*: b) = gRecordToObject a `M.union` gRecordToObject b
1050−
1051−instance (Selector s, GToJSON a) => GRecordToObject (S1 s a) where
1052− gRecordToObject m1 = M.singleton (pack (selName m1)) (gToJSON (unM1 m1))
1053−
1054−--------------------------------------------------------------------------------
1055−
1056−class GProductToValues f where
1057− gProductToValues :: f a -> DList Value
1058−
1059−instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
1060− gProductToValues (a :*: b) = gProductToValues a `append` gProductToValues b
1061−
1062−instance (GToJSON a) => GProductToValues a where
1063− gProductToValues = singleton . gToJSON
1064−
1065−--------------------------------------------------------------------------------
1066−
10671055class GFromProduct f where
10681056 gParseProduct :: Array -> Parser (f a)
10691057
@@ -1078,19 +1066,6 @@ instance (GFromJSON a) => GFromProduct a where
10781066
10791067--------------------------------------------------------------------------------
10801068
1081−class GObject f where
1082− gObject :: f a -> Object
1083−
1084−instance (GObject a, GObject b) => GObject (a :+: b) where
1085− gObject (L1 x) = gObject x
1086− gObject (R1 x) = gObject x
1087−
1088−instance (Constructor c, GToJSON a, ConsToJSON a)
1089− => GObject (C1 c a) where
1090− gObject m1 = M.singleton (pack (conName m1)) (gToJSON m1)
1091−
1092−--------------------------------------------------------------------------------
1093−
10941069class GFromSum f where
10951070 gParseSum :: Pair -> Parser (f a)
10961071
@@ -1107,6 +1082,21 @@ notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
11071082
11081083--------------------------------------------------------------------------------
11091084
1085+newtype Tagged s b = Tagged {unTagged :: b}
1086+
1087+data True
1088+data False
1089+
1090+class IsRecord (f :: * -> *) b | f -> b
1091+
1092+instance (IsRecord f b) => IsRecord (f :*: g) b
1093+instance IsRecord (M1 S NoSelector f) False
1094+instance (IsRecord f b) => IsRecord (M1 S c f) b
1095+instance IsRecord (K1 i c) True
1096+instance IsRecord U1 False
1097+
1098+--------------------------------------------------------------------------------
1099+
11101100type DList a = [a] -> [a]
11111101
11121102toList :: DList a -> [a]