Merge pull request #159 from haskell-graphql/pedantic-builds

Make warnings fail the build

Author: jml

.circleci/config.yml

@@ -28,5 +28,8 @@ jobs:
             - /root/.stack
             - .stack-work
       - run:
+          # Build with --pedantic here to avoid introducing warnings. We
+          # *don't* build with -Werror on Hackage as that is strongly
+          # discouraged.
           name: Tests
-          command: stack test --skip-ghc-check --no-terminal
+          command: stack test --skip-ghc-check --no-terminal --pedantic

src/GraphQL/API.hs

@@ -34,9 +34,8 @@ module GraphQL.API
 
 import Protolude hiding (Enum, TypeError)
 
-import GraphQL.Internal.Schema hiding (Type)
-import qualified GraphQL.Internal.Schema (Type)
 import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..))
+import qualified GraphQL.Internal.Schema as Schema
 import GraphQL.Internal.Name (NameError, nameFromSymbol)
 import GraphQL.API.Enum (GraphQLEnum(..))
 import GHC.Generics ((:*:)(..))
@@ -95,15 +94,15 @@ cons = (:)
 -- Transform into a Schema definition
 class HasObjectDefinition a where
   -- Todo rename to getObjectTypeDefinition
-  getDefinition :: Either NameError ObjectTypeDefinition
+  getDefinition :: Either NameError Schema.ObjectTypeDefinition
 
 class HasFieldDefinition a where
-  getFieldDefinition :: Either NameError FieldDefinition
+  getFieldDefinition :: Either NameError Schema.FieldDefinition
 
 
 -- Fields
 class HasFieldDefinitions a where
-  getFieldDefinitions :: Either NameError [FieldDefinition]
+  getFieldDefinitions :: Either NameError [Schema.FieldDefinition]
 
 instance forall a as. (HasFieldDefinition a, HasFieldDefinitions as) => HasFieldDefinitions (a:as) where
   getFieldDefinitions = cons <$> getFieldDefinition @a <*> getFieldDefinitions @as
@@ -116,7 +115,7 @@ instance HasFieldDefinitions '[] where
 -- Union "Horse" '[Leg, Head, Tail]
 --               ^^^^^^^^^^^^^^^^^^ this part
 class UnionTypeObjectTypeDefinitionList a where
-  getUnionTypeObjectTypeDefinitions :: Either NameError [ObjectTypeDefinition]
+  getUnionTypeObjectTypeDefinitions :: Either NameError [Schema.ObjectTypeDefinition]
 
 instance forall a as. (HasObjectDefinition a, UnionTypeObjectTypeDefinitionList as) => UnionTypeObjectTypeDefinitionList (a:as) where
   getUnionTypeObjectTypeDefinitions = cons <$> getDefinition @a <*> getUnionTypeObjectTypeDefinitions @as
@@ -126,7 +125,7 @@ instance UnionTypeObjectTypeDefinitionList '[] where
 
 -- Interfaces
 class HasInterfaceDefinitions a where
-  getInterfaceDefinitions :: Either NameError Interfaces
+  getInterfaceDefinitions :: Either NameError Schema.Interfaces
 
 instance forall a as. (HasInterfaceDefinition a, HasInterfaceDefinitions as) => HasInterfaceDefinitions (a:as) where
   getInterfaceDefinitions = cons <$> getInterfaceDefinition @a <*> getInterfaceDefinitions @as
@@ -135,35 +134,35 @@ instance HasInterfaceDefinitions '[] where
   getInterfaceDefinitions = pure []
 
 class HasInterfaceDefinition a where
-  getInterfaceDefinition :: Either NameError InterfaceTypeDefinition
+  getInterfaceDefinition :: Either NameError Schema.InterfaceTypeDefinition
 
 instance forall ks fields. (KnownSymbol ks, HasFieldDefinitions fields) => HasInterfaceDefinition (Interface ks fields) where
   getInterfaceDefinition =
     let name = nameFromSymbol @ks
