graphql-api 0.3.0 → 0.4.0

raw patch · 49 files changed

+3616/−2695 lines, 49 filesdep −tastydep −tasty-hspecnew-component:exe:input-object-examplenew-component:exe:union-examplePVP ok

version bump matches the API change (PVP)

Dependencies removed: tasty, tasty-hspec

API changes (from Hackage documentation)

Files

• CHANGELOG.rst +9/−0
• examples/InputObject.hs +54/−0
• examples/UnionExample.hs +42/−0
• graphql-api.cabal +52/−20
• src/GraphQL.hs +30/−17
• src/GraphQL/API.hs +20/−352
• src/GraphQL/API/Enum.hs +0/−121
• src/GraphQL/Internal/API.hs +395/−0
• src/GraphQL/Internal/API/Enum.hs +125/−0
• src/GraphQL/Internal/Arbitrary.hs +2/−0
• src/GraphQL/Internal/Execution.hs +6/−2
• src/GraphQL/Internal/Name.hs +3/−1
• src/GraphQL/Internal/OrderedMap.hs +3/−1
• src/GraphQL/Internal/Output.hs +6/−4
• src/GraphQL/Internal/Resolver.hs +572/−0
• src/GraphQL/Internal/Schema.hs +73/−12
• src/GraphQL/Internal/Syntax/AST.hs +14/−2
• src/GraphQL/Internal/Syntax/Encoder.hs +3/−0
• src/GraphQL/Internal/Syntax/Parser.hs +4/−1
• src/GraphQL/Internal/Syntax/Tokens.hs +3/−1
• src/GraphQL/Internal/Validation.hs +80/−40
• src/GraphQL/Internal/Value.hs +367/−0
• src/GraphQL/Internal/Value/FromValue.hs +134/−0
• src/GraphQL/Internal/Value/ToValue.hs +59/−0
• src/GraphQL/Resolver.hs +11/−501
• src/GraphQL/Value.hs +43/−326
• src/GraphQL/Value/FromValue.hs +0/−135
• src/GraphQL/Value/ToValue.hs +0/−57
• tests/ASTSpec.hs +317/−0
• tests/ASTTests.hs +0/−213
• tests/EndToEndSpec.hs +484/−0
• tests/EndToEndTests.hs +0/−328
• tests/EnumTests.hs +1/−1
• tests/ExampleSchema.hs +14/−8
• tests/Examples/InputObject.hs +0/−46
• tests/Examples/UnionExample.hs +0/−52
• tests/Main.hs +10/−0
• tests/OrderedMapSpec.hs +42/−0
• tests/OrderedMapTests.hs +0/−43
• tests/ResolverSpec.hs +150/−0
• tests/ResolverTests.hs +0/−96
• tests/SchemaSpec.hs +132/−0
• tests/SchemaTests.hs +0/−75
• tests/Spec.hs +1/−35
• tests/ValidationSpec.hs +257/−0
• tests/ValidationTests.hs +0/−131
• tests/ValueSpec.hs +96/−0
• tests/ValueTests.hs +0/−70
• tests/doctests/Main.hs +2/−4

@@ -2,6 +2,13 @@ graphql-api changelog ===================== +0.4.0 (2019-10-15)+==================++* Schemas that have empty field lists or empty unions will fail much earlier+* [breaking change] allow user-supplied handlers to emit errors (#224)+* Better compile-time error reporting+ 0.3.0 (2018-02-08) ================== @@ -12,6 +19,8 @@ * 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`_)+* ``GraphQL.Value.ToValue`` and ``GraphQL.Value.FromValue`` modules have been removed.+  Import ``ToValue(..)`` and ``FromValue(..)`` from ``GraphQL.Value`` directly.  Improvements ------------

@@ -0,0 +1,54 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeOperators #-}++-- | Demonstrate input object usage.+module Main (main) where++import Protolude hiding (Enum)++import qualified Data.Aeson as Aeson++import GraphQL+import GraphQL.API+import GraphQL.Resolver (Handler, returns)+import GraphQL.Value (FromValue, toValue)++data DogStuff = DogStuff { _toy :: Text, _likesTreats :: Bool } deriving (Show, Generic)+instance FromValue DogStuff+instance HasAnnotatedInputType DogStuff+instance Defaultable DogStuff where+  -- TODO defaultFor takes a Name which makes sense, but what's the+  -- name for an input object?+  defaultFor _ = Just (DogStuff "shoe" False)++type Query = Object "Query" '[]+  '[ Argument "dogStuff" DogStuff :> Field "description" Text ]++root :: Handler IO Query+root = pure description++description :: DogStuff -> Handler IO Text+description (DogStuff toy likesTreats)+  | likesTreats = returns $ "likes treats and their favorite toy is a " <> toy+  | otherwise = returns $ "their favorite toy is a " <> toy++-- | Show input object usage+--+-- >>> response <- example "{ description(dogStuff: {toy: \"bone\", likesTreats: true}) }"+-- >>> putStrLn $ encode $ toValue response+-- {"data":{"description":"likes treats and their favorite toy is a bone"}}+--+-- >>> response <- example "{ description }"+-- >>> putStrLn $ encode $ toValue response+-- {"data":{"description":"their favorite toy is a shoe"}}+example :: Text -> IO Response+example = interpretAnonymousQuery @Query root+++main :: IO ()+main = do+  response <- example "{ description(dogStuff: {_toy: \"bone\", _likesTreats: true}) }"+  putStrLn $ Aeson.encode $ toValue response+  response' <- example "{ description }"+  putStrLn $ Aeson.encode $ toValue response'

@@ -0,0 +1,42 @@+{-# LANGUAGE DataKinds #-}+module Main (main) where++import Protolude++import qualified Data.Aeson as Aeson+import GraphQL.API (Field, List, Object, Union)+import GraphQL (interpretAnonymousQuery)+import GraphQL.Resolver (Handler, (:<>)(..), unionValue, returns)+import GraphQL.Value (ToValue(..))++-- Slightly reduced example from the spec+type MiniCat = Object "MiniCat" '[] '[Field "name" Text, Field "meowVolume" Int32]+type MiniDog = Object "MiniDog" '[] '[Field "barkVolume" Int32]++type CatOrDog = Object "Me" '[] '[Field "myPet" (Union "CatOrDog" '[MiniCat, MiniDog])]+type CatOrDogList = Object "CatOrDogList" '[] '[Field "pets" (List (Union "CatOrDog" '[MiniCat, MiniDog]))]++miniCat :: Text -> Handler IO MiniCat+miniCat name = pure (returns name :<> returns 32)++miniDog :: Handler IO MiniDog+miniDog = pure (returns 100)++catOrDog :: Handler IO CatOrDog+catOrDog = pure $ do+  name <- pure "MonadicFelix" -- we can do monadic actions+  unionValue @MiniCat (miniCat name)++catOrDogList :: Handler IO CatOrDogList+catOrDogList = pure $+  returns [ unionValue @MiniCat (miniCat "Felix")+          , unionValue @MiniCat (miniCat "Mini")+          , unionValue @MiniDog miniDog+          ]++main :: IO ()+main = do+  response <- interpretAnonymousQuery @CatOrDog catOrDog "{ myPet { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }"+  putStrLn $ Aeson.encode $ toValue response+  response' <- interpretAnonymousQuery @CatOrDogList catOrDogList "{ pets { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }"+  putStrLn $ Aeson.encode $ toValue response'

@@ -1,11 +1,13 @@--- This file has been generated from package.yaml by hpack version 0.20.0.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack ----- hash: 2160ff0226a0b10f7166ddbcf09ec6f79dfddfd66c81244898fb1afabe36bcf8+-- hash: 39720cafd3fe95e5c20d8064aaddbffaa16071fb08720ffc587d4d48228deec8  name:           graphql-api-version:        0.3.0+version:        0.4.0 synopsis:       GraphQL API description:    Implement [GraphQL](http://graphql.org/) servers in Haskell.                 .@@ -22,8 +24,6 @@ license:        Apache license-file:   LICENSE.Apache-2.0 build-type:     Simple-cabal-version:  >= 1.10- extra-source-files:     CHANGELOG.rst @@ -51,26 +51,61 @@   exposed-modules:       GraphQL       GraphQL.API-      GraphQL.API.Enum+      GraphQL.Internal.API+      GraphQL.Internal.API.Enum       GraphQL.Internal.Arbitrary       GraphQL.Internal.Execution       GraphQL.Internal.Name       GraphQL.Internal.OrderedMap       GraphQL.Internal.Output+      GraphQL.Internal.Resolver       GraphQL.Internal.Schema       GraphQL.Internal.Syntax.AST       GraphQL.Internal.Syntax.Encoder       GraphQL.Internal.Syntax.Parser       GraphQL.Internal.Syntax.Tokens       GraphQL.Internal.Validation+      GraphQL.Internal.Value+      GraphQL.Internal.Value.FromValue+      GraphQL.Internal.Value.ToValue       GraphQL.Resolver       GraphQL.Value-      GraphQL.Value.FromValue-      GraphQL.Value.ToValue   other-modules:       Paths_graphql_api   default-language: Haskell2010 +executable input-object-example+  main-is: InputObject.hs+  hs-source-dirs:+      examples+  default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications+  ghc-options: -Wall -fno-warn-redundant-constraints+  build-depends:+      aeson+    , attoparsec+    , base >=4.9 && <5+    , exceptions+    , graphql-api+    , protolude >=0.2.1+    , transformers+  default-language: Haskell2010++executable union-example+  main-is: UnionExample.hs+  hs-source-dirs:+      examples+  default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications+  ghc-options: -Wall -fno-warn-redundant-constraints+  build-depends:+      aeson+    , attoparsec+    , base >=4.9 && <5+    , exceptions+    , graphql-api+    , protolude >=0.2.1+    , transformers+  default-language: Haskell2010+ test-suite graphql-api-doctests   type: exitcode-stdio-1.0   main-is: Main.hs@@ -91,7 +126,7 @@  test-suite graphql-api-tests   type: exitcode-stdio-1.0-  main-is: Spec.hs+  main-is: Main.hs   hs-source-dirs:       tests   default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications@@ -108,21 +143,18 @@     , hspec     , protolude >=0.2.1     , raw-strings-qq-    , tasty-    , tasty-hspec     , transformers   other-modules:-      ASTTests-      EndToEndTests+      ASTSpec+      EndToEndSpec       EnumTests-      Examples.InputObject-      Examples.UnionExample       ExampleSchema-      OrderedMapTests-      ResolverTests-      SchemaTests-      ValidationTests-      ValueTests+      OrderedMapSpec+      ResolverSpec+      SchemaSpec+      Spec+      ValidationSpec+      ValueSpec       Paths_graphql_api   default-language: Haskell2010 

@@ -1,7 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} -- | Interface for GraphQL API. -- -- __Note__: This module is highly subject to change. We're still figuring@@ -27,7 +29,7 @@ import Data.Attoparsec.Text (parseOnly, endOfInput) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty-import GraphQL.API (HasObjectDefinition(..))+import GraphQL.API (HasObjectDefinition(..), Object, SchemaError(..)) import GraphQL.Internal.Execution   ( VariableValues   , ExecutionError@@ -51,8 +53,13 @@   ) import GraphQL.Internal.Schema (Schema) import qualified GraphQL.Internal.Schema as Schema-import GraphQL.Resolver (HasResolver(..), Result(..))-import GraphQL.Value (Name, NameError, Value, pattern ValueObject)+import GraphQL.Resolver+  ( HasResolver(..)+  , OperationResolverConstraint+  , Result(..)+  , resolveOperation+  )+import GraphQL.Value (Name, Value)  -- | Errors that can happen while processing a query document. data QueryError@@ -66,7 +73,7 @@   -- | Validated, but failed during execution.   | ExecutionError ExecutionError   -- | Error in the schema.-  | SchemaError NameError+  | SchemaError SchemaError   -- | Got a value that wasn't an object.   | NonObjectResult Value   deriving (Eq, Show)@@ -85,7 +92,10 @@  -- | Execute a GraphQL query. executeQuery-  :: forall api m. (HasResolver m api, Applicative m, HasObjectDefinition api)+  :: forall api m fields typeName interfaces.+  ( Object typeName interfaces fields ~ api+  , OperationResolverConstraint m fields typeName interfaces+  )   => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it.   -> QueryDocument VariableValue  -- ^ A validated query document. Build one with 'compileQuery'.   -> Maybe Name -- ^ An optional name. If 'Nothing', then executes the only operation in the query. If @Just "something"@, executes the query named @"something".@@ -94,17 +104,14 @@ executeQuery handler document name variables =   case getOperation document name variables of     Left e -> pure (ExecutionFailure (singleError e))-    Right operation -> toResult <$> resolve @m @api handler (Just operation)+    Right operation ->+      toResult+        <$> resolveOperation @m @fields @typeName @interfaces handler operation   where-    toResult (Result errors result) =-      case result of-        -- TODO: Prevent this at compile time. Particularly frustrating since-        -- we *know* that api has an object definition.-        ValueObject object ->-          case NonEmpty.nonEmpty errors of-            Nothing -> Success object-            Just errs -> PartialSuccess object (map toError errs)-        v -> ExecutionFailure (singleError (NonObjectResult v))+    toResult (Result errors object) =+      case NonEmpty.nonEmpty errors of+        Nothing -> Success object+        Just errs -> PartialSuccess object (map toError errs)  -- | Create a GraphQL schema. makeSchema :: forall api. HasObjectDefinition api => Either QueryError Schema@@ -114,7 +121,10 @@ -- -- Compiles then executes a GraphQL query. interpretQuery-  :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api)+  :: forall api m fields typeName interfaces.+  ( Object typeName interfaces fields ~ api+  , OperationResolverConstraint m fields typeName interfaces+  )   => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it.   -> Text -- ^ The text of a query document. Will be parsed and then executed.   -> Maybe Name -- ^ An optional name for the operation within document to run. If 'Nothing', execute the only operation in the document. If @Just "something"@, execute the query or mutation named @"something"@.@@ -129,7 +139,10 @@ -- -- Anonymous queries have no name and take no variables. interpretAnonymousQuery-  :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api)+  :: forall api m fields typeName interfaces.+  ( Object typeName interfaces fields ~ api+  , OperationResolverConstraint m fields typeName interfaces+  )   => Handler m api -- ^ Handler for the anonymous query.   -> Text -- ^ The text of the anonymous query. Should defined only a single, unnamed query operation.   -> m Response -- ^ The result of running the query.

@@ -1,16 +1,6 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}---- | Type-level definitions for a GraphQL schema.+-- | Description: Define a GraphQL schema with Haskell types+--+-- Use this to define your GraphQL schema with Haskell types. module GraphQL.API   ( Object   , Field@@ -22,345 +12,23 @@   , Interface   , (:>)(..)   , Defaultable(..)-  , HasAnnotatedType(..)-  , HasAnnotatedInputType   , HasObjectDefinition(..)-  , getArgumentDefinition-  -- | Exported for testing. Perhaps should be a different module.-  , getFieldDefinition-  , getInterfaceDefinition-  , getAnnotatedInputType+  , HasAnnotatedInputType(..)+  , SchemaError(..)   ) where -import Protolude hiding (Enum, TypeError)--import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..))-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)----- $setup--- >>> :set -XDataKinds -XTypeOperators---- | Argument operator. Can only be used with 'Field'.------ Say we have a @Company@ object that has a field that shows whether--- someone is an employee, e.g.------ @---   type Company {---     hasEmployee(employeeName: String!): String!---   }--- @------ Then we might represent that as:------ >>> type Company = Object "Company" '[] '[Argument "employeeName" Text :> Field "hasEmployee" Bool]------ For multiple arguments, simply chain them together with ':>', ending--- finally with 'Field'. e.g.------ @---   Argument "foo" String :> Argument "bar" Int :> Field "qux" Int--- @-data a :> b = a :> b-infixr 8 :>---data Object (name :: Symbol) (interfaces :: [Type]) (fields :: [Type])-data Enum (name :: Symbol) (values :: Type)-data Union (name :: Symbol) (types :: [Type])-data List (elemType :: Type)---- TODO(tom): AFACIT We can't constrain "fields" to e.g. have at least--- one field in it - is this a problem?-data Interface (name :: Symbol) (fields :: [Type])-data Field (name :: Symbol) (fieldType :: Type)-data Argument (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 Schema.ObjectTypeDefinition--class HasFieldDefinition a where-  getFieldDefinition :: Either NameError Schema.FieldDefinition----- Fields-class HasFieldDefinitions a where-  getFieldDefinitions :: Either NameError [Schema.FieldDefinition]--instance forall a as. (HasFieldDefinition a, HasFieldDefinitions as) => HasFieldDefinitions (a:as) where-  getFieldDefinitions = cons <$> getFieldDefinition @a <*> getFieldDefinitions @as--instance HasFieldDefinitions '[] where-  getFieldDefinitions = pure []----- object types from union type lists, e.g. for--- Union "Horse" '[Leg, Head, Tail]---               ^^^^^^^^^^^^^^^^^^ this part-class HasUnionTypeObjectTypeDefinitions a where-  getUnionTypeObjectTypeDefinitions :: Either NameError [Schema.ObjectTypeDefinition]--instance forall a as. (HasObjectDefinition a, HasUnionTypeObjectTypeDefinitions as) => HasUnionTypeObjectTypeDefinitions (a:as) where-  getUnionTypeObjectTypeDefinitions = cons <$> getDefinition @a <*> getUnionTypeObjectTypeDefinitions @as--instance HasUnionTypeObjectTypeDefinitions '[] where-  getUnionTypeObjectTypeDefinitions = pure []---- Interfaces-class HasInterfaceDefinitions a where-  getInterfaceDefinitions :: Either NameError Schema.Interfaces--instance forall a as. (HasInterfaceDefinition a, HasInterfaceDefinitions as) => HasInterfaceDefinitions (a:as) where-  getInterfaceDefinitions = cons <$> getInterfaceDefinition @a <*> getInterfaceDefinitions @as--instance HasInterfaceDefinitions '[] where-  getInterfaceDefinitions = pure []--class HasInterfaceDefinition a where-  getInterfaceDefinition :: Either NameError Schema.InterfaceTypeDefinition--instance forall ks fields. (KnownSymbol ks, HasFieldDefinitions fields) => HasInterfaceDefinition (Interface ks fields) where-  getInterfaceDefinition =-    let name = nameFromSymbol @ks-        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 = 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 (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 Schema.FieldDefinition <$> name <*> pure [] <*> getAnnotatedType @t--class HasArgumentDefinition a where-  getArgumentDefinition :: Either NameError Schema.ArgumentDefinition--instance forall ks t. (KnownSymbol ks, HasAnnotatedInputType t) => HasArgumentDefinition (Argument ks t) where-  getArgumentDefinition = Schema.ArgumentDefinition <$> argName <*> argType <*> defaultValue-    where-      argName = nameFromSymbol @ks-      argType = getAnnotatedInputType @t-      defaultValue = pure Nothing--instance forall a b. (HasArgumentDefinition a, HasFieldDefinition b) => HasFieldDefinition (a :> b) where-  getFieldDefinition =-    prependArg <$> argument <*> getFieldDefinition @b-    where-      prependArg arg (Schema.FieldDefinition name argDefs at) = Schema.FieldDefinition name (arg:argDefs) at-      argument = getArgumentDefinition @a--instance forall ks is fields.-  (KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions fields) =>-  HasObjectDefinition (Object ks is fields) where-  getDefinition =-    let name = nameFromSymbol @ks-        interfaces = getInterfaceDefinitions @is-        fields = Schema.NonEmptyList <$> getFieldDefinitions @fields-    in Schema.ObjectTypeDefinition <$> name <*> interfaces <*> fields---- Builtin output types (annotated types)-class HasAnnotatedType a where-  -- TODO - the fact that we have to return TypeNonNull for normal-  -- types will amost certainly lead to bugs because people will-  -- 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 (Schema.AnnotatedType Schema.GType)---- | Turn a non-null type into the optional version of its own type.-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 :: 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--- class.---- TODO(jml): Be smarter and figure out how to say "all integral types" rather--- than listing each individually.--instance HasAnnotatedType Int where-  getAnnotatedType = builtinType Schema.GInt--instance HasAnnotatedType Int32 where-  getAnnotatedType = builtinType Schema.GInt--instance HasAnnotatedType Bool where-  getAnnotatedType = builtinType Schema.GBool--instance HasAnnotatedType Text where-  getAnnotatedType = builtinType Schema.GString--instance HasAnnotatedType Double where-  getAnnotatedType = builtinType Schema.GFloat--instance HasAnnotatedType Float where-  getAnnotatedType = builtinType Schema.GFloat--instance forall t. (HasAnnotatedType t) => HasAnnotatedType (List t) where-  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 [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, HasUnionTypeObjectTypeDefinitions as) => HasAnnotatedType (Union ks as) where-  getAnnotatedType =-    let name = nameFromSymbol @ks-        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 = 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 (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 :: Schema.Builtin -> Either NameError (Schema.AnnotatedType Schema.InputType)-builtinInputType = pure . Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.BuiltinInputType--instance HasAnnotatedInputType Int where-  getAnnotatedInputType = builtinInputType Schema.GInt--instance HasAnnotatedInputType Int32 where-  getAnnotatedInputType = builtinInputType Schema.GInt--instance HasAnnotatedInputType Bool where-  getAnnotatedInputType = builtinInputType Schema.GBool--instance HasAnnotatedInputType Text where-  getAnnotatedInputType = builtinInputType Schema.GString--instance HasAnnotatedInputType Double where-  getAnnotatedInputType = builtinInputType Schema.GFloat--instance HasAnnotatedInputType Float where-  getAnnotatedInputType = builtinInputType Schema.GFloat--instance forall t. (HasAnnotatedInputType t) => HasAnnotatedInputType (List t) where-  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 [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 (Schema.AnnotatedType Schema.InputType)--class GenericInputObjectFieldDefinitions (f :: Type -> Type) where-  genericGetInputObjectFieldDefinitions :: Either NameError [Schema.InputObjectFieldDefinition]--instance forall dataName consName records s l p.-  ( KnownSymbol dataName-  , KnownSymbol consName-  , GenericInputObjectFieldDefinitions records-  ) => GenericAnnotatedInputType (D1 ('MetaData dataName s l 'False)-                                  (C1 ('MetaCons consName p 'True) records-                                  )) where-  genericGetAnnotatedInputType = do-    name <- nameFromSymbol @dataName-    map ( Schema.TypeNonNull-          . Schema.NonNullTypeNamed-          . Schema.DefinedInputType-          . Schema.InputTypeDefinitionObject-          . Schema.InputObjectTypeDefinition name-          . Schema.NonEmptyList-        ) (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-  genericGetInputObjectFieldDefinitions = do-    name <- nameFromSymbol @fieldName-    annotatedInputType <- getAnnotatedInputType @wrappedType-    let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing-    r <- genericGetInputObjectFieldDefinitions @rest-    pure (l:r)--instance forall wrappedType fieldName u s l.-  ( KnownSymbol fieldName-  , HasAnnotatedInputType wrappedType-  ) => GenericInputObjectFieldDefinitions (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where-  genericGetInputObjectFieldDefinitions = do-    name <- nameFromSymbol @fieldName-    annotatedInputType <- getAnnotatedInputType @wrappedType-    let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing-    pure [l]+import GraphQL.Internal.API+  ( Object+  , Field+  , Argument+  , Union+  , List+  , Enum+  , GraphQLEnum(..)+  , Interface+  , (:>)(..)+  , Defaultable(..)+  , HasObjectDefinition(..)+  , HasAnnotatedInputType(..)+  , SchemaError(..)+  )

