@@ -5,7 +5,13 @@
55
66{-# LANGUAGE CPP #-}
77#ifdef GENERICS
8−{-# LANGUAGE DefaultSignatures, TypeOperators #-}
8+{-# LANGUAGE DefaultSignatures
9+ , TypeOperators
10+ , EmptyDataDecls
11+ , KindSignatures
12+ , MultiParamTypeClasses
13+ , FunctionalDependencies
14+ #-}
915#endif
1016
1117-- |
@@ -922,18 +928,11 @@ instance GFromJSON U1 where
922928
923929--------------------------------------------------------------------------------
924930
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
931+instance (ConsToJSON a) => GToJSON (C1 c a) where
932+ gToJSON = consToJSON . unM1
929933
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
934+instance (ConsFromJSON a) => GFromJSON (C1 c a) where
935+ gParseJSON = fmap M1 . consParseJSON
937936
938937--------------------------------------------------------------------------------
939938
@@ -956,6 +955,52 @@ instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
956955
957956--------------------------------------------------------------------------------
958957
958+class ConsToJSON f where consToJSON :: f a -> Value
959+class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
960+
961+instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
962+ consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
963+
964+instance (GRecordToObject f) => ConsToJSON' True f where
965+ consToJSON' = Tagged (Object . gRecordToObject)
966+
967+instance GToJSON f => ConsToJSON' False f where
968+ consToJSON' = Tagged gToJSON
969+
970+--------------------------------------------------------------------------------
971+
972+class ConsFromJSON f where consParseJSON :: Value -> Parser (f a)
973+class ConsFromJSON' b f where consParseJSON' :: Tagged b (Value -> Parser (f a))
974+
975+instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where
976+ consParseJSON = unTagged (consParseJSON' :: Tagged b (Value -> Parser (f a)))
977+
978+instance (GFromRecord f) => ConsFromJSON' True f where
979+ consParseJSON' = Tagged parseRecord
980+ where
981+ parseRecord (Object obj) = gParseRecord obj
982+ parseRecord v = typeMismatch "record (:*:)" v
983+
984+instance (GFromJSON f) => ConsFromJSON' False f where
985+ consParseJSON' = Tagged gParseJSON
986+
987+--------------------------------------------------------------------------------
988+
989+newtype Tagged s b = Tagged {unTagged :: b}
990+
991+data True
992+data False
993+
994+class IsRecord (f :: * -> *) b | f -> b
995+
996+instance (IsRecord f b) => IsRecord (f :*: g) b
997+instance IsRecord (M1 S NoSelector f) False
998+instance (IsRecord f b) => IsRecord (M1 S c f) b
999+instance IsRecord (K1 i c) True
1000+instance IsRecord U1 False
1001+
1002+--------------------------------------------------------------------------------
1003+
9591004class GFromRecord f where
9601005 gParseRecord :: Object -> Parser (f a)
9611006
@@ -969,11 +1014,6 @@ instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
9691014 where
9701015 key = selName (undefined :: t s a p)
9711016
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−
9771017--------------------------------------------------------------------------------
9781018
9791019class GRecordToObject f where
@@ -985,11 +1025,6 @@ instance (GRecordToObject a, GRecordToObject b) => GRecordToObject (a :*: b) whe
9851025instance (Selector s, GToJSON a) => GRecordToObject (S1 s a) where
9861026 gRecordToObject m1 = M.singleton (pack (selName m1)) (gToJSON (unM1 m1))
9871027
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
992−
9931028--------------------------------------------------------------------------------
9941029
9951030class GProductToValues f where
@@ -1024,7 +1059,8 @@ instance (GObject a, GObject b) => GObject (a :+: b) where
10241059 gObject (L1 x) = gObject x
10251060 gObject (R1 x) = gObject x
10261061
1027−instance (Constructor c, GToJSON a, GRecordToObject a) => GObject (C1 c a) where
1062+instance (Constructor c, GToJSON a, ConsToJSON a)
1063+ => GObject (C1 c a) where
10281064 gObject m1 = M.singleton (pack (conName m1)) (gToJSON m1)
10291065
10301066--------------------------------------------------------------------------------
@@ -1035,7 +1071,7 @@ class GFromSum f where
10351071instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
10361072 gParseSum keyVal = (L1 <$> gParseSum keyVal) <|> (R1 <$> gParseSum keyVal)
10371073
1038−instance (Constructor c, GFromJSON a, GFromRecord a) => GFromSum (C1 c a) where
1074+instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
10391075 gParseSum (key, value)
10401076 | key == pack (conName (undefined :: t c a p)) = gParseJSON value
10411077 | otherwise = notFound $ unpack key