graphql-api 0.2.0 → 0.3.0

raw patch · 22 files changed

+507/−365 lines, 22 filesdep ~protoludePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: protolude

API changes (from Hackage documentation)

Files

• CHANGELOG.rst +49/−0
• graphql-api.cabal +49/−45
• src/GraphQL/API.hs +96/−74
• src/GraphQL/API/Enum.hs +8/−6
• src/GraphQL/Internal/Execution.hs +2/−2
• src/GraphQL/Internal/Name.hs +68/−7
• src/GraphQL/Internal/Schema.hs +5/−5
• src/GraphQL/Internal/Syntax/AST.hs +13/−85
• src/GraphQL/Internal/Syntax/Encoder.hs +30/−25
• src/GraphQL/Internal/Syntax/Parser.hs +22/−21
• src/GraphQL/Internal/Validation.hs +25/−25
• src/GraphQL/Resolver.hs +7/−36
• src/GraphQL/Value/FromValue.hs +1/−1
• tests/ASTTests.hs +52/−3
• tests/Doctests.hs +0/−21
• tests/EnumTests.hs +1/−1
• tests/ExampleSchema.hs +1/−3
• tests/Examples/InputObject.hs +1/−1
• tests/ResolverTests.hs +14/−0
• tests/SchemaTests.hs +1/−1
• tests/ValidationTests.hs +41/−3
• tests/doctests/Main.hs +21/−0

@@ -0,0 +1,49 @@+=====================+graphql-api changelog+=====================++0.3.0 (2018-02-08)+==================++Breaking changes+----------------++* ``Enum`` handlers are now monadic (see `#118`_)+* You must use protolude 0.2.1 or later+* ``Defaultable`` must now be imported from ``GraphQL.API``, rather than ``GraphQL.Resolver``,+  this moves ``GraphQL.API`` closer to being sufficient for API definition. (see `#149`_)++Improvements+------------++* Now support GHC 8.2 as well as 8.0.2 and later+* Added support for anonymous queries (thanks `@sunwukonga`_)++.. _`#118`: https://github.com/jml/graphql-api/issues/118+.. _`#149`: https://github.com/haskell-graphql/graphql-api/issues/149+.. _`@sunwukonga`: https://github.com/sunwukonga++v0.2.0 (2017-10-12)+===================++* Make ``Name`` an overloaded string that panics if an invalid name is+  provided.+* Correctly descend into the type parameter of a ``Maybe``. See https://github.com/jml/graphql-api/issues/119.+  This is a backwards-incompatible change.++  A common update would be having to ``fmap pure callback`` instead of just ``callback``+  for ``Maybe`` handlers.+++v0.1.0 (2017-01-30)+===================++No code changes.++* Remove ``-Werror`` in order to upload to hackage+++v0.1.0 (2017-01-29)+===================++Initial release, support basic handling of GraphQL queries.