@@ -1,121 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--module GraphQL.API.Enum-  ( GraphQLEnum(..)-  ) where--import Protolude hiding (Enum, TypeError)-import GraphQL.Internal.Name (Name, nameFromSymbol, NameError)-import GraphQL.Internal.Output (GraphQLError(..))-import GHC.Generics (D, (:+:)(..))-import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..))-import GHC.Types (Type)--invalidEnumName :: forall t. NameError -> Either Text t-invalidEnumName x = Left ("In Enum: " <> formatError x)---- TODO: Enums have a slightly more restricted set of names than 'Name'--- implies. Especially, they cannot be 'true', 'false', or 'nil'. The parser--- /probably/ guarantees this, so it should export this guarantee by providing--- an 'Enum' type.--class GenericEnumValues (f :: Type -> Type) where-  genericEnumValues :: [Either NameError Name]-  -- XXX: Why is this 'Text' and not 'NameError'?-  genericEnumFromValue :: Name -> Either Text (f p)-  genericEnumToValue :: f p -> Name--instance forall conName m p f nt.-  ( KnownSymbol conName-  , KnownSymbol m-  , KnownSymbol p-  , GenericEnumValues f-  ) => GenericEnumValues (M1 D ('MetaData conName m p nt) f) where-  genericEnumValues = genericEnumValues @f-  genericEnumFromValue name = M1 <$> genericEnumFromValue name-  genericEnumToValue (M1 gv) = genericEnumToValue gv--instance forall left right.-  ( GenericEnumValues left-  , GenericEnumValues right-  ) => GenericEnumValues (left :+: right) where-  genericEnumValues = genericEnumValues @left <> genericEnumValues @right-  genericEnumFromValue vname =-    let left = genericEnumFromValue @left vname-        right = genericEnumFromValue @right vname-    in case (left, right) of-      (x@(Right _), Left _) -> L1 <$> x-      (Left _, x@(Right _)) -> R1 <$> x-      (err@(Left _), Left _) -> L1 <$> err-      _ -> panic "Can't have two successful branches in Haskell"--  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-  genericEnumValues = let name = nameFromSymbol @conName in [name]-  genericEnumFromValue vname =-    case nameFromSymbol @conName of-      Right name -> if name == vname-                    then Right (M1 U1)-                    else Left ("Not a valid choice for enum: " <> show vname)-      -- XXX: This is impossible to catch during validation, because we cannot-      -- validate type-level symbols, we can only validate values. We could-      -- show that the schema is invalid at the type-level and still decide to-      -- call this anyway. The error should rather say that the schema is-      -- invalid.-      ---      -- Further, we don't actually have any schema-level validation, so-      -- "should have been caught during validation" is misleading.-      Left x -> invalidEnumName x-  genericEnumToValue (M1 _) =-    let Right name = nameFromSymbol @conName-    in name---- TODO(tom): better type errors using `n`. Also type errors for other--- invalid constructors.-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 = 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 = 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.------ TODO: Update this comment to explain what a GraphQLEnum is, why you might--- want an instance, and any laws that apply to method relations.-class GraphQLEnum a where-  -- TODO: Document each of these methods.-  enumValues :: [Either NameError Name]-  default enumValues :: (Generic a, GenericEnumValues (Rep a)) => [Either NameError Name]-  enumValues = genericEnumValues @(Rep a)--  enumFromValue :: Name -> Either Text a-  default enumFromValue :: (Generic a, GenericEnumValues (Rep a)) => Name -> Either Text a-  enumFromValue v = to <$> genericEnumFromValue v--  enumToValue :: a -> Name-  default enumToValue :: (Generic a, GenericEnumValues (Rep a)) => a -> Name-  enumToValue = genericEnumToValue . from

@@ -0,0 +1,395 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Define a GraphQL schema with Haskell types+module GraphQL.Internal.API+  ( Object+  , Field+  , Argument+  , Union+  , List+  , Enum+  , GraphQLEnum(..)+  , Interface+  , (:>)(..)+  , Defaultable(..)+  , HasAnnotatedType(..)+  , HasAnnotatedInputType+  , HasObjectDefinition(..)+  , getArgumentDefinition+  , SchemaError(..)+  , nameFromSymbol+  -- | Exported for testing.+  , getFieldDefinition+  , getInterfaceDefinition+  , getAnnotatedInputType+  ) where++import Protolude hiding (Enum, TypeError)++import qualified Data.List.NonEmpty as NonEmpty+import Data.Semigroup as S ((<>))+import GHC.Generics ((:*:)(..))+import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..))+import GHC.Types (Type)++import qualified GraphQL.Internal.Schema as Schema+import qualified GraphQL.Internal.Name as Name+import GraphQL.Internal.Name (Name, NameError)+import GraphQL.Internal.API.Enum (GraphQLEnum(..))+import GraphQL.Internal.Output (GraphQLError(..))++-- $setup+-- >>> :set -XDataKinds -XTypeOperators++-- | Argument operator. Can only be used with 'Field'.+--+-- Say we have a @Company@ object that has a field that shows whether+-- someone is an employee, e.g.+--+-- @+--   type Company {+--     hasEmployee(employeeName: String!): String!+--   }+-- @+--+-- Then we might represent that as:+--+-- >>> type Company = Object "Company" '[] '[Argument "employeeName" Text :> Field "hasEmployee" Bool]+--+-- For multiple arguments, simply chain them together with ':>', ending+-- finally with 'Field'. e.g.+--+-- @+--   Argument "foo" String :> Argument "bar" Int :> Field "qux" Int+-- @+data a :> b = a :> b+infixr 8 :>+++data Object (name :: Symbol) (interfaces :: [Type]) (fields :: [Type])+data Enum (name :: Symbol) (values :: Type)+data Union (name :: Symbol) (types :: [Type])+data List (elemType :: Type)++-- TODO(tom): AFACIT We can't constrain "fields" to e.g. have at least+-- one field in it - is this a problem?+data Interface (name :: Symbol) (fields :: [Type])+data Field (name :: Symbol) (fieldType :: Type)+data Argument (name :: Symbol) (argType :: Type)+++-- | The type-level schema was somehow invalid.+data SchemaError+  = NameError NameError+  | EmptyFieldList+  | EmptyUnion+  deriving (Eq, Show)++instance GraphQLError SchemaError where+  formatError (NameError err) = formatError err+  formatError EmptyFieldList = "Empty field list in type definition"+  formatError EmptyUnion = "Empty object list in union"++nameFromSymbol :: forall (n :: Symbol). KnownSymbol n => Either SchemaError Name+nameFromSymbol = first NameError (Name.nameFromSymbol @n)++-- | 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 = (:)++singleton :: a -> NonEmpty a+singleton x = x :| []++-- Transform into a Schema definition+class HasObjectDefinition a where+  -- Todo rename to getObjectTypeDefinition+  getDefinition :: Either SchemaError Schema.ObjectTypeDefinition++class HasFieldDefinition a where+  getFieldDefinition :: Either SchemaError Schema.FieldDefinition+++-- Fields+class HasFieldDefinitions a where+  getFieldDefinitions :: Either SchemaError (NonEmpty Schema.FieldDefinition)++instance forall a as. (HasFieldDefinition a, HasFieldDefinitions as) => HasFieldDefinitions (a:as) where+  getFieldDefinitions =+    case getFieldDefinitions @as of+      Left EmptyFieldList -> singleton <$> getFieldDefinition @a+      Left err -> Left err+      Right fields -> NonEmpty.cons <$> getFieldDefinition @a <*> pure fields++instance HasFieldDefinitions '[] where+  getFieldDefinitions = Left EmptyFieldList+++-- object types from union type lists, e.g. for+-- Union "Horse" '[Leg, Head, Tail]+--               ^^^^^^^^^^^^^^^^^^ this part+class HasUnionTypeObjectTypeDefinitions a where+  getUnionTypeObjectTypeDefinitions :: Either SchemaError (NonEmpty Schema.ObjectTypeDefinition)++instance forall a as. (HasObjectDefinition a, HasUnionTypeObjectTypeDefinitions as) => HasUnionTypeObjectTypeDefinitions (a:as) where+  getUnionTypeObjectTypeDefinitions =+    case getUnionTypeObjectTypeDefinitions @as of+      Left EmptyUnion -> singleton <$> getDefinition @a+      Left err -> Left err+      Right objects -> NonEmpty.cons <$> getDefinition @a <*> pure objects++instance HasUnionTypeObjectTypeDefinitions '[] where+  getUnionTypeObjectTypeDefinitions = Left EmptyUnion++-- Interfaces+class HasInterfaceDefinitions a where+  getInterfaceDefinitions :: Either SchemaError Schema.Interfaces++instance forall a as. (HasInterfaceDefinition a, HasInterfaceDefinitions as) => HasInterfaceDefinitions (a:as) where+  getInterfaceDefinitions = cons <$> getInterfaceDefinition @a <*> getInterfaceDefinitions @as++instance HasInterfaceDefinitions '[] where+  getInterfaceDefinitions = pure []++class HasInterfaceDefinition a where+  getInterfaceDefinition :: Either SchemaError Schema.InterfaceTypeDefinition++instance forall ks fields. (KnownSymbol ks, HasFieldDefinitions fields) => HasInterfaceDefinition (Interface ks fields) where+  getInterfaceDefinition =+    let name = nameFromSymbol @ks+        fields = 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 = 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 (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 Schema.FieldDefinition <$> name <*> pure [] <*> getAnnotatedType @t++class HasArgumentDefinition a where+  getArgumentDefinition :: Either SchemaError Schema.ArgumentDefinition++instance forall ks t. (KnownSymbol ks, HasAnnotatedInputType t) => HasArgumentDefinition (Argument ks t) where+  getArgumentDefinition = Schema.ArgumentDefinition <$> argName <*> argType <*> defaultValue+    where+      argName = nameFromSymbol @ks+      argType = getAnnotatedInputType @t+      defaultValue = pure Nothing++instance forall a b. (HasArgumentDefinition a, HasFieldDefinition b) => HasFieldDefinition (a :> b) where+  getFieldDefinition =+    prependArg <$> argument <*> getFieldDefinition @b+    where+      prependArg arg (Schema.FieldDefinition name argDefs at) = Schema.FieldDefinition name (arg:argDefs) at+      argument = getArgumentDefinition @a++instance forall ks is fields.+  (KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions fields) =>+  HasObjectDefinition (Object ks is fields) where+  getDefinition =+    let name = nameFromSymbol @ks+        interfaces = getInterfaceDefinitions @is+        fields = getFieldDefinitions @fields+    in Schema.ObjectTypeDefinition <$> name <*> interfaces <*> fields++-- Builtin output types (annotated types)+class HasAnnotatedType a where+  -- TODO - the fact that we have to return TypeNonNull for normal+  -- types will amost certainly lead to bugs because people will+  -- forget this. Maybe we can flip the internal encoding to be+  -- non-null by default and needing explicit null-encoding (via+  -- Maybe).+  getAnnotatedType :: Either SchemaError (Schema.AnnotatedType Schema.GType)++-- | Turn a non-null type into the optional version of its own type.+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 :: Schema.Builtin -> Either SchemaError (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+-- class.++-- TODO(jml): Be smarter and figure out how to say "all integral types" rather+-- than listing each individually.++instance HasAnnotatedType Int where+  getAnnotatedType = builtinType Schema.GInt++instance HasAnnotatedType Int32 where+  getAnnotatedType = builtinType Schema.GInt++instance HasAnnotatedType Bool where+  getAnnotatedType = builtinType Schema.GBool++instance HasAnnotatedType Text where+  getAnnotatedType = builtinType Schema.GString++instance HasAnnotatedType Double where+  getAnnotatedType = builtinType Schema.GFloat++instance HasAnnotatedType Float where+  getAnnotatedType = builtinType Schema.GFloat++instance forall t. (HasAnnotatedType t) => HasAnnotatedType (List t) where+  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 [Schema.Name]+    let et = Schema.EnumTypeDefinition <$> name <*> map (map Schema.EnumValueDefinition) (first NameError enums)+    Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.DefinedType . Schema.TypeDefinitionEnum <$> et++instance forall ks as. (KnownSymbol ks, HasUnionTypeObjectTypeDefinitions as) => HasAnnotatedType (Union ks as) where+  getAnnotatedType =+    let name = nameFromSymbol @ks+        types = 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 = 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 SchemaError (Schema.AnnotatedType Schema.InputType)+  default getAnnotatedInputType :: (Generic a, GenericAnnotatedInputType (Rep a)) => Either SchemaError (Schema.AnnotatedType Schema.InputType)+  getAnnotatedInputType = genericGetAnnotatedInputType @(Rep a)++instance forall a. HasAnnotatedInputType a => HasAnnotatedInputType (Maybe a) where+  getAnnotatedInputType = dropNonNull <$> getAnnotatedInputType @a++builtinInputType :: Schema.Builtin -> Either SchemaError (Schema.AnnotatedType Schema.InputType)+builtinInputType = pure . Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.BuiltinInputType++instance HasAnnotatedInputType Int where+  getAnnotatedInputType = builtinInputType Schema.GInt++instance HasAnnotatedInputType Int32 where+  getAnnotatedInputType = builtinInputType Schema.GInt++instance HasAnnotatedInputType Bool where+  getAnnotatedInputType = builtinInputType Schema.GBool++instance HasAnnotatedInputType Text where+  getAnnotatedInputType = builtinInputType Schema.GString++instance HasAnnotatedInputType Double where+  getAnnotatedInputType = builtinInputType Schema.GFloat++instance HasAnnotatedInputType Float where+  getAnnotatedInputType = builtinInputType Schema.GFloat++instance forall t. (HasAnnotatedInputType t) => HasAnnotatedInputType (List t) where+  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 [Schema.Name]+    let et = Schema.EnumTypeDefinition <$> name <*> map (map Schema.EnumValueDefinition) (first NameError enums)+    Schema.TypeNonNull . Schema.NonNullTypeNamed . Schema.DefinedInputType . Schema.InputTypeDefinitionEnum <$> et+++-- Generic getAnnotatedInputType function+class GenericAnnotatedInputType (f :: Type -> Type) where+  genericGetAnnotatedInputType :: Either SchemaError (Schema.AnnotatedType Schema.InputType)++class GenericInputObjectFieldDefinitions (f :: Type -> Type) where+  genericGetInputObjectFieldDefinitions :: Either SchemaError (NonEmpty Schema.InputObjectFieldDefinition)++instance forall dataName consName records s l p.+  ( KnownSymbol dataName+  , KnownSymbol consName+  , GenericInputObjectFieldDefinitions records+  ) => GenericAnnotatedInputType (D1 ('MetaData dataName s l 'False)+                                  (C1 ('MetaCons consName p 'True) records+                                  )) where+  genericGetAnnotatedInputType = do+    name <- nameFromSymbol @dataName+    map ( Schema.TypeNonNull+          . Schema.NonNullTypeNamed+          . Schema.DefinedInputType+          . Schema.InputTypeDefinitionObject+          . Schema.InputObjectTypeDefinition name+        ) (genericGetInputObjectFieldDefinitions @records)++instance forall a b.+  ( GenericInputObjectFieldDefinitions a+  , GenericInputObjectFieldDefinitions b+  ) => GenericInputObjectFieldDefinitions (a :*: b) where+  genericGetInputObjectFieldDefinitions = do+    l <- genericGetInputObjectFieldDefinitions @a+    r <- genericGetInputObjectFieldDefinitions @b+    pure (l S.<> r)++instance forall wrappedType fieldName u s l.+  ( KnownSymbol fieldName+  , HasAnnotatedInputType wrappedType+  ) => GenericInputObjectFieldDefinitions (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where+  genericGetInputObjectFieldDefinitions = do+    name <- nameFromSymbol @fieldName+    annotatedInputType <- getAnnotatedInputType @wrappedType+    let l = Schema.InputObjectFieldDefinition name annotatedInputType Nothing+    pure (l :| [])