-        fields = NonEmptyList <$> getFieldDefinitions @fields
-    in InterfaceTypeDefinition <$> name <*> fields
+        fields = Schema.NonEmptyList <$> getFieldDefinitions @fields
+    in Schema.InterfaceTypeDefinition <$> name <*> fields
 
 -- Give users some help if they don't terminate Arguments with a Field:
 -- NB the "redundant constraints" warning is a GHC bug: https://ghc.haskell.org/trac/ghc/ticket/11099
 instance forall ks t. TypeError ('Text ":> Arguments must end with a Field") =>
          HasFieldDefinition (Argument ks t) where
-  getFieldDefinition = notImplemented
+  getFieldDefinition = panic ":> Arugments must end with a Field. This should not happen, but rather we'll get a compile-time error instead."
 
 instance forall ks is ts. (KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions ts) => HasAnnotatedType (Object ks is ts) where
   getAnnotatedType =
     let obj = getDefinition @(Object ks is ts)
-    in (TypeNamed . DefinedType . TypeDefinitionObject) <$> obj
+    in (Schema.TypeNamed . Schema.DefinedType . Schema.TypeDefinitionObject) <$> obj
 
 instance forall t ks. (KnownSymbol ks, HasAnnotatedType t) => HasFieldDefinition (Field ks t) where
   getFieldDefinition =
     let name = nameFromSymbol @ks
-    in FieldDefinition <$> name <*> pure [] <*> getAnnotatedType @t
+    in Schema.FieldDefinition <$> name <*> pure [] <*> getAnnotatedType @t
 
 class HasArgumentDefinition a where
-  getArgumentDefinition :: Either NameError ArgumentDefinition
+  getArgumentDefinition :: Either NameError Schema.ArgumentDefinition
 
 instance forall ks t. (KnownSymbol ks, HasAnnotatedInputType t) => HasArgumentDefinition (Argument ks t) where
-  getArgumentDefinition = ArgumentDefinition <$> argName <*> argType <*> defaultValue
+  getArgumentDefinition = Schema.ArgumentDefinition <$> argName <*> argType <*> defaultValue
     where
       argName = nameFromSymbol @ks
       argType = getAnnotatedInputType @t
@@ -173,7 +172,7 @@ instance forall a b. (HasArgumentDefinition a, HasFieldDefinition b) => HasField
   getFieldDefinition =
     prependArg <$> argument <*> getFieldDefinition @b
     where
-      prependArg arg (FieldDefinition name argDefs at) = FieldDefinition name (arg:argDefs) at
+      prependArg arg (Schema.FieldDefinition name argDefs at) = Schema.FieldDefinition name (arg:argDefs) at
       argument = getArgumentDefinition @a
 
 instance forall ks is fields.
@@ -182,8 +181,8 @@ instance forall ks is fields.
   getDefinition =
     let name = nameFromSymbol @ks
         interfaces = getInterfaceDefinitions @is
-        fields = NonEmptyList <$> getFieldDefinitions @fields
-    in ObjectTypeDefinition <$> name <*> interfaces <*> fields
+        fields = Schema.NonEmptyList <$> getFieldDefinitions @fields
+    in Schema.ObjectTypeDefinition <$> name <*> interfaces <*> fields
 
 -- Builtin output types (annotated types)
 class HasAnnotatedType a where
@@ -192,21 +191,21 @@ class HasAnnotatedType a where
   -- forget this. Maybe we can flip the internal encoding to be
   -- non-null by default and needing explicit null-encoding (via
   -- Maybe).
-  getAnnotatedType :: Either NameError (AnnotatedType GraphQL.Internal.Schema.Type)
+  getAnnotatedType :: Either NameError (Schema.AnnotatedType Schema.GType)
 
 -- | Turn a non-null type into the optional version of its own type.
-dropNonNull :: AnnotatedType t -> AnnotatedType t
-dropNonNull (TypeNonNull (NonNullTypeNamed t)) = TypeNamed t
-dropNonNull (TypeNonNull (NonNullTypeList t)) = TypeList t
-dropNonNull x@(TypeNamed _) = x
-dropNonNull x@(TypeList _) = x
+dropNonNull :: Schema.AnnotatedType t -> Schema.AnnotatedType t
+dropNonNull (Schema.TypeNonNull (Schema.NonNullTypeNamed t)) = Schema.TypeNamed t
+dropNonNull (Schema.TypeNonNull (Schema.NonNullTypeList t)) = Schema.TypeList t
+dropNonNull x@(Schema.TypeNamed _) = x
+dropNonNull x@(Schema.TypeList _) = x
 
 instance forall a. HasAnnotatedType a => HasAnnotatedType (Maybe a) where
   -- see TODO in HasAnnotatedType class
   getAnnotatedType = dropNonNull <$> getAnnotatedType @a
 
-builtinType :: Builtin -> Either NameError (AnnotatedType GraphQL.Internal.Schema.Type)
-builtinType = pure . TypeNonNull . NonNullTypeNamed . BuiltinType
+builtinType :: Schema.Builtin -> Either NameError (Schema.AnnotatedType Schema.GType)
+builtinType = pure . Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.BuiltinType
 
 -- TODO(jml): Given that AnnotatedType is parametrised, we can probably reduce
 -- a great deal of duplication by making HasAnnotatedType a parametrised type
@@ -216,93 +215,93 @@ builtinType = pure . TypeNonNull . NonNullTypeNamed . BuiltinType
 -- than listing each individually.
 
 instance HasAnnotatedType Int where
-  getAnnotatedType = builtinType GInt
+  getAnnotatedType = builtinType Schema.GInt
 
 instance HasAnnotatedType Int32 where
-  getAnnotatedType = builtinType GInt
+  getAnnotatedType = builtinType Schema.GInt
 
 instance HasAnnotatedType Bool where
-  getAnnotatedType = builtinType GBool
+  getAnnotatedType = builtinType Schema.GBool
 
 instance HasAnnotatedType Text where
-  getAnnotatedType = builtinType GString
+  getAnnotatedType = builtinType Schema.GString
 
 instance HasAnnotatedType Double where
-  getAnnotatedType = builtinType GFloat
+  getAnnotatedType = builtinType Schema.GFloat
 
 instance HasAnnotatedType Float where
-  getAnnotatedType = builtinType GFloat
+  getAnnotatedType = builtinType Schema.GFloat
 
 instance forall t. (HasAnnotatedType t) => HasAnnotatedType (List t) where
-  getAnnotatedType = TypeList . ListType <$> getAnnotatedType @t
+  getAnnotatedType = Schema.TypeList . Schema.ListType <$> getAnnotatedType @t
 
 instance forall ks enum. (KnownSymbol ks, GraphQLEnum enum) => HasAnnotatedType (Enum ks enum) where
   getAnnotatedType = do
     let name = nameFromSymbol @ks
-    let enums = sequenceA (enumValues @enum) :: Either NameError [Name]
-    let et = EnumTypeDefinition <$> name <*> map (map EnumValueDefinition) enums
-    TypeNonNull . NonNullTypeNamed . DefinedType . TypeDefinitionEnum <$> et
+    let enums = sequenceA (enumValues @enum) :: Either NameError [Schema.Name]
+    let et = Schema.EnumTypeDefinition <$> name <*> map (map Schema.EnumValueDefinition) enums
+    Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.DefinedType . Schema.TypeDefinitionEnum <$> et
 
 instance forall ks as. (KnownSymbol ks, UnionTypeObjectTypeDefinitionList as) => HasAnnotatedType (Union ks as) where
   getAnnotatedType =
     let name = nameFromSymbol @ks
-        types = NonEmptyList <$> getUnionTypeObjectTypeDefinitions @as
-    in (TypeNamed . DefinedType . TypeDefinitionUnion) <$> (UnionTypeDefinition <$> name <*> types)
+        types = Schema.NonEmptyList <$> getUnionTypeObjectTypeDefinitions @as
+    in (Schema.TypeNamed . Schema.DefinedType . Schema.TypeDefinitionUnion) <$> (Schema.UnionTypeDefinition <$> name <*> types)
 
 -- Help users with better type errors
 instance TypeError ('Text "Cannot encode Integer because it has arbitrary size but the JSON encoding is a number") =>
          HasAnnotatedType Integer where
-  getAnnotatedType = undefined
+  getAnnotatedType = panic "Cannot encode Integer into JSON due to its arbitrary size. Should get a compile-time error instead of this."
 
 
 -- Builtin input types
 class HasAnnotatedInputType a where
   -- See TODO comment in "HasAnnotatedType" class for nullability.
-  getAnnotatedInputType :: Either NameError (AnnotatedType InputType)
-  default getAnnotatedInputType :: (Generic a, GenericAnnotatedInputType (Rep a)) => Either NameError (AnnotatedType InputType)
+  getAnnotatedInputType :: Either NameError (Schema.AnnotatedType Schema.InputType)
+  default getAnnotatedInputType :: (Generic a, GenericAnnotatedInputType (Rep a)) => Either NameError (Schema.AnnotatedType Schema.InputType)
   getAnnotatedInputType = genericGetAnnotatedInputType @(Rep a)
 
 instance forall a. HasAnnotatedInputType a => HasAnnotatedInputType (Maybe a) where
   getAnnotatedInputType = dropNonNull <$> getAnnotatedInputType @a
 
-builtinInputType :: Builtin -> Either NameError (AnnotatedType InputType)
-builtinInputType = pure . TypeNonNull . NonNullTypeNamed . BuiltinInputType
+builtinInputType :: Schema.Builtin -> Either NameError (Schema.AnnotatedType Schema.InputType)
+builtinInputType = pure . Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.BuiltinInputType
 
 instance HasAnnotatedInputType Int where
-  getAnnotatedInputType = builtinInputType GInt
+  getAnnotatedInputType = builtinInputType Schema.GInt
 
 instance HasAnnotatedInputType Int32 where
-  getAnnotatedInputType = builtinInputType GInt
+  getAnnotatedInputType = builtinInputType Schema.GInt
 
 instance HasAnnotatedInputType Bool where
-  getAnnotatedInputType = builtinInputType GBool
+  getAnnotatedInputType = builtinInputType Schema.GBool
 
 instance HasAnnotatedInputType Text where
-  getAnnotatedInputType = builtinInputType GString
+  getAnnotatedInputType = builtinInputType Schema.GString
 
 instance HasAnnotatedInputType Double where
-  getAnnotatedInputType = builtinInputType GFloat
+  getAnnotatedInputType = builtinInputType Schema.GFloat
 
 instance HasAnnotatedInputType Float where
-  getAnnotatedInputType = builtinInputType GFloat
+  getAnnotatedInputType = builtinInputType Schema.GFloat
 
 instance forall t. (HasAnnotatedInputType t) => HasAnnotatedInputType (List t) where
-  getAnnotatedInputType = TypeList . ListType <$> getAnnotatedInputType @t
+  getAnnotatedInputType = Schema.TypeList . Schema.ListType <$> getAnnotatedInputType @t
 
 instance forall ks enum. (KnownSymbol ks, GraphQLEnum enum) => HasAnnotatedInputType (Enum ks enum) where
   getAnnotatedInputType = do
     let name = nameFromSymbol @ks
-        enums = sequenceA (enumValues @enum) :: Either NameError [Name]
-    let et = EnumTypeDefinition <$> name <*> map (map EnumValueDefinition) enums
-    TypeNonNull . NonNullTypeNamed . DefinedInputType . InputTypeDefinitionEnum <$> et
+        enums = sequenceA (enumValues @enum) :: Either NameError [Schema.Name]
+    let et = Schema.EnumTypeDefinition <$> name <*> map (map Schema.EnumValueDefinition) enums
+    Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.DefinedInputType . Schema.InputTypeDefinitionEnum <$> et
 
 
 -- Generic getAnnotatedInputType function
 class GenericAnnotatedInputType (f :: Type -> Type) where
-  genericGetAnnotatedInputType :: Either NameError (AnnotatedType InputType)
+  genericGetAnnotatedInputType :: Either NameError (Schema.AnnotatedType Schema.InputType)
 
 class GenericInputObjectFieldDefinitions (f :: Type -> Type) where
-  genericGetInputObjectFieldDefinitions :: Either NameError [InputObjectFieldDefinition]
+  genericGetInputObjectFieldDefinitions :: Either NameError [Schema.InputObjectFieldDefinition]
 
 instance forall dataName consName records s l p.
   ( KnownSymbol dataName
@@ -313,12 +312,12 @@ instance forall dataName consName records s l p.
                                   )) where
   genericGetAnnotatedInputType = do
     name <- nameFromSymbol @dataName
-    map ( TypeNonNull
-          . NonNullTypeNamed
-          . DefinedInputType
-          . InputTypeDefinitionObject
-          . (InputObjectTypeDefinition name)
-          . NonEmptyList
+    map ( Schema.TypeNonNull
+          . Schema.NonNullTypeNamed
+          . Schema.DefinedInputType
+          . Schema.InputTypeDefinitionObject
+          . (Schema.InputObjectTypeDefinition name)
+          . Schema.NonEmptyList
         ) (genericGetInputObjectFieldDefinitions @records)
 
 instance forall wrappedType fieldName rest u s l.
@@ -329,7 +328,7 @@ instance forall wrappedType fieldName rest u s l.
   genericGetInputObjectFieldDefinitions = do
     name <- nameFromSymbol @fieldName
     annotatedInputType <- getAnnotatedInputType @wrappedType
-    let l = InputObjectFieldDefinition name annotatedInputType Nothing
+    let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing
     r <- genericGetInputObjectFieldDefinitions @rest
     pure (l:r)
 
@@ -340,5 +339,5 @@ instance forall wrappedType fieldName u s l.
   genericGetInputObjectFieldDefinitions = do
     name <- nameFromSymbol @fieldName
     annotatedInputType <- getAnnotatedInputType @wrappedType
-    let l = InputObjectFieldDefinition name annotatedInputType Nothing
+    let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing
     pure [l]

src/GraphQL/API/Enum.hs

@@ -86,18 +86,20 @@ instance forall conName p b sa sb.
   ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName)
   , KnownSymbol conName
   ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb)) where