@@ -1,23 +1,35 @@--- This file has been generated from package.yaml by hpack version 0.17.0.+-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack+--+-- hash: 2160ff0226a0b10f7166ddbcf09ec6f79dfddfd66c81244898fb1afabe36bcf8  name:           graphql-api-version:        0.2.0-synopsis:       Sketch of GraphQL stuff-description:    Please see README.md+version:        0.3.0+synopsis:       GraphQL API+description:    Implement [GraphQL](http://graphql.org/) servers in Haskell.+                .+                Provides a Servant-like type-based API for defining GraphQL schemas and+                implementing handlers for those schemas.+                .+                See [README.md](https://github.com/haskell-graphql/graphql-api#graphql-api) for more details. category:       Web-homepage:       https://github.com/jml/graphql-api#readme-bug-reports:    https://github.com/jml/graphql-api/issues-maintainer:     Jonathan M. Lange <jml@mumak.net>+stability:      unstable+homepage:       https://github.com/haskell-graphql/graphql-api#readme+bug-reports:    https://github.com/haskell-graphql/graphql-api/issues+author:         Jonathan M. Lange, Tom Hunger+maintainer:     Jonathan M. Lange <jml@mumak.net>, Tom Hunger <tehunger@gmail.com> license:        Apache license-file:   LICENSE.Apache-2.0 build-type:     Simple cabal-version:  >= 1.10 +extra-source-files:+    CHANGELOG.rst+ source-repository head   type: git-  location: https://github.com/jml/graphql-api+  location: https://github.com/haskell-graphql/graphql-api  library   hs-source-dirs:@@ -25,17 +37,17 @@   default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications   ghc-options: -Wall -fno-warn-redundant-constraints   build-depends:-      base >= 4.9 && < 5-    , protolude >= 0.2-    , exceptions-    , transformers-    , attoparsec+      QuickCheck     , aeson+    , attoparsec+    , base >=4.9 && <5     , containers+    , exceptions     , ghc-prim+    , protolude >=0.2.1     , scientific-    , QuickCheck     , text+    , transformers   exposed-modules:       GraphQL       GraphQL.API@@ -55,35 +67,26 @@       GraphQL.Value       GraphQL.Value.FromValue       GraphQL.Value.ToValue+  other-modules:+      Paths_graphql_api   default-language: Haskell2010  test-suite graphql-api-doctests   type: exitcode-stdio-1.0-  main-is: Doctests.hs+  main-is: Main.hs   hs-source-dirs:-      tests+      tests/doctests   default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications   ghc-options: -Wall -fno-warn-redundant-constraints -threaded   build-depends:-      base >= 4.9 && < 5-    , protolude >= 0.2+      attoparsec+    , base >=4.9 && <5+    , doctest     , exceptions+    , protolude >=0.2.1     , transformers-    , attoparsec-    , doctest   other-modules:-      ASTTests-      EndToEndTests-      EnumTests-      Examples.InputObject-      Examples.UnionExample-      ExampleSchema-      OrderedMapTests-      ResolverTests-      SchemaTests-      Spec-      ValidationTests-      ValueTests+      Paths_graphql_api   default-language: Haskell2010  test-suite graphql-api-tests@@ -94,23 +97,22 @@   default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications   ghc-options: -Wall -fno-warn-redundant-constraints   build-depends:-      base >= 4.9 && < 5-    , protolude >= 0.2-    , exceptions-    , transformers-    , attoparsec+      QuickCheck     , aeson+    , attoparsec+    , base >=4.9 && <5     , containers+    , directory+    , exceptions     , graphql-api     , hspec-    , QuickCheck+    , protolude >=0.2.1     , raw-strings-qq     , tasty     , tasty-hspec-    , directory+    , transformers   other-modules:       ASTTests-      Doctests       EndToEndTests       EnumTests       Examples.InputObject@@ -121,6 +123,7 @@       SchemaTests       ValidationTests       ValueTests+      Paths_graphql_api   default-language: Haskell2010  benchmark criterion@@ -131,13 +134,14 @@   default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications   ghc-options: -Wall -fno-warn-redundant-constraints   build-depends:-      base >= 4.9 && < 5-    , protolude >= 0.2-    , exceptions-    , transformers-    , attoparsec+      attoparsec+    , base >=4.9 && <5     , criterion+    , exceptions     , graphql-api+    , protolude >=0.2.1+    , transformers   other-modules:       Validation+      Paths_graphql_api   default-language: Haskell2010

@@ -15,13 +15,13 @@   ( Object   , Field   , Argument-  , DefaultArgument   , Union   , List   , Enum   , GraphQLEnum(..)   , Interface   , (:>)(..)+  , Defaultable(..)   , HasAnnotatedType(..)   , HasAnnotatedInputType   , HasObjectDefinition(..)@@ -34,10 +34,9 @@  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 GraphQL.Internal.Name (NameError, nameFromSymbol)+import qualified GraphQL.Internal.Schema as Schema+import GraphQL.Internal.Name (Name, NameError, nameFromSymbol) import GraphQL.API.Enum (GraphQLEnum(..)) import GHC.Generics ((:*:)(..)) import GHC.Types (Type)@@ -83,27 +82,50 @@ data Argument (name :: Symbol) (argType :: Type)  --- Can't set the value for default arguments via types, but can--- distinguish to force users to provide a default argument somewhere--- in their function (using Maybe? ore some new type like--- https://hackage.haskell.org/package/optional-args-1.0.1)-data DefaultArgument (name :: Symbol) (argType :: Type)+-- | Specify a default value for a type in a GraphQL schema.+--+-- GraphQL schema can have default values in certain places. For example,+-- arguments to fields can have default values. Because we cannot lift+-- arbitrary values to the type level, we need some way of getting at those+-- values. This typeclass provides the means.+--+-- To specify a default, implement this typeclass.+--+-- The default implementation is to say that there *is* no default for this+-- type.+class Defaultable a where+  -- | defaultFor returns the value to be used when no value has been given.+  defaultFor :: Name -> Maybe a+  defaultFor _ = empty +instance Defaultable Int32++instance Defaultable Double++instance Defaultable Bool++instance Defaultable Text++instance Defaultable (Maybe a) where+  -- | The default for @Maybe a@ is @Nothing@.+  defaultFor _ = pure Nothing++ cons :: a -> [a] -> [a] 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@@ -115,18 +137,18 @@ -- object types from union type lists, e.g. for -- Union "Horse" '[Leg, Head, Tail] --               ^^^^^^^^^^^^^^^^^^ this part-class UnionTypeObjectTypeDefinitionList a where-  getUnionTypeObjectTypeDefinitions :: Either NameError [ObjectTypeDefinition]+class HasUnionTypeObjectTypeDefinitions a where+  getUnionTypeObjectTypeDefinitions :: Either NameError [Schema.ObjectTypeDefinition] -instance forall a as. (HasObjectDefinition a, UnionTypeObjectTypeDefinitionList as) => UnionTypeObjectTypeDefinitionList (a:as) where+instance forall a as. (HasObjectDefinition a, HasUnionTypeObjectTypeDefinitions as) => HasUnionTypeObjectTypeDefinitions (a:as) where   getUnionTypeObjectTypeDefinitions = cons <$> getDefinition @a <*> getUnionTypeObjectTypeDefinitions @as -instance UnionTypeObjectTypeDefinitionList '[] where+instance HasUnionTypeObjectTypeDefinitions '[] where   getUnionTypeObjectTypeDefinitions = pure []  -- 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 +157,35 @@   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 +195,7 @@   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 +204,8 @@   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 +214,21 @@   -- 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 +238,93 @@ -- 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+instance forall ks as. (KnownSymbol ks, HasUnionTypeObjectTypeDefinitions 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 +335,12 @@                                   )) 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 +351,7 @@   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 +362,5 @@   genericGetInputObjectFieldDefinitions = do     name <- nameFromSymbol @fieldName     annotatedInputType <- getAnnotatedInputType @wrappedType-    let l = InputObjectFieldDefinition name annotatedInputType Nothing+    let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing     pure [l]

@@ -86,18 +86,20 @@   ( 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.

@@ -32,7 +32,7 @@   , VariableDefinition(..)   , VariableValue   , Variable-  , Type(..)+  , GType(..)   )  -- | Get an operation from a GraphQL document@@ -51,7 +51,7 @@ --     * Return {operation}. getOperation :: QueryDocument value -> Maybe Name -> Either ExecutionError (Operation value) getOperation (LoneAnonymousOperation op) Nothing = pure op-getOperation (MultipleOperations ops) (Just name) = note (NoSuchOperation name) (Map.lookup name ops)+getOperation (MultipleOperations ops) (Just name) = note (NoSuchOperation name) (Map.lookup (pure name) ops) getOperation (MultipleOperations ops) Nothing =   case toList ops of     [op] -> pure op

@@ -5,10 +5,11 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module GraphQL.Internal.Name-  ( Name(unName)+  ( Name(unName, Name)   , NameError(..)   , makeName   , nameFromSymbol+  , nameParser   -- * Named things   , HasName(..)   -- * Unsafe functions@@ -17,14 +18,59 @@  import Protolude +import qualified Data.Aeson as Aeson import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)-import GraphQL.Internal.Syntax.AST-  ( Name(..)-  , NameError(..)-  , unsafeMakeName-  , makeName-  )+import Data.Char (isDigit)+import Data.Text as T (Text)+import qualified Data.Attoparsec.Text as A+import Test.QuickCheck (Arbitrary(..), elements, listOf)+import Data.String (IsString(..)) +import GraphQL.Internal.Syntax.Tokens (tok)++-- * Name++-- | A name in GraphQL.+--+-- https://facebook.github.io/graphql/#sec-Names+newtype Name = Name { unName :: T.Text } deriving (Eq, Ord, Show)+++-- | Create a 'Name', panicking if the given text is invalid.+--+-- Prefer 'makeName' to this in all cases.+--+-- >>> unsafeMakeName "foo"+-- Name {unName = "foo"}+unsafeMakeName :: HasCallStack => Text -> Name+unsafeMakeName name =+  case makeName name of+    Left e -> panic (show e)+    Right n -> n++-- | Create a 'Name'.+--+-- Names must match the regex @[_A-Za-z][_0-9A-Za-z]*@. If the given text does+-- not match, return NameError.+--+-- >>> makeName "foo"+-- Right (Name {unName = "foo"})+-- >>> makeName "9-bar"+-- Left (NameError "9-bar")+makeName :: Text -> Either NameError Name+makeName name = first (const (NameError name)) (A.parseOnly nameParser name)++-- | Parser for 'Name'.+nameParser :: A.Parser Name+nameParser = Name <$> tok ((<>) <$> A.takeWhile1 isA_z+                                <*> A.takeWhile ((||) <$> isDigit <*> isA_z))+  where+    -- `isAlpha` handles many more Unicode Chars+    isA_z = A.inClass $ '_' : ['A'..'Z'] <> ['a'..'z']++-- | An invalid name.+newtype NameError = NameError Text deriving (Eq, Show)+ -- | Convert a type-level 'Symbol' into a GraphQL 'Name'. nameFromSymbol :: forall (n :: Symbol). KnownSymbol n => Either NameError Name nameFromSymbol = makeName (toS (symbolVal @n Proxy))@@ -41,3 +87,18 @@ class HasName a where   -- | Get the name of the object.   getName :: a -> Name++instance IsString Name where+  fromString = unsafeMakeName . toS++instance Aeson.ToJSON Name where+  toJSON = Aeson.toJSON . unName++instance Arbitrary Name where+  arbitrary = do+    initial <- elements alpha+    rest <- listOf (elements (alpha <> numeric))+    pure (Name (toS (initial:rest)))+    where+      alpha = ['A'..'Z'] <> ['a'..'z'] <> ['_']+      numeric = ['0'..'9']

@@ -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@@ -100,13 +100,13 @@                    | 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 @@  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

@@ -4,17 +4,11 @@ {-# LANGUAGE ScopedTypeVariables #-}  module GraphQL.Internal.Syntax.AST-  ( Name(unName)-  , nameParser-  , NameError(..)-  , unsafeMakeName-  , makeName-  , QueryDocument(..)+  ( QueryDocument(..)   , SchemaDocument(..)   , Definition(..)   , OperationDefinition(..)   , Node(..)-  , getNodeName   , VariableDefinition(..)   , Variable(..)   , SelectionSet@@ -33,7 +27,7 @@   , ObjectField(..)   , DefaultValue   , Directive(..)-  , Type(..)+  , GType(..)   , NamedType(..)   , ListType(..)   , NonNullType(..)@@ -54,72 +48,10 @@  import Protolude -import qualified Data.Aeson as Aeson-import qualified Data.Attoparsec.Text as A-import Data.Char (isDigit)-import Data.String (IsString(..))-import Test.QuickCheck (Arbitrary(..), elements, listOf, oneof)+import Test.QuickCheck (Arbitrary(..), listOf, oneof)  import GraphQL.Internal.Arbitrary (arbitraryText)-import GraphQL.Internal.Syntax.Tokens (tok)---- * Name---- | A name in GraphQL.------ https://facebook.github.io/graphql/#sec-Names-newtype Name = Name { unName :: Text } deriving (Eq, Ord, Show)---- | Create a 'Name', panicking if the given text is invalid.------ Prefer 'makeName' to this in all cases.------ >>> unsafeMakeName "foo"--- Name {unName = "foo"}-unsafeMakeName :: HasCallStack => Text -> Name-unsafeMakeName name =-  case makeName name of-    Left e -> panic (show e)-    Right n -> n---- | Create a 'Name'.------ Names must match the regex @[_A-Za-z][_0-9A-Za-z]*@. If the given text does--- not match, return Nothing.------ >>> makeName "foo"--- Right (Name {unName = "foo"})--- >>> makeName "9-bar"--- Left (NameError "9-bar")-makeName :: Text -> Either NameError Name-makeName name = first (const (NameError name)) (A.parseOnly nameParser name)---- | An invalid name.-newtype NameError = NameError Text deriving (Eq, Show)---instance IsString Name where-  fromString = unsafeMakeName . toS--instance Aeson.ToJSON Name where-  toJSON = Aeson.toJSON . unName--instance Arbitrary Name where-  arbitrary = do-    initial <- elements alpha-    rest <- listOf (elements (alpha <> numeric))-    pure (Name (toS (initial:rest)))-    where-      alpha = ['A'..'Z'] <> ['a'..'z'] <> ['_']-      numeric = ['0'..'9']---- | Parser for 'Name'.-nameParser :: A.Parser Name-nameParser = Name <$> tok ((<>) <$> A.takeWhile1 isA_z-                                <*> A.takeWhile ((||) <$> isDigit <*> isA_z))-  where-    -- `isAlpha` handles many more Unicode Chars-    isA_z = A.inClass $ '_' : ['A'..'Z'] <> ['a'..'z']+import GraphQL.Internal.Name (Name)  -- * Documents @@ -143,14 +75,10 @@   | AnonymousQuery SelectionSet   deriving (Eq,Show) -data Node = Node Name [VariableDefinition] [Directive] SelectionSet+data Node = Node (Maybe Name) [VariableDefinition] [Directive] SelectionSet             deriving (Eq,Show) --- TODO: Just make Node implement HasName.-getNodeName :: Node -> Name-getNodeName (Node name _ _ _) = name--data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)+data VariableDefinition = VariableDefinition Variable GType (Maybe DefaultValue)                           deriving (Eq,Show)  newtype Variable = Variable Name deriving (Eq, Ord, Show)@@ -241,14 +169,14 @@  -- * Type Reference -data Type = TypeNamed NamedType-          | TypeList ListType-          | TypeNonNull NonNullType-            deriving (Eq, Ord, Show)+data GType = TypeNamed NamedType+           | TypeList ListType+           | TypeNonNull NonNullType+           deriving (Eq, Ord, Show)  newtype NamedType = NamedType Name deriving (Eq, Ord, Show) -newtype ListType = ListType Type deriving (Eq, Ord, Show)+newtype ListType = ListType GType deriving (Eq, Ord, Show)  data NonNullType = NonNullTypeNamed NamedType                  | NonNullTypeList  ListType@@ -270,12 +198,12 @@  type Interfaces = [NamedType] -data FieldDefinition = FieldDefinition Name ArgumentsDefinition Type+data FieldDefinition = FieldDefinition Name ArgumentsDefinition GType                        deriving (Eq,Show)  type ArgumentsDefinition = [InputValueDefinition] -data InputValueDefinition = InputValueDefinition Name Type (Maybe DefaultValue)+data InputValueDefinition = InputValueDefinition Name GType (Maybe DefaultValue)                             deriving (Eq,Show)  data InterfaceTypeDefinition = InterfaceTypeDefinition Name [FieldDefinition]

@@ -10,6 +10,7 @@ import Data.Text (Text, cons, intercalate, pack, snoc)  import qualified GraphQL.Internal.Syntax.AST as AST+import GraphQL.Internal.Name (unName)  -- * Document @@ -29,11 +30,15 @@ operationDefinition (AST.AnonymousQuery ss) = selectionSet ss  node :: AST.Node -> Text-node (AST.Node name vds ds ss) =-     AST.unName name+node (AST.Node (Just name) vds ds ss) =+     unName name   <> optempty variableDefinitions vds   <> optempty directives ds   <> selectionSet ss+node (AST.Node Nothing vds ds ss) =+     optempty variableDefinitions vds+  <> optempty directives ds+  <> selectionSet ss  variableDefinitions :: [AST.VariableDefinition] -> Text variableDefinitions = parensCommas variableDefinition@@ -46,7 +51,7 @@ defaultValue val = "=" <> value val  variable :: AST.Variable -> Text-variable (AST.Variable name) = "$" <> AST.unName name+variable (AST.Variable name) = "$" <> unName name  selectionSet :: AST.SelectionSet -> Text selectionSet = bracesCommas selection@@ -58,8 +63,8 @@  field :: AST.Field -> Text field (AST.Field alias name args ds ss) =-       optempty (`snoc` ':') (maybe mempty AST.unName alias)-    <> AST.unName name+       optempty (`snoc` ':') (maybe mempty unName alias)+    <> unName name     <> optempty arguments args     <> optempty directives ds     <> optempty selectionSet ss@@ -68,17 +73,17 @@ arguments = parensCommas argument  argument :: AST.Argument -> Text-argument (AST.Argument name v) = AST.unName name <> ":" <> value v+argument (AST.Argument name v) = unName name <> ":" <> value v  -- * Fragments  fragmentSpread :: AST.FragmentSpread -> Text fragmentSpread (AST.FragmentSpread name ds) =-  "..." <> AST.unName name <> optempty directives ds+  "..." <> unName name <> optempty directives ds  inlineFragment :: AST.InlineFragment -> Text inlineFragment (AST.InlineFragment (Just (AST.NamedType tc)) ds ss) =-  "... on " <> AST.unName tc+  "... on " <> unName tc             <> optempty directives ds             <> optempty selectionSet ss inlineFragment (AST.InlineFragment Nothing ds ss) =@@ -87,7 +92,7 @@  fragmentDefinition :: AST.FragmentDefinition -> Text fragmentDefinition (AST.FragmentDefinition name (AST.NamedType tc) ds ss) =-  "fragment " <> AST.unName name <> " on " <> AST.unName tc+  "fragment " <> unName name <> " on " <> unName tc               <> optempty directives ds               <> selectionSet ss @@ -101,7 +106,7 @@ value (AST.ValueFloat    x) = pack $ show x value (AST.ValueBoolean  x) = booleanValue x value (AST.ValueString   x) = stringValue x-value (AST.ValueEnum     x) = AST.unName x+value (AST.ValueEnum     x) = unName x value (AST.ValueList     x) = listValue x value (AST.ValueObject   x) = objectValue x value AST.ValueNull = "null"@@ -121,7 +126,7 @@ objectValue (AST.ObjectValue ofs) = bracesCommas objectField ofs  objectField :: AST.ObjectField -> Text-objectField (AST.ObjectField name v) = AST.unName name <> ":" <> value v+objectField (AST.ObjectField name v) = unName name <> ":" <> value v  -- * Directives @@ -129,23 +134,23 @@ directives = spaces directive  directive :: AST.Directive -> Text-directive (AST.Directive name args) = "@" <> AST.unName name <> optempty arguments args+directive (AST.Directive name args) = "@" <> unName name <> optempty arguments args  -- * Type Reference -type_ :: AST.Type -> Text-type_ (AST.TypeNamed (AST.NamedType x)) = AST.unName x+type_ :: AST.GType -> Text+type_ (AST.TypeNamed (AST.NamedType x)) = unName x type_ (AST.TypeList x) = listType x type_ (AST.TypeNonNull x) = nonNullType x  namedType :: AST.NamedType -> Text-namedType (AST.NamedType name) = AST.unName name+namedType (AST.NamedType name) = unName name  listType :: AST.ListType -> Text listType (AST.ListType ty) = brackets (type_ ty)  nonNullType :: AST.NonNullType -> Text-nonNullType (AST.NonNullTypeNamed (AST.NamedType x)) = AST.unName x <> "!"+nonNullType (AST.NonNullTypeNamed (AST.NamedType x)) = unName x <> "!" nonNullType (AST.NonNullTypeList  x) = listType x <> "!"  typeDefinition :: AST.TypeDefinition -> Text@@ -159,7 +164,7 @@  objectTypeDefinition :: AST.ObjectTypeDefinition -> Text objectTypeDefinition (AST.ObjectTypeDefinition name ifaces fds) =-  "type " <> AST.unName name+  "type " <> unName name           <> optempty (spaced . interfaces) ifaces           <> optempty fieldDefinitions fds @@ -171,7 +176,7 @@  fieldDefinition :: AST.FieldDefinition -> Text fieldDefinition (AST.FieldDefinition name args ty) =-  AST.unName name <> optempty argumentsDefinition args+  unName name <> optempty argumentsDefinition args                        <> ":"                        <> type_ ty @@ -180,36 +185,36 @@  interfaceTypeDefinition :: AST.InterfaceTypeDefinition -> Text interfaceTypeDefinition (AST.InterfaceTypeDefinition name fds) =-  "interface " <> AST.unName name <> fieldDefinitions fds+  "interface " <> unName name <> fieldDefinitions fds  unionTypeDefinition :: AST.UnionTypeDefinition -> Text unionTypeDefinition (AST.UnionTypeDefinition name ums) =-  "union " <> AST.unName name <> "=" <> unionMembers ums+  "union " <> unName name <> "=" <> unionMembers ums  unionMembers :: [AST.NamedType] -> Text unionMembers = intercalate "|" . fmap namedType  scalarTypeDefinition :: AST.ScalarTypeDefinition -> Text-scalarTypeDefinition (AST.ScalarTypeDefinition name) = "scalar " <> AST.unName name+scalarTypeDefinition (AST.ScalarTypeDefinition name) = "scalar " <> unName name  enumTypeDefinition :: AST.EnumTypeDefinition -> Text enumTypeDefinition (AST.EnumTypeDefinition name evds) =-  "enum " <> AST.unName name+  "enum " <> unName name           <> bracesCommas enumValueDefinition evds  enumValueDefinition :: AST.EnumValueDefinition -> Text-enumValueDefinition (AST.EnumValueDefinition name) = AST.unName name+enumValueDefinition (AST.EnumValueDefinition name) = unName name  inputObjectTypeDefinition :: AST.InputObjectTypeDefinition -> Text inputObjectTypeDefinition (AST.InputObjectTypeDefinition name ivds) =-  "input " <> AST.unName name <> inputValueDefinitions ivds+  "input " <> unName name <> inputValueDefinitions ivds  inputValueDefinitions :: [AST.InputValueDefinition] -> Text inputValueDefinitions = bracesCommas inputValueDefinition  inputValueDefinition :: AST.InputValueDefinition -> Text inputValueDefinition (AST.InputValueDefinition name ty dv) =-  AST.unName name <> ":" <> type_ ty <> maybe mempty defaultValue dv+  unName name <> ":" <> type_ ty <> maybe mempty defaultValue dv  typeExtensionDefinition :: AST.TypeExtensionDefinition -> Text typeExtensionDefinition (AST.TypeExtensionDefinition otd) =

@@ -28,6 +28,7 @@  import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Internal.Syntax.Tokens (tok, whiteSpace)+import GraphQL.Internal.Name (nameParser)  -- * Document @@ -51,7 +52,7 @@   <?> "operationDefinition error!"  node :: Parser AST.Node-node = AST.Node <$> AST.nameParser+node = AST.Node <$> optional nameParser                 <*> optempty variableDefinitions                 <*> optempty directives                 <*> selectionSet@@ -70,7 +71,7 @@ defaultValue = tok "=" *> value  variable :: Parser AST.Variable-variable = AST.Variable <$ tok "$" <*> AST.nameParser+variable = AST.Variable <$ tok "$" <*> nameParser  selectionSet :: Parser AST.SelectionSet selectionSet = braces $ many1 selection@@ -84,19 +85,19 @@  field :: Parser AST.Field field = AST.Field <$> option empty (pure <$> alias)-                  <*> AST.nameParser+                  <*> nameParser                   <*> optempty arguments                   <*> optempty directives                   <*> optempty selectionSet  alias :: Parser AST.Alias-alias = AST.nameParser <* tok ":"+alias = nameParser <* tok ":"  arguments :: Parser [AST.Argument] arguments = parens $ many1 argument  argument :: Parser AST.Argument-argument = AST.Argument <$> AST.nameParser <* tok ":" <*> value+argument = AST.Argument <$> nameParser <* tok ":" <*> value  -- * Fragments @@ -105,7 +106,7 @@ -- See https://facebook.github.io/graphql/#FragmentSpread fragmentSpread = AST.FragmentSpread   <$  tok "..."-  <*> AST.nameParser+  <*> nameParser   <*> optempty directives  -- InlineFragment tried first in order to guard against 'on' keyword@@ -119,7 +120,7 @@ fragmentDefinition :: Parser AST.FragmentDefinition fragmentDefinition = AST.FragmentDefinition   <$  tok "fragment"-  <*> AST.nameParser+  <*> nameParser   <*  tok "on"   <*> typeCondition   <*> optempty directives@@ -139,7 +140,7 @@   <|> AST.ValueBoolean  <$> (booleanValue <?> "booleanValue")   <|> AST.ValueString   <$> (stringValue <?> "stringValue")   -- `true` and `false` have been tried before-  <|> AST.ValueEnum     <$> (AST.nameParser <?> "name")+  <|> AST.ValueEnum     <$> (nameParser <?> "name")   <|> AST.ValueList     <$> (listValue <?> "listValue")   <|> AST.ValueObject   <$> (objectValue <?> "objectValue")   <?> "value error!")@@ -192,7 +193,7 @@ objectValue = AST.ObjectValue <$> braces (many (objectField <?> "objectField"))  objectField :: Parser AST.ObjectField-objectField = AST.ObjectField <$> AST.nameParser <* tok ":" <*> value+objectField = AST.ObjectField <$> nameParser <* tok ":" <*> value  -- * Directives @@ -202,19 +203,19 @@ directive :: Parser AST.Directive directive = AST.Directive   <$  tok "@"-  <*> AST.nameParser+  <*> nameParser   <*> optempty arguments  -- * Type Reference -type_ :: Parser AST.Type+type_ :: Parser AST.GType type_ = AST.TypeList    <$> listType     <|> AST.TypeNonNull <$> nonNullType     <|> AST.TypeNamed   <$> namedType     <?> "type_ error!"  namedType :: Parser AST.NamedType-namedType = AST.NamedType <$> AST.nameParser+namedType = AST.NamedType <$> nameParser  listType :: Parser AST.ListType listType = AST.ListType <$> brackets type_@@ -240,7 +241,7 @@ objectTypeDefinition :: Parser AST.ObjectTypeDefinition objectTypeDefinition = AST.ObjectTypeDefinition   <$  tok "type"-  <*> AST.nameParser+  <*> nameParser   <*> optempty interfaces   <*> fieldDefinitions @@ -252,7 +253,7 @@  fieldDefinition :: Parser AST.FieldDefinition fieldDefinition = AST.FieldDefinition-  <$> AST.nameParser+  <$> nameParser   <*> optempty argumentsDefinition   <*  tok ":"   <*> type_@@ -263,13 +264,13 @@ interfaceTypeDefinition :: Parser AST.InterfaceTypeDefinition interfaceTypeDefinition = AST.InterfaceTypeDefinition   <$  tok "interface"-  <*> AST.nameParser+  <*> nameParser   <*> fieldDefinitions  unionTypeDefinition :: Parser AST.UnionTypeDefinition unionTypeDefinition = AST.UnionTypeDefinition   <$  tok "union"-  <*> AST.nameParser+  <*> nameParser   <*  tok "="   <*> unionMembers @@ -279,24 +280,24 @@ scalarTypeDefinition :: Parser AST.ScalarTypeDefinition scalarTypeDefinition = AST.ScalarTypeDefinition   <$  tok "scalar"-  <*> AST.nameParser+  <*> nameParser  enumTypeDefinition :: Parser AST.EnumTypeDefinition enumTypeDefinition = AST.EnumTypeDefinition   <$  tok "enum"-  <*> AST.nameParser+  <*> nameParser   <*> enumValueDefinitions  enumValueDefinitions :: Parser [AST.EnumValueDefinition] enumValueDefinitions = braces $ many1 enumValueDefinition  enumValueDefinition :: Parser AST.EnumValueDefinition-enumValueDefinition = AST.EnumValueDefinition <$> AST.nameParser+enumValueDefinition = AST.EnumValueDefinition <$> nameParser  inputObjectTypeDefinition :: Parser AST.InputObjectTypeDefinition inputObjectTypeDefinition = AST.InputObjectTypeDefinition   <$  tok "input"-  <*> AST.nameParser+  <*> nameParser   <*> inputValueDefinitions  inputValueDefinitions :: Parser [AST.InputValueDefinition]@@ -304,7 +305,7 @@  inputValueDefinition :: Parser AST.InputValueDefinition inputValueDefinition = AST.InputValueDefinition-  <$> AST.nameParser+  <$> nameParser   <*  tok ":"   <*> type_   <*> optional defaultValue

@@ -44,7 +44,7 @@   , VariableDefinition(..)   , VariableValue   , Variable-  , AST.Type(..)+  , AST.GType(..)   -- * Resolving queries   , SelectionSetByType   , SelectionSet(..)@@ -58,7 +58,7 @@   , findDuplicates   ) where -import Protolude hiding ((<>))+import Protolude hiding ((<>), throwE)  import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty@@ -123,7 +123,7 @@ -- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'. type OperationType value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value -type Operations value = Map Name (Operation value)+type Operations value = Map (Maybe Name) (Operation value)  -- | Turn a parsed document into a known valid one. --@@ -132,9 +132,9 @@ validate :: Schema -> AST.QueryDocument -> Either (NonEmpty ValidationError) (QueryDocument VariableValue) validate schema (AST.QueryDocument defns) = runValidator $ do   let (operations, fragments) = splitBy splitDefns defns-  let (anonymous, named) = splitBy splitOps operations+  let (anonymous, maybeNamed) = splitBy splitOps operations   (frags, visitedFrags) <- resolveFragmentDefinitions =<< validateFragmentDefinitions schema fragments-  case (anonymous, named) of+  case (anonymous, maybeNamed) of     ([], ops) -> do       (validOps, usedFrags) <- runStateT (validateOperations schema frags ops) mempty       assertAllFragmentsUsed frags (visitedFrags <> usedFrags)@@ -146,7 +146,7 @@       validValuesSS <- validateValues ss       resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS       pure (LoneAnonymousOperation (Query emptyVariableDefinitions emptyDirectives resolvedValuesSS))-    _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst named))+    _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst maybeNamed))    where     splitBy :: (a -> Either b c) -> [a] -> ([b], [c])@@ -156,17 +156,17 @@     splitDefns (AST.DefinitionFragment frag) = Right frag      splitOps (AST.AnonymousQuery ss) = Left ss-    splitOps (AST.Query node@(AST.Node name _ _ _)) = Right (name, (Query, node))-    splitOps (AST.Mutation node@(AST.Node name _ _ _)) = Right (name, (Mutation, node))+    splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Query, node))+    splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Mutation, node)) -    assertAllFragmentsUsed :: Fragments value -> Set Name -> Validation ()+    assertAllFragmentsUsed :: Fragments value -> Set (Maybe Name) -> Validation ()     assertAllFragmentsUsed fragments used =-      let unused = Map.keysSet fragments `Set.difference` used+      let unused = ( Set.map pure (Map.keysSet fragments)) `Set.difference` used       in unless (Set.null unused) (throwE (UnusedFragments unused))  -- * Operations -validateOperations :: Schema -> Fragments AST.Value -> [(Name, (OperationType AST.Value, AST.Node))] -> StateT (Set Name) Validation (Operations AST.Value)+validateOperations :: Schema -> Fragments AST.Value -> [(Maybe Name, (OperationType AST.Value, AST.Node))] -> StateT (Set (Maybe Name)) Validation (Operations AST.Value) validateOperations schema fragments ops = do   deduped <- lift (mapErrors DuplicateOperation (makeMap ops))   traverse validateNode deduped@@ -219,7 +219,7 @@ -- We do this /before/ validating the values (since that's much easier once -- everything is in a nice structure and away from the AST), which means we -- can't yet evaluate directives.-validateSelectionSet :: Schema -> Fragments AST.Value -> [AST.Selection] -> StateT (Set Name) Validation (SelectionSetByType AST.Value)+validateSelectionSet :: Schema -> Fragments AST.Value -> [AST.Selection] -> StateT (Set (Maybe Name)) Validation (SelectionSetByType AST.Value) validateSelectionSet schema fragments selections = do   unresolved <- lift $ traverse (validateSelection schema) selections   resolved <- traverse (resolveSelection fragments) unresolved@@ -508,14 +508,14 @@ -- We're doing a standard depth-first traversal of fragment references, where -- references are by name, so the set of names can be thought of as a record -- of visited references.-resolveSelection :: Fragments a -> Selection' UnresolvedFragmentSpread a -> StateT (Set Name) Validation (Selection' FragmentSpread a)+resolveSelection :: Fragments a -> Selection' UnresolvedFragmentSpread a -> StateT (Set (Maybe Name)) Validation (Selection' FragmentSpread a) resolveSelection fragments = traverseFragmentSpreads resolveFragmentSpread   where     resolveFragmentSpread (UnresolvedFragmentSpread name directive) = do       case Map.lookup name fragments of         Nothing -> lift (throwE (NoSuchFragment name))         Just fragment -> do-          modify (Set.insert name)+          modify (Set.insert (pure name))           pure (FragmentSpread name directive fragment)  -- * Fragment definitions@@ -577,7 +577,7 @@ -- -- <https://facebook.github.io/graphql/#sec-Fragment-spread-target-defined> -- <https://facebook.github.io/graphql/#sec-Fragment-spreads-must-not-form-cycles>-resolveFragmentDefinitions :: Map Name (FragmentDefinition UnresolvedFragmentSpread value) -> Validation (Fragments value, Set Name)+resolveFragmentDefinitions :: Map Name (FragmentDefinition UnresolvedFragmentSpread value) -> Validation (Fragments value, Set (Maybe Name)) resolveFragmentDefinitions allFragments =   splitResult <$> traverse resolveFragment allFragments   where@@ -595,12 +595,12 @@       FragmentDefinition name cond directives <$> traverse (traverseFragmentSpreads resolveSpread) ss      resolveSpread (UnresolvedFragmentSpread name directives) = do-      visited <- Set.member name <$> get+      visited <- Set.member (pure name) <$> get       when visited (lift (throwE (CircularFragmentSpread name)))       case Map.lookup name allFragments of         Nothing -> lift (throwE (NoSuchFragment name))         Just definition -> do-          modify (Set.insert name)+          modify (Set.insert (pure name))           FragmentSpread name directives <$> resolveFragment' definition  -- * Arguments@@ -624,7 +624,7 @@ data VariableDefinition   = VariableDefinition     { variable :: Variable -- ^ The name of the variable-    , variableType :: AST.Type -- ^ The type of the variable+    , variableType :: AST.GType -- ^ The type of the variable     , defaultValue :: Maybe Value -- ^ An optional default value for the variable     } deriving (Eq, Ord, Show) @@ -727,12 +727,12 @@   -- with the given name.   --   -- <https://facebook.github.io/graphql/#sec-Operation-Name-Uniqueness>-  = DuplicateOperation Name+  = DuplicateOperation (Maybe Name)   -- | 'MixedAnonymousOperations' means there was more than one operation   -- defined in a document with an anonymous operation.   --   -- <https://facebook.github.io/graphql/#sec-Lone-Anonymous-Operation>-  | MixedAnonymousOperations Int [Name]+  | MixedAnonymousOperations Int [Maybe Name]   -- | 'DuplicateArgument' means that multiple copies of the same argument was   -- given to the same field, directive, etc.   | DuplicateArgument Name@@ -755,7 +755,7 @@   | CircularFragmentSpread Name   -- | 'UnusedFragments' means that fragments were defined that weren't used.   -- <https://facebook.github.io/graphql/#sec-Fragments-Must-Be-Used>-  | UnusedFragments (Set Name)+  | UnusedFragments (Set (Maybe Name))   -- | Variables were defined without being used.   -- <https://facebook.github.io/graphql/#sec-All-Variables-Used>   | UnusedVariables (Set Variable)@@ -777,10 +777,10 @@   deriving (Eq, Show)  instance GraphQLError ValidationError where-  formatError (DuplicateOperation name) = "More than one operation named '" <> show name <> "'"-  formatError (MixedAnonymousOperations n names)-    | n > 1 && null names = "Multiple anonymous operations defined. Found " <> show n-    | otherwise = "Document contains both anonymous operations (" <> show n <> ") and named operations (" <> show names <> ")"+  formatError (DuplicateOperation maybeName) = "More than one operation named '" <> show maybeName <> "'"+  formatError (MixedAnonymousOperations n maybeNames)+    | n > 1 && null maybeNames = "Multiple anonymous operations defined. Found " <> show n+    | otherwise = "Document contains both anonymous operations (" <> show n <> ") and named operations (" <> show maybeNames <> ")"   formatError (DuplicateArgument name) = "More than one argument named '" <> show name <> "'"   formatError (DuplicateFragmentDefinition name) = "More than one fragment named '" <> show name <> "'"   formatError (NoSuchFragment name) = "No fragment named '" <> show name <> "'"