@@ -0,0 +1,125 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Define GraphQL Enums with Haskell types+module GraphQL.Internal.API.Enum+  ( GraphQLEnum(..)+  ) where++import Protolude hiding (Enum, TypeError)++import GHC.Generics (D, (:+:)(..))+import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..))+import GHC.Types (Type)++import GraphQL.Internal.Name (Name, nameFromSymbol, NameError)+import GraphQL.Internal.Output (GraphQLError(..))++invalidEnumName :: forall t. NameError -> Either Text t+invalidEnumName x = Left ("In Enum: " <> formatError x)++-- TODO: Enums have a slightly more restricted set of names than 'Name'+-- implies. Especially, they cannot be 'true', 'false', or 'nil'. The parser+-- /probably/ guarantees this, so it should export this guarantee by providing+-- an 'Enum' type.++class GenericEnumValues (f :: Type -> Type) where+  genericEnumValues :: [Either NameError Name]+  -- XXX: Why is this 'Text' and not 'NameError'?+  genericEnumFromValue :: Name -> Either Text (f p)+  genericEnumToValue :: f p -> Name++instance forall conName m p f nt.+  ( KnownSymbol conName+  , KnownSymbol m+  , KnownSymbol p+  , GenericEnumValues f+  ) => GenericEnumValues (M1 D ('MetaData conName m p nt) f) where+  genericEnumValues = genericEnumValues @f+  genericEnumFromValue name = M1 <$> genericEnumFromValue name+  genericEnumToValue (M1 gv) = genericEnumToValue gv++instance forall left right.+  ( GenericEnumValues left+  , GenericEnumValues right+  ) => GenericEnumValues (left :+: right) where+  genericEnumValues = genericEnumValues @left <> genericEnumValues @right+  genericEnumFromValue vname =+    let left = genericEnumFromValue @left vname+        right = genericEnumFromValue @right vname+    in case (left, right) of+      (x@(Right _), Left _) -> L1 <$> x+      (Left _, x@(Right _)) -> R1 <$> x+      (err@(Left _), Left _) -> L1 <$> err+      _ -> panic "Can't have two successful branches in Haskell"++  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+  genericEnumValues = let name = nameFromSymbol @conName in [name]+  genericEnumFromValue vname =+    case nameFromSymbol @conName of+      Right name -> if name == vname+                    then Right (M1 U1)+                    else Left ("Not a valid choice for enum: " <> show vname)+      -- XXX: This is impossible to catch during validation, because we cannot+      -- validate type-level symbols, we can only validate values. We could+      -- show that the schema is invalid at the type-level and still decide to+      -- call this anyway. The error should rather say that the schema is+      -- invalid.+      --+      -- Further, we don't actually have any schema-level validation, so+      -- "should have been caught during validation" is misleading.+      Left x -> invalidEnumName x+  genericEnumToValue (M1 _) =+    let Right name = nameFromSymbol @conName+    in name++-- TODO(tom): better type errors using `n`. Also type errors for other+-- invalid constructors.+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 = 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 = 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.+--+-- TODO: Update this comment to explain what a GraphQLEnum is, why you might+-- want an instance, and any laws that apply to method relations.+class GraphQLEnum a where+  -- TODO: Document each of these methods.+  enumValues :: [Either NameError Name]+  default enumValues :: (Generic a, GenericEnumValues (Rep a)) => [Either NameError Name]+  enumValues = genericEnumValues @(Rep a)++  enumFromValue :: Name -> Either Text a+  default enumFromValue :: (Generic a, GenericEnumValues (Rep a)) => Name -> Either Text a+  enumFromValue v = to <$> genericEnumFromValue v++  enumToValue :: a -> Name+  default enumToValue :: (Generic a, GenericEnumValues (Rep a)) => a -> Name+  enumToValue = genericEnumToValue . from

@@ -1,5 +1,7 @@ {-# LANGUAGE RankNTypes #-}+{-# OPTIONS_HADDOCK not-home #-} +-- | Description: QuickCheck instances to help with testing module GraphQL.Internal.Arbitrary   ( arbitraryText   , arbitraryNonEmpty

@@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternSynonyms #-}--- | Implement the \"Execution\" part of the GraphQL spec.+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Implement the \"Execution\" part of the GraphQL spec. -- -- Actually, most of the execution work takes place in 'GraphQL.Resolver', but -- there's still a fair bit required to glue together the results of@@ -26,13 +28,15 @@   , Object'(..)   ) import GraphQL.Internal.Output (GraphQLError(..))+import GraphQL.Internal.Schema+  ( AnnotatedType (TypeNonNull)+  ) import GraphQL.Internal.Validation   ( Operation   , QueryDocument(..)   , VariableDefinition(..)   , VariableValue   , Variable-  , GType(..)   )  -- | Get an operation from a GraphQL document

@@ -1,9 +1,11 @@--- | Representation of GraphQL names. {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Representation of GraphQL names. module GraphQL.Internal.Name   ( Name(unName, Name)   , NameError(..)

@@ -1,5 +1,7 @@ {-# LANGUAGE RankNTypes #-}--- | Data structure for mapping keys to values while preserving order of appearance.+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Data structure for mapping keys to values while preserving order of appearance -- -- There are many cases in GraphQL where we want to have a map from names to -- values, where values can easily be lookup up by name and name is unique.

@@ -1,7 +1,7 @@ {-# LANGUAGE PatternSynonyms #-}--- | GraphQL output.------ How we encode GraphQL responses.+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: How we encode GraphQL responses module GraphQL.Internal.Output   ( Response(..)   , Errors@@ -11,8 +11,10 @@   ) where  import Protolude hiding (Location, Map)+ import Data.Aeson (ToJSON(..)) import Data.List.NonEmpty (NonEmpty(..))+ import GraphQL.Value   ( Object   , objectFromList@@ -20,9 +22,9 @@   , pattern ValueObject   , pattern ValueNull   , NameError(..)+  , ToValue(..)   ) import GraphQL.Internal.Name (Name)-import GraphQL.Value.ToValue (ToValue(..))  -- | GraphQL response. --

@@ -0,0 +1,572 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-} -- nicer type errors in some cases+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} -- for TypeError+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Implement handlers for GraphQL schemas+module GraphQL.Internal.Resolver+  ( ResolverError(..)+  , HasResolver(..)+  , OperationResolverConstraint+  , (:<>)(..)+  , Result(..)+  , unionValue+  , resolveOperation+  , returns+  , handlerError+  ) where++-- TODO (probably incomplete, the spec is large)+-- - input objects - I'm not super clear from the spec on how+--   they differ from normal objects.+-- - "extend type X" is used in examples in the spec but it's not+--   explained anywhere?+-- - 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, throwE)++import qualified Data.Text as Text+import qualified Data.List.NonEmpty as NonEmpty+import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..), Symbol, symbolVal)+import GHC.Types (Type)+import qualified GHC.Exts (Any)+import Unsafe.Coerce (unsafeCoerce)++import GraphQL.Internal.API+  ( HasAnnotatedType(..)+  , HasAnnotatedInputType(..)+  , (:>)+  )+import qualified GraphQL.Internal.API as API+import qualified GraphQL.Value as GValue+import GraphQL.Value+  ( Value+  , pattern ValueEnum+  , FromValue(..)+  , ToValue(..)+  )+import GraphQL.Internal.Name (Name, HasName(..))+import qualified GraphQL.Internal.OrderedMap as OrderedMap+import GraphQL.Internal.Output (GraphQLError(..))+import GraphQL.Internal.Validation+  ( SelectionSetByType+  , SelectionSet(..)+  , Field+  , ValidationErrors+  , getSubSelectionSet+  , getSelectionSetForType+  , lookupArgument+  )++data ResolverError+  -- | There was a problem in the schema. Server-side problem.+  = SchemaError API.SchemaError+  -- | Couldn't find the requested field in the object. A client-side problem.+  | FieldNotFoundError Name+  -- | No value provided for name, and no default specified. Client-side problem.+  | ValueMissing Name+  -- | Could not translate value into Haskell. Probably a client-side problem.+  | InvalidValue Name Text+  -- | Found validation errors when we tried to merge fields.+  | ValidationError ValidationErrors+  -- | Tried to get subselection of leaf field.+  | SubSelectionOnLeaf (SelectionSetByType Value)+  -- | Tried to treat an object as a leaf.+  | MissingSelectionSet+  -- | Error from handler+  | HandlerError Text+  deriving (Show, Eq)++instance GraphQLError ResolverError where+  formatError (SchemaError e) =+    "Schema error: " <> formatError e+  formatError (FieldNotFoundError field) =+    "Field not supported by the API: " <> show field+  formatError (ValueMissing name) =+    "No value provided for " <> show name <> ", and no default specified."+  formatError (InvalidValue name text) =+    "Could not coerce " <> show name <> " to valid value: " <> text+  formatError (ValidationError errs) =+    "Validation errors: " <> Text.intercalate ", " (map formatError (NonEmpty.toList errs))+  formatError (SubSelectionOnLeaf ss) =+    "Tried to get values within leaf field: " <> show ss+  formatError MissingSelectionSet =+    "Tried to treat object as if it were leaf field."+  formatError (HandlerError err) =+    "Handler error: " <> err++-- | Object field separation operator.+--+-- Use this to provide handlers for fields of an object.+--+-- Say you had the following GraphQL type with \"foo\" and \"bar\" fields,+-- e.g.+--+-- @+--   type MyObject {+--     foo: Int!+--     bar: String!+--   }+-- @+--+-- You could provide handlers for it like this:+--+-- >>> :m +System.Environment+-- >>> let fooHandler = pure 42+-- >>> let barHandler = System.Environment.getProgName+-- >>> let myObjectHandler = pure $ fooHandler :<> barHandler :<> ()+data a :<> b = a :<> b+infixr 8 :<>+++-- Result collects errors and values at the same time unless a handler+-- tells us to bail out in which case we stop the processing+-- immediately.+data Result a = Result [ResolverError] a deriving (Show, Functor, Eq)++-- Aggregating results keeps all errors and creates a ValueList+-- containing the individual values.+aggregateResults :: [Result Value] -> Result Value+aggregateResults r = toValue <$> sequenceA r++throwE :: Applicative f => ResolverError -> f (Result Value)+throwE err = pure (Result [err] GValue.ValueNull)++instance Applicative Result where+  pure v = Result [] v+  (Result e1 f) <*> (Result e2 x) = Result (e1 <> e2) (f x)++ok :: Value -> Result Value+ok = pure+++-- | The result of a handler is either text errors generated by the+-- handler or a value.+type HandlerResult a = Either Text a++-- | `returns` is a convenience function for a Handler that is+-- returning the expected value.+returns :: Applicative f => a -> f (HandlerResult a)+returns = pure . Right++-- | `handlerError` is a convenience function for a Handler that has+-- encountered an error and is unable to return the expected value.+handlerError :: Applicative f => Text -> f (HandlerResult a)+handlerError = pure . Left+++class HasResolver m a where+  type Handler m a+  resolve :: Handler m a -> Maybe (SelectionSetByType Value) -> m (Result Value)++type OperationResolverConstraint m fields typeName interfaces =+    ( RunFields m (RunFieldsType m fields)+    , API.HasObjectDefinition (API.Object typeName interfaces fields)+    , Monad m+    )++resolveOperation+  :: forall m fields typeName interfaces.+  ( OperationResolverConstraint m fields typeName interfaces )+  => Handler m (API.Object typeName interfaces fields)+  -> SelectionSetByType Value+  -> m (Result GValue.Object)+resolveOperation handler ss =+  resolveObject @m @fields @typeName @interfaces handler ss++-- | Called when the schema expects an input argument @name@ of type @a@ but+-- @name@ has not been provided.+valueMissing :: API.Defaultable a => Name -> Either ResolverError a+valueMissing name = maybe (Left (ValueMissing name)) Right (API.defaultFor name)++gotHandlerErr :: Text -> Result Value+gotHandlerErr err = Result [HandlerError err] GValue.ValueNull++handlerResult :: (Applicative f, ToValue a) => f (HandlerResult a) -> f (Result Value)+handlerResult = fmap (either gotHandlerErr (ok . toValue))++instance forall m. (Applicative m) => HasResolver m Int32 where+  type Handler m Int32 = m (HandlerResult Int32)+  resolve handler Nothing = handlerResult @m handler+  resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss)++instance forall m. (Applicative m) => HasResolver m Double where+  type Handler m Double = m (HandlerResult Double)+  resolve handler Nothing =  handlerResult handler+  resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss)++instance forall m. (Applicative m) => HasResolver m Text where+  type Handler m Text = m (HandlerResult Text)+  resolve handler Nothing =  handlerResult handler+  resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss)++instance forall m. (Applicative m) => HasResolver m Bool where+  type Handler m Bool = m (HandlerResult Bool)+  resolve handler Nothing =  handlerResult handler+  resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss)++instance forall m hg. (Monad m, Applicative m, HasResolver m hg) => HasResolver m (API.List hg) where+  type Handler m (API.List hg) = m (HandlerResult [Handler m hg])+  resolve handler selectionSet = do+    handler >>= \case+      Right h ->+        let a = traverse (flip (resolve @m @hg) selectionSet) h+        in map aggregateResults a+      Left err -> pure $ gotHandlerErr err++instance forall m ksN enum. (Applicative m, API.GraphQLEnum enum) => HasResolver m (API.Enum ksN enum) where+  type Handler m (API.Enum ksN enum) = m (HandlerResult enum)+  resolve handler Nothing = either gotHandlerErr (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+  type Handler m (Maybe hg) = m (HandlerResult (Maybe (Handler m hg)))+  resolve handler selectionSet = do+    result <- handler+    case result of+      Right res ->+        case res of+          Just x -> resolve @m @hg (x :: Handler m hg) selectionSet+          Nothing -> (pure . ok) GValue.ValueNull+      Left err -> pure $ gotHandlerErr err++-- TODO: A parametrized `Result` is really not a good way to handle the+-- "result" for resolveField, but not sure what to use either. Tom liked the+-- tuple we had before more because it didn't imply any other structure or+-- meaning. Maybe we can just create a new datatype. jml thinks we should+-- extract some helpful generic monad, ala `Validator`.+-- <https://github.com/jml/graphql-api/issues/98>+type ResolveFieldResult = Result (Maybe GValue.Value)++-- Extract field name from an argument type. TODO: ideally we'd run+-- this directly on the "a :> b" argument structure, but that requires+-- passing in the plain argument structure type into resolveField or+-- resolving "name" in the buildFieldResolver. Both options duplicate+-- code somwehere else.+type family FieldName (a :: Type) = (r :: Symbol) where+  FieldName (JustHandler (API.Field name t)) = name+  FieldName (PlainArgument a f) = FieldName f+  FieldName (EnumArgument a f) = FieldName f+  FieldName x = TypeError ('Text "Unexpected branch in FieldName type family. Please file a bug!" ':<>: 'ShowType x)++resolveField :: forall dispatchType (m :: Type -> Type).+  (BuildFieldResolver m dispatchType, Monad m, KnownSymbol (FieldName dispatchType))+  => FieldHandler m dispatchType -> m ResolveFieldResult -> Field Value -> m ResolveFieldResult+resolveField handler nextHandler field =+  -- check name before+  case API.nameFromSymbol @(FieldName dispatchType) of+    Left err -> pure (Result [SchemaError err] (Just GValue.ValueNull))+    Right name'+      | getName field == name' ->+          case buildFieldResolver @m @dispatchType handler field of+            Left err -> pure (Result [err] (Just GValue.ValueNull))+            Right resolver -> do+              Result errs value <- resolver+              pure (Result errs (Just value))+      | otherwise -> nextHandler++-- We're using our usual trick of rewriting a type in a closed type+-- family to emulate a closed typeclass. The following are the+-- universe of "allowed" class instances for field types:+data JustHandler a+data EnumArgument a b+data PlainArgument a b++-- injective helps with errors sometimes+type family FieldResolverDispatchType (a :: Type) = (r :: Type) | r -> a where+  FieldResolverDispatchType (API.Field ksA t) = JustHandler (API.Field ksA t)+  FieldResolverDispatchType (API.Argument ksB (API.Enum name t) :> f) = EnumArgument (API.Argument ksB (API.Enum name t)) (FieldResolverDispatchType f)+  FieldResolverDispatchType (API.Argument ksC t :> f) = PlainArgument (API.Argument ksC t) (FieldResolverDispatchType f)++-- | Derive the handler type from the Field/Argument type in a closed+-- type family: We don't want anyone else to extend this ever.+type family FieldHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where+  FieldHandler m (JustHandler (API.Field ksD t)) = Handler m t+  FieldHandler m (PlainArgument (API.Argument ksE t) f) = t -> FieldHandler m f+  FieldHandler m (EnumArgument (API.Argument ksF (API.Enum name t)) f) = t -> FieldHandler m f++class BuildFieldResolver m fieldResolverType where+  buildFieldResolver :: FieldHandler m fieldResolverType -> Field Value -> Either ResolverError (m (Result Value))++instance forall ksG t m.+  ( KnownSymbol ksG, HasResolver m t, HasAnnotatedType t, Monad m+  ) => BuildFieldResolver m (JustHandler (API.Field ksG t)) where+  buildFieldResolver handler field = do+    pure (resolve @m @t handler (getSubSelectionSet field))++instance forall ksH t f m.+  ( KnownSymbol ksH+  , BuildFieldResolver m f+  , FromValue t+  , API.Defaultable t+  , HasAnnotatedInputType t+  , Monad m+  ) => BuildFieldResolver m (PlainArgument (API.Argument ksH t) f) where+  buildFieldResolver handler field = do+    argument <- first SchemaError (API.getArgumentDefinition @(API.Argument ksH t))+    let argName = getName argument+    value <- case lookupArgument field argName of+      Nothing -> valueMissing @t argName+      Just v -> first (InvalidValue argName) (fromValue @t v)+    buildFieldResolver @m @f (handler value) field++instance forall ksK t f m name.+  ( KnownSymbol ksK+  , BuildFieldResolver m f+  , KnownSymbol name+  , API.Defaultable t+  , API.GraphQLEnum t+  , Monad m+  ) => BuildFieldResolver m (EnumArgument (API.Argument ksK (API.Enum name t)) f) where+  buildFieldResolver handler field = do+    argName <- first SchemaError (API.nameFromSymbol @ksK)+    value <- case lookupArgument field argName of+      Nothing -> valueMissing @t argName+      Just (ValueEnum enum) -> first (InvalidValue argName) (API.enumFromValue @t enum)+      Just value -> Left (InvalidValue argName (show value <> " not an enum: " <> show (API.enumValues @t)))+    buildFieldResolver @m @f (handler value) field++-- Note that we enumerate all ks variables with capital letters so we+-- can figure out error messages like the following that don't come+-- with line numbers:+--+--        • No instance for (GHC.TypeLits.KnownSymbol ks0)+--            arising from a use of ‘interpretAnonymousQuery’++-- We only allow Field and Argument :> Field combinations:+type family RunFieldsType (m :: Type -> Type) (a :: [Type]) = (r :: Type) where+  RunFieldsType m '[API.Field ksI t] = API.Field ksI t+  RunFieldsType m '[a :> b] = a :> b+  RunFieldsType m ((API.Field ksJ t) ': rest) = API.Field ksJ t :<> RunFieldsType m rest+  RunFieldsType m ((a :> b) ': rest) = (a :> b) :<> RunFieldsType m rest+  RunFieldsType m a = TypeError (+    'Text "All field entries in an Object must be Field or Argument :> Field. Got: " ':<>: 'ShowType a)++-- Match the three possible cases for Fields (see also RunFieldsType)+type family RunFieldsHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where+  RunFieldsHandler m (f :<> fs) = FieldHandler m (FieldResolverDispatchType f) :<> RunFieldsHandler m fs+  RunFieldsHandler m (API.Field ksL t) = FieldHandler m (FieldResolverDispatchType (API.Field ksL t))+  RunFieldsHandler m (a :> b) = FieldHandler m (FieldResolverDispatchType (a :> b))+  RunFieldsHandler m a = TypeError (+    'Text "Unexpected RunFieldsHandler types: " ':<>: 'ShowType a)+++class RunFields m a where+  -- | Run a single 'Selection' over all possible fields (as specified by the+  -- type @a@), returning exactly one 'GValue.ObjectField' when a field+  -- matches, or an error otherwise.+  --+  -- Individual implementations are responsible for calling 'runFields' if+  -- they haven't matched the field and there are still candidate fields+  -- within the handler.+  runFields :: RunFieldsHandler m a -> Field Value -> m ResolveFieldResult++instance forall f fs m dispatchType.+         ( BuildFieldResolver m dispatchType+         , dispatchType ~ FieldResolverDispatchType f+         , RunFields m fs+         , KnownSymbol (FieldName dispatchType)+         , Monad m+         ) => RunFields m (f :<> fs) where+  runFields (handler :<> nextHandlers) field =+    resolveField @dispatchType @m handler nextHandler field+    where+      nextHandler = runFields @m @fs nextHandlers field++instance forall ksM t m dispatchType.+         ( BuildFieldResolver m dispatchType+         , KnownSymbol ksM+         , dispatchType ~ FieldResolverDispatchType (API.Field ksM t)+         , Monad m+         ) => RunFields m (API.Field ksM t) where+  runFields handler field =+    resolveField @dispatchType @m handler nextHandler field+    where+      nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing)++instance forall m a b dispatchType.+         ( BuildFieldResolver m dispatchType+         , dispatchType ~ FieldResolverDispatchType (a :> b)+         , KnownSymbol (FieldName dispatchType)+         , Monad m+         ) => RunFields m (a :> b) where+  runFields handler field =+    resolveField @dispatchType @m handler nextHandler field+    where+      nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing)++resolveObject+  :: forall m fields typeName interfaces.+  ( OperationResolverConstraint m fields typeName interfaces )+  => Handler m (API.Object typeName interfaces fields)+  -> SelectionSetByType Value+  -> m (Result GValue.Object)+resolveObject mHandler selectionSet =+  case getSelectionSet of+    Left err -> return (Result [err] (GValue.Object' OrderedMap.empty))+    Right ss -> do+      -- Run the handler so the field resolvers have access to the object.+      -- This (and other places, including field resolvers) is where user+      -- code can do things like look up something in a database.+      handler <- mHandler+      r <- traverse (runFields @m @(RunFieldsType m fields) handler) ss+      let (Result errs obj)  = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r+      pure (Result errs obj)++  where+    getSelectionSet = do+      defn <- first SchemaError $ API.getDefinition @(API.Object typeName interfaces fields)+      -- Fields of a selection set may be behind "type conditions", due to+      -- inline fragments or the use of fragment spreads. These type+      -- conditions are represented in the schema by the name of a type+      -- (e.g. "Dog"). To determine which type conditions (and thus which+      -- fields) are relevant for this 1selection set, we need to look up the+      -- actual types they refer to, as interfaces (say) match objects+      -- differently than unions.+      --+      -- See <https://facebook.github.io/graphql/#sec-Field-Collection> for+      -- more details.+      (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet+      pure ss'++instance forall typeName interfaces fields m.+         ( RunFields m (RunFieldsType m fields)+         , API.HasObjectDefinition (API.Object typeName interfaces fields)+         , Monad m+         ) => HasResolver m (API.Object typeName interfaces fields) where+  type Handler m (API.Object typeName interfaces fields) = m (RunFieldsHandler m (RunFieldsType m fields))++  resolve _ Nothing = throwE MissingSelectionSet+  resolve handler (Just ss) = do+    result <- resolveObject @m @fields @typeName @interfaces handler ss+    return $ GValue.ValueObject <$> result++-- TODO(tom): we're getting to a point where it might make sense to+-- split resolver into submodules (GraphQL.Resolver.Union  etc.)+++-- | For unions we need a way to have type-safe, open sum types based+-- on the possible 'API.Object's of a union. The following closed type+-- family selects one Object from the union and returns the matching+-- 'HasResolver' 'Handler' type. If the object @o@ is not a member of+-- 'API.Union' then the user code won't compile.+--+-- This type family is an implementation detail but its TypeError+-- messages are visible at compile time.+type family TypeIndex (m :: Type -> Type) (object :: Type) (union :: Type) = (result :: Type) where+  TypeIndex m (API.Object name interfaces fields) (API.Union uName (API.Object name interfaces fields:_)) =+    Handler m (API.Object name interfaces fields)+  TypeIndex m (API.Object name interfaces fields) (API.Union uName (API.Object name' i' f':objects)) =+    TypeIndex m (API.Object name interfaces fields) (API.Union uName objects)+  -- Slightly nicer type errors:+  TypeIndex _ (API.Object name interfaces fields) (API.Union uName '[]) =+    TypeError ('Text "Type not found in union definition: " ':<>: 'ShowType (API.Object name interfaces fields))+  TypeIndex _ (API.Object name interfaces fields) x =+    TypeError ('Text "3rd type must be a union but it is: " ':<>: 'ShowType x)+  TypeIndex _ o _ =+    TypeError ('Text "Invalid TypeIndex. Must be Object but got: " ':<>: 'ShowType o)+++-- | The 'Handler' type of a 'API.Union' must be the same for all+-- possible Objects, but each Object has a different type. We+-- unsafeCoerce the return type into an Any, tagging it with the union+-- and the underlying monad for type safety, but we elide the Object+-- type itself. This way we can represent all 'Handler' types of the+-- Union with a single type and still stay type-safe.+type role DynamicUnionValue representational representational+data DynamicUnionValue (union :: Type) (m :: Type -> Type) = DynamicUnionValue { _label :: Text, _value :: GHC.Exts.Any }++class RunUnion m union objects where+  runUnion :: DynamicUnionValue union m -> SelectionSetByType Value -> m (Result Value)++instance forall m union objects name interfaces fields.+  ( Monad m+  , KnownSymbol name+  , TypeIndex m (API.Object name interfaces fields) union ~ Handler m (API.Object name interfaces fields)+  , RunFields m (RunFieldsType m fields)+  , API.HasObjectDefinition (API.Object name interfaces fields)+  , RunUnion m union objects+  ) => RunUnion m union (API.Object name interfaces fields:objects) where+  runUnion duv selectionSet =+    case extractUnionValue @(API.Object name interfaces fields) @union @m duv of+      Just handler -> resolve @m @(API.Object name interfaces fields) handler (Just selectionSet)+      Nothing -> runUnion @m @union @objects duv selectionSet++-- AFAICT it should not be possible to ever hit the empty case because+-- the compiler doesn't allow constructing a unionValue that's not in+-- the Union. If the following code ever gets executed it's almost+-- certainly a bug in the union code.+--+-- We still need to implement this instance for the compiler because+-- it exhaustively checks all cases when deconstructs the Union.+instance forall m union. RunUnion m union '[] where+  runUnion (DynamicUnionValue label _) selection =+    panic ("Unexpected branch in runUnion, got " <> show selection <> " for label " <> label <> ". Please file a bug.")++instance forall m unionName objects.+  ( Monad m+  , KnownSymbol unionName+  , RunUnion m (API.Union unionName objects) objects+  ) => HasResolver m (API.Union unionName objects) where+  type Handler m (API.Union unionName objects) = m (DynamicUnionValue (API.Union unionName objects) m)+  resolve _ Nothing = throwE MissingSelectionSet+  resolve mHandler (Just selectionSet) = do+    duv <- mHandler+    runUnion @m @(API.Union unionName objects) @objects duv selectionSet++symbolText :: forall ks. KnownSymbol ks => Text+symbolText = toS (symbolVal @ks Proxy)++-- | Translate a 'Handler' into a DynamicUnionValue type required by+-- 'Union' handlers. This is dynamic, but nevertheless type-safe+-- because we can only tag with types that are part of the union.+--+-- Use e.g. like "unionValue @Cat" if you have an object like this:+--+-- >>> type Cat = API.Object "Cat" '[] '[API.Field "name" Text]+--+-- and then use `unionValue @Cat (pure (pure "Felix"))`. See+-- `examples/UnionExample.hs` for more code.+unionValue ::+  forall (object :: Type) (union :: Type) m (name :: Symbol) interfaces fields.+  (Monad m, API.Object name interfaces fields ~ object, KnownSymbol name)+  => TypeIndex m object union -> m (DynamicUnionValue union m)+unionValue x =+  -- TODO(tom) - we might want to move to Typeable `cast` for uValue+  -- instead of doing our own unsafeCoerce because it comes with+  -- additional safety guarantees: Typerep is unforgeable, while we+  -- can still into a bad place by matching on name only. We can't+  -- actually segfault this because right now we walk the list of+  -- objects in a union left-to-right so in case of duplicate names we+  -- only every see one type. That doesn't seen like a great thing to+  -- rely on though!++  -- Note that unsafeCoerce is safe because we index the type from the+  -- union with an 'API.Object' whose name we're storing in label. On+  -- the way out we check that the name is the same, and we know the+  -- type universe is the same because we annotated DynamicUnionValue+  -- with the type universe.+  pure (DynamicUnionValue (symbolText @name) (unsafeCoerce x))++extractUnionValue ::+  forall (object :: Type) (union :: Type) m (name :: Symbol) interfaces fields.+  (API.Object name interfaces fields ~ object, KnownSymbol name)+  => DynamicUnionValue union m -> Maybe (TypeIndex m object union)+extractUnionValue (DynamicUnionValue uName uValue) =+  if uName == symbolText @name+  then Just (unsafeCoerce uValue)+  else Nothing

@@ -1,6 +1,6 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_HADDOCK not-home #-} --- | Fully realized GraphQL schema type system at the value level.+-- | Description: Fully realized GraphQL schema type system at the Haskell value level -- -- Differs from "Data.GraphQL.AST" in the -- [graphql](http://hackage.haskell.org/package/graphql) package in that there@@ -20,9 +20,9 @@   , FieldDefinition(..)   , Interfaces   , InterfaceTypeDefinition(..)-  , NonEmptyList(..)   , ObjectTypeDefinition(..)   , UnionTypeDefinition(..)+  , ScalarTypeDefinition(..)   -- ** Input types   , InputType(..)   , InputTypeDefinition(..)@@ -34,15 +34,20 @@   , NonNullType(..)   , DefinesTypes(..)   , doesFragmentTypeApply+  , getInputTypeDefinition+  , builtinFromName+  , astAnnotationToSchemaAnnotation   -- * The schema   , Schema   , makeSchema+  , emptySchema   , lookupType   ) where  import Protolude  import qualified Data.Map as Map+import qualified GraphQL.Internal.Syntax.AST as AST import GraphQL.Value (Value) import GraphQL.Internal.Name (HasName(..), Name) @@ -59,13 +64,15 @@ makeSchema :: ObjectTypeDefinition -> Schema makeSchema = Schema . getDefinedTypes +-- | Create an empty schema for testing purpose.+--+emptySchema :: Schema+emptySchema = Schema (Map.empty :: (Map Name TypeDefinition))+ -- | Find the type with the given name in the schema. lookupType :: Schema -> Name -> Maybe TypeDefinition lookupType (Schema schema) name = Map.lookup name schema --- XXX: Use the built-in NonEmptyList in Haskell-newtype NonEmptyList a = NonEmptyList [a] deriving (Eq, Ord, Show, Functor, Foldable)- -- | A thing that defines types. Excludes definitions of input types. class DefinesTypes t where   -- | Get the types defined by @t@@@ -140,7 +147,7 @@       TypeDefinitionTypeExtension _ ->         panic "TODO: we should remove the 'extend' behaviour entirely" -data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces (NonEmptyList FieldDefinition)+data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces (NonEmpty FieldDefinition)                             deriving (Eq, Ord, Show)  instance HasName ObjectTypeDefinition where@@ -161,7 +168,9 @@   getName (FieldDefinition name _ _) = name  instance DefinesTypes FieldDefinition where-  getDefinedTypes (FieldDefinition _ _ retVal) = getDefinedTypes (getAnnotatedType retVal)+  getDefinedTypes (FieldDefinition _ args retVal) = +    getDefinedTypes (getAnnotatedType retVal) <>+    foldMap getDefinedTypes args  data ArgumentDefinition = ArgumentDefinition Name (AnnotatedType InputType) (Maybe DefaultValue)                           deriving (Eq, Ord, Show)@@ -169,7 +178,10 @@ instance HasName ArgumentDefinition where   getName (ArgumentDefinition name _ _) = name -data InterfaceTypeDefinition = InterfaceTypeDefinition Name (NonEmptyList FieldDefinition)+instance DefinesTypes ArgumentDefinition where+  getDefinedTypes (ArgumentDefinition _ annotatedType _) = getDefinedTypes $ getAnnotatedType annotatedType++data InterfaceTypeDefinition = InterfaceTypeDefinition Name (NonEmpty FieldDefinition)                                deriving (Eq, Ord, Show)  instance HasName InterfaceTypeDefinition where@@ -178,7 +190,7 @@ instance DefinesTypes InterfaceTypeDefinition where   getDefinedTypes i@(InterfaceTypeDefinition name fields) = Map.singleton name (TypeDefinitionInterface i) <> foldMap getDefinedTypes fields -data UnionTypeDefinition = UnionTypeDefinition Name (NonEmptyList ObjectTypeDefinition)+data UnionTypeDefinition = UnionTypeDefinition Name (NonEmpty ObjectTypeDefinition)                            deriving (Eq, Ord, Show)  instance HasName UnionTypeDefinition where@@ -236,7 +248,7 @@ instance HasName EnumValueDefinition where   getName (EnumValueDefinition name) = name -data InputObjectTypeDefinition = InputObjectTypeDefinition Name (NonEmptyList InputObjectFieldDefinition)+data InputObjectTypeDefinition = InputObjectTypeDefinition Name (NonEmpty InputObjectFieldDefinition)                                  deriving (Eq, Ord, Show)  instance HasName InputObjectTypeDefinition where@@ -260,6 +272,12 @@   getName (DefinedInputType x) = getName x   getName (BuiltinInputType x) = getName x +instance DefinesTypes InputType where+  getDefinedTypes inputType =+    case inputType of +       DefinedInputType typeDefinition -> getDefinedTypes typeDefinition+       BuiltinInputType _ -> mempty+ data InputTypeDefinition   = InputTypeDefinitionObject        InputObjectTypeDefinition   | InputTypeDefinitionScalar        ScalarTypeDefinition@@ -271,6 +289,13 @@   getName (InputTypeDefinitionScalar x) = getName x   getName (InputTypeDefinitionEnum x) = getName x +instance DefinesTypes InputTypeDefinition where+  getDefinedTypes inputTypeDefinition =+    case inputTypeDefinition of +       InputTypeDefinitionObject typeDefinition -> getDefinedTypes (TypeDefinitionInputObject typeDefinition)+       InputTypeDefinitionScalar typeDefinition -> getDefinedTypes (TypeDefinitionScalar typeDefinition)+       InputTypeDefinitionEnum typeDefinition -> getDefinedTypes (TypeDefinitionEnum typeDefinition)+ -- | A literal value specified as a default as part of a type definition. -- -- Use this type alias when you want to be clear that a definition may include@@ -304,4 +329,40 @@     _ -> False   where     implements (ObjectTypeDefinition _ interfaces _) int = int `elem` interfaces-    branchOf obj (UnionTypeDefinition _ (NonEmptyList branches)) = obj `elem` branches+    branchOf obj (UnionTypeDefinition _ branches) = obj `elem` branches++-- | Convert the given 'TypeDefinition' to an 'InputTypeDefinition' if it's a valid 'InputTypeDefinition'+-- (because 'InputTypeDefinition' is a subset of 'TypeDefinition')+-- see <http://facebook.github.io/graphql/June2018/#sec-Input-and-Output-Types>+getInputTypeDefinition :: TypeDefinition -> Maybe InputTypeDefinition+getInputTypeDefinition td =+  case td of+    TypeDefinitionInputObject itd -> Just (InputTypeDefinitionObject itd) +    TypeDefinitionScalar itd -> Just (InputTypeDefinitionScalar itd) +    TypeDefinitionEnum itd -> Just (InputTypeDefinitionEnum itd)+    _ -> Nothing++-- | Create a 'Builtin' type from a 'Name'+-- +-- Mostly used for the AST validation +-- theobat: There's probably a better way to do it but can't find it right now +builtinFromName :: Name -> Maybe Builtin+builtinFromName typeName+  | typeName == getName GInt = Just GInt+  | typeName == getName GBool = Just GBool+  | typeName == getName GString = Just GString+  | typeName == getName GFloat = Just GFloat+  | typeName == getName GID = Just GID+  | otherwise = Nothing++-- | Simple translation between 'AST' annotation types and 'Schema' annotation types+--+-- AST type annotations do not need any validation.+-- GraphQL annotations are semantic decorations around type names to indicate type composition (list/non null).+astAnnotationToSchemaAnnotation :: AST.GType -> a -> AnnotatedType a+astAnnotationToSchemaAnnotation gtype schemaTypeName = +  case gtype of+    AST.TypeNamed _ -> TypeNamed schemaTypeName+    AST.TypeList (AST.ListType astTypeName) -> TypeList (ListType $ astAnnotationToSchemaAnnotation astTypeName schemaTypeName)+    AST.TypeNonNull (AST.NonNullTypeNamed _) -> TypeNonNull (NonNullTypeNamed schemaTypeName)+    AST.TypeNonNull (AST.NonNullTypeList (AST.ListType astTypeName)) -> TypeNonNull (NonNullTypeList (ListType (astAnnotationToSchemaAnnotation astTypeName schemaTypeName)))

@@ -2,7 +2,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK not-home #-} +-- | Description: The GraphQL AST module GraphQL.Internal.Syntax.AST   ( QueryDocument(..)   , SchemaDocument(..)@@ -51,8 +53,11 @@ import Test.QuickCheck (Arbitrary(..), listOf, oneof)  import GraphQL.Internal.Arbitrary (arbitraryText)-import GraphQL.Internal.Name (Name)-+import GraphQL.Internal.Name          +  ( Name+  , HasName(..)+  )+   -- * Documents  -- | A 'QueryDocument' is something a user might send us.@@ -173,6 +178,13 @@            | TypeList ListType            | TypeNonNull NonNullType            deriving (Eq, Ord, Show)++-- | Get the name of the given 'GType'.+instance HasName GType where+  getName (TypeNamed (NamedType n)) = n+  getName (TypeList (ListType t)) = getName t+  getName (TypeNonNull (NonNullTypeNamed (NamedType n))) = n+  getName (TypeNonNull (NonNullTypeList (ListType l))) = getName l  newtype NamedType = NamedType Name deriving (Eq, Ord, Show) 

@@ -1,3 +1,6 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Turn GraphQL ASTs into text module GraphQL.Internal.Syntax.Encoder   ( queryDocument   , schemaDocument

@@ -1,11 +1,14 @@ {-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Parse text into GraphQL ASTs module GraphQL.Internal.Syntax.Parser   ( queryDocument   , schemaDocument   , value   ) where -import Protolude hiding (option, takeWhile)+import Protolude hiding (option)  import Control.Applicative ((<|>), empty, many, optional) import Control.Monad (fail)

@@ -1,4 +1,6 @@--- | Basic tokenising used by parser.+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Basic tokenising used by parser module GraphQL.Internal.Syntax.Tokens   ( tok   , whiteSpace

@@ -5,7 +5,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE KindSignatures #-}--- | Transform GraphQL query documents from AST into valid structures+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Transform GraphQL query documents from AST into valid structures -- -- This corresponds roughly to the -- [Validation](https://facebook.github.io/graphql/#sec-Validation) section of@@ -56,6 +58,7 @@   , getResponseKey   -- * Exported for testing   , findDuplicates+  , formatErrors   ) where  import Protolude hiding ((<>), throwE)@@ -79,6 +82,12 @@   , Schema   , doesFragmentTypeApply   , lookupType+  , AnnotatedType(..)+  , InputType (BuiltinInputType, DefinedInputType) +  , AnnotatedType+  , getInputTypeDefinition+  , builtinFromName+  , astAnnotationToSchemaAnnotation   ) import GraphQL.Value   ( Value@@ -98,30 +107,34 @@   | MultipleOperations (Operations value)   deriving (Eq, Show) ++data OperationType+  = Mutation+  | Query+  deriving (Eq, Show)+ data Operation value-  = Query VariableDefinitions (Directives value) (SelectionSetByType value)-  | Mutation VariableDefinitions (Directives value) (SelectionSetByType value)+  = Operation OperationType VariableDefinitions (Directives value) (SelectionSetByType value)   deriving (Eq, Show)  instance Functor Operation where-  fmap f (Query vars directives selectionSet) = Query vars (fmap f directives) (fmap f selectionSet)-  fmap f (Mutation vars directives selectionSet) = Mutation vars (fmap f directives) (fmap f selectionSet)+  fmap f (Operation operationType vars directives selectionSet)+    = Operation operationType vars (fmap f directives) (fmap f selectionSet)  instance Foldable Operation where-  foldMap f (Query _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet-  foldMap f (Mutation _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet+  foldMap f (Operation _ _ directives selectionSet)+    = foldMap f directives `mappend` foldMap f selectionSet  instance Traversable Operation where-  traverse f (Query vars directives selectionSet) = Query vars <$> traverse f directives <*> traverse f selectionSet-  traverse f (Mutation vars directives selectionSet) = Mutation vars <$> traverse f directives <*> traverse f selectionSet+  traverse f (Operation operationType vars directives selectionSet)+    = Operation operationType vars <$> traverse f directives <*> traverse f selectionSet  -- | Get the selection set for an operation. getSelectionSet :: Operation value -> SelectionSetByType value-getSelectionSet (Query _ _ ss) = ss-getSelectionSet (Mutation _ _ ss) = ss+getSelectionSet (Operation _ _ _ ss) = ss  -- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'.-type OperationType value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value+type OperationBuilder value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value  type Operations value = Map (Maybe Name) (Operation value) @@ -145,7 +158,7 @@       assertAllFragmentsUsed frags (visitedFrags <> usedFrags)       validValuesSS <- validateValues ss       resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS-      pure (LoneAnonymousOperation (Query emptyVariableDefinitions emptyDirectives resolvedValuesSS))+      pure (LoneAnonymousOperation (Operation Query emptyVariableDefinitions emptyDirectives resolvedValuesSS))     _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst maybeNamed))    where@@ -156,41 +169,29 @@     splitDefns (AST.DefinitionFragment frag) = Right frag      splitOps (AST.AnonymousQuery ss) = Left ss-    splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Query, node))-    splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Mutation, node))+    splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Operation Query, node))+    splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Operation Mutation, node))      assertAllFragmentsUsed :: Fragments value -> Set (Maybe Name) -> Validation ()     assertAllFragmentsUsed fragments used =-      let unused = ( Set.map pure (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 -> [(Maybe Name, (OperationType AST.Value, AST.Node))] -> StateT (Set (Maybe Name)) Validation (Operations AST.Value)+validateOperations :: Schema -> Fragments AST.Value -> [(Maybe Name, (OperationBuilder 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   where-    validateNode (operationType, AST.Node _ vars directives ss) =-      operationType <$> lift (validateVariableDefinitions vars)+    validateNode (operationBuilder, AST.Node _ vars directives ss) =+      operationBuilder <$> lift (validateVariableDefinitions schema vars)                     <*> lift (validateDirectives directives)                     <*> validateSelectionSet schema fragments ss --- TODO: Either make operation type (Query, Mutation) a parameter of an--- Operation constructor or give all the fields accessors. This duplication is--- driving me batty. validateOperation :: Operation AST.Value -> Validation (Operation VariableValue)-validateOperation (Query vars directives selectionSet) = do-  validValues <- Query vars <$> validateValues directives <*> validateValues selectionSet-  -- Instead of doing this, we could build up a list of used variables as we-  -- resolve them.-  let usedVariables = getVariables validValues-  let definedVariables = getDefinedVariables vars-  let unusedVariables = definedVariables `Set.difference` usedVariables-  unless (Set.null unusedVariables) $ throwE (UnusedVariables unusedVariables)-  resolveVariables vars validValues-validateOperation (Mutation vars directives selectionSet) = do-  validValues <- Mutation vars <$> validateValues directives <*> validateValues selectionSet+validateOperation (Operation operationType vars directives selectionSet) = do+  validValues <- Operation operationType vars <$> validateValues directives <*> validateValues selectionSet   -- Instead of doing this, we could build up a list of used variables as we   -- resolve them.   let usedVariables = getVariables validValues@@ -624,7 +625,7 @@ data VariableDefinition   = VariableDefinition     { variable :: Variable -- ^ The name of the variable-    , variableType :: AST.GType -- ^ The type of the variable+    , variableType :: AnnotatedType InputType -- ^ The type of the variable     , defaultValue :: Maybe Value -- ^ An optional default value for the variable     } deriving (Eq, Ord, Show) @@ -640,17 +641,44 @@ emptyVariableDefinitions = mempty  -- | Ensure that a set of variable definitions is valid.-validateVariableDefinitions :: [AST.VariableDefinition] -> Validation VariableDefinitions-validateVariableDefinitions vars = do-  validatedDefns <- traverse validateVariableDefinition vars+validateVariableDefinitions :: Schema -> [AST.VariableDefinition] -> Validation VariableDefinitions+validateVariableDefinitions schema vars = do+  validatedDefns <- traverse (validateVariableDefinition schema) vars   let items = [ (variable defn, defn) | defn <- validatedDefns]   mapErrors DuplicateVariableDefinition (makeMap items)  -- | Ensure that a variable definition is a valid one.-validateVariableDefinition :: AST.VariableDefinition -> Validation VariableDefinition-validateVariableDefinition (AST.VariableDefinition name varType value) =-  VariableDefinition name varType <$> traverse validateDefaultValue value+validateVariableDefinition :: Schema -> AST.VariableDefinition -> Validation VariableDefinition+validateVariableDefinition schema (AST.VariableDefinition var varType value) =+  VariableDefinition var+    <$> validateTypeAssertion schema var varType+    <*> traverse validateDefaultValue value +-- | Ensure that a variable has a correct type declaration given a schema.+validateTypeAssertion :: Schema -> Variable -> AST.GType -> Validation (AnnotatedType InputType)+validateTypeAssertion schema var varTypeAST =+  astAnnotationToSchemaAnnotation varTypeAST <$>+  case lookupType schema varTypeNameAST of+    Nothing -> validateVariableTypeBuiltin var varTypeNameAST+    Just cleanTypeDef -> validateVariableTypeDefinition var cleanTypeDef+  where +    varTypeNameAST = getName varTypeAST++-- | Validate a variable type which has a type definition in the schema.+validateVariableTypeDefinition :: Variable -> TypeDefinition -> Validation InputType+validateVariableTypeDefinition var typeDef = +  case getInputTypeDefinition typeDef of +    Nothing -> throwE (VariableTypeIsNotInputType var $ getName typeDef)+    Just value -> pure (DefinedInputType value)+ ++-- | Validate a variable type which has no type definition (either builtin or not in the schema).+validateVariableTypeBuiltin :: Variable -> Name -> Validation InputType+validateVariableTypeBuiltin var typeName = +  case builtinFromName typeName of+    Nothing -> throwE (VariableTypeNotFound var typeName)+    Just builtin -> pure (BuiltinInputType builtin)+ -- | Ensure that a default value contains no variables. validateDefaultValue :: AST.DefaultValue -> Validation Value validateDefaultValue defaultValue =@@ -774,6 +802,11 @@   | IncompatibleFields Name   -- | There's a type condition that's not present in the schema.   | TypeConditionNotFound Name+  -- | There's a variable type that's not present in the schema.+  | VariableTypeNotFound Variable Name+  -- | A variable was defined with a non input type.+  -- <http://facebook.github.io/graphql/June2018/#sec-Variables-Are-Input-Types>+  | VariableTypeIsNotInputType Variable Name   deriving (Eq, Show)  instance GraphQLError ValidationError where@@ -796,6 +829,8 @@   formatError (MismatchedArguments name) = "Two different sets of arguments given for same response key: " <> show name   formatError (IncompatibleFields name) = "Field " <> show name <> " has a leaf in one place and a non-leaf in another."   formatError (TypeConditionNotFound name) = "Type condition " <> show name <> " not found in schema."+  formatError (VariableTypeNotFound var name) = "Type named " <> show name <> " for variable " <> show var <> " is not in the schema."+  formatError (VariableTypeIsNotInputType var name) = "Type named " <> show name <> " for variable " <> show var <> " is not an input type."  type ValidationErrors = NonEmpty ValidationError @@ -838,6 +873,11 @@     Just dups -> throwErrors dups  -- * Error handling++-- | Utility function for tests, format ErrorTypes to their text representation+-- returns a list of error messages+formatErrors :: [ValidationError] -> [Text]+formatErrors errors = formatError <$> errors  -- | A 'Validator' is a value that can either be valid or have a non-empty -- list of errors.

@@ -0,0 +1,367 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Literal GraphQL values+module GraphQL.Internal.Value+  ( Value+  , Value'(..)+  , ConstScalar+  , UnresolvedVariableValue+  , pattern ValueInt+  , pattern ValueFloat+  , pattern ValueBoolean+  , pattern ValueString+  , pattern ValueEnum+  , pattern ValueList+  , pattern ValueObject+  , pattern ValueNull+  , toObject+  , valueToAST+  , astToVariableValue+  , variableValueToAST+  , List+  , List'(..)+  , String(..)+    -- * Names+  , Name(..)+  , NameError(..)+  , makeName+    -- * Objects+  , Object+  , Object'(..)+  , ObjectField+  , ObjectField'(ObjectField)+    -- ** Constructing+  , makeObject+  , objectFromList+  , objectFromOrderedMap+    -- ** Combining+  , unionObjects+    -- ** Querying+  , objectFields+  ) where++import Protolude++import qualified Data.Aeson as Aeson+import Data.Aeson (ToJSON(..), (.=), pairs)+import qualified Data.Map as Map+import Test.QuickCheck (Arbitrary(..), Gen, oneof, listOf, sized)++import GraphQL.Internal.Arbitrary (arbitraryText)+import GraphQL.Internal.Name (Name(..), NameError(..), makeName)+import GraphQL.Internal.Syntax.AST (Variable)+import qualified GraphQL.Internal.Syntax.AST as AST+import GraphQL.Internal.OrderedMap (OrderedMap)+import qualified GraphQL.Internal.OrderedMap as OrderedMap++-- * Values++-- | A GraphQL value. @scalar@ represents the type of scalar that's contained+-- within this value.+--+-- Normally, it is one of either 'ConstScalar' (to indicate that there are no+-- variables whatsoever) or 'VariableScalar' (to indicate that there might be+-- some variables).+data Value' scalar+  = ValueScalar' scalar+  | ValueList' (List' scalar)+  | ValueObject' (Object' scalar)+  deriving (Eq, Ord, Show, Functor)++instance Foldable Value' where+  foldMap f (ValueScalar' scalar) = f scalar+  foldMap f (ValueList' values) = foldMap f values+  foldMap f (ValueObject' obj) = foldMap f obj++instance Traversable Value' where+  traverse f (ValueScalar' x) = ValueScalar' <$> f x+  traverse f (ValueList' xs) = ValueList' <$> traverse f xs+  traverse f (ValueObject' xs) = ValueObject' <$> traverse f xs++instance ToJSON scalar => ToJSON (Value' scalar) where+  toJSON (ValueScalar' x) = toJSON x+  toJSON (ValueList' x) = toJSON x+  toJSON (ValueObject' x) = toJSON x++instance Arbitrary scalar => Arbitrary (Value' scalar) where+  -- | Generate an arbitrary value. Uses the generator's \"size\" property to+  -- determine maximum object depth.+  arbitrary = sized genValue++-- | Generate an arbitrary value, with objects at most @n@ levels deep.+genValue :: Arbitrary scalar => Int -> Gen (Value' scalar)+genValue n+  | n <= 0 = arbitrary+  | otherwise = oneof [ ValueScalar' <$> arbitrary+                      , ValueObject' <$> genObject (n - 1)+                      , ValueList' . List' <$> listOf (genValue (n - 1))+                      ]++-- | A GraphQL value which contains no variables.+type Value = Value' ConstScalar++-- TODO: These next two definitions are quite internal. We should move this+-- module to Internal and then re-export the bits that end-users will use.+-- <https://github.com/jml/graphql-api/issues/99>++-- | A GraphQL value which might contain some variables. These variables are+-- not yet associated with+-- <https://facebook.github.io/graphql/#VariableDefinition variable+-- definitions> (see also 'GraphQL.Internal.Validation.VariableDefinition'),+-- which are provided in a different context.+type UnresolvedVariableValue = Value' UnresolvedVariableScalar++pattern ValueInt :: Int32 -> Value+pattern ValueInt x = ValueScalar' (ConstInt x)++pattern ValueFloat :: Double -> Value+pattern ValueFloat x = ValueScalar' (ConstFloat x)++pattern ValueBoolean :: Bool -> Value+pattern ValueBoolean x = ValueScalar' (ConstBoolean x)++pattern ValueString :: String -> Value+pattern ValueString x = ValueScalar' (ConstString x)++pattern ValueEnum :: Name -> Value+pattern ValueEnum x = ValueScalar' (ConstEnum x)++pattern ValueList :: forall t. List' t -> Value' t+pattern ValueList x = ValueList' x++pattern ValueObject :: forall t. Object' t -> Value' t+pattern ValueObject x = ValueObject' x++pattern ValueNull :: Value+pattern ValueNull = ValueScalar' ConstNull++-- | If a value is an object, return just that. Otherwise @Nothing@.+toObject :: Value' scalar -> Maybe (Object' scalar)+toObject (ValueObject' o) = pure o+toObject _ = empty++-- * Scalars++-- | A non-variable value which contains no other values.+data ConstScalar+  = ConstInt Int32+  | ConstFloat Double+  | ConstBoolean Bool+  | ConstString String+  | ConstEnum Name+  | ConstNull+  deriving (Eq, Ord, Show)++instance ToJSON ConstScalar where+  toJSON (ConstInt x) = toJSON x+  toJSON (ConstFloat x) = toJSON x+  toJSON (ConstBoolean x) = toJSON x+  toJSON (ConstString x) = toJSON x+  toJSON (ConstEnum x) = toJSON x+  toJSON ConstNull = Aeson.Null++-- | A value which contains no other values, and might be a variable that+-- might lack a definition.+type UnresolvedVariableScalar = Either Variable ConstScalar++-- | Generate an arbitrary scalar value.+instance Arbitrary ConstScalar where+  arbitrary = oneof [ ConstInt <$> arbitrary+                    , ConstFloat <$> arbitrary+                    , ConstBoolean <$> arbitrary+                    , ConstString <$> arbitrary+                    , ConstEnum <$> arbitrary+                    , pure ConstNull+                    ]++-- | Convert a constant scalar to an AST.Value+constScalarToAST :: ConstScalar -> AST.Value+constScalarToAST scalar =+  case scalar of+    ConstInt x -> AST.ValueInt x+    ConstFloat x -> AST.ValueFloat x+    ConstBoolean x -> AST.ValueBoolean x+    ConstString (String x) -> AST.ValueString (AST.StringValue x)+    ConstEnum x -> AST.ValueEnum x+    ConstNull -> AST.ValueNull++-- | Convert a variable scalar to an AST.Value+variableToAST :: UnresolvedVariableScalar -> AST.Value+variableToAST (Left variable) = AST.ValueVariable variable+variableToAST (Right constant) = constScalarToAST constant++-- | Convert a value from the AST into a variable scalar, presuming it /is/ a+-- scalar.+astToScalar :: AST.Value -> Maybe UnresolvedVariableScalar+astToScalar (AST.ValueInt x) = pure $ Right $ ConstInt x+astToScalar (AST.ValueFloat x) = pure $ Right $ ConstFloat x+astToScalar (AST.ValueBoolean x) = pure $ Right $ ConstBoolean x+astToScalar (AST.ValueString (AST.StringValue x)) = pure $ Right $ ConstString (String x)+astToScalar (AST.ValueEnum x) = pure $ Right $ ConstEnum x+astToScalar AST.ValueNull = pure $ Right ConstNull+astToScalar (AST.ValueVariable x) = pure $ Left x+astToScalar _ = empty+++-- * Strings++newtype String = String Text deriving (Eq, Ord, Show)++instance Arbitrary String where+  arbitrary = String <$> arbitraryText++instance ToJSON String where+  toJSON (String x) = toJSON x++-- * Lists++newtype List' scalar = List' [Value' scalar] deriving (Eq, Ord, Show, Functor)++instance Foldable List' where+  foldMap f (List' values) = mconcat (map (foldMap f) values)++instance Traversable List' where+  traverse f (List' xs) = List' <$> traverse (traverse f) xs+++-- | A list of values that are known to be constants.+--+-- Note that this list might not be valid GraphQL, because GraphQL only allows+-- homogeneous lists (i.e. all elements of the same type), and we do no type+-- checking at this point.+type List = List' ConstScalar++instance Arbitrary scalar => Arbitrary (List' scalar) where+  -- TODO: GraphQL does not allow heterogeneous lists:+  -- https://facebook.github.io/graphql/#sec-Lists, so this will generate+  -- invalid lists.+  arbitrary = List' <$> listOf arbitrary+++instance ToJSON scalar => ToJSON (List' scalar) where+  toJSON (List' x) = toJSON x++-- * Objects++-- | A GraphQL object.+--+-- Note that https://facebook.github.io/graphql/#sec-Response calls these+-- \"Maps\", but everywhere else in the spec refers to them as objects.+newtype Object' scalar = Object' (OrderedMap Name (Value' scalar)) deriving (Eq, Ord, Show, Functor)++instance Foldable Object' where+  foldMap f (Object' fieldMap) = foldMap (foldMap f) fieldMap++instance Traversable Object' where+  traverse f (Object' xs) = Object' <$> traverse (traverse f) xs++-- | A GraphQL object that contains only non-variable values.+type Object = Object' ConstScalar++objectFields :: Object' scalar -> [ObjectField' scalar]+objectFields (Object' object) = map (uncurry ObjectField') (OrderedMap.toList object)++instance Arbitrary scalar => Arbitrary (Object' scalar) where+  arbitrary = sized genObject++-- | Generate an arbitrary object to the given maximum depth.+genObject :: Arbitrary scalar => Int -> Gen (Object' scalar)+genObject n = Object' <$> OrderedMap.genOrderedMap arbitrary (genValue n)++data ObjectField' scalar = ObjectField' Name (Value' scalar) deriving (Eq, Ord, Show, Functor)++-- | A field of an object that has a non-variable value.+type ObjectField = ObjectField' ConstScalar++pattern ObjectField :: forall t. Name -> Value' t -> ObjectField' t+pattern ObjectField name value = ObjectField' name value++instance Arbitrary scalar => Arbitrary (ObjectField' scalar) where+  arbitrary = ObjectField' <$> arbitrary <*> arbitrary++-- | Make an object from a list of object fields.+makeObject :: [ObjectField' scalar] -> Maybe (Object' scalar)+makeObject fields = objectFromList [(name, value) | ObjectField' name value <- fields]++-- | Make an object from an ordered map.+objectFromOrderedMap :: OrderedMap Name (Value' scalar) -> Object' scalar+objectFromOrderedMap = Object'++-- | Create an object from a list of (name, value) pairs.+objectFromList :: [(Name, Value' scalar)] -> Maybe (Object' scalar)+objectFromList xs = Object' <$> OrderedMap.orderedMap xs++unionObjects :: [Object' scalar] -> Maybe (Object' scalar)+unionObjects objects = Object' <$> OrderedMap.unions [obj | Object' obj <- objects]++instance ToJSON scalar => ToJSON (Object' scalar) where+  -- Direct encoding to preserve order of keys / values+  toJSON (Object' xs) = toJSON (Map.fromList [(unName k, v) | (k, v) <- OrderedMap.toList xs])+  toEncoding (Object' xs) = pairs (foldMap (\(k, v) -> toS (unName k) .= v) (OrderedMap.toList xs))+++++-- * Conversion to and from AST.++-- | Convert an AST value into a literal value.+--+-- This is a stop-gap until we have proper conversion of user queries into+-- canonical forms.+astToValue' :: (AST.Value -> scalar) -> AST.Value -> Maybe (Value' scalar)+astToValue' f x@(AST.ValueInt _) = pure (ValueScalar' (f x))+astToValue' f x@(AST.ValueFloat _) = pure (ValueScalar' (f x))+astToValue' f x@(AST.ValueBoolean _) = pure (ValueScalar' (f x))+astToValue' f x@(AST.ValueString (AST.StringValue _)) = pure (ValueScalar' (f x))+astToValue' f x@(AST.ValueEnum _) = pure (ValueScalar' (f x))+astToValue' f AST.ValueNull = pure (ValueScalar' (f AST.ValueNull))+astToValue' f x@(AST.ValueVariable _) = pure (ValueScalar' (f x))+astToValue' f (AST.ValueList (AST.ListValue xs)) = ValueList' . List' <$> traverse (astToValue' f) xs+astToValue' f (AST.ValueObject (AST.ObjectValue fields)) = do+  fields' <- traverse toObjectField fields+  object <- makeObject fields'+  pure (ValueObject' object)+  where+    toObjectField (AST.ObjectField name value) = ObjectField' name <$> astToValue' f value++-- | Convert an AST value to a variable value.+--+-- Will fail if the AST value contains duplicate object fields, or is+-- otherwise invalid.+astToVariableValue :: HasCallStack => AST.Value -> Maybe UnresolvedVariableValue+astToVariableValue ast = astToValue' convertScalar ast+  where+    convertScalar x =+      case astToScalar x of+        Just scalar -> scalar+        Nothing -> panic ("Non-scalar passed to convertScalar, bug in astToValue': " <> show x)++-- | Convert a value to an AST value.+valueToAST :: Value -> AST.Value+valueToAST = valueToAST' constScalarToAST++-- | Convert a variable value to an AST value.+variableValueToAST :: UnresolvedVariableValue -> AST.Value+variableValueToAST = valueToAST' variableToAST++-- | Convert a literal value into an AST value.+--+-- Nulls are converted into Nothing.+--+-- This function probably isn't particularly useful, but it functions as a+-- stop-gap until we have QuickCheck generators for the AST.+valueToAST' :: (scalar -> AST.Value) -> Value' scalar -> AST.Value+valueToAST' f (ValueScalar' x) = f x+valueToAST' f (ValueList' (List' xs)) = AST.ValueList (AST.ListValue (map (valueToAST' f) xs))+valueToAST' f (ValueObject' (Object' fields)) = AST.ValueObject (AST.ObjectValue (map toObjectField (OrderedMap.toList fields)))+  where+    toObjectField (name, value) = AST.ObjectField name (valueToAST' f value)

@@ -0,0 +1,134 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Convert GraphQL values to domain-specific Haskell values+module GraphQL.Internal.Value.FromValue+  ( FromValue(..)+  , prop_roundtripValue+  , wrongType+  ) where++import Protolude hiding (TypeError)++import qualified Data.List.NonEmpty as NonEmpty+import GHC.Generics ((:*:)(..))+import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..))+import GHC.Types (Type)++import GraphQL.Internal.Name (nameFromSymbol)+import qualified GraphQL.Internal.OrderedMap as OM+import GraphQL.Internal.Value+import GraphQL.Internal.Value.ToValue (ToValue(..))++-- * FromValue++-- | @a@ can be converted from a GraphQL 'Value' to a Haskell value.+--+-- The @FromValue@ instance converts 'AST.Value' to the type expected by the+-- handler function. It is the boundary between incoming data and your custom+-- application Haskell types.+--+-- @FromValue@ has a generic instance for converting input objects to+-- records.+class FromValue a where+  -- | Convert an already-parsed value into a Haskell value, generally to be+  -- passed to a handler.+  fromValue :: Value' ConstScalar -> Either Text a+  default fromValue :: (Generic a, GenericFromValue (Rep a)) => Value' ConstScalar -> Either Text a+  fromValue (ValueObject v) = to <$> genericFromValue v+  fromValue v = wrongType "genericFromValue only works with objects." v++instance FromValue Int32 where+  fromValue (ValueInt v) = pure v+  fromValue v = wrongType "Int" v++instance FromValue Double where+  fromValue (ValueFloat v) = pure v+  fromValue v = wrongType "Double" v++instance FromValue Bool where+  fromValue (ValueBoolean v) = pure v+  fromValue v = wrongType "Bool" v++instance FromValue Text where+  fromValue (ValueString (String v)) = pure v+  fromValue v = wrongType "String" v++instance forall v. FromValue v => FromValue [v] where+  fromValue (ValueList' (List' values)) = traverse (fromValue @v) values+  fromValue v = wrongType "List" v++instance forall v. FromValue v => FromValue (NonEmpty v) where+  fromValue (ValueList' (List' values)) =+    case NonEmpty.nonEmpty values of+      Nothing -> Left "Cannot construct NonEmpty from empty list"+      Just values' -> traverse (fromValue @v) values'+  fromValue v = wrongType "List" v++instance forall v. FromValue v => FromValue (Maybe v) where+  fromValue ValueNull = pure Nothing+  fromValue x = Just <$> fromValue @v x++-- | Anything that can be converted to a value and from a value should roundtrip.+prop_roundtripValue :: forall a. (Eq a, ToValue a, FromValue a) => a -> Bool+prop_roundtripValue x = fromValue (toValue x) == Right x++-- | Throw an error saying that @value@ does not have the @expected@ type.+wrongType :: (MonadError Text m, Show a) => Text -> a -> m b+wrongType expected value = throwError ("Wrong type, should be: `" <> expected <> "` but is: `" <> show value <> "`")++-- We only allow generic record reading for now because I am not sure+-- how we should interpret any other generic things (e.g. tuples).+class GenericFromValue (f :: Type -> Type) where+  genericFromValue :: Object' ConstScalar -> Either Text (f p)++instance forall dataName consName records s l p.+  ( KnownSymbol dataName+  , KnownSymbol consName+  , GenericFromValue records+  ) => GenericFromValue (D1 ('MetaData dataName s l 'False)+                         (C1 ('MetaCons consName p 'True) records+                         )) where+  genericFromValue o = M1 . M1 <$> genericFromValue @records o+++instance forall l r.+  ( GenericFromValue l+  , GenericFromValue r+  ) => GenericFromValue (l :*: r) where+  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 (Object' fieldMap) = do+  fieldName <- case nameFromSymbol @fieldName of+    Left err -> throwError ("invalid field name" <> show err)+    Right name' -> pure name'+   -- TODO(tom): How do we deal with optional fields? Maybe sounds+   -- like the correct type, but how would Maybe be different from+   -- `null`? Delegating to FromValue not good enough here because of+   -- the dictionary lookup.+  case OM.lookup fieldName fieldMap of+    Nothing -> throwError ("Key not found: " <> show fieldName)+    Just v -> M1 . K1 <$> fromValue @wrappedType v++instance forall wrappedType fieldName u s l.+  ( KnownSymbol fieldName+  , FromValue wrappedType+  ) => GenericFromValue (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where+  genericFromValue = getValue @wrappedType @fieldName++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 = panic "genericFromValue cannot be called for records with more than one data constructor. Code that tries will not be compiled."

@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Turn domain-specific Haskell values into GraphQL values.+module GraphQL.Internal.Value.ToValue+  ( ToValue(..)+  ) where++import Protolude++import GraphQL.Internal.Value++-- * ToValue++-- | Turn a Haskell value into a GraphQL value.+class ToValue a where+  toValue :: a -> Value' ConstScalar++instance ToValue (Value' ConstScalar) where+  toValue = identity++-- XXX: Should this just be for Foldable?+instance ToValue a => ToValue [a] where+  toValue = toValue . List' . map toValue++-- TODO - tom still thinks that using Maybe for nullable is maybe not+-- the best idea. <https://github.com/jml/graphql-api/issues/100>+instance ToValue a => ToValue (Maybe a) where+  toValue Nothing = ValueNull+  toValue (Just v) = toValue v++instance ToValue a => ToValue (NonEmpty a) where+  toValue = toValue . makeList++instance ToValue Bool where+  toValue = ValueBoolean++instance ToValue Int32 where+  toValue = ValueInt++instance ToValue Double where+  toValue = ValueFloat++instance ToValue String where+  toValue = ValueString++-- XXX: Make more generic: any string-like thing rather than just Text.+instance ToValue Text where+  toValue = toValue . String++instance ToValue List where+  toValue = ValueList'++instance ToValue (Object' ConstScalar) where+  toValue = ValueObject'+++makeList :: (Functor f, Foldable f, ToValue a) => f a -> List+makeList = List' . Protolude.toList . map toValue

@@ -1,508 +1,18 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeFamilyDependencies #-} -- nicer type errors in some cases-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-} -- for TypeError-+-- | Description: Implement handlers for GraphQL schemas+--+-- Contains everything you need to write handlers for your GraphQL schema. module GraphQL.Resolver+  ( module Export+  ) where++import GraphQL.Internal.Resolver as Export   ( ResolverError(..)   , HasResolver(..)+  , OperationResolverConstraint   , (:<>)(..)   , Result(..)   , unionValue-  ) where---- TODO (probably incomplete, the spec is large)--- - input objects - I'm not super clear from the spec on how---   they differ from normal objects.--- - "extend type X" is used in examples in the spec but it's not---   explained anywhere?--- - 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, throwE)--import qualified Data.Text as Text-import qualified Data.List.NonEmpty as NonEmpty-import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..), Symbol, symbolVal)-import GHC.Types (Type)-import qualified GHC.Exts (Any)-import Unsafe.Coerce (unsafeCoerce)--import GraphQL.API-  ( (:>)-  , HasAnnotatedType(..)-  , HasAnnotatedInputType(..)-  )-import qualified GraphQL.API as API-import qualified GraphQL.Value as GValue-import GraphQL.Value-  ( Value-  , pattern ValueEnum-  )-import GraphQL.Value.FromValue (FromValue(..))-import GraphQL.Value.ToValue (ToValue(..))-import GraphQL.Internal.Name (Name, NameError(..), HasName(..), nameFromSymbol)-import qualified GraphQL.Internal.OrderedMap as OrderedMap-import GraphQL.Internal.Output (GraphQLError(..))-import GraphQL.Internal.Validation-  ( SelectionSetByType-  , SelectionSet(..)-  , Field-  , ValidationErrors-  , getSubSelectionSet-  , getSelectionSetForType-  , lookupArgument+  , resolveOperation+  , returns+  , handlerError   )--data ResolverError-  -- | There was a problem in the schema. Server-side problem.-  = SchemaError NameError-  -- | Couldn't find the requested field in the object. A client-side problem.-  | FieldNotFoundError Name-  -- | No value provided for name, and no default specified. Client-side problem.-  | ValueMissing Name-  -- | Could not translate value into Haskell. Probably a client-side problem.-  | InvalidValue Name Text-  -- | Found validation errors when we tried to merge fields.-  | ValidationError ValidationErrors-  -- | Tried to get subselection of leaf field.-  | SubSelectionOnLeaf (SelectionSetByType Value)-  -- | Tried to treat an object as a leaf.-  | MissingSelectionSet-  deriving (Show, Eq)--instance GraphQLError ResolverError where-  formatError (SchemaError e) =-    "Schema error: " <> formatError e-  formatError (FieldNotFoundError field) =-    "Field not supported by the API: " <> show field-  formatError (ValueMissing name) =-    "No value provided for " <> show name <> ", and no default specified."-  formatError (InvalidValue name text) =-    "Could not coerce " <> show name <> " to valid value: " <> text-  formatError (ValidationError errs) =-    "Validation errors: " <> Text.intercalate ", " (map formatError (NonEmpty.toList errs))-  formatError (SubSelectionOnLeaf ss) =-    "Tried to get values within leaf field: " <> show ss-  formatError MissingSelectionSet =-    "Tried to treat object as if it were leaf field."---- | Object field separation operator.------ Use this to provide handlers for fields of an object.------ Say you had the following GraphQL type with \"foo\" and \"bar\" fields,--- e.g.------ @---   type MyObject {---     foo: Int!---     bar: String!---   }--- @------ You could provide handlers for it like this:------ >>> :m +System.Environment--- >>> let fooHandler = pure 42--- >>> let barHandler = System.Environment.getProgName--- >>> let myObjectHandler = pure $ fooHandler :<> barHandler :<> ()-data a :<> b = a :<> b-infixr 8 :<>----- Result collects errors and values at the same time unless a handler--- tells us to bail out in which case we stop the processing--- immediately.-data Result a = Result [ResolverError] a deriving (Show, Functor, Eq)---- Aggregating results keeps all errors and creates a ValueList--- containing the individual values.-aggregateResults :: [Result Value] -> Result Value-aggregateResults r = toValue <$> sequenceA r--throwE :: Applicative f => ResolverError -> f (Result Value)-throwE err = pure (Result [err] GValue.ValueNull)--instance Applicative Result where-  pure v = Result [] v-  (Result e1 f) <*> (Result e2 x) = Result (e1 <> e2) (f x)--ok :: Value -> Result Value-ok = pure--class HasResolver m a where-  type Handler m a-  resolve :: Handler m a -> Maybe (SelectionSetByType Value) -> m (Result Value)---- | Called when the schema expects an input argument @name@ of type @a@ but--- @name@ has not been provided.-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-  resolve handler Nothing = map (ok . toValue) handler-  resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss)--instance forall m. (Applicative m) => HasResolver m Double where-  type Handler m Double = m Double-  resolve handler Nothing =  map (ok . toValue) handler-  resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss)--instance forall m. (Applicative m) => HasResolver m Text where-  type Handler m Text = m Text-  resolve handler Nothing =  map (ok . toValue) handler-  resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss)--instance forall m. (Applicative m) => HasResolver m Bool where-  type Handler m Bool = m Bool-  resolve handler Nothing =  map (ok . toValue) handler-  resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss)--instance forall m hg. (Monad m, Applicative m, HasResolver m hg) => HasResolver m (API.List hg) where-  type Handler m (API.List hg) = m [Handler m hg]-  resolve handler selectionSet = do-    h <- handler-    let a = traverse (flip (resolve @m @hg) selectionSet) h-    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) = 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-  type Handler m (Maybe hg) = m (Maybe (Handler m hg))-  resolve handler selectionSet = do-    result <- handler-    case result of-      Just x -> resolve @m @hg (x :: Handler m hg) selectionSet-      Nothing -> (pure . ok) GValue.ValueNull---- TODO: A parametrized `Result` is really not a good way to handle the--- "result" for resolveField, but not sure what to use either. Tom liked the--- tuple we had before more because it didn't imply any other structure or--- meaning. Maybe we can just create a new datatype. jml thinks we should--- extract some helpful generic monad, ala `Validator`.--- <https://github.com/jml/graphql-api/issues/98>-type ResolveFieldResult = Result (Maybe GValue.Value)---- Extract field name from an argument type. TODO: ideally we'd run--- this directly on the "a :> b" argument structure, but that requires--- passing in the plain argument structure type into resolveField or--- resolving "name" in the buildFieldResolver. Both options duplicate--- code somwehere else.-type family FieldName (a :: Type) = (r :: Symbol) where-  FieldName (JustHandler (API.Field name t)) = name-  FieldName (PlainArgument a f) = FieldName f-  FieldName (EnumArgument a f) = FieldName f-  FieldName x = TypeError ('Text "Unexpected branch in FieldName type family. Please file a bug!" ':<>: 'ShowType x)--resolveField :: forall dispatchType (m :: Type -> Type).-  (BuildFieldResolver m dispatchType, Monad m, KnownSymbol (FieldName dispatchType))-  => FieldHandler m dispatchType -> m ResolveFieldResult -> Field Value -> m ResolveFieldResult-resolveField handler nextHandler field =-  -- check name before-  case nameFromSymbol @(FieldName dispatchType) of-    Left err -> pure (Result [SchemaError err] (Just GValue.ValueNull))-    Right name'-      | getName field == name' ->-          case buildFieldResolver @m @dispatchType handler field of-            Left err -> pure (Result [err] (Just GValue.ValueNull))-            Right resolver -> do-              Result errs value <- resolver-              pure (Result errs (Just value))-      | otherwise -> nextHandler---- We're using our usual trick of rewriting a type in a closed type--- family to emulate a closed typeclass. The following are the--- universe of "allowed" class instances for field types:-data JustHandler a-data EnumArgument a b-data PlainArgument a b---- injective helps with errors sometimes-type family FieldResolverDispatchType (a :: Type) = (r :: Type) | r -> a where-  FieldResolverDispatchType (API.Field ksA t) = JustHandler (API.Field ksA t)-  FieldResolverDispatchType (API.Argument ksB (API.Enum name t) :> f) = EnumArgument (API.Argument ksB (API.Enum name t)) (FieldResolverDispatchType f)-  FieldResolverDispatchType (API.Argument ksC t :> f) = PlainArgument (API.Argument ksC t) (FieldResolverDispatchType f)---- | Derive the handler type from the Field/Argument type in a closed--- type family: We don't want anyone else to extend this ever.-type family FieldHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where-  FieldHandler m (JustHandler (API.Field ksD t)) = Handler m t-  FieldHandler m (PlainArgument (API.Argument ksE t) f) = t -> FieldHandler m f-  FieldHandler m (EnumArgument (API.Argument ksF (API.Enum name t)) f) = t -> FieldHandler m f--class BuildFieldResolver m fieldResolverType where-  buildFieldResolver :: FieldHandler m fieldResolverType -> Field Value -> Either ResolverError (m (Result Value))--instance forall ksG t m.-  ( KnownSymbol ksG, HasResolver m t, HasAnnotatedType t, Monad m-  ) => BuildFieldResolver m (JustHandler (API.Field ksG t)) where-  buildFieldResolver handler field = do-    pure (resolve @m @t handler (getSubSelectionSet field))--instance forall ksH t f m.-  ( KnownSymbol ksH-  , BuildFieldResolver m f-  , FromValue t-  , API.Defaultable t-  , HasAnnotatedInputType t-  , Monad m-  ) => BuildFieldResolver m (PlainArgument (API.Argument ksH t) f) where-  buildFieldResolver handler field = do-    argument <- first SchemaError (API.getArgumentDefinition @(API.Argument ksH t))-    let argName = getName argument-    value <- case lookupArgument field argName of-      Nothing -> valueMissing @t argName-      Just v -> first (InvalidValue argName) (fromValue @t v)-    buildFieldResolver @m @f (handler value) field--instance forall ksK t f m name.-  ( KnownSymbol ksK-  , BuildFieldResolver m f-  , KnownSymbol name-  , API.Defaultable t-  , API.GraphQLEnum t-  , Monad m-  ) => BuildFieldResolver m (EnumArgument (API.Argument ksK (API.Enum name t)) f) where-  buildFieldResolver handler field = do-    argName <- first SchemaError (nameFromSymbol @ksK)-    value <- case lookupArgument field argName of-      Nothing -> valueMissing @t argName-      Just (ValueEnum enum) -> first (InvalidValue argName) (API.enumFromValue @t enum)-      Just value -> Left (InvalidValue argName (show value <> " not an enum: " <> show (API.enumValues @t)))-    buildFieldResolver @m @f (handler value) field---- Note that we enumerate all ks variables with capital letters so we--- can figure out error messages like the following that don't come--- with line numbers:------        • No instance for (GHC.TypeLits.KnownSymbol ks0)---            arising from a use of ‘interpretAnonymousQuery’---- We only allow Field and Argument :> Field combinations:-type family RunFieldsType (m :: Type -> Type) (a :: [Type]) = (r :: Type) where-  RunFieldsType m '[API.Field ksI t] = API.Field ksI t-  RunFieldsType m '[a :> b] = a :> b-  RunFieldsType m ((API.Field ksJ t) ': rest) = API.Field ksJ t :<> RunFieldsType m rest-  RunFieldsType m ((a :> b) ': rest) = (a :> b) :<> RunFieldsType m rest-  RunFieldsType m a = TypeError (-    'Text "All field entries in an Object must be Field or Argument :> Field. Got: " ':<>: 'ShowType a)---- Match the three possible cases for Fields (see also RunFieldsType)-type family RunFieldsHandler (m :: Type -> Type) (a :: Type) = (r :: Type) where-  RunFieldsHandler m (f :<> fs) = FieldHandler m (FieldResolverDispatchType f) :<> RunFieldsHandler m fs-  RunFieldsHandler m (API.Field ksL t) = FieldHandler m (FieldResolverDispatchType (API.Field ksL t))-  RunFieldsHandler m (a :> b) = FieldHandler m (FieldResolverDispatchType (a :> b))-  RunFieldsHandler m a = TypeError (-    'Text "Unexpected RunFieldsHandler types: " ':<>: 'ShowType a)---class RunFields m a where-  -- | Run a single 'Selection' over all possible fields (as specified by the-  -- type @a@), returning exactly one 'GValue.ObjectField' when a field-  -- matches, or an error otherwise.-  ---  -- Individual implementations are responsible for calling 'runFields' if-  -- they haven't matched the field and there are still candidate fields-  -- within the handler.-  runFields :: RunFieldsHandler m a -> Field Value -> m ResolveFieldResult--instance forall f fs m dispatchType.-         ( BuildFieldResolver m dispatchType-         , dispatchType ~ FieldResolverDispatchType f-         , RunFields m fs-         , KnownSymbol (FieldName dispatchType)-         , Monad m-         ) => RunFields m (f :<> fs) where-  runFields (handler :<> nextHandlers) field =-    resolveField @dispatchType @m handler nextHandler field-    where-      nextHandler = runFields @m @fs nextHandlers field--instance forall ksM t m dispatchType.-         ( BuildFieldResolver m dispatchType-         , KnownSymbol ksM-         , dispatchType ~ FieldResolverDispatchType (API.Field ksM t)-         , Monad m-         ) => RunFields m (API.Field ksM t) where-  runFields handler field =-    resolveField @dispatchType @m handler nextHandler field-    where-      nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing)--instance forall m a b dispatchType.-         ( BuildFieldResolver m dispatchType-         , dispatchType ~ FieldResolverDispatchType (a :> b)-         , KnownSymbol (FieldName dispatchType)-         , Monad m-         ) => RunFields m (a :> b) where-  runFields handler field =-    resolveField @dispatchType @m handler nextHandler field-    where-      nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing)--instance forall typeName interfaces fields m.-         ( RunFields m (RunFieldsType m fields)-         , API.HasObjectDefinition (API.Object typeName interfaces fields)-         , Monad m-         ) => HasResolver m (API.Object typeName interfaces fields) where-  type Handler m (API.Object typeName interfaces fields) = m (RunFieldsHandler m (RunFieldsType m fields))--  resolve _ Nothing = throwE MissingSelectionSet-  resolve mHandler (Just selectionSet) =-    case getSelectionSet of-      Left err -> throwE err-      Right ss -> do-        -- Run the handler so the field resolvers have access to the object.-        -- This (and other places, including field resolvers) is where user-        -- code can do things like look up something in a database.-        handler <- mHandler-        r <- traverse (runFields @m @(RunFieldsType m fields) handler) ss-        let (Result errs obj)  = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r-        pure (Result errs (GValue.ValueObject obj))--    where-      getSelectionSet = do-        defn <- first SchemaError $ API.getDefinition @(API.Object typeName interfaces fields)-        -- Fields of a selection set may be behind "type conditions", due to-        -- inline fragments or the use of fragment spreads. These type-        -- conditions are represented in the schema by the name of a type-        -- (e.g. "Dog"). To determine which type conditions (and thus which-        -- fields) are relevant for this 1selection set, we need to look up the-        -- actual types they refer to, as interfaces (say) match objects-        -- differently than unions.-        ---        -- See <https://facebook.github.io/graphql/#sec-Field-Collection> for-        -- more details.-        (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet-        pure ss'---- TODO(tom): we're getting to a point where it might make sense to--- split resolver into submodules (GraphQL.Resolver.Union  etc.)----- | For unions we need a way to have type-safe, open sum types based--- on the possible 'API.Object's of a union. The following closed type--- family selects one Object from the union and returns the matching--- 'HasResolver' 'Handler' type. If the object @o@ is not a member of--- 'API.Union' then the user code won't compile.------ This type family is an implementation detail but its TypeError--- messages are visible at compile time.-type family TypeIndex (m :: Type -> Type) (object :: Type) (union :: Type) = (result :: Type) where-  TypeIndex m (API.Object name interfaces fields) (API.Union uName (API.Object name interfaces fields:_)) =-    Handler m (API.Object name interfaces fields)-  TypeIndex m (API.Object name interfaces fields) (API.Union uName (API.Object name' i' f':objects)) =-    TypeIndex m (API.Object name interfaces fields) (API.Union uName objects)-  -- Slightly nicer type errors:-  TypeIndex _ (API.Object name interfaces fields) (API.Union uName '[]) =-    TypeError ('Text "Type not found in union definition: " ':<>: 'ShowType (API.Object name interfaces fields))-  TypeIndex _ (API.Object name interfaces fields) x =-    TypeError ('Text "3rd type must be a union but it is: " ':<>: 'ShowType x)-  TypeIndex _ o _ =-    TypeError ('Text "Invalid TypeIndex. Must be Object but got: " ':<>: 'ShowType o)----- | The 'Handler' type of a 'API.Union' must be the same for all--- possible Objects, but each Object has a different type. We--- unsafeCoerce the return type into an Any, tagging it with the union--- and the underlying monad for type safety, but we elide the Object--- type itself. This way we can represent all 'Handler' types of the--- Union with a single type and still stay type-safe.-type role DynamicUnionValue representational representational-data DynamicUnionValue (union :: Type) (m :: Type -> Type) = DynamicUnionValue { _label :: Text, _value :: GHC.Exts.Any }--class RunUnion m union objects where-  runUnion :: DynamicUnionValue union m -> SelectionSetByType Value -> m (Result Value)--instance forall m union objects name interfaces fields.-  ( Monad m-  , KnownSymbol name-  , TypeIndex m (API.Object name interfaces fields) union ~ Handler m (API.Object name interfaces fields)-  , RunFields m (RunFieldsType m fields)-  , API.HasObjectDefinition (API.Object name interfaces fields)-  , RunUnion m union objects-  ) => RunUnion m union (API.Object name interfaces fields:objects) where-  runUnion duv selectionSet =-    case extractUnionValue @(API.Object name interfaces fields) @union @m duv of-      Just handler -> resolve @m @(API.Object name interfaces fields) handler (Just selectionSet)-      Nothing -> runUnion @m @union @objects duv selectionSet---- AFAICT it should not be possible to ever hit the empty case because--- the compiler doesn't allow constructing a unionValue that's not in--- the Union. If the following code ever gets executed it's almost--- certainly a bug in the union code.------ We still need to implement this instance for the compiler because--- it exhaustively checks all cases when deconstructs the Union.-instance forall m union. RunUnion m union '[] where-  runUnion (DynamicUnionValue label _) selection =-    panic ("Unexpected branch in runUnion, got " <> show selection <> " for label " <> label <> ". Please file a bug.")--instance forall m unionName objects.-  ( Monad m-  , KnownSymbol unionName-  , RunUnion m (API.Union unionName objects) objects-  ) => HasResolver m (API.Union unionName objects) where-  type Handler m (API.Union unionName objects) = m (DynamicUnionValue (API.Union unionName objects) m)-  resolve _ Nothing = throwE MissingSelectionSet-  resolve mHandler (Just selectionSet) = do-    duv <- mHandler-    runUnion @m @(API.Union unionName objects) @objects duv selectionSet--symbolText :: forall ks. KnownSymbol ks => Text-symbolText = toS (symbolVal @ks Proxy)---- | Translate a 'Handler' into a DynamicUnionValue type required by--- 'Union' handlers. This is dynamic, but nevertheless type-safe--- because we can only tag with types that are part of the union.------ Use e.g. like "unionValue @Cat" if you have an object like this:------ >>> type Cat = API.Object "Cat" '[] '[API.Field "name" Text]------ and then use `unionValue @Cat (pure (pure "Felix"))`. See--- `examples/UnionExample.hs` for more code.-unionValue ::-  forall (object :: Type) (union :: Type) m (name :: Symbol) interfaces fields.-  (Monad m, API.Object name interfaces fields ~ object, KnownSymbol name)-  => TypeIndex m object union -> m (DynamicUnionValue union m)-unionValue x =-  -- TODO(tom) - we might want to move to Typeable `cast` for uValue-  -- instead of doing our own unsafeCoerce because it comes with-  -- additional safety guarantees: Typerep is unforgeable, while we-  -- can still into a bad place by matching on name only. We can't-  -- actually segfault this because right now we walk the list of-  -- objects in a union left-to-right so in case of duplicate names we-  -- only every see one type. That doesn't seen like a great thing to-  -- rely on though!--  -- Note that unsafeCoerce is safe because we index the type from the-  -- union with an 'API.Object' whose name we're storing in label. On-  -- the way out we check that the name is the same, and we know the-  -- type universe is the same because we annotated DynamicUnionValue-  -- with the type universe.-  pure (DynamicUnionValue (symbolText @name) (unsafeCoerce x))--extractUnionValue ::-  forall (object :: Type) (union :: Type) m (name :: Symbol) interfaces fields.-  (API.Object name interfaces fields ~ object, KnownSymbol name)-  => DynamicUnionValue union m -> Maybe (TypeIndex m object union)-extractUnionValue (DynamicUnionValue uName uValue) =-  if uName == symbolText @name-  then Just (unsafeCoerce uValue)-  else Nothing

@@ -1,14 +1,5 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}+-- | Description: Literal GraphQL values {-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}---- | Literal GraphQL values. module GraphQL.Value   ( Value   , Value'(..)@@ -46,321 +37,47 @@   , unionObjects     -- ** Querying   , objectFields+    -- * Converting to and from Value+  , ToValue(..)+  , FromValue(..)   ) where -import Protolude--import qualified Data.Aeson as Aeson-import Data.Aeson (ToJSON(..), (.=), pairs)-import qualified Data.Map as Map-import Test.QuickCheck (Arbitrary(..), Gen, oneof, listOf, sized)--import GraphQL.Internal.Arbitrary (arbitraryText)-import GraphQL.Internal.Name (Name(..), NameError(..), makeName)-import GraphQL.Internal.Syntax.AST (Variable)-import qualified GraphQL.Internal.Syntax.AST as AST-import GraphQL.Internal.OrderedMap (OrderedMap)-import qualified GraphQL.Internal.OrderedMap as OrderedMap---- * Values---- | A GraphQL value. @scalar@ represents the type of scalar that's contained--- within this value.------ Normally, it is one of either 'ConstScalar' (to indicate that there are no--- variables whatsoever) or 'VariableScalar' (to indicate that there might be--- some variables).-data Value' scalar-  = ValueScalar' scalar-  | ValueList' (List' scalar)-  | ValueObject' (Object' scalar)-  deriving (Eq, Ord, Show, Functor)--instance Foldable Value' where-  foldMap f (ValueScalar' scalar) = f scalar-  foldMap f (ValueList' values) = foldMap f values-  foldMap f (ValueObject' obj) = foldMap f obj--instance Traversable Value' where-  traverse f (ValueScalar' x) = ValueScalar' <$> f x-  traverse f (ValueList' xs) = ValueList' <$> traverse f xs-  traverse f (ValueObject' xs) = ValueObject' <$> traverse f xs--instance ToJSON scalar => ToJSON (Value' scalar) where-  toJSON (ValueScalar' x) = toJSON x-  toJSON (ValueList' x) = toJSON x-  toJSON (ValueObject' x) = toJSON x--instance Arbitrary scalar => Arbitrary (Value' scalar) where-  -- | Generate an arbitrary value. Uses the generator's \"size\" property to-  -- determine maximum object depth.-  arbitrary = sized genValue---- | Generate an arbitrary value, with objects at most @n@ levels deep.-genValue :: Arbitrary scalar => Int -> Gen (Value' scalar)-genValue n-  | n <= 0 = arbitrary-  | otherwise = oneof [ ValueScalar' <$> arbitrary-                      , ValueObject' <$> genObject (n - 1)-                      , ValueList' . List' <$> listOf (genValue (n - 1))-                      ]---- | A GraphQL value which contains no variables.-type Value = Value' ConstScalar---- TODO: These next two definitions are quite internal. We should move this--- module to Internal and then re-export the bits that end-users will use.--- <https://github.com/jml/graphql-api/issues/99>---- | A GraphQL value which might contain some variables. These variables are--- not yet associated with--- <https://facebook.github.io/graphql/#VariableDefinition variable--- definitions> (see also 'GraphQL.Internal.Validation.VariableDefinition'),--- which are provided in a different context.-type UnresolvedVariableValue = Value' UnresolvedVariableScalar--pattern ValueInt :: Int32 -> Value-pattern ValueInt x = ValueScalar' (ConstInt x)--pattern ValueFloat :: Double -> Value-pattern ValueFloat x = ValueScalar' (ConstFloat x)--pattern ValueBoolean :: Bool -> Value-pattern ValueBoolean x = ValueScalar' (ConstBoolean x)--pattern ValueString :: String -> Value-pattern ValueString x = ValueScalar' (ConstString x)--pattern ValueEnum :: Name -> Value-pattern ValueEnum x = ValueScalar' (ConstEnum x)--pattern ValueList :: forall t. List' t -> Value' t-pattern ValueList x = ValueList' x--pattern ValueObject :: forall t. Object' t -> Value' t-pattern ValueObject x = ValueObject' x--pattern ValueNull :: Value-pattern ValueNull = ValueScalar' ConstNull---- | If a value is an object, return just that. Otherwise @Nothing@.-toObject :: Value' scalar -> Maybe (Object' scalar)-toObject (ValueObject' o) = pure o-toObject _ = empty---- * Scalars---- | A non-variable value which contains no other values.-data ConstScalar-  = ConstInt Int32-  | ConstFloat Double-  | ConstBoolean Bool-  | ConstString String-  | ConstEnum Name-  | ConstNull-  deriving (Eq, Ord, Show)--instance ToJSON ConstScalar where-  toJSON (ConstInt x) = toJSON x-  toJSON (ConstFloat x) = toJSON x-  toJSON (ConstBoolean x) = toJSON x-  toJSON (ConstString x) = toJSON x-  toJSON (ConstEnum x) = toJSON x-  toJSON ConstNull = Aeson.Null---- | A value which contains no other values, and might be a variable that--- might lack a definition.-type UnresolvedVariableScalar = Either Variable ConstScalar---- | Generate an arbitrary scalar value.-instance Arbitrary ConstScalar where-  arbitrary = oneof [ ConstInt <$> arbitrary-                    , ConstFloat <$> arbitrary-                    , ConstBoolean <$> arbitrary-                    , ConstString <$> arbitrary-                    , ConstEnum <$> arbitrary-                    , pure ConstNull-                    ]---- | Convert a constant scalar to an AST.Value-constScalarToAST :: ConstScalar -> AST.Value-constScalarToAST scalar =-  case scalar of-    ConstInt x -> AST.ValueInt x-    ConstFloat x -> AST.ValueFloat x-    ConstBoolean x -> AST.ValueBoolean x-    ConstString (String x) -> AST.ValueString (AST.StringValue x)-    ConstEnum x -> AST.ValueEnum x-    ConstNull -> AST.ValueNull---- | Convert a variable scalar to an AST.Value-variableToAST :: UnresolvedVariableScalar -> AST.Value-variableToAST (Left variable) = AST.ValueVariable variable-variableToAST (Right constant) = constScalarToAST constant---- | Convert a value from the AST into a variable scalar, presuming it /is/ a--- scalar.-astToScalar :: AST.Value -> Maybe UnresolvedVariableScalar-astToScalar (AST.ValueInt x) = pure $ Right $ ConstInt x-astToScalar (AST.ValueFloat x) = pure $ Right $ ConstFloat x-astToScalar (AST.ValueBoolean x) = pure $ Right $ ConstBoolean x-astToScalar (AST.ValueString (AST.StringValue x)) = pure $ Right $ ConstString (String x)-astToScalar (AST.ValueEnum x) = pure $ Right $ ConstEnum x-astToScalar AST.ValueNull = pure $ Right ConstNull-astToScalar (AST.ValueVariable x) = pure $ Left x-astToScalar _ = empty----- * Strings--newtype String = String Text deriving (Eq, Ord, Show)--instance Arbitrary String where-  arbitrary = String <$> arbitraryText--instance ToJSON String where-  toJSON (String x) = toJSON x---- * Lists--newtype List' scalar = List' [Value' scalar] deriving (Eq, Ord, Show, Functor)--instance Foldable List' where-  foldMap f (List' values) = mconcat (map (foldMap f) values)--instance Traversable List' where-  traverse f (List' xs) = List' <$> traverse (traverse f) xs----- | A list of values that are known to be constants.------ Note that this list might not be valid GraphQL, because GraphQL only allows--- homogeneous lists (i.e. all elements of the same type), and we do no type--- checking at this point.-type List = List' ConstScalar--instance Arbitrary scalar => Arbitrary (List' scalar) where-  -- TODO: GraphQL does not allow heterogeneous lists:-  -- https://facebook.github.io/graphql/#sec-Lists, so this will generate-  -- invalid lists.-  arbitrary = List' <$> listOf arbitrary---instance ToJSON scalar => ToJSON (List' scalar) where-  toJSON (List' x) = toJSON x---- * Objects---- | A GraphQL object.------ Note that https://facebook.github.io/graphql/#sec-Response calls these--- \"Maps\", but everywhere else in the spec refers to them as objects.-newtype Object' scalar = Object' (OrderedMap Name (Value' scalar)) deriving (Eq, Ord, Show, Functor)--instance Foldable Object' where-  foldMap f (Object' fieldMap) = foldMap (foldMap f) fieldMap--instance Traversable Object' where-  traverse f (Object' xs) = Object' <$> traverse (traverse f) xs---- | A GraphQL object that contains only non-variable values.-type Object = Object' ConstScalar--objectFields :: Object' scalar -> [ObjectField' scalar]-objectFields (Object' object) = map (uncurry ObjectField') (OrderedMap.toList object)--instance Arbitrary scalar => Arbitrary (Object' scalar) where-  arbitrary = sized genObject---- | Generate an arbitrary object to the given maximum depth.-genObject :: Arbitrary scalar => Int -> Gen (Object' scalar)-genObject n = Object' <$> OrderedMap.genOrderedMap arbitrary (genValue n)--data ObjectField' scalar = ObjectField' Name (Value' scalar) deriving (Eq, Ord, Show, Functor)---- | A field of an object that has a non-variable value.-type ObjectField = ObjectField' ConstScalar--pattern ObjectField :: forall t. Name -> Value' t -> ObjectField' t-pattern ObjectField name value = ObjectField' name value--instance Arbitrary scalar => Arbitrary (ObjectField' scalar) where-  arbitrary = ObjectField' <$> arbitrary <*> arbitrary---- | Make an object from a list of object fields.-makeObject :: [ObjectField' scalar] -> Maybe (Object' scalar)-makeObject fields = objectFromList [(name, value) | ObjectField' name value <- fields]---- | Make an object from an ordered map.-objectFromOrderedMap :: OrderedMap Name (Value' scalar) -> Object' scalar-objectFromOrderedMap = Object'---- | Create an object from a list of (name, value) pairs.-objectFromList :: [(Name, Value' scalar)] -> Maybe (Object' scalar)-objectFromList xs = Object' <$> OrderedMap.orderedMap xs--unionObjects :: [Object' scalar] -> Maybe (Object' scalar)-unionObjects objects = Object' <$> OrderedMap.unions [obj | Object' obj <- objects]--instance ToJSON scalar => ToJSON (Object' scalar) where-  -- Direct encoding to preserve order of keys / values-  toJSON (Object' xs) = toJSON (Map.fromList [(unName k, v) | (k, v) <- OrderedMap.toList xs])-  toEncoding (Object' xs) = pairs (foldMap (\(k, v) -> toS (unName k) .= v) (OrderedMap.toList xs))------- * Conversion to and from AST.---- | Convert an AST value into a literal value.------ This is a stop-gap until we have proper conversion of user queries into--- canonical forms.-astToValue' :: (AST.Value -> scalar) -> AST.Value -> Maybe (Value' scalar)-astToValue' f x@(AST.ValueInt _) = pure (ValueScalar' (f x))-astToValue' f x@(AST.ValueFloat _) = pure (ValueScalar' (f x))-astToValue' f x@(AST.ValueBoolean _) = pure (ValueScalar' (f x))-astToValue' f x@(AST.ValueString (AST.StringValue _)) = pure (ValueScalar' (f x))-astToValue' f x@(AST.ValueEnum _) = pure (ValueScalar' (f x))-astToValue' f AST.ValueNull = pure (ValueScalar' (f AST.ValueNull))-astToValue' f x@(AST.ValueVariable _) = pure (ValueScalar' (f x))-astToValue' f (AST.ValueList (AST.ListValue xs)) = ValueList' . List' <$> traverse (astToValue' f) xs-astToValue' f (AST.ValueObject (AST.ObjectValue fields)) = do-  fields' <- traverse toObjectField fields-  object <- makeObject fields'-  pure (ValueObject' object)-  where-    toObjectField (AST.ObjectField name value) = ObjectField' name <$> astToValue' f value---- | Convert an AST value to a variable value.------ Will fail if the AST value contains duplicate object fields, or is--- otherwise invalid.-astToVariableValue :: HasCallStack => AST.Value -> Maybe UnresolvedVariableValue-astToVariableValue ast = astToValue' convertScalar ast-  where-    convertScalar x =-      case astToScalar x of-        Just scalar -> scalar-        Nothing -> panic ("Non-scalar passed to convertScalar, bug in astToValue': " <> show x)---- | Convert a value to an AST value.-valueToAST :: Value -> AST.Value-valueToAST = valueToAST' constScalarToAST---- | Convert a variable value to an AST value.-variableValueToAST :: UnresolvedVariableValue -> AST.Value-variableValueToAST = valueToAST' variableToAST---- | Convert a literal value into an AST value.------ Nulls are converted into Nothing.------ This function probably isn't particularly useful, but it functions as a--- stop-gap until we have QuickCheck generators for the AST.-valueToAST' :: (scalar -> AST.Value) -> Value' scalar -> AST.Value-valueToAST' f (ValueScalar' x) = f x-valueToAST' f (ValueList' (List' xs)) = AST.ValueList (AST.ListValue (map (valueToAST' f) xs))-valueToAST' f (ValueObject' (Object' fields)) = AST.ValueObject (AST.ObjectValue (map toObjectField (OrderedMap.toList fields)))-  where-    toObjectField (name, value) = AST.ObjectField name (valueToAST' f value)+import GraphQL.Internal.Value+  ( Value+  , Value'(..)+  , ConstScalar+  , UnresolvedVariableValue+  , pattern ValueInt+  , pattern ValueFloat+  , pattern ValueBoolean+  , pattern ValueString+  , pattern ValueEnum+  , pattern ValueList+  , pattern ValueObject+  , pattern ValueNull+  , toObject+  , valueToAST+  , astToVariableValue+  , variableValueToAST+  , List+  , List'(..)+  , String(..)+  , Name(..)+  , NameError(..)+  , makeName+  , Object+  , Object'(..)+  , ObjectField+  , ObjectField'(ObjectField)+  , makeObject+  , objectFromList+  , objectFromOrderedMap+  , unionObjects+  , objectFields+  )+import GraphQL.Internal.Value.FromValue+  ( FromValue(..)+  )+import GraphQL.Internal.Value.ToValue+  ( ToValue(..)+  )

@@ -1,135 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE AllowAmbiguousTypes #-}---- | Literal GraphQL values.-module GraphQL.Value.FromValue-  ( FromValue(..)-  , prop_roundtripValue-  , wrongType-  ) where--import Protolude hiding (TypeError)-import GraphQL.Internal.Name (nameFromSymbol)-import qualified GraphQL.Internal.OrderedMap as OM-import GraphQL.Value-import GraphQL.Value.ToValue (ToValue(..))-import qualified Data.List.NonEmpty as NonEmpty-import Data.List.NonEmpty (NonEmpty)-import GHC.Generics ((:*:)(..))-import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..))-import GHC.Types (Type)---- * FromValue---- | @a@ can be converted from a GraphQL 'Value' to a Haskell value.------ The @FromValue@ instance converts 'AST.Value' to the type expected by the--- handler function. It is the boundary between incoming data and your custom--- application Haskell types.------ @FromValue@ has a generic instance for converting input objects to--- records.-class FromValue a where-  -- | Convert an already-parsed value into a Haskell value, generally to be-  -- passed to a handler.-  fromValue :: Value' ConstScalar -> Either Text a-  default fromValue :: (Generic a, GenericFromValue (Rep a)) => Value' ConstScalar -> Either Text a-  fromValue (ValueObject v) = to <$> genericFromValue v-  fromValue v = wrongType "genericFromValue only works with objects." v--instance FromValue Int32 where-  fromValue (ValueInt v) = pure v-  fromValue v = wrongType "Int" v--instance FromValue Double where-  fromValue (ValueFloat v) = pure v-  fromValue v = wrongType "Double" v--instance FromValue Bool where-  fromValue (ValueBoolean v) = pure v-  fromValue v = wrongType "Bool" v--instance FromValue Text where-  fromValue (ValueString (String v)) = pure v-  fromValue v = wrongType "String" v--instance forall v. FromValue v => FromValue [v] where-  fromValue (ValueList' (List' values)) = traverse (fromValue @v) values-  fromValue v = wrongType "List" v--instance forall v. FromValue v => FromValue (NonEmpty v) where-  fromValue (ValueList' (List' values)) =-    case NonEmpty.nonEmpty values of-      Nothing -> Left "Cannot construct NonEmpty from empty list"-      Just values' -> traverse (fromValue @v) values'-  fromValue v = wrongType "List" v--instance forall v. FromValue v => FromValue (Maybe v) where-  fromValue ValueNull = pure Nothing-  fromValue x = Just <$> fromValue @v x---- | Anything that can be converted to a value and from a value should roundtrip.-prop_roundtripValue :: forall a. (Eq a, ToValue a, FromValue a) => a -> Bool-prop_roundtripValue x = fromValue (toValue x) == Right x---- | Throw an error saying that @value@ does not have the @expected@ type.-wrongType :: (MonadError Text m, Show a) => Text -> a -> m b-wrongType expected value = throwError ("Wrong type, should be: `" <> expected <> "` but is: `" <> show value <> "`")---- We only allow generic record reading for now because I am not sure--- how we should interpret any other generic things (e.g. tuples).-class GenericFromValue (f :: Type -> Type) where-  genericFromValue :: Object' ConstScalar -> Either Text (f p)--instance forall dataName consName records s l p.-  ( KnownSymbol dataName-  , KnownSymbol consName-  , GenericFromValue records-  ) => GenericFromValue (D1 ('MetaData dataName s l 'False)-                         (C1 ('MetaCons consName p 'True) records-                         )) where-  genericFromValue o = M1 . M1 <$> genericFromValue @records o--instance forall wrappedType fieldName rest u s l.-  ( KnownSymbol fieldName-  , FromValue wrappedType-  , GenericFromValue rest-  ) => GenericFromValue (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType) :*: rest) where-  genericFromValue object = do-    l <- getValue @wrappedType @fieldName object-    r <- genericFromValue @rest object-    pure (l :*: r)---- | 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 (Object' fieldMap) = do-  fieldName <- case nameFromSymbol @fieldName of-    Left err -> throwError ("invalid field name" <> show err)-    Right name' -> pure name'-   -- TODO(tom): How do we deal with optional fields? Maybe sounds-   -- like the correct type, but how would Maybe be different from-   -- `null`? Delegating to FromValue not good enough here because of-   -- the dictionary lookup.-  case OM.lookup fieldName fieldMap of-    Nothing -> throwError ("Key not found: " <> show fieldName)-    Just v -> M1 . K1 <$> fromValue @wrappedType v--instance forall wrappedType fieldName u s l.-  ( KnownSymbol fieldName-  , FromValue wrappedType-  ) => GenericFromValue (S1 ('MetaSel ('Just fieldName) u s l) (Rec0 wrappedType)) where-  genericFromValue = getValue @wrappedType @fieldName--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 = panic "genericFromValue cannot be called for records with more than one data constructor. Code that tries will not be compiled."

@@ -1,57 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module GraphQL.Value.ToValue-  ( ToValue(..)-  ) where--import Protolude-import GraphQL.Value-import Data.List.NonEmpty (NonEmpty)---- * ToValue---- | Turn a Haskell value into a GraphQL value.-class ToValue a where-  toValue :: a -> Value' ConstScalar--instance ToValue (Value' ConstScalar) where-  toValue = identity---- XXX: Should this just be for Foldable?-instance ToValue a => ToValue [a] where-  toValue = toValue . List' . map toValue---- TODO - tom still thinks that using Maybe for nullable is maybe not--- the best idea. <https://github.com/jml/graphql-api/issues/100>-instance ToValue a => ToValue (Maybe a) where-  toValue Nothing = ValueNull-  toValue (Just v) = toValue v--instance ToValue a => ToValue (NonEmpty a) where-  toValue = toValue . makeList--instance ToValue Bool where-  toValue = ValueBoolean--instance ToValue Int32 where-  toValue = ValueInt--instance ToValue Double where-  toValue = ValueFloat--instance ToValue String where-  toValue = ValueString---- XXX: Make more generic: any string-like thing rather than just Text.-instance ToValue Text where-  toValue = toValue . String--instance ToValue List where-  toValue = ValueList'--instance ToValue (Object' ConstScalar) where-  toValue = ValueObject'---makeList :: (Functor f, Foldable f, ToValue a) => f a -> List-makeList = List' . Protolude.toList . map toValue

@@ -0,0 +1,317 @@+{-# LANGUAGE QuasiQuotes #-}++-- | Tests for AST, including parser and encoder.+module ASTSpec (spec) where++import Protolude++import Data.Attoparsec.Text (parseOnly)+import Text.RawString.QQ (r)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (arbitrary, forAll, resize)+import Test.Hspec++import GraphQL.Value (String(..))+import GraphQL.Internal.Name (Name)+import qualified GraphQL.Internal.Syntax.AST as AST+import qualified GraphQL.Internal.Syntax.Parser as Parser+import qualified GraphQL.Internal.Syntax.Encoder as Encoder++kitchenSink :: Text+kitchenSink = "query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:\"value\"})}\n"++dog :: Name+dog = "dog"++someName :: Name+someName = "name"++spec :: Spec+spec = describe "AST" $ do+  describe "Parser and encoder" $ do+    it "roundtrips on minified documents" $ do+      let actual = Encoder.queryDocument <$> parseOnly Parser.queryDocument kitchenSink+      actual `shouldBe` Right kitchenSink+    describe "parsing numbers" $ do+      it "works for some integers" $ do+        parseOnly Parser.value "1" `shouldBe` Right (AST.ValueInt 1)+      prop "works for all integers" $ do+        \x -> parseOnly Parser.value (show x) == Right (AST.ValueInt x)+      it "works for some floats" $ do+        parseOnly Parser.value "1.5" `shouldBe` Right (AST.ValueFloat 1.5)+      it "treats floats as floats even if they end with .0" $ do+        parseOnly Parser.value "0.0" `shouldBe` Right (AST.ValueFloat 0.0)+      prop "works for floats" $ do+        \x -> parseOnly Parser.value (show x) == Right (AST.ValueFloat x)+    describe "strings" $ do+      prop "works for all strings" $ do+        \(String x) ->+          let input = AST.ValueString (AST.StringValue x)+              output = Encoder.value input in+          parseOnly Parser.value output == Right input+      it "handles unusual strings" $ do+        let input = AST.ValueString (AST.StringValue "\fh\244")+        let output = Encoder.value input+        -- \f is \u000c+        output `shouldBe` "\"\\u000ch\244\""+        parseOnly Parser.value output `shouldBe` Right input+    describe "parsing values" $ do+      prop "works for all literal values" $ do+        forAll (resize 3 arbitrary) $ \x -> parseOnly Parser.value (Encoder.value x) `shouldBe` Right x+      it "parses ununusual objects" $ do+        let input = AST.ValueObject+                    (AST.ObjectValue+                     [ AST.ObjectField "s"+                       (AST.ValueString (AST.StringValue "\224\225v^6{FPDk\DC3\a")),+                       AST.ObjectField "Hsr" (AST.ValueInt 0)+                     ])+        let output = Encoder.value input+        parseOnly Parser.value output `shouldBe` Right input+      it "parses lists of floats" $ do+        let input = AST.ValueList+                      (AST.ListValue+                       [ AST.ValueFloat 1.5+                       , AST.ValueFloat 1.5+                       ])+        let output = Encoder.value input+        output `shouldBe` "[1.5,1.5]"+        parseOnly Parser.value output `shouldBe` Right input+  describe "Parser" $ do+    it "parses shorthand syntax documents" $ do+      let query = [r|{+                       dog {+                         name+                       }+                     }|]+      let Right parsed = parseOnly Parser.queryDocument query+      let expected = AST.QueryDocument+                     [ AST.DefinitionOperation+                       (AST.AnonymousQuery+                         [ AST.SelectionField+                           (AST.Field Nothing dog [] []+                             [ AST.SelectionField (AST.Field Nothing someName [] [] [])+                             ])+                         ])+                     ]+      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 "errors on missing selection set" $ do+      let query = [r|query {+                       dog {+                         +                       }+                     }|]+      let Left parsed = parseOnly Parser.queryDocument query+      -- this is not very explicit+      parsed `shouldBe` "query document error! > definition error!: string"++    it "parses invalid documents" $ do+      let query = [r|{+                       dog {+                         name+                       }+                     }++                     query getName {+                       dog {+                         owner {+                           name+                         }+                       }+                     }|]+      let Right parsed = parseOnly Parser.queryDocument query+      let expected = AST.QueryDocument+                     [ AST.DefinitionOperation+                       (AST.AnonymousQuery+                         [ AST.SelectionField+                           (AST.Field Nothing dog [] []+                             [ AST.SelectionField (AST.Field Nothing someName [] [] [])+                             ])+                         ])+                     , AST.DefinitionOperation+                       (AST.Query+                        (AST.Node (pure "getName") [] []+                         [ AST.SelectionField+                           (AST.Field Nothing dog [] []+                            [ AST.SelectionField+                              (AST.Field Nothing "owner" [] []+                               [ AST.SelectionField (AST.Field Nothing someName [] [] [])+                               ])+                            ])+                         ]))+                     ]+      parsed `shouldBe` expected++    it "includes variable definitions" $ do+      let query = [r|+                    query houseTrainedQuery($atOtherHomes: Boolean = true) {+                      dog {+                        isHousetrained(atOtherHomes: $atOtherHomes)+                      }+                    }+                    |]+      let Right parsed = parseOnly Parser.queryDocument query+      let expected = AST.QueryDocument+                     [ AST.DefinitionOperation+                         (AST.Query+                           (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"))+                                (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 variable annotation" $ do+      let query = [r|+                    query ($atOtherHomes: [Home!]) {+                      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.TypeList +                                  (AST.ListType +                                    (AST.TypeNonNull+                                      (AST.NonNullTypeNamed (AST.NamedType "Home"))+                                    )+                                  )+                                )+                                Nothing+                            ] []+                            [ 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 inline argument (List, Object, Enum, String, Number)" $ do+      -- keys are not quoted for inline objects+      let query = [r|+                    query {+                      dog {+                        isHousetrained(atOtherHomes: [{testKey: 123, anotherKey: "string"}])+                      }+                    }+                    |]+      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 "isHousetrained"+                                      [ AST.Argument "atOtherHomes"+                                          (AST.ValueList (AST.ListValue [+                                            (AST.ValueObject (AST.ObjectValue [+                                              (AST.ObjectField "testKey" (AST.ValueInt 123)),+                                              (AST.ObjectField "anotherKey" (AST.ValueString (AST.StringValue "string")))+                                            ]))+                                          ]))+                                      ] [] [])+                                 ])+                            ]))+                     ]+      parsed `shouldBe` expected+    it "parses anonymous query with fragment" $ do+      -- keys are not quoted for inline objects+      let query = [r|+                    fragment dogTest on Dog {+                      name+                    }+                    query {+                      dog {+                        ...dogTest+                      }+                    }+                    |]+      let Right parsed = parseOnly Parser.queryDocument query+      let expected = AST.QueryDocument+                     [(AST.DefinitionFragment (AST.FragmentDefinition "dogTest"+                        (AST.NamedType "Dog") [] [+                          AST.SelectionField (AST.Field Nothing "name" [] [] [])+                        ])),+                        (AST.DefinitionOperation+                         (AST.Query+                           (AST.Node Nothing+                            [] []+                            [AST.SelectionField+                              (AST.Field Nothing dog [] []+                                [AST.SelectionFragmentSpread (AST.FragmentSpread "dogTest" [])+                                ])    +                            ])))+                     ]+      parsed `shouldBe` expected

@@ -1,213 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}---- | Tests for AST, including parser and encoder.-module ASTTests (tests) where--import Protolude--import Data.Attoparsec.Text (parseOnly)-import Text.RawString.QQ (r)-import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck (arbitrary, forAll, resize)-import Test.Tasty (TestTree)-import Test.Tasty.Hspec (testSpec, describe, it, shouldBe)--import GraphQL.Value (String(..))-import GraphQL.Internal.Name (Name)-import qualified GraphQL.Internal.Syntax.AST as AST-import qualified GraphQL.Internal.Syntax.Parser as Parser-import qualified GraphQL.Internal.Syntax.Encoder as Encoder--kitchenSink :: Text-kitchenSink = "query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:\"value\"})}\n"--dog :: Name-dog = "dog"--someName :: Name-someName = "name"--tests :: IO TestTree-tests = testSpec "AST" $ do-  describe "Parser and encoder" $ do-    it "roundtrips on minified documents" $ do-      let actual = Encoder.queryDocument <$> parseOnly Parser.queryDocument kitchenSink-      actual `shouldBe` Right kitchenSink-    describe "parsing numbers" $ do-      it "works for some integers" $ do-        parseOnly Parser.value "1" `shouldBe` Right (AST.ValueInt 1)-      prop "works for all integers" $ do-        \x -> parseOnly Parser.value (show x) == Right (AST.ValueInt x)-      it "works for some floats" $ do-        parseOnly Parser.value "1.5" `shouldBe` Right (AST.ValueFloat 1.5)-      it "treats floats as floats even if they end with .0" $ do-        parseOnly Parser.value "0.0" `shouldBe` Right (AST.ValueFloat 0.0)-      prop "works for floats" $ do-        \x -> parseOnly Parser.value (show x) == Right (AST.ValueFloat x)-    describe "strings" $ do-      prop "works for all strings" $ do-        \(String x) ->-          let input = AST.ValueString (AST.StringValue x)-              output = Encoder.value input in-          parseOnly Parser.value output == Right input-      it "handles unusual strings" $ do-        let input = AST.ValueString (AST.StringValue "\fh\244")-        let output = Encoder.value input-        -- \f is \u000c-        output `shouldBe` "\"\\u000ch\244\""-        parseOnly Parser.value output `shouldBe` Right input-    describe "parsing values" $ do-      prop "works for all literal values" $ do-        forAll (resize 3 arbitrary) $ \x -> parseOnly Parser.value (Encoder.value x) `shouldBe` Right x-      it "parses ununusual objects" $ do-        let input = AST.ValueObject-                    (AST.ObjectValue-                     [ AST.ObjectField "s"-                       (AST.ValueString (AST.StringValue "\224\225v^6{FPDk\DC3\a")),-                       AST.ObjectField "Hsr" (AST.ValueInt 0)-                     ])-        let output = Encoder.value input-        parseOnly Parser.value output `shouldBe` Right input-      it "parses lists of floats" $ do-        let input = AST.ValueList-                      (AST.ListValue-                       [ AST.ValueFloat 1.5-                       , AST.ValueFloat 1.5-                       ])-        let output = Encoder.value input-        output `shouldBe` "[1.5,1.5]"-        parseOnly Parser.value output `shouldBe` Right input-  describe "Parser" $ do-    it "parses shorthand syntax documents" $ do-      let query = [r|{-                       dog {-                         name-                       }-                     }|]-      let Right parsed = parseOnly Parser.queryDocument query-      let expected = AST.QueryDocument-                     [ AST.DefinitionOperation-                       (AST.AnonymousQuery-                         [ AST.SelectionField-                           (AST.Field Nothing dog [] []-                             [ AST.SelectionField (AST.Field Nothing someName [] [] [])-                             ])-                         ])-                     ]-      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 {-                         name-                       }-                     }--                     query getName {-                       dog {-                         owner {-                           name-                         }-                       }-                     }|]-      let Right parsed = parseOnly Parser.queryDocument query-      let expected = AST.QueryDocument-                     [ AST.DefinitionOperation-                       (AST.AnonymousQuery-                         [ AST.SelectionField-                           (AST.Field Nothing dog [] []-                             [ AST.SelectionField (AST.Field Nothing someName [] [] [])-                             ])-                         ])-                     , AST.DefinitionOperation-                       (AST.Query-                        (AST.Node (pure "getName") [] []-                         [ AST.SelectionField-                           (AST.Field Nothing dog [] []-                            [ AST.SelectionField-                              (AST.Field Nothing "owner" [] []-                               [ AST.SelectionField (AST.Field Nothing someName [] [] [])-                               ])-                            ])-                         ]))-                     ]-      parsed `shouldBe` expected--    it "includes variable definitions" $ do-      let query = [r|-                    query houseTrainedQuery($atOtherHomes: Boolean = true) {-                      dog {-                        isHousetrained(atOtherHomes: $atOtherHomes)-                      }-                    }-                    |]-      let Right parsed = parseOnly Parser.queryDocument query-      let expected = AST.QueryDocument-                     [ AST.DefinitionOperation-                         (AST.Query-                           (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"))-                                (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

@@ -0,0 +1,484 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeOperators #-}+-- | Tests that span the entire system.+--+-- These tests function both as examples of how to use the API, as well as+-- sanity checks on our reasoning.+module EndToEndSpec (spec) where++import Protolude++import Data.Aeson (Value(Null), toJSON, object, (.=))+import qualified Data.Map as Map+import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery)+import GraphQL.API (Object, Field, List, Argument, (:>), Defaultable(..), HasAnnotatedInputType(..))+import GraphQL.Internal.Syntax.AST (Variable(..))+import GraphQL.Resolver ((:<>)(..), Handler, unionValue, returns)+import GraphQL.Value (ToValue(..), FromValue(..), makeName)+import Test.Hspec+import Text.RawString.QQ (r)++import ExampleSchema++-- | Example query root.+--+-- @+-- type QueryRoot {+--   dog: Dog+--   describeDog(dog: DEFAULT): String+-- }+-- @+--+-- Drawn from <https://facebook.github.io/graphql/#sec-Validation>.+type QueryRoot = Object "QueryRoot" '[]+  '[ Field "dog" Dog+   , Argument "dog" DogStuff :> Field "describeDog" Text+   , Field "catOrDog" CatOrDog+   , Field "catOrDogList" (List CatOrDog)+   ]++-- | An object that is passed as an argument. i.e. an input object.+--+-- TODO: Ideally this would be Dog itself, or ServerDog at worst.+-- Unfortunately, jml cannot figure out how to do that.+data DogStuff = DogStuff { toy :: Text, likesTreats :: Bool } deriving (Show, Generic)+instance FromValue DogStuff+instance HasAnnotatedInputType DogStuff+instance Defaultable DogStuff where+  defaultFor "dog" = pure DogStuff { toy = "shoe", likesTreats = False }+  defaultFor _ = empty++catOrDog :: Handler IO CatOrDog+catOrDog = do+  name <- pure "MonadicFelix" -- we can do monadic actions+  unionValue @Cat (catHandler name Nothing 15)++catOrDogList :: Handler IO (List CatOrDog)+catOrDogList =+  returns [ unionValue @Cat (catHandler "Felix the Cat" (Just "felix") 42)+          , unionValue @Cat (catHandler "Henry" Nothing 10)+          , unionValue @Dog (viewServerDog mortgage)+          ]++catHandler :: Text -> Maybe Text -> Int32 -> Handler IO Cat+catHandler name nickName meowVolume = pure $+  returns name :<>+  returns (returns <$> nickName) :<>+  returns . const False :<>  -- doesn't know any commands+  returns meowVolume++-- | Our server's internal representation of a 'Dog'.+data ServerDog+  = ServerDog+    { name :: Text+    , nickname :: Maybe Text+    , barkVolume :: Int32+    , knownCommands :: Set DogCommand+    , houseTrainedAtHome :: Bool+    , houseTrainedElsewhere :: Bool+    , owner :: ServerHuman+    }++-- | Whether 'ServerDog' knows the given command.+doesKnowCommand :: ServerDog -> DogCommand -> Bool+doesKnowCommand dog command = command `elem` knownCommands dog++-- | Whether 'ServerDog' is house-trained.+isHouseTrained :: ServerDog -> Maybe Bool -> Bool+isHouseTrained dog Nothing = houseTrainedAtHome dog || houseTrainedElsewhere dog+isHouseTrained dog (Just False) = houseTrainedAtHome dog+isHouseTrained dog (Just True) = houseTrainedElsewhere dog++-- | Present 'ServerDog' for GraphQL.+viewServerDog :: ServerDog -> Handler IO Dog+viewServerDog dog@ServerDog{..} = pure $+  returns name :<>+  returns (fmap returns nickname) :<>+  returns barkVolume :<>+  returns . doesKnowCommand dog :<>+  returns . isHouseTrained dog :<>+  viewServerHuman owner++describeDog :: DogStuff -> Handler IO Text+describeDog (DogStuff toy likesTreats)+  | likesTreats = returns $ "likes treats and their favorite toy is a " <> toy+  | otherwise = returns $ "their favorite toy is a " <> toy++rootHandler :: ServerDog -> Handler IO QueryRoot+rootHandler dog = pure $ viewServerDog dog :<> describeDog :<> catOrDog :<> catOrDogList++-- | jml has a stuffed black dog called "Mortgage".+mortgage :: ServerDog+mortgage = ServerDog+           { name = "Mortgage"+           , nickname = Just "Mort"+           , barkVolume = 0  -- He's stuffed+           , knownCommands = mempty  -- He's stuffed+           , houseTrainedAtHome = True  -- Never been a problem+           , houseTrainedElsewhere = True  -- Untested in the field+           , owner = jml+           }++-- | Our server's internal representation of a 'Human'.+newtype ServerHuman = ServerHuman Text deriving (Eq, Ord, Show, Generic)+++-- | Present a 'ServerHuman' as a GraphQL 'Human'.+viewServerHuman :: ServerHuman -> Handler IO Human+viewServerHuman (ServerHuman name) = pure (returns name)++-- | It me.+jml :: ServerHuman+jml = ServerHuman "jml"+++spec :: Spec+spec = describe "End-to-end tests" $ do+  describe "interpretAnonymousQuery" $ do+    it "Handles the simplest possible valid query" $ do+      let query = [r|{+                      dog {+                        name+                      }+                    }+                   |]+      response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query+      let expected =+            object+            [ "data" .= object+              [ "dog" .= object+                [ "name" .= ("Mortgage" :: Text)+                ]+              ]+            ]+      toJSON (toValue response) `shouldBe` expected+    it "Handles more than one field" $ do+      let query = [r|{+                      dog {+                        name+                        barkVolume+                      }+                    }+                   |]+      response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query+      let expected =+            object+            [ "data" .= object+              [ "dog" .= object+                [ "name" .= ("Mortgage" :: Text)+                , "barkVolume" .= (0 :: Int32)+                ]+              ]+            ]+      toJSON (toValue response) `shouldBe` expected+    it "Handles nested queries" $ do+      let query = [r|{+                      dog {+                        name+                        owner {+                          name+                        }+                      }+                    }+                   |]+      response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query+      let expected =+            object+            [ "data" .= object+              [ "dog" .= object+                [ "name" .= ("Mortgage" :: Text)+                , "owner" .= object+                  [ "name" .= ("jml" :: Text)+                  ]+                ]+              ]+            ]+      toJSON (toValue response) `shouldBe` expected+    it "It aliases fields" $ do+      let query = [r|{+                      dog {+                        name+                        boss: owner {+                          name+                        }+                      }+                    }+                   |]+      response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query+      let expected =+            object+            [ "data" .= object+              [ "dog" .= object+                [ "name" .= ("Mortgage" :: Text)+                , "boss" .= object+                  [ "name" .= ("jml" :: Text)+                  ]+                ]+              ]+            ]+      toJSON (toValue response) `shouldBe` expected+    it "Passes arguments to functions" $ do+      let query = [r|{+                      dog {+                        name+                        doesKnowCommand(dogCommand: Sit)+                      }+                     }+                    |]+      response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query+      let expected =+            object+            [ "data" .= object+              [ "dog" .= object+                [ "name" .= ("Mortgage" :: Text)+                , "doesKnowCommand" .= False+                ]+              ]+            ]+      toJSON (toValue response) `shouldBe` expected+    it "Passes arguments that are objects to functions" $ do+      let query = [r|{+                      describeDog(dog: {toy: "bone", likesTreats: true})+                     }+                    |]+      response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query+      let expected =+            object+            [ "data" .= object+              [ "describeDog" .= ("likes treats and their favorite toy is a bone" :: Text) ]+            ]+      toJSON (toValue response) `shouldBe` expected+    it "Passes default arguments that are objects to functions" $ do+      let query = [r|{+                      describeDog+                     }+                    |]+      response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query+      let expected =+            object+            [ "data" .= object+              [ "describeDog" .= ("their favorite toy is a shoe" :: Text) ]+            ]+      toJSON (toValue response) `shouldBe` expected+    it "Handles fairly complex queries" $ do+      let query = [r|{+                      dog {+                        callsign: name+                        ... on Dog {+                          callsign: name+                          me: owner {+                            ... on Sentient {+                              name+                            }+                            ... on Human {+                              name+                            }+                            name+                          }+                        }+                      }+                     }+                    |]+      response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query+      let expected =+            object+            [ "data" .= object+              [ "dog" .= object+                [ "callsign" .= ("Mortgage" :: Text)+                , "me" .= object+                  [ "name" .= ("jml" :: Text)+                  ]+                ]+              ]+            ]+      toJSON (toValue response) `shouldBe` expected+    it "Lets you query union types" $ do+      let query = "{ catOrDog { ... on Cat { name meowVolume } ... on Dog { barkVolume } } }"+      response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query+      let expected =+            object+            [ "data" .= object+              [ "catOrDog" .= object+                [ "name" .= ("MonadicFelix" :: Text)+                , "meowVolume" .= (15 :: Float)+                ]+              ]+            ]+      toJSON (toValue response) `shouldBe` expected+    it "Lets you query lists of union types" $ do+      let query = "{ catOrDogList { ... on Cat { name meowVolume } ... on Dog { barkVolume } } }"+      response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query+      let expected =+            object+            [ "data" .= object+              [ "catOrDogList" .=+                [ object+                  [ "name" .= ("Felix the Cat" :: Text)+                  , "meowVolume" .= (42 :: Float)+                  ]+                , object+                  [ "name" .= ("Henry" :: Text)+                  , "meowVolume" .= (10 :: Float)+                  ]+                , object+                  [ "barkVolume" .= (0 :: Float)+                  ]+                ]+              ]+            ]+      toJSON (toValue response) `shouldBe` expected+  describe "interpretQuery" $ do+    it "Handles the simplest named query" $ do+      let query = [r|query myQuery {+                      dog {+                        name+                      }+                    }+                   |]+      response <- interpretQuery @QueryRoot (rootHandler mortgage) query Nothing mempty+      let expected =+            object+            [ "data" .= object+              [ "dog" .= object+                [ "name" .= ("Mortgage" :: Text)+                ]+              ]+            ]+      toJSON (toValue response) `shouldBe` expected+    it "Allows calling query by name" $ do+      let query = [r|query myQuery {+                      dog {+                        name+                      }+                    }+                   |]+      let Right name = makeName "myQuery"+      response <- interpretQuery @QueryRoot (rootHandler mortgage) query (Just name) mempty+      let expected =+            object+            [ "data" .= object+              [ "dog" .= object+                [ "name" .= ("Mortgage" :: Text)+                ]+              ]+            ]+      toJSON (toValue response) `shouldBe` expected+    describe "Handles variables" $ do+      let Right schema = makeSchema @Dog+      let Right query =+            compileQuery schema+            [r|query myQuery($whichCommand: DogCommand) {+                 dog {+                   name+                   doesKnowCommand(dogCommand: $whichCommand)+                 }+               }+              |]+      let Right annotatedQuery =+            compileQuery schema+            [r|query myQuery($whichCommand: DogCommand!) {+                 dog {+                   name+                   doesKnowCommand(dogCommand: $whichCommand)+                 }+               }+              |]+      let Right badQuery =+            compileQuery schema+            [r|query myQuery($whichCommand: String!) {+                 dog {+                   name+                   doesKnowCommand(dogCommand: $whichCommand)+                 }+               }+              |]+      it "Errors when variable and argument types are in conflict" $ do+        let vars = Map.singleton (Variable "whichCommand") $ toValue @Text "cow"+        response <- executeQuery  @QueryRoot (rootHandler mortgage) badQuery Nothing vars+        let expected =+              object+              [ "data" .= object+                [ "dog" .= object+                  [ "name" .= ("Mortgage" :: Text)+                  , "doesKnowCommand" .= Null+                  ]+                ]+              , "errors" .=+                [+                  object+                  -- TODO: This error message is pretty bad. We should define+                  -- a typeclass for client-friendly "Show" (separate from+                  -- actual Show which remains extremely useful for debugging)+                  -- and use that when including values in error messages.+                  [ "message" .= ("Could not coerce Name {unName = \"dogCommand\"} to valid value: ValueScalar' (ConstString (String \"cow\")) not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text)+                  ]+                ]+              ]+        toJSON (toValue response) `shouldBe` expected+      it "Errors when no variables provided" $ do+        response <- executeQuery  @QueryRoot (rootHandler mortgage) query Nothing mempty+        let expected =+              object+              [ "data" .= object+                [ "dog" .= object+                  [ "name" .= ("Mortgage" :: Text)+                  , "doesKnowCommand" .= Null+                  ]+                ]+              , "errors" .=+                [+                  object+                  [ "message" .= ("Could not coerce Name {unName = \"dogCommand\"} to valid value: ValueScalar' ConstNull not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text)+                  ]+                ]+              ]+        toJSON (toValue response) `shouldBe` expected+      it "Substitutes variables when they are provided" $ do+        -- TODO: This is a crummy way to make a variable map. jml doesn't want+        -- to come up with a new API in this PR, but probably we should have a+        -- very simple function to turn a JSON value / object into the+        -- variable map that we desire. Alternatively, we should have APIs+        -- like Aeson does.+        -- <https://github.com/jml/graphql-api/issues/96>+        let Right varName = makeName "whichCommand"+        let vars = Map.singleton (Variable varName) (toValue Sit)+        response <- executeQuery  @QueryRoot (rootHandler mortgage) query Nothing vars+        let expected =+              object+              [ "data" .= object+                [ "dog" .= object+                  [ "name" .= ("Mortgage" :: Text)+                  , "doesKnowCommand" .= False+                  ]+                ]+              ]+        toJSON (toValue response) `shouldBe` expected+      it "Substitutes annotated variables when they are provided" $ do+        let Right varName = makeName "whichCommand"+        let vars = Map.singleton (Variable varName) (toValue Sit)+        response <- executeQuery  @QueryRoot (rootHandler mortgage) annotatedQuery Nothing vars+        let expected =+              object+              [ "data" .= object+                [ "dog" .= object+                  [ "name" .= ("Mortgage" :: Text)+                  , "doesKnowCommand" .= False+                  ]+                ]+              ]+        toJSON (toValue response) `shouldBe` expected+      it "Errors when non-null variable is not provided" $ do+        response <- executeQuery  @QueryRoot (rootHandler mortgage) annotatedQuery Nothing mempty+        let expected =+              object+              [ "data" .= Null+              , "errors" .=+                [+                  object+                  [ "message" .= ("Execution error: MissingValue (Variable (Name {unName = \"whichCommand\"}))" :: Text)+                  ]+                ]+              ]+        toJSON (toValue response) `shouldBe` expected

@@ -1,328 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE QuasiQuotes #-}--- | Tests that span the entire system.------ These tests function both as examples of how to use the API, as well as--- sanity checks on our reasoning.-module EndToEndTests (tests) where--import Protolude--import Data.Aeson (Value(Null), toJSON, object, (.=))-import qualified Data.Map as Map-import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery)-import GraphQL.API (Object, Field)-import GraphQL.Internal.Syntax.AST (Variable(..))-import GraphQL.Resolver ((:<>)(..), Handler)-import GraphQL.Value (makeName)-import GraphQL.Value.ToValue (ToValue(..))-import Test.Tasty (TestTree)-import Test.Tasty.Hspec (testSpec, describe, it, shouldBe)-import Text.RawString.QQ (r)--import ExampleSchema---- | Example query root.------ @--- type QueryRoot {---   dog: Dog--- }--- @------ Drawn from <https://facebook.github.io/graphql/#sec-Validation>.-type QueryRoot = Object "QueryRoot" '[]-  '[ Field "dog" Dog-   ]---- | Our server's internal representation of a 'Dog'.-data ServerDog-  = ServerDog-    { name :: Text-    , nickname :: Maybe Text-    , barkVolume :: Int32-    , knownCommands :: Set DogCommand-    , houseTrainedAtHome :: Bool-    , houseTrainedElsewhere :: Bool-    , owner :: ServerHuman-    }---- | Whether 'ServerDog' knows the given command.-doesKnowCommand :: ServerDog -> DogCommand -> Bool-doesKnowCommand dog command = command `elem` knownCommands dog---- | Whether 'ServerDog' is house-trained.-isHouseTrained :: ServerDog -> Maybe Bool -> Bool-isHouseTrained dog Nothing = houseTrainedAtHome dog || houseTrainedElsewhere dog-isHouseTrained dog (Just False) = houseTrainedAtHome dog-isHouseTrained dog (Just True) = houseTrainedElsewhere dog---- | Present 'ServerDog' for GraphQL.-viewServerDog :: ServerDog -> Handler IO Dog-viewServerDog dog@(ServerDog{..}) = pure $-  pure name :<>-  pure (fmap pure nickname) :<>-  pure barkVolume :<>-  pure . doesKnowCommand dog :<>-  pure . isHouseTrained dog :<>-  viewServerHuman owner---- | jml has a stuffed black dog called "Mortgage".-mortgage :: ServerDog-mortgage = ServerDog-           { name = "Mortgage"-           , nickname = Just "Mort"-           , barkVolume = 0  -- He's stuffed-           , knownCommands = mempty  -- He's stuffed-           , houseTrainedAtHome = True  -- Never been a problem-           , houseTrainedElsewhere = True  -- Untested in the field-           , owner = jml-           }---- | Our server's internal representation of a 'Human'.-data ServerHuman = ServerHuman Text deriving (Eq, Ord, Show)---- | Present a 'ServerHuman' as a GraphQL 'Human'.-viewServerHuman :: ServerHuman -> Handler IO Human-viewServerHuman (ServerHuman name) = pure (pure name)---- | It me.-jml :: ServerHuman-jml = ServerHuman "jml"--tests :: IO TestTree-tests = testSpec "End-to-end tests" $ do-  describe "interpretAnonymousQuery" $ do-    it "Handles the simplest possible valid query" $ do-      let root = pure (viewServerDog mortgage)-      let query = [r|{-                      dog {-                        name-                      }-                    }-                   |]-      response <- interpretAnonymousQuery @QueryRoot root query-      let expected =-            object-            [ "data" .= object-              [ "dog" .= object-                [ "name" .= ("Mortgage" :: Text)-                ]-              ]-            ]-      toJSON (toValue response) `shouldBe` expected-    it "Handles more than one field" $ do-      let root = pure (viewServerDog mortgage)-      let query = [r|{-                      dog {-                        name-                        barkVolume-                      }-                    }-                   |]-      response <- interpretAnonymousQuery @QueryRoot root query-      let expected =-            object-            [ "data" .= object-              [ "dog" .= object-                [ "name" .= ("Mortgage" :: Text)-                , "barkVolume" .= (0 :: Int32)-                ]-              ]-            ]-      toJSON (toValue response) `shouldBe` expected-    it "Handles nested queries" $ do-      let root = pure (viewServerDog mortgage)-      let query = [r|{-                      dog {-                        name-                        owner {-                          name-                        }-                      }-                    }-                   |]-      response <- interpretAnonymousQuery @QueryRoot root query-      let expected =-            object-            [ "data" .= object-              [ "dog" .= object-                [ "name" .= ("Mortgage" :: Text)-                , "owner" .= object-                  [ "name" .= ("jml" :: Text)-                  ]-                ]-              ]-            ]-      toJSON (toValue response) `shouldBe` expected-    it "It aliases fields" $ do-      let root = pure (viewServerDog mortgage)-      let query = [r|{-                      dog {-                        name-                        boss: owner {-                          name-                        }-                      }-                    }-                   |]-      response <- interpretAnonymousQuery @QueryRoot root query-      let expected =-            object-            [ "data" .= object-              [ "dog" .= object-                [ "name" .= ("Mortgage" :: Text)-                , "boss" .= object-                  [ "name" .= ("jml" :: Text)-                  ]-                ]-              ]-            ]-      toJSON (toValue response) `shouldBe` expected-    it "Passes arguments to functions" $ do-      let root = pure (viewServerDog mortgage)-      let query = [r|{-                      dog {-                        name-                        doesKnowCommand(dogCommand: Sit)-                      }-                     }-                    |]-      response <- interpretAnonymousQuery @QueryRoot root query-      let expected =-            object-            [ "data" .= object-              [ "dog" .= object-                [ "name" .= ("Mortgage" :: Text)-                , "doesKnowCommand" .= False-                ]-              ]-            ]-      toJSON (toValue response) `shouldBe` expected-    it "Handles fairly complex queries" $ do-      let root = pure (viewServerDog mortgage)-      -- TODO: jml would like to put some union checks in here, but we don't-      -- have any unions reachable from Dog!-      let query = [r|{-                      dog {-                        callsign: name-                        ... on Dog {-                          callsign: name-                          me: owner {-                            ... on Sentient {-                              name-                            }-                            ... on Human {-                              name-                            }-                            name-                          }-                        }-                      }-                     }-                    |]-      response <- interpretAnonymousQuery @QueryRoot root query-      let expected =-            object-            [ "data" .= object-              [ "dog" .= object-                [ "callsign" .= ("Mortgage" :: Text)-                , "me" .= object-                  [ "name" .= ("jml" :: Text)-                  ]-                ]-              ]-            ]-      toJSON (toValue response) `shouldBe` expected-  describe "interpretQuery" $ do-    it "Handles the simplest named query" $ do-      let root = pure (viewServerDog mortgage)-      let query = [r|query myQuery {-                      dog {-                        name-                      }-                    }-                   |]-      response <- interpretQuery @QueryRoot root query Nothing mempty-      let expected =-            object-            [ "data" .= object-              [ "dog" .= object-                [ "name" .= ("Mortgage" :: Text)-                ]-              ]-            ]-      toJSON (toValue response) `shouldBe` expected-    it "Allows calling query by name" $ do-      let root = pure (viewServerDog mortgage)-      let query = [r|query myQuery {-                      dog {-                        name-                      }-                    }-                   |]-      let Right name = makeName "myQuery"-      response <- interpretQuery @QueryRoot root query (Just name) mempty-      let expected =-            object-            [ "data" .= object-              [ "dog" .= object-                [ "name" .= ("Mortgage" :: Text)-                ]-              ]-            ]-      toJSON (toValue response) `shouldBe` expected-    describe "Handles variables" $ do-      let root = pure (viewServerDog mortgage)-      let Right schema = makeSchema @Dog-      let Right query =-            compileQuery schema-            [r|query myQuery($whichCommand: DogCommand) {-                 dog {-                   name-                   doesKnowCommand(dogCommand: $whichCommand)-                 }-               }-              |]-      it "Errors when no variables provided" $ do-        response <- executeQuery  @QueryRoot root query Nothing mempty-        let expected =-              object-              [ "data" .= object-                [ "dog" .= object-                  [ "name" .= ("Mortgage" :: Text)-                  , "doesKnowCommand" .= Null-                  ]-                ]-              , "errors" .=-                [-                  object-                  -- TODO: This error message is pretty bad. We should define-                  -- a typeclass for client-friendly "Show" (separate from-                  -- actual Show which remains extremely useful for debugging)-                  -- and use that when including values in error messages.-                  [ "message" .= ("Could not coerce Name {unName = \"dogCommand\"} to valid value: ValueScalar' ConstNull not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text)-                  ]-                ]-              ]-        toJSON (toValue response) `shouldBe` expected-      it "Substitutes variables when they are provided" $ do-        -- TODO: This is a crummy way to make a variable map. jml doesn't want-        -- to come up with a new API in this PR, but probably we should have a-        -- very simple function to turn a JSON value / object into the-        -- variable map that we desire. Alternatively, we should have APIs-        -- like Aeson does.-        -- <https://github.com/jml/graphql-api/issues/96>-        let Right varName = makeName "whichCommand"-        let vars = Map.singleton (Variable varName) (toValue Sit)-        response <- executeQuery  @QueryRoot root query Nothing vars-        let expected =-              object-              [ "data" .= object-                [ "dog" .= object-                  [ "name" .= ("Mortgage" :: Text)-                  , "doesKnowCommand" .= False-                  ]-                ]-              ]-        toJSON (toValue response) `shouldBe` expected

@@ -3,7 +3,7 @@  import Protolude hiding (Enum) -import GraphQL.API.Enum (GraphQLEnum)+import GraphQL.API (GraphQLEnum)  -- https://github.com/jml/graphql-api/issues/116 -- Generic enum code is broken

@@ -87,8 +87,11 @@   , (:>)   , Defaultable(..)   )-import GraphQL.Value (pattern ValueEnum, unName)-import GraphQL.Value.ToValue (ToValue(..))+import GraphQL.Value+  ( pattern ValueEnum+  , unName+  , ToValue(..)+  )  -- | A command that can be given to a 'Dog'. --@@ -105,6 +108,12 @@ --     so it can be placed in a schema. data DogCommand = Sit | Down | Heel deriving (Show, Eq, Ord, Generic) +instance Defaultable DogCommand where+  -- Explicitly want no default for dogCommand+  defaultFor (unName -> "dogCommand") = Nothing+  -- DogCommand shouldn't be used elsewhere in schema, but who can say?+  defaultFor _ = Nothing+ instance GraphQLEnum DogCommand  -- TODO: Probably shouldn't have to do this for enums.@@ -175,12 +184,6 @@    , Field "owner" Human    ] -instance Defaultable DogCommand where-  -- Explicitly want no default for dogCommand-  defaultFor (unName -> "dogCommand") = Nothing-  -- DogCommand shouldn't be used elsewhere in schema, but who can say?-  defaultFor _ = Nothing- -- | Sentient beings have names. -- -- This defines an interface, 'Sentient', that objects can implement.@@ -245,6 +248,9 @@ -- enum CatCommand { JUMP } -- @ data CatCommand = Jump deriving Generic++instance Defaultable CatCommand where+  defaultFor _ = empty  instance GraphQLEnum CatCommand 

@@ -1,46 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveGeneric #-}--module Examples.InputObject where-import Protolude hiding (Enum)--import GraphQL-import GraphQL.API-import GraphQL.Resolver (Handler)-import GraphQL.Value.FromValue (FromValue)--data DogStuff = DogStuff { toy :: Text, likesTreats :: Bool } deriving (Show, Generic)-instance FromValue DogStuff-instance HasAnnotatedInputType DogStuff-instance Defaultable DogStuff where-  -- TODO defaultFor takes a Name which makes sense, but what's the-  -- name for an input object?-  defaultFor _ = Just (DogStuff "shoe" False)--type Query = Object "Query" '[]-  '[ Argument "dogStuff" DogStuff :> Field "description" Text ]--root :: Handler IO Query-root = pure description--description :: DogStuff -> Handler IO Text-description (DogStuff toy likesTreats)-  | likesTreats = pure $ "likes treats and their favorite toy is a " <> toy-  | otherwise = pure $ "their favorite toy is a " <> toy---- $setup--- >>> import Data.Aeson (encode)--- >>> import GraphQL.Value.ToValue (ToValue(..))---- | Show input object usage------ >>> response <- example "{ description(dogStuff: {toy: \"bone\", likesTreats: true}) }"--- >>> putStrLn $ encode $ toValue response--- {"data":{"description":"likes treats and their favorite toy is a bone"}}------ >>> response <- example "{ description }"--- >>> putStrLn $ encode $ toValue response--- {"data":{"description":"their favorite toy is a shoe"}}-example :: Text -> IO Response-example = interpretAnonymousQuery @Query root

@@ -1,52 +0,0 @@-{-# LANGUAGE DataKinds #-}-module Examples.UnionExample  where--import Protolude-import GraphQL.API (Field, List, Object, Union)-import GraphQL (Response, interpretAnonymousQuery)-import GraphQL.Resolver (Handler, (:<>)(..), unionValue)---- Slightly reduced example from the spec-type MiniCat = Object "MiniCat" '[] '[Field "name" Text, Field "meowVolume" Int32]-type MiniDog = Object "MiniDog" '[] '[Field "barkVolume" Int32]--type CatOrDog = Object "Me" '[] '[Field "myPet" (Union "CatOrDog" '[MiniCat, MiniDog])]-type CatOrDogList = Object "CatOrDogList" '[] '[Field "pets" (List (Union "CatOrDog" '[MiniCat, MiniDog]))]--miniCat :: Text -> Handler IO MiniCat-miniCat name = pure (pure name :<> pure 32)--miniDog :: Handler IO MiniDog-miniDog = pure (pure 100)--catOrDog :: Handler IO CatOrDog-catOrDog = pure $ do-  name <- pure "MonadicFelix" -- we can do monadic actions-  unionValue @MiniCat (miniCat name)--catOrDogList :: Handler IO CatOrDogList-catOrDogList = pure $-  pure [ unionValue @MiniCat (miniCat "Felix")-       , unionValue @MiniCat (miniCat "Mini")-       , unionValue @MiniDog miniDog-       ]---- $setup--- >>> import Data.Aeson (encode)--- >>> import GraphQL.Value.ToValue (ToValue(..))---- | Show usage of a single unionValue------ >>> response <- exampleQuery--- >>> putStrLn $ encode $ toValue response--- {"data":{"myPet":{"meowVolume":32,"name":"MonadicFelix"}}}-exampleQuery :: IO Response-exampleQuery = interpretAnonymousQuery @CatOrDog catOrDog "{ myPet { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }"---- | 'unionValue' can be used in a list context------ >>> response <- exampleListQuery--- >>> putStrLn $ encode $ toValue response--- {"data":{"pets":[{"meowVolume":32,"name":"Felix"},{"meowVolume":32,"name":"Mini"},{"barkVolume":100}]}}-exampleListQuery :: IO Response-exampleListQuery = interpretAnonymousQuery @CatOrDogList catOrDogList  "{ pets { ... on MiniCat { name meowVolume } ... on MiniDog { barkVolume } } }"

@@ -0,0 +1,10 @@+module Main where++import Protolude++import Test.Hspec+import qualified Spec (spec)++main :: IO ()+main = do+  hspec Spec.spec

@@ -0,0 +1,42 @@+module OrderedMapSpec (spec) where++import Protolude++import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Gen, arbitrary, forAll)+import Test.Hspec++import qualified Data.Map as Map+import GraphQL.Internal.OrderedMap (OrderedMap)+import qualified GraphQL.Internal.OrderedMap as OrderedMap+++orderedMaps :: Gen (OrderedMap Int Int)+orderedMaps = arbitrary++spec :: Spec+spec = describe "OrderedMap" $ do+  describe "Integrity" $ do+    prop "fromList . toList == id" $ do+      forAll orderedMaps (\x -> OrderedMap.orderedMap (OrderedMap.toList x) == Just x)+    prop "keys == Map.keys . toMap" $ do+      forAll orderedMaps (\x -> sort (OrderedMap.keys x) == sort (Map.keys (OrderedMap.toMap x)))+    prop "keys == map fst . Map.toList" $ do+      forAll orderedMaps (\x -> OrderedMap.keys x == map fst (OrderedMap.toList x))+    prop "has unique keys" $ do+      forAll orderedMaps (\x -> let ks = OrderedMap.keys x in ks == ordNub ks)+    prop "all keys can be looked up" $ do+      forAll orderedMaps (\x -> let keys = OrderedMap.keys x+                                    values = OrderedMap.values x+                                in mapMaybe (flip OrderedMap.lookup x) keys == values)+    it "empty is orderedMap []" $ do+      Just (OrderedMap.empty @Int @Int) `shouldBe` OrderedMap.orderedMap []+    prop "singleton x is orderedMap [x]" $ do+      \x y -> Just (OrderedMap.singleton @Int @Int x y) == OrderedMap.orderedMap [(x, y)]+    it "preserves insertion order" $ do+      let items1 = [("foo", 2), ("bar", 1)]+      let Just x = OrderedMap.orderedMap items1+      OrderedMap.toList @Text @Int x `shouldBe` items1+      let items2 = [("bar", 1), ("foo", 2)]+      let Just y = OrderedMap.orderedMap items2+      OrderedMap.toList @Text @Int y `shouldBe` items2

@@ -1,43 +0,0 @@-module OrderedMapTests (tests) where--import Protolude--import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck (Gen, arbitrary, forAll)-import Test.Tasty (TestTree)-import Test.Tasty.Hspec (testSpec, describe, it, shouldBe)--import qualified Data.Map as Map-import GraphQL.Internal.OrderedMap (OrderedMap)-import qualified GraphQL.Internal.OrderedMap as OrderedMap---orderedMaps :: Gen (OrderedMap Int Int)-orderedMaps = arbitrary--tests :: IO TestTree-tests = testSpec "OrderedMap" $ do-  describe "Integrity" $ do-    prop "fromList . toList == id" $ do-      forAll orderedMaps (\x -> OrderedMap.orderedMap (OrderedMap.toList x) == Just x)-    prop "keys == Map.keys . toMap" $ do-      forAll orderedMaps (\x -> sort (OrderedMap.keys x) == sort (Map.keys (OrderedMap.toMap x)))-    prop "keys == map fst . Map.toList" $ do-      forAll orderedMaps (\x -> OrderedMap.keys x == map fst (OrderedMap.toList x))-    prop "has unique keys" $ do-      forAll orderedMaps (\x -> let ks = OrderedMap.keys x in ks == ordNub ks)-    prop "all keys can be looked up" $ do-      forAll orderedMaps (\x -> let keys = OrderedMap.keys x-                                    values = OrderedMap.values x-                                in mapMaybe (flip OrderedMap.lookup x) keys == values)-    it "empty is orderedMap []" $ do-      Just (OrderedMap.empty @Int @Int) `shouldBe` OrderedMap.orderedMap []-    prop "singleton x is orderedMap [x]" $ do-      \x y -> Just (OrderedMap.singleton @Int @Int x y) == OrderedMap.orderedMap [(x, y)]-    it "preserves insertion order" $ do-      let items1 = [("foo", 2), ("bar", 1)]-      let Just x = OrderedMap.orderedMap items1-      OrderedMap.toList @Text @Int x `shouldBe` items1-      let items2 = [("bar", 1), ("foo", 2)]-      let Just y = OrderedMap.orderedMap items2-      OrderedMap.toList @Text @Int y `shouldBe` items2

@@ -0,0 +1,150 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+module ResolverSpec (spec) where++import Protolude hiding (Enum)++import Test.Hspec++import Data.Aeson (encode, toJSON, object, (.=), Value(Null))+import GraphQL+  ( Response(..)+  , interpretAnonymousQuery+  )+import GraphQL.API+  ( Object+  , Field+  , Argument+  , Enum+  , List+  , (:>)+  )+import GraphQL.Resolver+  ( Handler+  , ResolverError(..)+  , (:<>)(..)+  , returns+  , handlerError+  )+import GraphQL.Internal.Output (singleError)+import qualified GraphQL.Value as GValue+import EnumTests ( Mode(NormalFile) )++-- Test a custom error monad+type TMonad = ExceptT Text IO+type T = Object "T" '[] '[ Field "z" Int32+                         , Argument "x" Int32 :> Field "t" Int32+                         , Argument "y" Int32 :> Field "q" (Maybe Int32)+                         , Argument "d" Double :> Field "r" Double+                         , Field "l" (List Int32)+                         , Argument "n" Text :> Field "foo" (Maybe Foo)+                         , Field "bar" (Maybe Foo)+                         ]++tHandler :: Handler TMonad T+tHandler = pure $+  returns 10+  :<> (\x -> if x == 99 then handlerError "missed 99th value" else returns x)+  :<> returns . Just . (returns . (*2))+  :<> (\dArg -> if dArg == 9.9 then handlerError "bad 9.9 value" else returns dArg)+  :<> returns ([ returns 0, returns 7, handlerError "no number 9" ])+  :<> (\_nArg -> returns $ Just $ return $ returns "fred")+  :<> returns Nothing++-- https://github.com/jml/graphql-api/issues/119+-- Maybe X didn't descend into its argument. Now it does.+type Query = Object "Query" '[]+  '[ Argument "id" Text :> Field "test" (Maybe Foo) ]++type Foo = Object "Foo" '[]+  '[ Field "name" Text ]++data ServerFoo = ServerFoo+  { name :: Text+  } deriving (Eq, Show)++lookupFoo :: Text -> IO (Maybe ServerFoo)+lookupFoo _ = pure $ Just (ServerFoo "Mort")++viewFoo :: ServerFoo -> Handler IO Foo+viewFoo ServerFoo { name=name } = pure $ returns $ name++handler :: Handler IO Query+handler = pure $ \fooId -> do+  foo <- lookupFoo fooId+  returns $ viewFoo <$> foo++-- Enum test+type EnumQuery = Object "File" '[]+  '[ Field "mode" (Enum "modeEnumName" Mode) ]++enumHandler :: Handler IO EnumQuery+enumHandler = pure $ returns NormalFile++enumHandler2 :: Handler IO EnumQuery+enumHandler2 = pure $ handlerError "I forgot!"++-- /Enum test++spec :: Spec+spec = describe "TypeAPI" $ do+  describe "tTest" $ do+    it "works in a simple Int32 case" $ do+      Right (Success obj) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 12) }")+      encode obj `shouldBe` "{\"t\":12}"+    it "works in a simple Double case" $ do+      r <- runExceptT (interpretAnonymousQuery @T tHandler "{ r(d: 1.2) }")+      case r of+        Right (Success obj) -> encode obj `shouldBe` "{\"r\":1.2}"+        _ -> r `shouldNotBe` r+    it "works for value and error list elements" $ do+      r <- runExceptT (interpretAnonymousQuery @T tHandler "{ l }")+      case r of+        Right (PartialSuccess obj err) -> do+          encode obj `shouldBe` "{\"l\":[0,7,null]}"+          err `shouldBe` (singleError (HandlerError "no number 9"))+        _ -> r `shouldNotBe` r+    it "works for Nullable present elements" $ do+      r <- runExceptT (interpretAnonymousQuery @T tHandler "{ foo(n: \"flintstone\") { name } }")+      case r of+        Right (Success obj) -> do+          encode obj `shouldBe` "{\"foo\":{\"name\":\"fred\"}}"+        _ -> r `shouldNotBe` r+    it "works for Nullable null elements" $ do+      r <- runExceptT (interpretAnonymousQuery @T tHandler "{ bar { name } }")+      case r of+        Right (Success obj) -> do+          encode obj `shouldBe` "{\"bar\":null}"+        _ -> r `shouldNotBe` r+    it "complains about a missing field" $ do+      Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ not_a_field }")+      errs `shouldBe` singleError (FieldNotFoundError "not_a_field")+    it "complains about a handler throwing an exception" $ do+      r <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 99) }")+      case r of+        Right (PartialSuccess v errs) -> do+          -- n.b. this hasn't gone through the final JSON embedding,+          -- so it's the individual components instead of the final+          -- response of '{ "data": ..., "errors": ... }'+          errs `shouldBe` (singleError (HandlerError "missed 99th value"))+          toJSON (GValue.toValue v) `shouldBe` object [ "t" .= Null ]+        _ -> r `shouldNotBe` r+    it "complains about missing argument" $ do+      Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t }")+      errs `shouldBe` singleError (ValueMissing "x")+  describe "issue 119" $ do+    it "Just works" $ do+      Success obj <- interpretAnonymousQuery @Query handler "{ test(id: \"10\") { name } }"+      encode obj `shouldBe` "{\"test\":{\"name\":\"Mort\"}}"+  describe "Parse, validate and execute queries against API" $ do+    it "API.Enum works" $ do+      Success obj <- interpretAnonymousQuery @EnumQuery enumHandler "{ mode }"+      encode obj `shouldBe` "{\"mode\":\"NormalFile\"}"+    it "API.Enum handles errors" $ do+      r <- interpretAnonymousQuery @EnumQuery enumHandler2 "{ mode }"+      case r of+        (PartialSuccess obj errs) -> do+          encode obj `shouldBe` "{\"mode\":null}"+          errs `shouldBe` (singleError $ HandlerError "I forgot!")+        _ -> r `shouldNotBe` r

@@ -1,96 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-module ResolverTests (tests) where--import Protolude hiding (Enum)--import Test.Tasty (TestTree)-import Test.Tasty.Hspec (testSpec, describe, it, shouldBe)--import Data.Aeson (encode)-import GraphQL-  ( Response(..)-  , interpretAnonymousQuery-  )-import GraphQL.API-  ( Object-  , Field-  , Argument-  , Enum-  , (:>)-  )-import GraphQL.Resolver-  ( Handler-  , ResolverError(..)-  , (:<>)(..)-  )-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-                         , Argument "x" Int32 :> Field "t" Int32-                         , Argument "y" Int32 :> Field "q" Int32-                         ]--tHandler :: Handler TMonad T-tHandler =-  pure $ (pure 10) :<> (\tArg -> pure tArg) :<> (pure . (*2))----- https://github.com/jml/graphql-api/issues/119--- Maybe X didn't descend into its argument. Now it does.-type Query = Object "Query" '[]-  '[ Argument "id" Text :> Field "test" (Maybe Foo) ]--type Foo = Object "Foo" '[]-  '[ Field "name" Text ]--data ServerFoo = ServerFoo-  { name :: Text-  } deriving (Eq, Show)--lookupFoo :: Text -> IO (Maybe ServerFoo)-lookupFoo _ = pure $ Just (ServerFoo "Mort")--viewFoo :: ServerFoo -> Handler IO Foo-viewFoo ServerFoo { name=name } = pure $ pure $ name--handler :: Handler IO Query-handler = pure $ \fooId -> do-  foo <- lookupFoo fooId-  -- note that fmap maps over the Maybe, so we still need-  -- 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-    it "works in a simple case" $ do-      Right (Success object) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 12) }")-      encode object `shouldBe` "{\"t\":12}"-    it "complains about missing field" $ do-      Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ not_a_field }")-      errs `shouldBe` singleError (FieldNotFoundError "not_a_field")-    it "complains about missing argument" $ do-      Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t }")-      errs `shouldBe` singleError (ValueMissing "x")-  describe "issue 119" $ do-    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\"}"