-  genericEnumValues = undefined
-  genericEnumFromValue = undefined
-  genericEnumToValue = undefined
+  genericEnumValues = nonUnaryConstructorError
+  genericEnumFromValue = nonUnaryConstructorError
+  genericEnumToValue = nonUnaryConstructorError
 
 instance forall conName p b sa sb f.
   ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName)
   , KnownSymbol conName
   ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb) :+: f) where
-  genericEnumValues = undefined
-  genericEnumFromValue = undefined
-  genericEnumToValue = undefined
+  genericEnumValues = nonUnaryConstructorError
+  genericEnumFromValue = nonUnaryConstructorError
+  genericEnumToValue = nonUnaryConstructorError
 
+nonUnaryConstructorError :: a
+nonUnaryConstructorError = panic "Tried to construct enum with non-unary constructor. Should get a compile-time error instead of this."
 
 -- | For each enum type we need 1) a list of all possible values 2) a
 -- way to serialise and 3) deserialise.

src/GraphQL/Internal/Execution.hs

@@ -32,7 +32,7 @@ import GraphQL.Internal.Validation
   , VariableDefinition(..)
   , VariableValue
   , Variable
-  , Type(..)
+  , GType(..)
   )
 
 -- | Get an operation from a GraphQL document

src/GraphQL/Internal/Schema.hs