@@ -17,7 +17,6 @@   ( ResolverError(..)   , HasResolver(..)   , (:<>)(..)-  , Defaultable(..)   , Result(..)   , unionValue   ) where@@ -30,7 +29,7 @@ -- - Directives (https://facebook.github.io/graphql/#sec-Type-System.Directives) -- - Enforce non-empty lists (might only be doable via value-level validation) -import Protolude hiding (Enum, TypeError)+import Protolude hiding (Enum, TypeError, throwE)  import qualified Data.Text as Text import qualified Data.List.NonEmpty as NonEmpty@@ -146,38 +145,10 @@   type Handler m a   resolve :: Handler m a -> Maybe (SelectionSetByType Value) -> m (Result Value) --- | Specify a default value for a type in a GraphQL schema.------ GraphQL schema can have default values in certain places. For example,--- arguments to fields can have default values. Because we cannot lift--- arbitrary values to the type level, we need some way of getting at those--- values. This typeclass provides the means.------ To specify a default, implement this typeclass.------ The default implementation is to say that there *is* no default for this--- type.-class Defaultable a where-  -- | defaultFor returns the value to be used when no value has been given.-  defaultFor :: Name -> Maybe a-  defaultFor _ = empty- -- | Called when the schema expects an input argument @name@ of type @a@ but -- @name@ has not been provided.-valueMissing :: Defaultable a => Name -> Either ResolverError a-valueMissing name = maybe (Left (ValueMissing name)) Right (defaultFor name)--instance Defaultable Int32--instance Defaultable Double--instance Defaultable Bool--instance Defaultable Text--instance Defaultable (Maybe a) where-  -- | The default for @Maybe a@ is @Nothing@.-  defaultFor _ = pure Nothing+valueMissing :: API.Defaultable a => Name -> Either ResolverError a+valueMissing name = maybe (Left (ValueMissing name)) Right (API.defaultFor name)  instance forall m. (Applicative m) => HasResolver m Int32 where   type Handler m Int32 = m Int32@@ -207,8 +178,8 @@     map aggregateResults a  instance forall m ksN enum. (Applicative m, API.GraphQLEnum enum) => HasResolver m (API.Enum ksN enum) where-  type Handler m (API.Enum ksN enum) = enum-  resolve handler Nothing = (pure . ok . GValue.ValueEnum . API.enumToValue) handler+  type Handler m (API.Enum ksN enum) = m enum+  resolve handler Nothing = map (ok . GValue.ValueEnum . API.enumToValue) handler   resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss)  instance forall m hg. (HasResolver m hg, Monad m) => HasResolver m (Maybe hg) where@@ -287,7 +258,7 @@   ( KnownSymbol ksH   , BuildFieldResolver m f   , FromValue t-  , Defaultable t+  , API.Defaultable t   , HasAnnotatedInputType t   , Monad m   ) => BuildFieldResolver m (PlainArgument (API.Argument ksH t) f) where@@ -303,7 +274,7 @@   ( KnownSymbol ksK   , BuildFieldResolver m f   , KnownSymbol name-  , Defaultable t+  , API.Defaultable t   , API.GraphQLEnum t   , Monad m   ) => BuildFieldResolver m (EnumArgument (API.Argument ksK (API.Enum name t)) f) where

@@ -132,4 +132,4 @@ instance forall l r m.   ( TypeError ('Text "Generic fromValue only works for records with exactly one data constructor.")   ) => GenericFromValue (D1 m (l :+: r)) where-  genericFromValue = undefined+  genericFromValue = panic "genericFromValue cannot be called for records with more than one data constructor. Code that tries will not be compiled."

@@ -78,7 +78,7 @@         output `shouldBe` "[1.5,1.5]"         parseOnly Parser.value output `shouldBe` Right input   describe "Parser" $ do-    it "parses anonymous query documents" $ do+    it "parses shorthand syntax documents" $ do       let query = [r|{                        dog {                          name@@ -96,6 +96,25 @@                      ]       parsed `shouldBe` expected +    it "parses anonymous query documents" $ do+      let query = [r|query {+                       dog {+                         name+                       }+                     }|]+      let Right parsed = parseOnly Parser.queryDocument query+      let expected = AST.QueryDocument+                     [ AST.DefinitionOperation+                       (AST.Query+                         (AST.Node Nothing [] []+                           [ AST.SelectionField+                             (AST.Field Nothing dog [] []+                               [ AST.SelectionField (AST.Field Nothing someName [] [] [])+                               ])+                           ]))+                     ]+      parsed `shouldBe` expected+     it "parses invalid documents" $ do       let query = [r|{                        dog {@@ -121,7 +140,7 @@                          ])                      , AST.DefinitionOperation                        (AST.Query-                        (AST.Node "getName" [] []+                        (AST.Node (pure "getName") [] []                          [ AST.SelectionField                            (AST.Field Nothing dog [] []                             [ AST.SelectionField@@ -145,7 +164,37 @@       let expected = AST.QueryDocument                      [ AST.DefinitionOperation                          (AST.Query-                           (AST.Node "houseTrainedQuery"+                           (AST.Node (pure "houseTrainedQuery")+                            [ AST.VariableDefinition+                                (AST.Variable "atOtherHomes")+                                (AST.TypeNamed (AST.NamedType "Boolean"))+                                (Just (AST.ValueBoolean True))+                            ] []+                            [ AST.SelectionField+                                (AST.Field Nothing dog [] []+                                 [ AST.SelectionField+                                     (AST.Field Nothing "isHousetrained"+                                      [ AST.Argument "atOtherHomes"+                                          (AST.ValueVariable (AST.Variable "atOtherHomes"))+                                      ] [] [])+                                 ])+                            ]))+                     ]+      parsed `shouldBe` expected++    it "parses anonymous query with variables" $ do+      let query = [r|+                    query ($atOtherHomes: Boolean = true) {+                      dog {+                        isHousetrained(atOtherHomes: $atOtherHomes)+                      }+                    }+                    |]+      let Right parsed = parseOnly Parser.queryDocument query+      let expected = AST.QueryDocument+                     [ AST.DefinitionOperation+                         (AST.Query+                           (AST.Node Nothing                             [ AST.VariableDefinition                                 (AST.Variable "atOtherHomes")                                 (AST.TypeNamed (AST.NamedType "Boolean"))

@@ -1,21 +0,0 @@-module Main (main) where--import Protolude--import Test.DocTest--main :: IO ()-main = doctest $ ["-isrc"] <> options <> files-  where-    options = map ("-X" <>) extensions-    -- These must match the extensions in package.yaml.-    extensions = [ "NoImplicitPrelude"-                 , "OverloadedStrings"-                 , "RecordWildCards"-                 , "TypeApplications"-                 , "DataKinds"-                 ]-    -- library code and examples-    files = [ "src/"-            , "tests/Examples/"-            ]

@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveGeneric #-}-module EnumTests () where+module EnumTests ( Mode(Directory, NormalFile, ExecutableFile, Symlink) ) where  import Protolude hiding (Enum) 

@@ -85,10 +85,8 @@   , Interface   , Union   , (:>)+  , Defaultable(..)   )--- XXX: This really shouldn't be part of Resolver, since whether or not a--- thing has a default is part of the API / Schema definition.-import GraphQL.Resolver (Defaultable(..)) import GraphQL.Value (pattern ValueEnum, unName) import GraphQL.Value.ToValue (ToValue(..)) 

@@ -7,7 +7,7 @@  import GraphQL import GraphQL.API-import GraphQL.Resolver (Handler, Defaultable(..))+import GraphQL.Resolver (Handler) import GraphQL.Value.FromValue (FromValue)  data DogStuff = DogStuff { toy :: Text, likesTreats :: Bool } deriving (Show, Generic)

@@ -17,6 +17,7 @@   ( Object   , Field   , Argument+  , Enum   , (:>)   ) import GraphQL.Resolver@@ -26,6 +27,8 @@   ) import GraphQL.Internal.Output (singleError) +import EnumTests ( Mode(NormalFile) )+ -- Test a custom error monad type TMonad = ExceptT Text IO type T = Object "T" '[] '[ Field "z" Int32@@ -63,7 +66,14 @@   -- have to wrap the result in a pure.   sequence $ fmap (pure . viewFoo) foo +-- Enum test+type EnumQuery = Object "File" '[]+  '[ Field "mode" (Enum "modeEnumName" Mode) ] +enumHandler :: Handler IO EnumQuery+enumHandler = pure $ pure NormalFile+-- /Enum test+ tests :: IO TestTree tests = testSpec "TypeAPI" $ do   describe "tTest" $ do@@ -80,3 +90,7 @@     it "Just works" $ do       Success object <- interpretAnonymousQuery @Query handler "{ test(id: \"10\") { name } }"       encode object `shouldBe` "{\"test\":{\"name\":\"Mort\"}}"+  describe "Parse, validate and execute queries against API" $ do+    it "API.Enum works" $ do+      Success object <- interpretAnonymousQuery @EnumQuery enumHandler "{ mode }"+      encode object `shouldBe` "{\"mode\":\"NormalFile\"}"

@@ -27,7 +27,7 @@   , AnnotatedType(..)   , ListType(..)   , UnionTypeDefinition(..)-  , Type(..)+  , GType(..)   , TypeDefinition(..)   , NonNullType(..)   , Builtin(..)

@@ -19,16 +19,19 @@   , getErrors   ) -me :: Name-me = "me"+me :: Maybe Name+me = pure "me"  someName :: Name someName = "name" +dog :: Name+dog = "dog"+ -- | Schema used for these tests. Since none of them do type-level stuff, we -- don't need to define it. schema :: Schema-schema = undefined+schema = panic "schema evaluated. We weren't expecting that."  tests :: IO TestTree tests = testSpec "Validation" $ do@@ -42,6 +45,41 @@                       ]                     )                   )+                ]+      getErrors schema doc `shouldBe` []++    it "Treats anonymous queries as valid" $ do+      let doc = AST.QueryDocument+                [ AST.DefinitionOperation+                  (AST.Query+                    (AST.Node (Nothing) [] []+                      [ AST.SelectionField+                        (AST.Field Nothing dog [] []+                          [ AST.SelectionField (AST.Field Nothing someName [] [] [])+                          ])+                      ]))+                ]+      getErrors schema doc `shouldBe` []++    it "Treats anonymous queries with variables as valid" $ do+      let doc = AST.QueryDocument+                [ AST.DefinitionOperation+                    (AST.Query+                      (AST.Node Nothing+                       [ AST.VariableDefinition+                           (AST.Variable "atOtherHomes")+                           (AST.TypeNamed (AST.NamedType "Boolean"))+                           (Just (AST.ValueBoolean True))+                       ] []+                       [ AST.SelectionField+                           (AST.Field Nothing dog [] []+                            [ AST.SelectionField+                                (AST.Field Nothing "isHousetrained"+                                 [ AST.Argument "atOtherHomes"+                                     (AST.ValueVariable (AST.Variable "atOtherHomes"))+                                 ] [] [])+                            ])+                       ]))                 ]       getErrors schema doc `shouldBe` [] 

@@ -0,0 +1,21 @@+module Main (main) where++import Protolude++import Test.DocTest++main :: IO ()+main = doctest $ ["-isrc"] <> options <> files+  where+    options = map ("-X" <>) extensions+    -- These must match the extensions in package.yaml.+    extensions = [ "NoImplicitPrelude"+                 , "OverloadedStrings"+                 , "RecordWildCards"+                 , "TypeApplications"+                 , "DataKinds"+                 ]+    -- library code and examples+    files = [ "src/"+            , "tests/Examples/"+            ]