@@ -0,0 +1,132 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+module SchemaSpec (spec) where++import Protolude hiding (Down, Enum)++import Test.Hspec++import GraphQL.API+  ( Field+  , Enum+  , List+  , getAnnotatedInputType+  , getDefinition+  )+import qualified GraphQL.Internal.Syntax.AST as AST+import GraphQL.Internal.API+  ( getAnnotatedType+  , getFieldDefinition+  , getInterfaceDefinition+  )+import GraphQL.Internal.Schema+  ( EnumTypeDefinition(..)+  , EnumValueDefinition(..)+  , FieldDefinition(..)+  , ObjectTypeDefinition(..)+  , InterfaceTypeDefinition(..)+  , AnnotatedType(..)+  , ListType(..)+  , UnionTypeDefinition(..)+  , GType(..)+  , TypeDefinition(..)+  , InputTypeDefinition(..)+  , InputObjectTypeDefinition(..)+  , InputObjectFieldDefinition(..)+  , ScalarTypeDefinition(..)+  , AnnotatedType(..)+  , NonNullType(..)+  , Builtin(..)+  , InputType(..)+  , getInputTypeDefinition+  , builtinFromName+  , astAnnotationToSchemaAnnotation+  )+import ExampleSchema++spec :: Spec+spec = describe "Type" $ do+  describe "Field" $+    it "encodes correctly" $ do+    getFieldDefinition @(Field "hello" Int) `shouldBe` Right (FieldDefinition "hello" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GInt))))+  describe "Interface" $+    it "encodes correctly" $ do+    getInterfaceDefinition @Sentient `shouldBe`+      Right (InterfaceTypeDefinition+        "Sentient"+        (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| []))+  describe "full example" $+    it "encodes correctly" $ do+    getDefinition @Human `shouldBe`+      Right (ObjectTypeDefinition "Human"+        [ InterfaceTypeDefinition "Sentient" (+            FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| [])+        ]+        (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| []))+  describe "output Enum" $+    it "encodes correctly" $ do+    getAnnotatedType @(Enum "DogCommand" DogCommand) `shouldBe`+       Right (TypeNonNull (NonNullTypeNamed (DefinedType (TypeDefinitionEnum (EnumTypeDefinition "DogCommand"+         [ EnumValueDefinition "Sit"+         , EnumValueDefinition "Down"+         , EnumValueDefinition "Heel"+         ])))))+  describe "Union type" $+    it "encodes correctly" $ do+    getAnnotatedType @CatOrDog `shouldBe`+      TypeNamed . DefinedType . TypeDefinitionUnion . UnionTypeDefinition "CatOrDog"+        <$> sequence (getDefinition @Cat :| [getDefinition @Dog])+  describe "List" $+    it "encodes correctly" $ do+    getAnnotatedType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinType GInt)))))+    getAnnotatedInputType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinInputType GInt)))))+  describe "TypeDefinition accepted as InputTypes" $+    it "Enum/InputObject/Scalar" $ do+    getInputTypeDefinition (TypeDefinitionEnum (EnumTypeDefinition "DogCommand"+     [ EnumValueDefinition "Sit"+     , EnumValueDefinition "Down"+     , EnumValueDefinition "Heel"+     ])) `shouldBe` Just (InputTypeDefinitionEnum (EnumTypeDefinition "DogCommand"+     [ EnumValueDefinition "Sit"+     , EnumValueDefinition "Down"+     , EnumValueDefinition "Heel"+     ]))+    getInputTypeDefinition (TypeDefinitionInputObject (InputObjectTypeDefinition  "Human"+     (InputObjectFieldDefinition "name" (TypeNonNull (NonNullTypeNamed (BuiltinInputType GString))) Nothing :| [])+     )) `shouldBe` Just (InputTypeDefinitionObject (InputObjectTypeDefinition "Human"+     (InputObjectFieldDefinition "name" (TypeNonNull (NonNullTypeNamed (BuiltinInputType GString))) Nothing :| [])+     ))+    getInputTypeDefinition (TypeDefinitionScalar (ScalarTypeDefinition  "Human")) `shouldBe` Just (InputTypeDefinitionScalar (ScalarTypeDefinition  "Human"))+  describe "TypeDefinition refused as InputTypes" $+    -- todo: add all the others (union type, ..?)+    it "Object" $ do+    getInputTypeDefinition (TypeDefinitionObject (ObjectTypeDefinition "Human" []+        (FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString))) :| []))) `shouldBe` Nothing+  describe "Builtin types from name" $+    it "Int/Bool/String/Float/ID" $ do+    builtinFromName "Int" `shouldBe` Just GInt+    builtinFromName "Boolean" `shouldBe` Just GBool+    builtinFromName "String" `shouldBe` Just GString+    builtinFromName "Float" `shouldBe` Just GFloat+    builtinFromName "ID" `shouldBe` Just GID+    builtinFromName "RANDOMSTRING" `shouldBe` Nothing+  describe "Annotations from AST" $+    it "annotation like [[ScalarType!]]!" $ do+    let typeDefinitionScalar = (TypeDefinitionScalar (ScalarTypeDefinition "ScalarType"))+    astAnnotationToSchemaAnnotation (+      AST.TypeNonNull (+        AST.NonNullTypeList (+          AST.ListType (+            AST.TypeList (+              AST.ListType (+                AST.TypeNonNull (+                  AST.NonNullTypeNamed (AST.NamedType "ScalarType")+      ))))))) typeDefinitionScalar `shouldBe` (+        TypeNonNull (+          NonNullTypeList (+            ListType (+              TypeList (+                ListType (+                  TypeNonNull (+                    NonNullTypeNamed typeDefinitionScalar+        )))))))

