Commits

basvandijk committed f50fd12

Statically check if a constructor is a record instead of dynamically.
Besides possibly being more efficient this allows me to remove the undefined instances because they are no longer required.

  • Participants
  • Parent commits 7975354

Comments (0)

Files changed (1)

Data/Aeson/Types/Internal.hs

 
 {-# LANGUAGE CPP #-}
 #ifdef GENERICS
-{-# LANGUAGE DefaultSignatures, TypeOperators #-}
+{-# LANGUAGE DefaultSignatures
+           , TypeOperators
+           , EmptyDataDecls
+           , KindSignatures
+           , MultiParamTypeClasses
+           , FunctionalDependencies
+  #-}
 #endif
 
 -- |
 
 --------------------------------------------------------------------------------
 
-instance (Constructor c, GRecordToObject a, GToJSON a) => GToJSON (C1 c a) where
-    gToJSON m1@(M1 x)
-        | conIsRecord m1 = Object $ gRecordToObject x
-        | otherwise = gToJSON x
+instance (ConsToJSON a) => GToJSON (C1 c a) where
+    gToJSON = consToJSON . unM1
 
-instance (Constructor c, GFromRecord a, GFromJSON a) => GFromJSON (C1 c a) where
-    gParseJSON v
-        | conIsRecord (undefined :: t c a p) =
-            case v of
-              Object obj -> M1 <$> gParseRecord obj
-              _ -> typeMismatch "record (:*:)" v
-        | otherwise = M1 <$> gParseJSON v
+instance (ConsFromJSON a) => GFromJSON (C1 c a) where
+    gParseJSON = fmap M1 . consParseJSON
 
 --------------------------------------------------------------------------------
 
 
 --------------------------------------------------------------------------------
 
+class ConsToJSON    f where consToJSON  ::           f a -> Value
+class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
+
+instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
+    consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
+
+instance (GRecordToObject f) => ConsToJSON' True f where
+    consToJSON' = Tagged (Object . gRecordToObject)
+
+instance GToJSON f => ConsToJSON' False f where
+    consToJSON' = Tagged gToJSON
+
+--------------------------------------------------------------------------------
+
+class ConsFromJSON    f where consParseJSON  ::           Value -> Parser (f a)
+class ConsFromJSON' b f where consParseJSON' :: Tagged b (Value -> Parser (f a))
+
+instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where
+    consParseJSON = unTagged (consParseJSON' :: Tagged b (Value -> Parser (f a)))
+
+instance (GFromRecord f) => ConsFromJSON' True f where
+    consParseJSON' = Tagged parseRecord
+        where
+          parseRecord (Object obj) = gParseRecord obj
+          parseRecord v = typeMismatch "record (:*:)" v
+
+instance (GFromJSON f) => ConsFromJSON' False f where
+    consParseJSON' = Tagged gParseJSON
+
+--------------------------------------------------------------------------------
+
+newtype Tagged s b = Tagged {unTagged :: b}
+
+data True
+data False
+
+class IsRecord (f :: * -> *) b | f -> b
+
+instance (IsRecord f b) => IsRecord (f :*: g) b
+instance IsRecord (M1 S NoSelector f) False
+instance (IsRecord f b) => IsRecord (M1 S c f) b
+instance IsRecord (K1 i c) True
+instance IsRecord U1 False
+
+--------------------------------------------------------------------------------
+
 class GFromRecord f where
     gParseRecord :: Object -> Parser (f a)
 
         where
           key = selName (undefined :: t s a p)
 
-instance GFromRecord (a :+: b)  where gParseRecord = undefined
-instance GFromRecord U1         where gParseRecord = undefined
-instance GFromRecord (K1 i c)   where gParseRecord = undefined
-instance GFromRecord (M1 i c f) where gParseRecord = undefined
-
 --------------------------------------------------------------------------------
 
 class GRecordToObject f where
 instance (Selector s, GToJSON a) => GRecordToObject (S1 s a) where
     gRecordToObject m1 = M.singleton (pack (selName m1)) (gToJSON (unM1 m1))
 
-instance GRecordToObject (a :+: b)  where gRecordToObject = undefined
-instance GRecordToObject U1         where gRecordToObject = undefined
-instance GRecordToObject (K1 i c)   where gRecordToObject = undefined
-instance GRecordToObject (M1 i c f) where gRecordToObject = undefined
-
 --------------------------------------------------------------------------------
 
 class GProductToValues f where
     gObject (L1 x) = gObject x
     gObject (R1 x) = gObject x
 
-instance (Constructor c, GToJSON a, GRecordToObject a) => GObject (C1 c a) where
+instance (Constructor c, GToJSON a, ConsToJSON a)
+    => GObject (C1 c a) where
     gObject m1 = M.singleton (pack (conName m1)) (gToJSON m1)
 
 --------------------------------------------------------------------------------
 instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
     gParseSum keyVal = (L1 <$> gParseSum keyVal) <|> (R1 <$> gParseSum keyVal)
 
-instance (Constructor c, GFromJSON a, GFromRecord a) => GFromSum (C1 c a) where
+instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
     gParseSum (key, value)
         | key == pack (conName (undefined :: t c a p)) = gParseJSON value
         | otherwise = notFound $ unpack key