@@ -8,7 +8,7 @@
 --
 -- Equivalent representation of GraphQL /values/ is in "GraphQL.Value".
 module GraphQL.Internal.Schema
-  ( Type(..)
+  ( GType(..)
   -- * Builtin types
   , Builtin(..)
   -- * Defining new types
@@ -40,7 +40,7 @@ module GraphQL.Internal.Schema
   , lookupType
   ) where
 
-import Protolude hiding (Type)
+import Protolude
 
 import qualified Data.Map as Map
 import GraphQL.Value (Value)
@@ -100,13 +100,13 @@ data NonNullType t = NonNullTypeNamed t
                    | NonNullTypeList  (ListType t)
                    deriving (Eq, Ord, Show)
 
-data Type = DefinedType TypeDefinition | BuiltinType Builtin deriving (Eq, Ord, Show)
+data GType = DefinedType TypeDefinition | BuiltinType Builtin deriving (Eq, Ord, Show)
 
-instance DefinesTypes Type where
+instance DefinesTypes GType where
   getDefinedTypes (BuiltinType _) = mempty
   getDefinedTypes (DefinedType t) = getDefinedTypes t
 
-instance HasName Type where
+instance HasName GType where
   getName (DefinedType x) = getName x
   getName (BuiltinType x) = getName x
 
@@ -154,7 +154,7 @@ instance DefinesTypes ObjectTypeDefinition where
 
 type Interfaces = [InterfaceTypeDefinition]
 
-data FieldDefinition = FieldDefinition Name [ArgumentDefinition] (AnnotatedType Type)
+data FieldDefinition = FieldDefinition Name [ArgumentDefinition] (AnnotatedType GType)
                        deriving (Eq, Ord, Show)
 
 instance HasName FieldDefinition where