@@ -1,75 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-module SchemaTests (tests) where--import Protolude hiding (Down, Enum)--import Test.Tasty (TestTree)-import Test.Tasty.Hspec (testSpec, describe, it, shouldBe)--import GraphQL.API-  ( Field-  , Enum-  , List-  , getAnnotatedType-  , getAnnotatedInputType-  , getDefinition-  , getFieldDefinition-  , getInterfaceDefinition-  )-import GraphQL.Internal.Schema-  ( EnumTypeDefinition(..)-  , EnumValueDefinition(..)-  , FieldDefinition(..)-  , ObjectTypeDefinition(..)-  , NonEmptyList(..)-  , InterfaceTypeDefinition(..)-  , AnnotatedType(..)-  , ListType(..)-  , UnionTypeDefinition(..)-  , GType(..)-  , TypeDefinition(..)-  , NonNullType(..)-  , Builtin(..)-  , InputType(..)-  )-import ExampleSchema--tests :: IO TestTree-tests = testSpec "Type" $ do-  describe "Field" $-    it "encodes correctly" $ do-    getFieldDefinition @(Field "hello" Int) `shouldBe` Right (FieldDefinition "hello" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GInt))))-  describe "Interface" $-    it "encodes correctly" $ do-    getInterfaceDefinition @Sentient `shouldBe`-      Right (InterfaceTypeDefinition-        "Sentient"-        (NonEmptyList [FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))]))-  describe "full example" $-    it "encodes correctly" $ do-    getDefinition @Human `shouldBe`-      Right (ObjectTypeDefinition "Human"-        [ InterfaceTypeDefinition "Sentient" (-            NonEmptyList [FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))])-        ]-        (NonEmptyList [FieldDefinition "name" [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))]))-  describe "output Enum" $-    it "encodes correctly" $ do-    getAnnotatedType @(Enum "DogCommand" DogCommand) `shouldBe`-       Right (TypeNonNull (NonNullTypeNamed (DefinedType (TypeDefinitionEnum (EnumTypeDefinition "DogCommand"-         [ EnumValueDefinition "Sit"-         , EnumValueDefinition "Down"-         , EnumValueDefinition "Heel"-         ])))))-  describe "Union type" $-    it "encodes correctly" $ do-    getAnnotatedType @CatOrDog `shouldBe`-      TypeNamed . DefinedType . TypeDefinitionUnion . UnionTypeDefinition "CatOrDog"-        . NonEmptyList <$> sequence [ getDefinition @Cat-                                    , getDefinition @Dog-                                    ]-  describe "List" $-    it "encodes correctly" $ do-    getAnnotatedType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinType GInt)))))-    getAnnotatedInputType @(List Int) `shouldBe` Right (TypeList (ListType (TypeNonNull (NonNullTypeNamed (BuiltinInputType GInt)))))

