Properly recurse into (:*:) for HasAnnotatedInputType

Author: Victor Nawothnig

src/GraphQL/Internal/API.hs

@@ -35,8 +35,9 @@ module GraphQL.Internal.API
   , getAnnotatedInputType
   ) where
 
-import Protolude hiding (Enum, TypeError)
+import Protolude hiding (Enum, TypeError, (<>))
 
+import Data.Semigroup ((<>))
 import qualified Data.List.NonEmpty as NonEmpty
 import GHC.Generics ((:*:)(..))
 import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..))
@@ -358,12 +359,12 @@ class GenericAnnotatedInputType (f :: Type -> Type) where
 class GenericInputObjectFieldDefinitions (f :: Type -> Type) where
   genericGetInputObjectFieldDefinitions :: Either SchemaError (NonEmpty Schema.InputObjectFieldDefinition)
 
-instance forall dataName consName records s l p.
+instance forall dataName consName records m p f.
   ( KnownSymbol dataName
   , KnownSymbol consName
   , GenericInputObjectFieldDefinitions records
-  ) => GenericAnnotatedInputType (D1 ('MetaData dataName s l 'False)
-                                  (C1 ('MetaCons consName p 'True) records
+  ) => GenericAnnotatedInputType (D1 ('MetaData dataName m p 'False)
+                                  (C1 ('MetaCons consName f 'True) records
                                   )) where
   genericGetAnnotatedInputType = do
     name <- nameFromSymbol @dataName
@@ -374,17 +375,14 @@ instance forall dataName consName records s l p.
           . Schema.InputObjectTypeDefinition name
         ) (genericGetInputObjectFieldDefinitions @records)
 
-instance forall wrappedType fieldName rest u s l.
-  ( KnownSymbol fieldName
-  , HasAnnotatedInputType wrappedType
-  , GenericInputObjectFieldDefinitions rest
-  ) => GenericInputObjectFieldDefinitions (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType) :*: rest) where
+instance forall l r.
+  ( GenericInputObjectFieldDefinitions l
+  , GenericInputObjectFieldDefinitions r
+  ) => GenericInputObjectFieldDefinitions (l :*: r) where
   genericGetInputObjectFieldDefinitions = do
-    name <- nameFromSymbol @fieldName
-    annotatedInputType <- getAnnotatedInputType @wrappedType
-    let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing
-    r <- genericGetInputObjectFieldDefinitions @rest
-    pure (NonEmpty.cons l r)
+    l <- genericGetInputObjectFieldDefinitions @l
+    r <- genericGetInputObjectFieldDefinitions @r
+    pure (l <> r)
 
 instance forall wrappedType fieldName u s l.
   ( KnownSymbol fieldName

src/GraphQL/Internal/API/Enum.hs

@@ -64,7 +64,9 @@ instance forall left right.
   genericEnumToValue (L1 gv) = genericEnumToValue gv
   genericEnumToValue (R1 gv) = genericEnumToValue gv
 
-instance forall conName p b. (KnownSymbol conName) => GenericEnumValues (C1 ('MetaCons conName p b) U1) where
+instance forall conName f s.
+   ( KnownSymbol conName
+   ) => GenericEnumValues (C1 ('MetaCons conName f s) U1) where
   genericEnumValues = let name = nameFromSymbol @conName in [name]
   genericEnumFromValue vname =
     case nameFromSymbol @conName of
@@ -86,18 +88,18 @@ instance forall conName p b. (KnownSymbol conName) => GenericEnumValues (C1 ('Me
 
 -- TODO(tom): better type errors using `n`. Also type errors for other
 -- invalid constructors.
-instance forall conName p b sa sb.
+instance forall conName f s sa sb.
   ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName)
   , KnownSymbol conName
-  ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb)) where
+  ) => GenericEnumValues (C1 ('MetaCons conName f s) (S1 sa sb)) where
   genericEnumValues = nonUnaryConstructorError
   genericEnumFromValue = nonUnaryConstructorError
   genericEnumToValue = nonUnaryConstructorError
 
-instance forall conName p b sa sb f.
+instance forall conName f s sa sb r.
   ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName)
   , KnownSymbol conName
-  ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb) :+: f) where
+  ) => GenericEnumValues (C1 ('MetaCons conName f s) (S1 sa sb) :+: r) where
   genericEnumValues = nonUnaryConstructorError
   genericEnumFromValue = nonUnaryConstructorError
   genericEnumToValue = nonUnaryConstructorError

src/GraphQL/Internal/Value/FromValue.hs

@@ -91,12 +91,12 @@ wrongType expected value = throwError ("Wrong type, should be: `" <> expected <>
 class GenericFromValue (f :: Type -> Type) where
   genericFromValue :: Object' ConstScalar -> Either Text (f p)
 
-instance forall dataName consName records s l p.
+instance forall dataName consName records m p f.
   ( KnownSymbol dataName
   , KnownSymbol consName
   , GenericFromValue records
-  ) => GenericFromValue (D1 ('MetaData dataName s l 'False)
-                         (C1 ('MetaCons consName p 'True) records
+  ) => GenericFromValue (D1 ('MetaData dataName m p 'False)
+                         (C1 ('MetaCons consName f 'True) records
                          )) where
   genericFromValue o = M1 . M1 <$> genericFromValue @records o
 
@@ -108,8 +108,10 @@ instance forall l r.
   genericFromValue object = liftA2 (:*:) (genericFromValue @l object) (genericFromValue @r object)
 
 -- | Look up a single record field element in the Object.
-getValue :: forall wrappedType fieldName u s l p. (FromValue wrappedType, KnownSymbol fieldName)
-         => Object' ConstScalar -> Either Text ((S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) p)
+getValue :: forall wrappedType fieldName u s l p.
+  ( FromValue wrappedType
+  , KnownSymbol fieldName
+  ) => Object' ConstScalar -> Either Text ((S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) p)
 getValue (Object' fieldMap) = do
   fieldName <- case nameFromSymbol @fieldName of
     Left err -> throwError ("invalid field name" <> show err)

tests/ValueTests.hs

@@ -10,6 +10,7 @@ import Test.Tasty.Hspec (testSpec, describe, it, shouldBe, shouldSatisfy)
 
 import qualified GraphQL.Internal.Syntax.AST as AST
 import GraphQL.Internal.Arbitrary (arbitraryText, arbitraryNonEmpty)
+import GraphQL.API (HasAnnotatedInputType)
 import GraphQL.Value
   ( Object
   , Value'(ValueObject')
@@ -29,6 +30,7 @@ data Resource = Resource
     , resBool     :: Bool
     } deriving (Generic, Eq, Show)
 
+instance HasAnnotatedInputType
 instance FromValue Resource
 
 tests :: IO TestTree
@@ -59,7 +61,7 @@ tests = testSpec "Value" $ do
       prop_fieldsUnique
     -- See https://github.com/haskell-graphql/graphql-api/pull/178 for background
     it "derives fromValue instances for objects with more than three fields" $ do
-      let Just value = objectFromList 
+      let Just value = objectFromList
             [ ("resText",   toValue @Text "text")
             , ("resBool",   toValue @Bool False)
             , ("resDouble", toValue @Double 1.2)
@@ -70,10 +72,10 @@ tests = testSpec "Value" $ do
             { resText   = "text"
             , resInt    = 32
             , resDouble = 1.2
-            , resBool   = False 
+            , resBool   = False
             }
       observed `shouldBe` expected
-      
+
   describe "ToValue / FromValue instances" $ do
     prop "Bool" $ prop_roundtripValue @Bool
     prop "Int32" $ prop_roundtripValue @Int32