@@ -896,83 +896,126 @@ class GFromJSON f where
896896
897897--------------------------------------------------------------------------------
898898
899−-- | Meta-information is stripped:
900899instance (GToJSON a) => GToJSON (M1 i c a) where
901900 gToJSON = gToJSON . unM1
902901
903−-- | Meta-information is added:
904902instance (GFromJSON a) => GFromJSON (M1 i c a) where
905903 gParseJSON = fmap M1 . gParseJSON
906904
905+--------------------------------------------------------------------------------
907906
908−-- | Constants are converted using toJSON:
909907instance (ToJSON a) => GToJSON (K1 i a) where
910908 gToJSON = toJSON . unK1
911909
912−-- | Constants are parsed using parseJSON:
913910instance (FromJSON a) => GFromJSON (K1 i a) where
914911 gParseJSON = fmap K1 . parseJSON
915912
913+--------------------------------------------------------------------------------
916914
917−-- | Constructors without arguments are converted to the empty array:
918915instance GToJSON U1 where
919916 gToJSON _ = emptyArray
920917
921−-- | Constructors without arguments must be represented by the empty array:
922918instance GFromJSON U1 where
923919 gParseJSON v
924920 | isEmptyArray v = pure U1
925921 | otherwise = typeMismatch "unary constructor (U1)" v
926922
923+--------------------------------------------------------------------------------
924+
925+instance (Constructor c, GRecordToObject a, GToJSON a) => GToJSON (C1 c a) where
926+ gToJSON m1@(M1 x)
927+ | conIsRecord m1 = Object $ gRecordToObject x
928+ | otherwise = gToJSON x
929+
930+instance (Constructor c, GFromRecord a, GFromJSON a) => GFromJSON (C1 c a) where
931+ gParseJSON v
932+ | conIsRecord (undefined :: t c a p) =
933+ case v of
934+ Object obj -> M1 <$> gParseRecord obj
935+ _ -> typeMismatch "record (:*:)" v
936+ | otherwise = M1 <$> gParseJSON v
937+
938+--------------------------------------------------------------------------------
939+
940+instance (GProductToValues a, GProductToValues b) => GToJSON (a :*: b) where
941+ gToJSON = toJSON . toList . gProductToValues
942+
943+instance (GFromProduct a, GFromProduct b) => GFromJSON (a :*: b) where
944+ gParseJSON (Array arr) = gParseProduct arr
945+ gParseJSON v = typeMismatch "product (:*:)" v
946+
947+--------------------------------------------------------------------------------
927948
928−-- | Each value of a sum type is converted to an object
929−-- with a single key-value association where the key is the name of the constructor:
930949instance (GObject a, GObject b) => GToJSON (a :+: b) where
931950 gToJSON (L1 x) = Object $ gObject x
932951 gToJSON (R1 x) = Object $ gObject x
933952
934−-- | A sum type must be represented by an object with a single key-value association.
935−-- When this is the case, the sum will be recursively parsed using gParseSum:
936953instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
937954 gParseJSON (Object (M.toList -> [keyVal])) = gParseSum keyVal
938955 gParseJSON v = typeMismatch "sum (:+:)" v
939956
957+--------------------------------------------------------------------------------
940958
941−-- | Product types without field names are flattened and converted to an array:
942−instance (GToJSON a, Flatten b) => GToJSON (S1 NoSelector a :*: b) where
943− gToJSON = toJSON . flatten
959+class GFromRecord f where
960+ gParseRecord :: Object -> Parser (f a)
944961
945−-- | Product types without field names must be represented as an array.
946−-- When this is the case the product will be recursively parsed sing gParseProduct:
947−instance (GFromJSON a, GFromProduct b) => GFromJSON (S1 NoSelector a :*: b) where
948− gParseJSON (Array arr) = gParseProduct arr 0
949− gParseJSON v = typeMismatch "product (:*:)" v
962+instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
963+ gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj
964+
965+instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
966+ gParseRecord obj = case M.lookup (T.pack key) obj of
967+ Nothing -> notFound key
968+ Just v -> gParseJSON v
969+ where
970+ key = selName (undefined :: t s a p)
971+
972+instance GFromRecord (a :+: b) where gParseRecord = undefined
973+instance GFromRecord U1 where gParseRecord = undefined
974+instance GFromRecord (K1 i c) where gParseRecord = undefined
975+instance GFromRecord (M1 i c f) where gParseRecord = undefined
976+
977+--------------------------------------------------------------------------------
950978
979+class GRecordToObject f where
980+ gRecordToObject :: f a -> Object
951981
952−-- | Other product types, so the ones with field names (records),
953−-- are converted to a single object.
954−instance (GObject a, GObject b) => GToJSON (a :*: b) where
955− gToJSON = Object . gObject
982+instance (GRecordToObject a, GRecordToObject b) => GRecordToObject (a :*: b) where
983+ gRecordToObject (a :*: b) = gRecordToObject a `M.union` gRecordToObject b
956984
957−-- | Product types with field names (records) must be represented as a single object.
958−-- If this is the case the product will be recursively parsed using gParseRecord.
959−instance (GFromRecord a, GFromRecord b) => GFromJSON (a :*: b) where
960− gParseJSON (Object obj) = gParseRecord obj
961− gParseJSON v = typeMismatch "record (:*:)" v
985+instance (Selector s, GToJSON a) => GRecordToObject (S1 s a) where
986+ gRecordToObject m1 = M.singleton (pack (selName m1)) (gToJSON (unM1 m1))
987+
988+instance GRecordToObject (a :+: b) where gRecordToObject = undefined
989+instance GRecordToObject U1 where gRecordToObject = undefined
990+instance GRecordToObject (K1 i c) where gRecordToObject = undefined
991+instance GRecordToObject (M1 i c f) where gRecordToObject = undefined
962992
963993--------------------------------------------------------------------------------
964994
965−-- | Flatten /flattens/ a product type. For example:
966−-- a :*: (b :*: (c :*: d)) is converted to:
967−-- [gToJSON a, gToJSON b, gToJSON c, gToJSON d]
968−class Flatten f where
969− flatten :: f a -> [Value]
995+class GProductToValues f where
996+ gProductToValues :: f a -> DList Value
997+
998+instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
999+ gProductToValues (a :*: b) = gProductToValues a `append` gProductToValues b
1000+
1001+instance (GToJSON a) => GProductToValues a where
1002+ gProductToValues = singleton . gToJSON
1003+
1004+--------------------------------------------------------------------------------
1005+
1006+class GFromProduct f where
1007+ gParseProduct :: Array -> Parser (f a)
1008+
1009+instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
1010+ gParseProduct arr = (:*:) <$> gParseProduct arrL <*> gParseProduct arrR
1011+ where
1012+ (arrL, arrR) = V.splitAt (V.length arr `div` 2) arr
9701013
971−instance (GToJSON a, Flatten b) => Flatten (S1 NoSelector a :*: b) where
972− flatten (m1 :*: r) = gToJSON m1 : flatten r
1014+instance (GFromJSON a) => GFromProduct (S1 NoSelector a) where
1015+ gParseProduct ((!? 0) -> Just v) = gParseJSON v
1016+ gParseProduct _ = fail "Array to small"
9731017
974−instance (GToJSON a) => Flatten (S1 NoSelector a) where
975− flatten m1 = [gToJSON $ unM1 m1]
1018+instance GFromProduct (M1 i c f) where gParseProduct = undefined
9761019
9771020--------------------------------------------------------------------------------
9781021
@@ -983,17 +1026,8 @@ instance (GObject a, GObject b) => GObject (a :+: b) where
9831026 gObject (L1 x) = gObject x
9841027 gObject (R1 x) = gObject x
9851028
986−instance (GObject a, GObject b) => GObject (a :*: b) where
987− gObject (a :*: b) = gObject a `M.union` gObject b
988−
989−instance (Selector s, GToJSON a) => GObject (S1 s a) where
990− gObject = objectNamed selName
991−
992−instance (Constructor c, GToJSON a) => GObject (C1 c a) where
993− gObject = objectNamed conName
994−
995−objectNamed :: GToJSON f => (M1 i c f p -> String) -> M1 i c f p -> Object
996−objectNamed getName m1 = M.singleton (pack (getName m1)) (gToJSON (unM1 m1))
1029+instance (Constructor c, GToJSON a, GRecordToObject a) => GObject (C1 c a) where
1030+ gObject m1 = M.singleton (pack (conName m1)) (gToJSON m1)
9971031
9981032--------------------------------------------------------------------------------
9991033
@@ -1001,9 +1035,9 @@ class GFromSum f where
10011035 gParseSum :: Pair -> Parser (f a)
10021036
10031037instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
1004− gParseSum keyVal = fmap L1 (gParseSum keyVal) <|> fmap R1 (gParseSum keyVal)
1038+ gParseSum keyVal = (L1 <$> gParseSum keyVal) <|> (R1 <$> gParseSum keyVal)
10051039
1006−instance (Constructor c, GFromJSON a) => GFromSum (C1 c a) where
1040+instance (Constructor c, GFromJSON a, GFromRecord a) => GFromSum (C1 c a) where
10071041 gParseSum (key, value)
10081042 | key == pack (conName (undefined :: t c a p)) = gParseJSON value
10091043 | otherwise = notFound $ unpack key
@@ -1013,35 +1047,16 @@ notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
10131047
10141048--------------------------------------------------------------------------------
10151049
1016−class GFromProduct f where
1017− gParseProduct :: Array -> Int -> Parser (f a)
1050+type DList a = [a] -> [a]
10181051
1019−instance (GFromJSON a, GFromProduct b) => GFromProduct (a :*: b) where
1020− gParseProduct arr ix =
1021− case arr !? ix of
1022− Nothing -> arrayToSmall ix
1023− Just v -> (:*:) <$> gParseJSON v <*> gParseProduct arr (ix+1)
1052+toList :: DList a -> [a]
1053+toList = ($ [])
10241054
1025−instance (GFromJSON a) => GFromProduct (S1 NoSelector a) where
1026− gParseProduct arr ix = case arr !? ix of
1027− Nothing -> arrayToSmall ix
1028− Just v -> gParseJSON v
1055+singleton :: a -> DList a
1056+singleton = (:)
10291057
1030−arrayToSmall :: Int -> Parser a
1031−arrayToSmall ix = fail $ "Expected an array of at least " ++ show ix ++ " values"
1058+append :: DList a -> DList a -> DList a
1059+append = (.)
10321060
10331061--------------------------------------------------------------------------------
1034−
1035−class GFromRecord f where
1036− gParseRecord :: Object -> Parser (f a)
1037−
1038−instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
1039− gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj
1040−
1041−instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
1042− gParseRecord obj = case M.lookup (T.pack key) obj of
1043− Nothing -> notFound key
1044− Just v -> gParseJSON v
1045− where
1046− key = selName (undefined :: t s a p)
10471062#endif