@@ -1,35 +1,1 @@-module Main-  ( main-  ) where--import Protolude--import Test.Tasty (defaultMain, testGroup)--import qualified ASTTests-import qualified EndToEndTests-import qualified OrderedMapTests-import qualified ResolverTests-import qualified SchemaTests-import qualified ValidationTests-import qualified ValueTests-import qualified EnumTests ()---- import examples to ensure they compile-import Examples.InputObject ()-import Examples.UnionExample ()--main :: IO ()-main = do-  t <- sequence tests-  defaultMain . testGroup "GraphQL API" $ t-  where-    tests =-      [ ASTTests.tests-      , EndToEndTests.tests-      , OrderedMapTests.tests-      , ResolverTests.tests-      , SchemaTests.tests-      , ValidationTests.tests-      , ValueTests.tests-      ]+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

@@ -0,0 +1,257 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}++-- | Tests for query validation.+module ValidationSpec (spec) where++import Protolude++import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck ((===))+import Test.Hspec+import qualified Data.Set as Set++import GraphQL.Internal.Name (Name)+import qualified GraphQL.Internal.Syntax.AST as AST+import GraphQL.Internal.Schema (emptySchema, Schema)+import GraphQL.Internal.Validation+  ( ValidationError(..)+  , findDuplicates+  , getErrors+  , formatErrors+  )++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 = emptySchema++spec :: Spec+spec = describe "Validation" $ do+  describe "getErrors" $ do+    it "Treats simple queries as valid" $ do+      let doc = AST.QueryDocument+                [ AST.DefinitionOperation+                  ( AST.Query+                    ( AST.Node me [] []+                      [ AST.SelectionField (AST.Field Nothing someName [] [] [])+                      ]+                    )+                  )+                ]+      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` []+    it "Treats anonymous queries with annotated variables as valid ([[Boolean]]!)" $ do+      let doc = AST.QueryDocument+                [ AST.DefinitionOperation+                    (AST.Query+                      (AST.Node Nothing+                       [ AST.VariableDefinition+                           (AST.Variable "atOtherHomes")+                           (AST.TypeNonNull (AST.NonNullTypeList (AST.ListType +                            (AST.TypeList (AST.ListType (AST.TypeNamed (AST.NamedType "Boolean"))))+                           )))+                           Nothing+                       ] []+                       [ AST.SelectionField+                           (AST.Field Nothing dog [] []+                            [ AST.SelectionField+                                (AST.Field Nothing "isHousetrained"+                                 [ AST.Argument "atOtherHomes"+                                     (AST.ValueVariable (AST.Variable "atOtherHomes"))+                                 ] [] [])+                            ])+                       ]))+                ]+      getErrors schema doc `shouldBe` []++    it "Detects duplicate operation names" $ do+      let doc = AST.QueryDocument+                [ AST.DefinitionOperation+                  ( AST.Query+                    ( AST.Node me [] []+                      [ AST.SelectionField (AST.Field Nothing someName [] [] [])+                      ]+                    )+                  )+                , AST.DefinitionOperation+                  ( AST.Query+                    ( AST.Node me [] []+                      [ AST.SelectionField (AST.Field Nothing someName [] [] [])+                      ]+                    )+                  )+                ]+      getErrors schema doc `shouldBe` [DuplicateOperation me]++    it "Detects duplicate anonymous operations" $ do+      let doc = AST.QueryDocument+                [ AST.DefinitionOperation+                  ( AST.AnonymousQuery+                    [ AST.SelectionField (AST.Field Nothing someName [] [] [])+                    ]+                  )+                , AST.DefinitionOperation+                  ( AST.AnonymousQuery+                    [ AST.SelectionField (AST.Field Nothing someName [] [] [])+                    ]+                  )+                ]+      let errors = getErrors schema doc+      errors `shouldBe` [MixedAnonymousOperations 2 []]+      formatErrors errors `shouldBe` ["Multiple anonymous operations defined. Found 2"]++    it "Detects mixed operations" $ do+      let doc = AST.QueryDocument+                [ AST.DefinitionOperation+                  ( AST.AnonymousQuery+                    [ AST.SelectionField (AST.Field Nothing someName [] [] [])+                    ]+                  )+                , AST.DefinitionOperation+                  ( AST.Query (AST.Node (pure "houseTrainedQuery") [] []+                    [ AST.SelectionField (AST.Field Nothing someName [] [] [])+                    ]+                  ))+                ]+      let errors = getErrors schema doc+      errors `shouldBe` [MixedAnonymousOperations 1 [Just "houseTrainedQuery"]]+      formatErrors errors `shouldBe` ["Document contains both anonymous operations (1) and named operations ([Just (Name {unName = \"houseTrainedQuery\"})])"]++    it "Detects non-existing type in variable definition" $ do+      let doc = AST.QueryDocument+                [ AST.DefinitionOperation+                    (AST.Query+                      (AST.Node Nothing+                       [ AST.VariableDefinition+                           (AST.Variable "atOtherHomes")+                           (AST.TypeNamed (AST.NamedType "MyNonExistingType"))+                           (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` [VariableTypeNotFound (AST.Variable "atOtherHomes") "MyNonExistingType"]++    it "Detects unused variable definition" $ do+      let doc = AST.QueryDocument+                [ AST.DefinitionOperation+                    (AST.Query+                      (AST.Node Nothing+                       [ AST.VariableDefinition+                           (AST.Variable "atOtherHomes")+                           (AST.TypeNamed (AST.NamedType "String"))+                           (Just (AST.ValueBoolean True))+                       ] []+                       [ AST.SelectionField+                           (AST.Field Nothing dog [] []+                            [ AST.SelectionField+                                (AST.Field Nothing "isHousetrained"+                                 [] [] [])+                            ])+                       ]))+                ]+      getErrors schema doc `shouldBe` [UnusedVariables (Set.fromList [AST.Variable "atOtherHomes"])]++    it "Treats anonymous queries with inline arguments 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 "isHousetrained"+                                      [ AST.Argument "atOtherHomes"+                                          (AST.ValueList (AST.ListValue [+                                            (AST.ValueObject (AST.ObjectValue [+                                              (AST.ObjectField "testKey" (AST.ValueInt 123)),+                                              (AST.ObjectField "anotherKey" (AST.ValueString (AST.StringValue "string")))+                                            ]))+                                          ]))+                                      ] [] [])+                                 ])+                            ]))+                     ]+      getErrors schema doc `shouldBe` []+    it "Detects non-existent fragment type" $ do+      let doc = AST.QueryDocument+                  [(AST.DefinitionFragment (AST.FragmentDefinition "dogTest"+                    (AST.NamedType "Dog") [] [+                      AST.SelectionField (AST.Field Nothing "name" [] [] [])+                      ])),+                        (AST.DefinitionOperation+                         (AST.Query+                           (AST.Node Nothing+                            [] []+                            [AST.SelectionField+                              (AST.Field Nothing dog [] []+                                [AST.SelectionFragmentSpread (AST.FragmentSpread "dogTest" [])+                                ])    +                            ])))+                     ]+      getErrors schema doc `shouldBe` [TypeConditionNotFound "Dog"]++  describe "findDuplicates" $ do+    prop "returns empty on unique lists" $ do+      \xs -> findDuplicates @Int (ordNub xs) === []+    prop "finds only duplicates" $ \xs -> do+      all (>1) (count xs <$> findDuplicates @Int xs)+    prop "finds all duplicates" $ \xs -> do+      (sort . findDuplicates @Int) xs === (ordNub . sort . filter ((> 1) . count xs)) xs+++-- | Count the number of times 'x' occurs in 'xs'.+count :: Eq a => [a] -> a -> Int+count xs x = (length . filter (== x)) xs

@@ -1,131 +0,0 @@-{-# LANGUAGE TypeApplications #-}---- | Tests for query validation.-module ValidationTests (tests) where--import Protolude--import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck ((===))-import Test.Tasty (TestTree)-import Test.Tasty.Hspec (testSpec, describe, it, shouldBe)--import GraphQL.Internal.Name (Name)-import qualified GraphQL.Internal.Syntax.AST as AST-import GraphQL.Internal.Schema (Schema)-import GraphQL.Internal.Validation-  ( ValidationError(..)-  , findDuplicates-  , getErrors-  )--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 = panic "schema evaluated. We weren't expecting that."--tests :: IO TestTree-tests = testSpec "Validation" $ do-  describe "getErrors" $ do-    it "Treats simple queries as valid" $ do-      let doc = AST.QueryDocument-                [ AST.DefinitionOperation-                  ( AST.Query-                    ( AST.Node me [] []-                      [ AST.SelectionField (AST.Field Nothing someName [] [] [])-                      ]-                    )-                  )-                ]-      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` []--    it "Detects duplicate operation names" $ do-      let doc = AST.QueryDocument-                [ AST.DefinitionOperation-                  ( AST.Query-                    ( AST.Node me [] []-                      [ AST.SelectionField (AST.Field Nothing someName [] [] [])-                      ]-                    )-                  )-                , AST.DefinitionOperation-                  ( AST.Query-                    ( AST.Node me [] []-                      [ AST.SelectionField (AST.Field Nothing someName [] [] [])-                      ]-                    )-                  )-                ]-      getErrors schema doc `shouldBe` [DuplicateOperation me]--    it "Detects duplicate anonymous operations" $ do-      let doc = AST.QueryDocument-                [ AST.DefinitionOperation-                  ( AST.AnonymousQuery-                    [ AST.SelectionField (AST.Field Nothing someName [] [] [])-                    ]-                  )-                , AST.DefinitionOperation-                  ( AST.AnonymousQuery-                    [ AST.SelectionField (AST.Field Nothing someName [] [] [])-                    ]-                  )-                ]-      getErrors schema doc `shouldBe` [MixedAnonymousOperations 2 []]--  describe "findDuplicates" $ do-    prop "returns empty on unique lists" $ do-      \xs -> findDuplicates @Int (ordNub xs) === []-    prop "finds only duplicates" $ \xs -> do-      all (>1) (count xs <$> findDuplicates @Int xs)-    prop "finds all duplicates" $ \xs -> do-      (sort . findDuplicates @Int) xs === (ordNub . sort . filter ((> 1) . count xs)) xs----- | Count the number of times 'x' occurs in 'xs'.-count :: Eq a => [a] -> a -> Int-count xs x = (length . filter (== x)) xs

@@ -0,0 +1,96 @@+{-# LANGUAGE DeriveGeneric #-}+module ValueSpec (spec) where++import Protolude++import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (forAll)+import Test.Hspec++import qualified GraphQL.Internal.Syntax.AST as AST+import GraphQL.Internal.Arbitrary (arbitraryText, arbitraryNonEmpty)+import GraphQL.Value+  ( Object+  , Value'(ValueObject')+  , ObjectField'(..)+  , astToVariableValue+  , unionObjects+  , objectFields+  , objectFromList+  , toValue+  )+import GraphQL.Internal.Value.FromValue (FromValue(..), prop_roundtripValue)++data Resource = Resource+    { resText     :: Text+    , resInt      :: Int32+    , resDouble   :: Double+    , resBool     :: Bool+    } deriving (Generic, Eq, Show)++instance FromValue Resource++spec :: Spec+spec = describe "Value" $ do+  describe "unionObject" $ do+    it "returns empty on empty list" $ do+      unionObjects [] `shouldBe` (objectFromList [] :: Maybe Object)+    it "merges objects" $ do+      let (Just foo) = objectFromList [ ("foo", toValue @Int32 1)+                                      , ("bar",toValue @Int32 2)]+      let (Just bar) = objectFromList [ ("bar", toValue @Text "cow")+                                      , ("baz",toValue @Int32 3)]+      let observed = unionObjects [foo, bar]+      observed `shouldBe` Nothing+    it "merges objects with unique keys" $ do+      let (Just foo) = objectFromList [("foo", toValue @Int32 1)]+      let (Just bar) = objectFromList [ ("bar", toValue @Text "cow")+                                      , ("baz",toValue @Int32 3)]+      let (Just expected) = objectFromList [ ("foo", toValue @Int32 1)+                                           , ("bar", toValue @Text "cow")+                                           , ("baz", toValue @Int32 3)+                                           ]+      let (Just observed) = unionObjects [foo, bar]+      observed `shouldBe` expected+      expected `shouldSatisfy` prop_fieldsUnique+  describe "Objects" $ do+    prop "have unique fields" $ 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 +            [ ("resText",   toValue @Text "text")+            , ("resBool",   toValue @Bool False)+            , ("resDouble", toValue @Double 1.2)+            , ("resInt",    toValue @Int32 32)+            ]+      let Right observed = fromValue $ ValueObject' value+      let expected = Resource+            { resText   = "text"+            , resInt    = 32+            , resDouble = 1.2+            , resBool   = False +            }+      observed `shouldBe` expected+      +  describe "ToValue / FromValue instances" $ do+    prop "Bool" $ prop_roundtripValue @Bool+    prop "Int32" $ prop_roundtripValue @Int32+    prop "Double" $ prop_roundtripValue @Double+    prop "Text" $ forAll arbitraryText prop_roundtripValue+    prop "Lists" $ prop_roundtripValue @[Int32]+    prop "Non-empty lists" $ forAll (arbitraryNonEmpty @Int32) prop_roundtripValue+  describe "AST" $ do+    it "Objects converted from AST have unique fields" $ do+      let input = AST.ObjectValue [ AST.ObjectField "foo" (AST.ValueString (AST.StringValue "bar"))+                                  , AST.ObjectField "foo" (AST.ValueString (AST.StringValue "qux"))+                                  ]+      astToVariableValue (AST.ValueObject input) `shouldBe` Nothing+++-- | All of the fields in an object should have unique names.+prop_fieldsUnique :: Object -> Bool+prop_fieldsUnique object =+  fieldNames == ordNub fieldNames+  where+    fieldNames = [name | ObjectField name _ <- objectFields object]

@@ -1,70 +0,0 @@-module ValueTests (tests) where--import Protolude--import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck (forAll)-import Test.Tasty (TestTree)-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.Value-  ( Object-  , ObjectField'(..)-  , astToVariableValue-  , unionObjects-  , objectFields-  , objectFromList-  )-import GraphQL.Value.FromValue (prop_roundtripValue)-import GraphQL.Value.ToValue (toValue)---tests :: IO TestTree-tests = testSpec "Value" $ do-  describe "unionObject" $ do-    it "returns empty on empty list" $ do-      unionObjects [] `shouldBe` (objectFromList [] :: Maybe Object)-    it "merges objects" $ do-      let (Just foo) = objectFromList [ ("foo", toValue @Int32 1)-                                      , ("bar",toValue @Int32 2)]-      let (Just bar) = objectFromList [ ("bar", toValue @Text "cow")-                                      , ("baz",toValue @Int32 3)]-      let observed = unionObjects [foo, bar]-      observed `shouldBe` Nothing-    it "merges objects with unique keys" $ do-      let (Just foo) = objectFromList [("foo", toValue @Int32 1)]-      let (Just bar) = objectFromList [ ("bar", toValue @Text "cow")-                                      , ("baz",toValue @Int32 3)]-      let (Just expected) = objectFromList [ ("foo", toValue @Int32 1)-                                           , ("bar", toValue @Text "cow")-                                           , ("baz", toValue @Int32 3)-                                           ]-      let (Just observed) = unionObjects [foo, bar]-      observed `shouldBe` expected-      expected `shouldSatisfy` prop_fieldsUnique-  describe "Objects" $ do-    prop "have unique fields" $ do-      prop_fieldsUnique-  describe "ToValue / FromValue instances" $ do-    prop "Bool" $ prop_roundtripValue @Bool-    prop "Int32" $ prop_roundtripValue @Int32-    prop "Double" $ prop_roundtripValue @Double-    prop "Text" $ forAll arbitraryText prop_roundtripValue-    prop "Lists" $ prop_roundtripValue @[Int32]-    prop "Non-empty lists" $ forAll (arbitraryNonEmpty @Int32) prop_roundtripValue-  describe "AST" $ do-    it "Objects converted from AST have unique fields" $ do-      let input = AST.ObjectValue [ AST.ObjectField "foo" (AST.ValueString (AST.StringValue "bar"))-                                  , AST.ObjectField "foo" (AST.ValueString (AST.StringValue "qux"))-                                  ]-      astToVariableValue (AST.ValueObject input) `shouldBe` Nothing----- | All of the fields in an object should have unique names.-prop_fieldsUnique :: Object -> Bool-prop_fieldsUnique object =-  fieldNames == ordNub fieldNames-  where-    fieldNames = [name | ObjectField name _ <- objectFields object]

@@ -15,7 +15,5 @@                  , "TypeApplications"                  , "DataKinds"                  ]-    -- library code and examples-    files = [ "src/"-            , "tests/Examples/"-            ]+    -- library code+    files = [ "src/" ]