packages feed

graphql-api (empty) → 0.1.1

raw patch · 35 files changed

+5903/−0 lines, 35 filesdep +QuickCheckdep +aesondep +attoparsecsetup-changed

Dependencies added: QuickCheck, aeson, attoparsec, base, containers, criterion, directory, doctest, exceptions, graphql-api, hspec, protolude, raw-strings-qq, scientific, tasty, tasty-hspec, text, transformers

Files

+ LICENSE.Apache-2.0 view
@@ -0,0 +1,163 @@+Apache License++Version 2.0, January 2004++http://www.apache.org/licenses/++TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++1. Definitions.++"License" shall mean the terms and conditions for use, reproduction, and+distribution as defined by Sections 1 through 9 of this document.++"Licensor" shall mean the copyright owner or entity authorized by the+copyright owner that is granting the License.++"Legal Entity" shall mean the union of the acting entity and all other+entities that control, are controlled by, or are under common control with+that entity. For the purposes of this definition, "control" means (i) the+power, direct or indirect, to cause the direction or management of such+entity, whether by contract or otherwise, or (ii) ownership of fifty percent+(50%) or more of the outstanding shares, or (iii) beneficial ownership of such+entity.++"You" (or "Your") shall mean an individual or Legal Entity exercising+permissions granted by this License.++"Source" form shall mean the preferred form for making modifications,+including but not limited to software source code, documentation source, and+configuration files.++"Object" form shall mean any form resulting from mechanical transformation or+translation of a Source form, including but not limited to compiled object+code, generated documentation, and conversions to other media types.++"Work" shall mean the work of authorship, whether in Source or Object form,+made available under the License, as indicated by a copyright notice that is+included in or attached to the work (an example is provided in the Appendix+below).++"Derivative Works" shall mean any work, whether in Source or Object form, that+is based on (or derived from) the Work and for which the editorial revisions,+annotations, elaborations, or other modifications represent, as a whole, an+original work of authorship. For the purposes of this License, Derivative+Works shall not include works that remain separable from, or merely link (or+bind by name) to the interfaces of, the Work and Derivative Works thereof.++"Contribution" shall mean any work of authorship, including the original+version of the Work and any modifications or additions to that Work or+Derivative Works thereof, that is intentionally submitted to Licensor for+inclusion in the Work by the copyright owner or by an individual or Legal+Entity authorized to submit on behalf of the copyright owner. For the purposes+of this definition, "submitted" means any form of electronic, verbal, or+written communication sent to the Licensor or its representatives, including+but not limited to communication on electronic mailing lists, source code+control systems, and issue tracking systems that are managed by, or on behalf+of, the Licensor for the purpose of discussing and improving the Work, but+excluding communication that is conspicuously marked or otherwise designated+in writing by the copyright owner as "Not a Contribution."++"Contributor" shall mean Licensor and any individual or Legal Entity on behalf+of whom a Contribution has been received by Licensor and subsequently+incorporated within the Work.++2. Grant of Copyright License. Subject to the terms and conditions of this+License, each Contributor hereby grants to You a perpetual, worldwide,+non-exclusive, no-charge, royalty-free, irrevocable copyright license to+reproduce, prepare Derivative Works of, publicly display, publicly perform,+sublicense, and distribute the Work and such Derivative Works in Source or+Object form.++3. Grant of Patent License. Subject to the terms and conditions of this+License, each Contributor hereby grants to You a perpetual, worldwide,+non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this+section) patent license to make, have made, use, offer to sell, sell, import,+and otherwise transfer the Work, where such license applies only to those+patent claims licensable by such Contributor that are necessarily infringed by+their Contribution(s) alone or by combination of their Contribution(s) with+the Work to which such Contribution(s) was submitted. If You institute patent+litigation against any entity (including a cross-claim or counterclaim in a+lawsuit) alleging that the Work or a Contribution incorporated within the Work+constitutes direct or contributory patent infringement, then any patent+licenses granted to You under this License for that Work shall terminate as of+the date such litigation is filed.++4. Redistribution. You may reproduce and distribute copies of the Work or+Derivative Works thereof in any medium, with or without modifications, and in+Source or Object form, provided that You meet the following conditions:++You must give any other recipients of the Work or Derivative Works a copy of+this License; and++You must cause any modified files to carry prominent notices stating that You+changed the files; and++You must retain, in the Source form of any Derivative Works that You+distribute, all copyright, patent, trademark, and attribution notices from the+Source form of the Work, excluding those notices that do not pertain to any+part of the Derivative Works; and++If the Work includes a "NOTICE" text file as part of its distribution, then+any Derivative Works that You distribute must include a readable copy of the+attribution notices contained within such NOTICE file, excluding those notices+that do not pertain to any part of the Derivative Works, in at least one of+the following places: within a NOTICE text file distributed as part of the+Derivative Works; within the Source form or documentation, if provided along+with the Derivative Works; or, within a display generated by the Derivative+Works, if and wherever such third-party notices normally appear. The contents+of the NOTICE file are for informational purposes only and do not modify the+License. You may add Your own attribution notices within Derivative Works that+You distribute, alongside or as an addendum to the NOTICE text from the Work,+provided that such additional attribution notices cannot be construed as+modifying the License.++You may add Your own copyright statement to Your modifications and may provide+additional or different license terms and conditions for use, reproduction, or+distribution of Your modifications, or for any such Derivative Works as a+whole, provided Your use, reproduction, and distribution of the Work otherwise+complies with the conditions stated in this License.++5. Submission of Contributions. Unless You explicitly state otherwise, any+Contribution intentionally submitted for inclusion in the Work by You to the+Licensor shall be under the terms and conditions of this License, without any+additional terms or conditions. Notwithstanding the above, nothing herein+shall supersede or modify the terms of any separate license agreement you may+have executed with Licensor regarding such Contributions.++6. Trademarks. This License does not grant permission to use the trade names,+trademarks, service marks, or product names of the Licensor, except as+required for reasonable and customary use in describing the origin of the Work+and reproducing the content of the NOTICE file.++7. Disclaimer of Warranty. Unless required by applicable law or agreed to in+writing, Licensor provides the Work (and each Contributor provides its+Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY+KIND, either express or implied, including, without limitation, any warranties+or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+PARTICULAR PURPOSE. You are solely responsible for determining the+appropriateness of using or redistributing the Work and assume any risks+associated with Your exercise of permissions under this License.++8. Limitation of Liability. In no event and under no legal theory, whether in+tort (including negligence), contract, or otherwise, unless required by+applicable law (such as deliberate and grossly negligent acts) or agreed to in+writing, shall any Contributor be liable to You for damages, including any+direct, indirect, special, incidental, or consequential damages of any+character arising as a result of this License or out of the use or inability+to use the Work (including but not limited to damages for loss of goodwill,+work stoppage, computer failure or malfunction, or any and all other+commercial damages or losses), even if such Contributor has been advised of+the possibility of such damages.++9. Accepting Warranty or Additional Liability. While redistributing the Work+or Derivative Works thereof, You may choose to offer, and charge a fee for,+acceptance of support, warranty, indemnity, or other liability obligations+and/or rights consistent with this License. However, in accepting such+obligations, You may act only on Your own behalf and on Your sole+responsibility, not on behalf of any other Contributor, and only if You agree+to indemnify, defend, and hold each Contributor harmless for any liability+incurred by, or claims asserted against, such Contributor by reason of your+accepting any such warranty or additional liability.++END OF TERMS AND CONDITIONS
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ benchmarks/Main.hs view
@@ -0,0 +1,12 @@+module Main (main) where++import Protolude++import Criterion.Main (bgroup, defaultMain)+import qualified Validation+++main :: IO ()+main = do+  defaultMain [ bgroup "GraphQL API" Validation.benchmarks+              ]
+ benchmarks/Validation.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TypeApplications #-}+module Validation (benchmarks) where++import Protolude++import Criterion (Benchmark, bench, nf)+import GraphQL.Internal.Validation (findDuplicates)+++benchmarks :: [Benchmark]+benchmarks =+  [ bench "findDuplicates" (nf findDuplicates exampleData)+  ]+  where+    exampleData :: [Int]+    exampleData = [2, 8, 9, 8, 1, 7, 5, 0, 1, 3, 5, 4]
+ graphql-api.cabal view
@@ -0,0 +1,140 @@+-- This file has been generated from package.yaml by hpack version 0.15.0.+--+-- see: https://github.com/sol/hpack++name:           graphql-api+version:        0.1.1+synopsis:       Sketch of GraphQL stuff+description:    Please see README.md+category:       Web+homepage:       https://github.com/jml/graphql-api#readme+bug-reports:    https://github.com/jml/graphql-api/issues+maintainer:     Jonathan M. Lange <jml@mumak.net>+license:        Apache+license-file:   LICENSE.Apache-2.0+build-type:     Simple+cabal-version:  >= 1.10++source-repository head+  type: git+  location: https://github.com/jml/graphql-api++library+  hs-source-dirs:+      src+  default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications+  ghc-options: -Wall -fno-warn-redundant-constraints+  build-depends:+      base >= 4.9 && < 5+    , protolude+    , exceptions+    , transformers+    , attoparsec+    , aeson+    , containers+    , scientific+    , QuickCheck+    , text+  exposed-modules:+      GraphQL+      GraphQL.API+      GraphQL.API.Enum+      GraphQL.Internal.Arbitrary+      GraphQL.Internal.Execution+      GraphQL.Internal.Name+      GraphQL.Internal.OrderedMap+      GraphQL.Internal.Output+      GraphQL.Internal.Schema+      GraphQL.Internal.Syntax.AST+      GraphQL.Internal.Syntax.Encoder+      GraphQL.Internal.Syntax.Parser+      GraphQL.Internal.Syntax.Tokens+      GraphQL.Internal.Validation+      GraphQL.Resolver+      GraphQL.Value+      GraphQL.Value.FromValue+      GraphQL.Value.ToValue+  default-language: Haskell2010++test-suite graphql-api-doctests+  type: exitcode-stdio-1.0+  main-is: Doctests.hs+  hs-source-dirs:+      tests+  default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications+  ghc-options: -Wall -fno-warn-redundant-constraints -threaded+  build-depends:+      base >= 4.9 && < 5+    , protolude+    , exceptions+    , transformers+    , attoparsec+    , doctest+  other-modules:+      ASTTests+      EndToEndTests+      Examples.InputObject+      Examples.UnionExample+      ExampleSchema+      OrderedMapTests+      ResolverTests+      SchemaTests+      Spec+      ValidationTests+      ValueTests+  default-language: Haskell2010++test-suite graphql-api-tests+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      tests+  default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications+  ghc-options: -Wall -fno-warn-redundant-constraints+  build-depends:+      base >= 4.9 && < 5+    , protolude+    , exceptions+    , transformers+    , attoparsec+    , aeson+    , containers+    , graphql-api+    , hspec+    , QuickCheck+    , raw-strings-qq+    , tasty+    , tasty-hspec+    , directory+  other-modules:+      ASTTests+      Doctests+      EndToEndTests+      Examples.InputObject+      Examples.UnionExample+      ExampleSchema+      OrderedMapTests+      ResolverTests+      SchemaTests+      ValidationTests+      ValueTests+  default-language: Haskell2010++benchmark criterion+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+      benchmarks+  default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards TypeApplications+  ghc-options: -Wall -fno-warn-redundant-constraints+  build-depends:+      base >= 4.9 && < 5+    , protolude+    , exceptions+    , transformers+    , attoparsec+    , criterion+    , graphql-api+  other-modules:+      Validation+  default-language: Haskell2010
+ src/GraphQL.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Interface for GraphQL API.+--+-- __Note__: This module is highly subject to change. We're still figuring+-- where to draw the lines and what to expose.+module GraphQL+  (+    -- * Running queries+    interpretQuery+  , interpretAnonymousQuery+  , Response(..)+    -- * Preparing queries then running them+  , makeSchema+  , compileQuery+  , executeQuery+  , QueryError+  , Schema+  , VariableValues+  , Value+  ) where++import Protolude++import Data.Attoparsec.Text (parseOnly, endOfInput)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import GraphQL.API (HasObjectDefinition(..))+import GraphQL.Internal.Execution+  ( VariableValues+  , ExecutionError+  , substituteVariables+  )+import qualified GraphQL.Internal.Execution as Execution+import qualified GraphQL.Internal.Syntax.AST as AST+import qualified GraphQL.Internal.Syntax.Parser as Parser+import GraphQL.Internal.Validation+  ( QueryDocument+  , SelectionSetByType+  , ValidationErrors+  , validate+  , getSelectionSet+  , VariableValue+  )+import GraphQL.Internal.Output+  ( GraphQLError(..)+  , Response(..)+  , singleError+  )+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)++-- | Errors that can happen while processing a query document.+data QueryError+  -- | Failed to parse.+  = ParseError Text+  -- | Parsed, but failed validation.+  --+  -- See <https://facebook.github.io/graphql/#sec-Validation> for more+  -- details.+  | ValidationError ValidationErrors+  -- | Validated, but failed during execution.+  | ExecutionError ExecutionError+  -- | Error in the schema.+  | SchemaError NameError+  -- | Got a value that wasn't an object.+  | NonObjectResult Value+  deriving (Eq, Show)++instance GraphQLError QueryError where+  formatError (ParseError e) =+    "Couldn't parse query document: " <> e+  formatError (ValidationError es) =+    "Validation errors:\n" <> mconcat ["  " <> formatError e <> "\n" | e <- NonEmpty.toList es]+  formatError (ExecutionError e) =+    "Execution error: " <> show e+  formatError (SchemaError e) =+    "Schema error: " <> formatError e+  formatError (NonObjectResult v) =+    "Query returned a value that is not an object: " <> show v++-- | Execute a GraphQL query.+executeQuery+  :: forall api m. (HasResolver m api, Applicative m, HasObjectDefinition api)+  => 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".+  -> VariableValues -- ^ Values for variables defined in the query document. A map of 'Variable' to 'Value'.+  -> m Response -- ^ The outcome of running the query.+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)+  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))++-- | Create a GraphQL schema.+makeSchema :: forall api. HasObjectDefinition api => Either QueryError Schema+makeSchema = first SchemaError (Schema.makeSchema <$> getDefinition @api)++-- | Interpet a GraphQL query.+--+-- Compiles then executes a GraphQL query.+interpretQuery+  :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api)+  => 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"@.+  -> VariableValues -- ^ Values for variables defined in the query document. A map of 'Variable' to 'Value'.+  -> m Response -- ^ The outcome of running the query.+interpretQuery handler query name variables =+  case makeSchema @api >>= flip compileQuery query of+    Left err -> pure (PreExecutionFailure (toError err :| []))+    Right document -> executeQuery @api @m handler document name variables++-- | Interpret an anonymous GraphQL query.+--+-- Anonymous queries have no name and take no variables.+interpretAnonymousQuery+  :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api)+  => 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.+interpretAnonymousQuery handler query = interpretQuery @api @m handler query Nothing mempty++-- | Turn some text into a valid query document.+compileQuery :: Schema -> Text -> Either QueryError (QueryDocument VariableValue)+compileQuery schema query = do+  parsed <- first ParseError (parseQuery query)+  first ValidationError (validate schema parsed)++-- | Parse a query document.+parseQuery :: Text -> Either Text AST.QueryDocument+parseQuery query = first toS (parseOnly (Parser.queryDocument <* endOfInput) query)++-- | Get an operation from a query document ready to be processed.+getOperation :: QueryDocument VariableValue -> Maybe Name -> VariableValues -> Either QueryError (SelectionSetByType Value)+getOperation document name vars = first ExecutionError $ do+  op <- Execution.getOperation document name+  resolved <- substituteVariables op vars+  pure (getSelectionSet resolved)
+ src/GraphQL/API.hs view
@@ -0,0 +1,343 @@+{-# 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.+module GraphQL.API+  ( Object+  , Field+  , Argument+  , DefaultArgument+  , Union+  , List+  , Enum+  , GraphQLEnum(..)+  , Interface+  , (:>)(..)+  , HasAnnotatedType(..)+  , HasAnnotatedInputType+  , HasObjectDefinition(..)+  , getArgumentDefinition+  -- | Exported for testing. Perhaps should be a different module.+  , getFieldDefinition+  , getInterfaceDefinition+  , getAnnotatedInputType+  ) where++import Protolude hiding (Enum, TypeError)++import GraphQL.Internal.Schema hiding (Type)+import qualified GraphQL.Internal.Schema (Type)+import GHC.TypeLits (Symbol, KnownSymbol, TypeError, ErrorMessage(..))+import GraphQL.Internal.Name (NameError, nameFromSymbol)+import GraphQL.API.Enum (GraphQLEnum(..))+import GHC.Generics ((:*:)(..))+++-- $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)+++-- Can't set the value for default arguments via types, but can+-- distinguish to force users to provide a default argument somewhere+-- in their function (using Maybe? ore some new type like+-- https://hackage.haskell.org/package/optional-args-1.0.1)+data DefaultArgument (name :: Symbol) (argType :: Type)++cons :: a -> [a] -> [a]+cons = (:)++-- Transform into a Schema definition+class HasObjectDefinition a where+  -- Todo rename to getObjectTypeDefinition+  getDefinition :: Either NameError ObjectTypeDefinition++class HasFieldDefinition a where+  getFieldDefinition :: Either NameError FieldDefinition+++-- Fields+class HasFieldDefinitions a where+  getFieldDefinitions :: Either NameError [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 UnionTypeObjectTypeDefinitionList a where+  getUnionTypeObjectTypeDefinitions :: Either NameError [ObjectTypeDefinition]++instance forall a as. (HasObjectDefinition a, UnionTypeObjectTypeDefinitionList as) => UnionTypeObjectTypeDefinitionList (a:as) where+  getUnionTypeObjectTypeDefinitions = cons <$> getDefinition @a <*> getUnionTypeObjectTypeDefinitions @as++instance UnionTypeObjectTypeDefinitionList '[] where+  getUnionTypeObjectTypeDefinitions = pure []++-- Interfaces+class HasInterfaceDefinitions a where+  getInterfaceDefinitions :: Either NameError 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 InterfaceTypeDefinition++instance forall ks fields. (KnownSymbol ks, HasFieldDefinitions fields) => HasInterfaceDefinition (Interface ks fields) where+  getInterfaceDefinition =+    let name = nameFromSymbol @ks+        fields = NonEmptyList <$> getFieldDefinitions @fields+    in InterfaceTypeDefinition <$> name <*> fields++-- Give users some help if they don't terminate Arguments with a Field:+-- NB the "redundant constraints" warning is a GHC bug: https://ghc.haskell.org/trac/ghc/ticket/11099+instance forall ks t. TypeError ('Text ":> Arguments must end with a Field") =>+         HasFieldDefinition (Argument ks t) where+  getFieldDefinition = notImplemented++instance forall ks is ts. (KnownSymbol ks, HasInterfaceDefinitions is, HasFieldDefinitions ts) => HasAnnotatedType (Object ks is ts) where+  getAnnotatedType =+    let obj = getDefinition @(Object ks is ts)+    in (TypeNamed . DefinedType . TypeDefinitionObject) <$> obj++instance forall t ks. (KnownSymbol ks, HasAnnotatedType t) => HasFieldDefinition (Field ks t) where+  getFieldDefinition =+    let name = nameFromSymbol @ks+    in FieldDefinition <$> name <*> pure [] <*> getAnnotatedType @t++class HasArgumentDefinition a where+  getArgumentDefinition :: Either NameError ArgumentDefinition++instance forall ks t. (KnownSymbol ks, HasAnnotatedInputType t) => HasArgumentDefinition (Argument ks t) where+  getArgumentDefinition = 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 (FieldDefinition name argDefs at) = 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 = NonEmptyList <$> getFieldDefinitions @fields+    in 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 (AnnotatedType GraphQL.Internal.Schema.Type)++-- | Turn a non-null type into the optional version of its own type.+dropNonNull :: AnnotatedType t -> AnnotatedType t+dropNonNull (TypeNonNull (NonNullTypeNamed t)) = TypeNamed t+dropNonNull (TypeNonNull (NonNullTypeList t)) = TypeList t+dropNonNull x@(TypeNamed _) = x+dropNonNull x@(TypeList _) = x++instance forall a. HasAnnotatedType a => HasAnnotatedType (Maybe a) where+  -- see TODO in HasAnnotatedType class+  getAnnotatedType = dropNonNull <$> getAnnotatedType @a++builtinType :: Builtin -> Either NameError (AnnotatedType GraphQL.Internal.Schema.Type)+builtinType = pure . TypeNonNull . NonNullTypeNamed . BuiltinType++-- 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 GInt++instance HasAnnotatedType Int32 where+  getAnnotatedType = builtinType GInt++instance HasAnnotatedType Bool where+  getAnnotatedType = builtinType GBool++instance HasAnnotatedType Text where+  getAnnotatedType = builtinType GString++instance HasAnnotatedType Double where+  getAnnotatedType = builtinType GFloat++instance HasAnnotatedType Float where+  getAnnotatedType = builtinType GFloat++instance forall t. (HasAnnotatedType t) => HasAnnotatedType (List t) where+  getAnnotatedType = TypeList . ListType <$> getAnnotatedType @t++instance forall ks enum. (KnownSymbol ks, GraphQLEnum enum) => HasAnnotatedType (Enum ks enum) where+  getAnnotatedType = do+    let name = nameFromSymbol @ks+    let enums = sequenceA (enumValues @enum) :: Either NameError [Name]+    let et = EnumTypeDefinition <$> name <*> map (map EnumValueDefinition) enums+    TypeNonNull . NonNullTypeNamed . DefinedType . TypeDefinitionEnum <$> et++instance forall ks as. (KnownSymbol ks, UnionTypeObjectTypeDefinitionList as) => HasAnnotatedType (Union ks as) where+  getAnnotatedType =+    let name = nameFromSymbol @ks+        types = NonEmptyList <$> getUnionTypeObjectTypeDefinitions @as+    in (TypeNamed . DefinedType . TypeDefinitionUnion) <$> (UnionTypeDefinition <$> name <*> types)++-- Help users with better type errors+instance TypeError ('Text "Cannot encode Integer because it has arbitrary size but the JSON encoding is a number") =>+         HasAnnotatedType Integer where+  getAnnotatedType = undefined+++-- Builtin input types+class HasAnnotatedInputType a where+  -- See TODO comment in "HasAnnotatedType" class for nullability.+  getAnnotatedInputType :: Either NameError (AnnotatedType InputType)+  default getAnnotatedInputType :: (Generic a, GenericAnnotatedInputType (Rep a)) => Either NameError (AnnotatedType InputType)+  getAnnotatedInputType = genericGetAnnotatedInputType @(Rep a)++instance forall a. HasAnnotatedInputType a => HasAnnotatedInputType (Maybe a) where+  getAnnotatedInputType = dropNonNull <$> getAnnotatedInputType @a++builtinInputType :: Builtin -> Either NameError (AnnotatedType InputType)+builtinInputType = pure . TypeNonNull . NonNullTypeNamed . BuiltinInputType++instance HasAnnotatedInputType Int where+  getAnnotatedInputType = builtinInputType GInt++instance HasAnnotatedInputType Int32 where+  getAnnotatedInputType = builtinInputType GInt++instance HasAnnotatedInputType Bool where+  getAnnotatedInputType = builtinInputType GBool++instance HasAnnotatedInputType Text where+  getAnnotatedInputType = builtinInputType GString++instance HasAnnotatedInputType Double where+  getAnnotatedInputType = builtinInputType GFloat++instance HasAnnotatedInputType Float where+  getAnnotatedInputType = builtinInputType GFloat++instance forall t. (HasAnnotatedInputType t) => HasAnnotatedInputType (List t) where+  getAnnotatedInputType = TypeList . ListType <$> getAnnotatedInputType @t++instance forall ks enum. (KnownSymbol ks, GraphQLEnum enum) => HasAnnotatedInputType (Enum ks enum) where+  getAnnotatedInputType = do+    let name = nameFromSymbol @ks+        enums = sequenceA (enumValues @enum) :: Either NameError [Name]+    let et = EnumTypeDefinition <$> name <*> map (map EnumValueDefinition) enums+    TypeNonNull . NonNullTypeNamed . DefinedInputType . InputTypeDefinitionEnum <$> et+++-- Generic getAnnotatedInputType function+class GenericAnnotatedInputType (f :: Type -> Type) where+  genericGetAnnotatedInputType :: Either NameError (AnnotatedType InputType)++class GenericInputObjectFieldDefinitions (f :: Type -> Type) where+  genericGetInputObjectFieldDefinitions :: Either NameError [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 ( TypeNonNull+          . NonNullTypeNamed+          . DefinedInputType+          . InputTypeDefinitionObject+          . (InputObjectTypeDefinition name)+          . 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 = 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 = InputObjectFieldDefinition name annotatedInputType Nothing+    pure [l]
+ src/GraphQL/API/Enum.hs view
@@ -0,0 +1,118 @@+{-# 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(..))++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 conName f p b.+  ( KnownSymbol conName+  , GenericEnumValues f+  ) => GenericEnumValues (C1 ('MetaCons conName p b) U1 :+: f) where+  genericEnumValues = let name = nameFromSymbol @conName in name:genericEnumValues @f+  genericEnumFromValue vname =+    case nameFromSymbol @conName of+      Right name -> if name == vname+                    then L1 <$> Right (M1 U1)+                    else R1 <$> genericEnumFromValue vname+      Left x -> invalidEnumName x+  genericEnumToValue (L1 _) =+    case nameFromSymbol @conName of+      Right name -> name+      -- 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 err -> panic ("Invalid name: " <> show err <> ". This should have been caught during validation. Please file a bug.")+  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)+      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 = undefined+  genericEnumFromValue = undefined+  genericEnumToValue = undefined++instance forall conName p b sa sb f.+  ( TypeError ('Text "Constructor not unary: " ':<>: 'Text conName)+  , KnownSymbol conName+  ) => GenericEnumValues (C1 ('MetaCons conName p b) (S1 sa sb) :+: f) where+  genericEnumValues = undefined+  genericEnumFromValue = undefined+  genericEnumToValue = undefined+++-- | 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
+ src/GraphQL/Internal/Arbitrary.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE RankNTypes #-}++module GraphQL.Internal.Arbitrary+  ( arbitraryText+  , arbitraryNonEmpty+  ) where++import Protolude++import qualified Data.List.NonEmpty as NonEmpty+import Data.List.NonEmpty (NonEmpty)+import qualified Data.String+import Test.QuickCheck (Gen, Arbitrary(..), arbitrary, listOf1)++-- | Generate arbitrary 'Text'.+arbitraryText :: Gen Text+arbitraryText = toS <$> arbitrary @Data.String.String++-- | Generate an arbitrary 'NonEmpty' list.+arbitraryNonEmpty :: forall a. Arbitrary a => Gen (NonEmpty a)+arbitraryNonEmpty =+  -- NonEmpty.fromList panics, but that's OK, because listOf1 is guaranteed to+  -- return a non-empty list, and because a panic in a test is highly+  -- informative and indicative of a bug.+  NonEmpty.fromList <$> listOf1 arbitrary+
+ src/GraphQL/Internal/Execution.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+-- | 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+-- 'GraphQL.Internal.Validation' and the processing in 'GraphQL.Resolver'.+-- This module provides that glue.+module GraphQL.Internal.Execution+  ( VariableValues+  , ExecutionError(..)+  , formatError+  , getOperation+  , substituteVariables+  ) where++import Protolude hiding (Type)++import qualified Data.Map as Map+import GraphQL.Value+  ( Name+  , Value+  , pattern ValueNull+  , Value'(..)+  , List'(..)+  , Object'(..)+  )+import GraphQL.Internal.Output (GraphQLError(..))+import GraphQL.Internal.Validation+  ( Operation+  , QueryDocument(..)+  , VariableDefinition(..)+  , VariableValue+  , Variable+  , Type(..)+  )++-- | Get an operation from a GraphQL document+--+-- <https://facebook.github.io/graphql/#sec-Executing-Requests>+--+-- GetOperation(document, operationName):+--+--   * If {operationName} is {null}:+--     * If {document} contains exactly one operation.+--       * Return the Operation contained in the {document}.+--     * Otherwise produce a query error requiring {operationName}.+--   * Otherwise:+--     * Let {operation} be the Operation named {operationName} in {document}.+--     * If {operation} was not found, produce a query error.+--     * Return {operation}.+getOperation :: QueryDocument value -> Maybe Name -> Either ExecutionError (Operation value)+getOperation (LoneAnonymousOperation op) Nothing = pure op+getOperation (MultipleOperations ops) (Just name) = note (NoSuchOperation name) (Map.lookup name ops)+getOperation (MultipleOperations ops) Nothing =+  case toList ops of+    [op] -> pure op+    _ -> throwError NoAnonymousOperation+getOperation _ (Just name) = throwError (NoSuchOperation name)+++-- | Substitute variables in a GraphQL document.+--+-- Once this is done, there will be no variables in the document whatsoever.+substituteVariables :: Operation VariableValue -> VariableValues -> Either ExecutionError (Operation Value)+substituteVariables op vars = traverse (replaceVariable vars) op++replaceVariable :: VariableValues -> VariableValue -> Either ExecutionError Value+replaceVariable vars value =+  case value of+    ValueScalar' (Left defn) -> getValue defn+    ValueScalar' (Right v) -> pure (ValueScalar' v)+    ValueList' (List' xs) -> ValueList' . List' <$> traverse (replaceVariable vars) xs+    ValueObject' (Object' xs) -> ValueObject' . Object' <$> traverse (replaceVariable vars) xs+  where++    getValue :: VariableDefinition -> Either ExecutionError Value+    getValue (VariableDefinition variableName variableType defaultValue) =+      note (MissingValue variableName) $+      Map.lookup variableName vars <|> defaultValue <|> allowNull variableType++    allowNull (TypeNonNull _) = empty+    allowNull _ = pure ValueNull++-- | An error that occurs while executing a query. Technically,+-- 'ResolverError' also falls into the same category, but is separate to help+-- our code be a bit better organized.+data ExecutionError+  = MissingValue Variable+  | NoSuchOperation Name+  | NoAnonymousOperation+  deriving (Eq, Show)++instance GraphQLError ExecutionError where+  formatError (MissingValue name) = "Missing value for " <> show name <> " and must be non-null."+  formatError (NoSuchOperation name) = "Requested operation " <> show name <> " but couldn't find it."+  formatError NoAnonymousOperation = "No name supplied for opertaion, but no anonymous operation."++-- | A map of variables to their values.+--+-- In GraphQL the variable values are not part of the query itself, they are+-- instead passed in through a separate channel. Create a 'VariableValues'+-- from this other channel and pass it to 'substituteVariables'.+--+-- GraphQL allows the values of variables to be specified, but doesn't provide+-- a way for doing so in the language.+type VariableValues = Map Variable Value
+ src/GraphQL/Internal/Name.hs view
@@ -0,0 +1,69 @@+-- | Representation of GraphQL names.+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module GraphQL.Internal.Name+  ( Name(unName)+  , NameError(..)+  , makeName+  , nameFromSymbol+  -- * Named things+  , HasName(..)+  -- * Unsafe functions+  , unsafeMakeName+  ) where++import Protolude++import qualified Data.Attoparsec.Text as A+import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)+import GraphQL.Internal.Syntax.AST+  ( Name(..)+  , nameParser+  )++-- | An invalid name.+newtype NameError = NameError Text deriving (Eq, Show)++-- | Create a 'Name'.+--+-- Names must match the regex @[_A-Za-z][_0-9A-Za-z]*@. If the given text does+-- not match, return Nothing.+--+-- >>> makeName "foo"+-- Right (Name {unName = "foo"})+-- >>> makeName "9-bar"+-- Left (NameError "9-bar")+makeName :: Text -> Either NameError Name+makeName name = first (const (NameError name)) (A.parseOnly nameParser name)++-- | Convert a type-level 'Symbol' into a GraphQL 'Name'.+nameFromSymbol :: forall (n :: Symbol). KnownSymbol n => Either NameError Name+nameFromSymbol = makeName (toS (symbolVal @n Proxy))++-- | Create a 'Name', panicking if the given text is invalid.+--+-- Prefer 'makeName' to this in all cases.+--+-- >>> unsafeMakeName "foo"+-- Name {unName = "foo"}+unsafeMakeName :: HasCallStack => Text -> Name+unsafeMakeName name =+  case makeName name of+    Left e -> panic (show e)+    Right n -> n++-- | Types that implement this have values with a single canonical name in a+-- GraphQL schema.+--+-- e.g. a field @foo(bar: Int32)@ would have the name @\"foo\"@.+--+-- If a thing *might* have a name, or has a name that might not be valid,+-- don't use this.+--+-- If a thing is aliased, then return the *original* name.+class HasName a where+  -- | Get the name of the object.+  getName :: a -> Name
+ src/GraphQL/Internal/OrderedMap.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE RankNTypes #-}+-- | 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.+-- This would normally be modelled as a 'Map'. However, in many of these+-- cases, the order in which the entries appear matters.+--+-- That is,+--+-- @+-- {+--   'foo': 1,+--   'bar': 2+-- }+-- @+--+-- Is different to,+--+-- @+-- {+--   'bar': 2,+--   'foo': 1,+-- }+--+-- Even though they have exactly the same keys, and the keys have exactly the+-- same values.+--+-- Goal for this module is to provide data structures that are "complete+-- enough" for implementing the rest of GraphQL.+module GraphQL.Internal.OrderedMap+  ( OrderedMap+  -- * Construction+  , empty+  , singleton+  , orderedMap+  -- * Querying+  , lookup+  -- * Filtering+  , GraphQL.Internal.OrderedMap.catMaybes+  -- * Combine+  -- ** Union+  , unions+  , unionWith+  , unionsWith+  , unionWithM+  , unionsWithM+  -- * Conversion+  , toList+  , toMap+  , keys+  , values+  -- * Properties+  , genOrderedMap+  ) where++import Protolude hiding (empty, toList)++import qualified Data.Map as Map+import Test.QuickCheck (Arbitrary(..), Gen, listOf)++data OrderedMap key value+  = OrderedMap+    { -- | Get the list of keys from an ordered map, in order of appearance.+      --+      -- This list is guaranteed to have no duplicates.+      keys :: [key]+      -- | Convert an ordered map to a regular map, losing insertion order.+    , toMap :: Map key value+    }+  deriving (Eq, Ord, Show)++-- | Convert an ordered map to a list of keys and values. The list is+-- guaranteed to be the same order as the order of insertion into the map.+--+-- /O(n log n)/+toList :: forall key value. Ord key => OrderedMap key value -> [(key, value)]+toList (OrderedMap keys entries) = Protolude.catMaybes (foreach keys $ \k -> (,) k <$> Map.lookup k entries)++instance Foldable (OrderedMap key) where+  foldr f z (OrderedMap _ entries) = foldr f z entries++instance Traversable (OrderedMap key) where+  traverse f (OrderedMap keys entries) = OrderedMap keys <$> traverse f entries++instance Functor (OrderedMap key) where+  fmap f (OrderedMap keys entries) = OrderedMap keys (map f entries)++instance (Arbitrary key, Arbitrary value, Ord key) => Arbitrary (OrderedMap key value) where+  arbitrary = genOrderedMap arbitrary arbitrary++-- | Generate an ordered map with the given key & value generators.+genOrderedMap :: forall key value. Ord key => Gen key -> Gen value -> Gen (OrderedMap key value)+genOrderedMap genKey genValue = do+  entries <- Map.fromList <$> (zip <$> listOf genKey <*> listOf genValue)+  pure (OrderedMap (Map.keys entries) entries)++-- | The empty OrderedMap. /O(1)/+empty :: forall key value. OrderedMap key value+empty = OrderedMap [] Map.empty++-- | Create an ordered map containing a single entry. /O(1)/+singleton :: forall key value. key -> value -> OrderedMap key value+singleton key value = OrderedMap [key] (Map.singleton key value)++-- | Find a value in an ordered map.+--+-- /O(log n)/+lookup :: forall key value. Ord key => key -> OrderedMap key value -> Maybe value+lookup key (OrderedMap _ entries) = Map.lookup key entries++-- | Get the values from an ordered map, in order of appearance. /O(n log n)/+values :: forall key value. Ord key => OrderedMap key value -> [value]+values = map snd . toList++-- | The union of a list of ordered maps.+--+-- If any map shares a key with any other map, return 'Nothing'.+--+-- Otherwise, return a new map containing all of the keys from all of the+-- maps. The keys from the first map will appear first, followed by the+-- second, and so forth.+--+-- /O(m * n log (m * n))/ where /m/ is the number of maps, and /n/ is the size of+-- the largest map.+unions :: forall key value. Ord key => [OrderedMap key value] -> Maybe (OrderedMap key value)+unions orderedMaps = orderedMap (orderedMaps >>= toList)++-- | Append the second ordered map to the first, combining any shared elements+-- with the given function.+unionWith :: Ord key+          => (value -> value -> value)+          -> OrderedMap key value+          -> OrderedMap key value+          -> OrderedMap key value+unionWith f x y =+  OrderedMap+  { toMap = Map.unionWith f (toMap x) (toMap y)+  , keys = keys x <> [k | k <- keys y, k `Map.notMember` toMap x]+  }++-- | Append together a list of ordered maps, preserving ordering of keys.+-- Combine any shared elements with the given function.+unionsWith :: Ord key+           => (value -> value -> value)+           -> [OrderedMap key value]+           -> OrderedMap key value+unionsWith f = foldl' (unionWith f) empty++-- | Take two ordered maps, append the second one to the first. If the second+-- contains any keys that also appear in the first, combine the two values+-- with the given function.+unionWithM :: (Monad m, Ord key)+           => (value -> value -> m value)+           -> OrderedMap key value+           -> OrderedMap key value+           -> m (OrderedMap key value)+unionWithM f x y = sequenceA (unionWith (liftMM f) (map pure x) (map pure y))++-- | Take a list of ordered maps and append them together. Any shared elements+-- are combined using the given function.+unionsWithM :: (Monad m, Ord key)+            => (value -> value -> m value)+            -> [OrderedMap key value]+            -> m (OrderedMap key value)+unionsWithM f xs = sequenceA (unionsWith (liftMM f) (map (map pure) xs))++liftMM :: Monad m => (a -> b -> m c) -> m a -> m b -> m c+liftMM f a' b' = do+  (a, b) <- (,) <$> a' <*> b'+  f a b++-- | Take an ordered map with 'Maybe' values and return the same map with all+-- the 'Nothing' values removed.+catMaybes :: Ord key => OrderedMap key (Maybe value) -> OrderedMap key value+catMaybes xs =+  OrderedMap+  { keys = [ k | k <- keys xs, k `Map.member` newMap ]+  , toMap = newMap+  }+  where+    newMap = Map.mapMaybe identity (toMap xs)++-- | Construct an ordered map from a list.+--+-- /O(n log n)/.+--+-- If the list contains duplicate keys, then return 'Nothing'. Otherwise,+-- return an 'OrderedMap', preserving the order.+orderedMap :: forall key value. Ord key => [(key, value)] -> Maybe (OrderedMap key value)+orderedMap entries+  | ks == ordNub ks = Just (OrderedMap ks (Map.fromList entries))+  | otherwise = Nothing+  where+    ks = map fst entries
+ src/GraphQL/Internal/Output.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE PatternSynonyms #-}+-- | GraphQL output.+--+-- How we encode GraphQL responses.+module GraphQL.Internal.Output+  ( Response(..)+  , Errors+  , Error(..)+  , GraphQLError(..)+  , singleError+  ) where++import Protolude hiding (Location, Map)+import Data.Aeson (ToJSON(..))+import Data.List.NonEmpty (NonEmpty(..))+import GraphQL.Value+  ( Object+  , objectFromList+  , Value+  , pattern ValueObject+  , pattern ValueNull+  , NameError(..)+  )+import GraphQL.Internal.Name (unsafeMakeName)+import GraphQL.Value.ToValue (ToValue(..))++-- | GraphQL response.+--+-- A GraphQL response must:+--+--   * be a map+--   * have a "data" key iff the operation executed+--   * have an "errors" key iff the operation encountered errors+--   * not include "data" if operation failed before execution (e.g. syntax errors,+--     validation errors, missing info)+--   * not have keys other than "data", "errors", and "extensions"+--+-- Other interesting things:+--+--   * Doesn't have to be JSON, but does have to have maps, strings, lists,+--     and null+--   * Can also support bool, int, enum, and float+--   * Value of "extensions" must be a map+--+-- "data" must be null if an error was encountered during execution that+-- prevented a valid response.+--+-- "errors"+--+--   * must be a non-empty list+--   * each error is a map with "message", optionally "locations" key+--     with list of locations+--   * locations are maps with 1-indexed "line" and "column" keys.+data Response+  = Success Object+  | PreExecutionFailure Errors+  | ExecutionFailure Errors+  | PartialSuccess Object Errors+  deriving (Eq, Ord, Show)++-- | Construct an object from a list of names and values.+--+-- Panic if there are duplicate names.+unsafeMakeObject :: HasCallStack => [(Text, Value)] -> Value+unsafeMakeObject fields =+  case objectFromList (map (first unsafeMakeName) fields) of+    Nothing -> panic $ "Object has duplicate keys: " <> show fields+    Just object -> ValueObject object++instance ToValue Response where+  toValue (Success x) = unsafeMakeObject [("data", toValue x)]+  toValue (PreExecutionFailure e) = unsafeMakeObject [("errors", toValue e)]+  toValue (ExecutionFailure e) = unsafeMakeObject [("data", ValueNull)+                                                  ,("errors", toValue e)]+  toValue (PartialSuccess x e) = unsafeMakeObject [("data", toValue x)+                                                  ,("errors", toValue e)+                                                  ]++instance ToJSON Response where+  toJSON = toJSON . toValue++type Errors = NonEmpty Error++data Error = Error Text [Location] deriving (Eq, Ord, Show)++instance ToValue Error where+  toValue (Error message []) = unsafeMakeObject [("message", toValue message)]+  toValue (Error message locations) = unsafeMakeObject [("message", toValue message)+                                                       ,("locations", toValue locations)+                                                       ]++-- | Make a list of errors containing a single error.+singleError :: GraphQLError e => e -> Errors+singleError e = toError e :| []++data Location = Location Line Column deriving (Eq, Ord, Show)+type Line = Int32  -- XXX: 1-indexed natural number+type Column = Int32  -- XXX: 1-indexed natural number++instance ToValue Location where+  toValue (Location line column) = unsafeMakeObject [("line" , toValue line)+                                                    ,("column", toValue column)+                                                    ]++-- | An error that arises while processing a GraphQL query.+class GraphQLError e where+  -- | Represent an error as human-readable text, primarily intended for+  -- developers of GraphQL clients, and secondarily for developers of GraphQL+  -- servers.+  formatError :: e -> Text++  -- | Represent an error as human-readable text, together with reference to a+  -- series of locations within a GraphQL query document. Default+  -- implementation calls 'formatError' and provides no locations.+  toError :: e -> Error+  toError e = Error (formatError e) []++-- Defined here to avoid circular dependency.+instance GraphQLError NameError where+  formatError (NameError name) = "Not a valid GraphQL name: " <> show name
+ src/GraphQL/Internal/Schema.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Fully realized GraphQL schema type system at the value level.+--+-- Differs from "Data.GraphQL.AST" in the+-- [graphql](http://hackage.haskell.org/package/graphql) package in that there+-- are no type references. Instead, everything is inlined.+--+-- Equivalent representation of GraphQL /values/ is in "GraphQL.Value".+module GraphQL.Internal.Schema+  ( Type(..)+  -- * Builtin types+  , Builtin(..)+  -- * Defining new types+  , TypeDefinition(..)+  , Name+  , ArgumentDefinition(..)+  , EnumValueDefinition(..)+  , EnumTypeDefinition(..)+  , FieldDefinition(..)+  , Interfaces+  , InterfaceTypeDefinition(..)+  , NonEmptyList(..)+  , ObjectTypeDefinition(..)+  , UnionTypeDefinition(..)+  -- ** Input types+  , InputType(..)+  , InputTypeDefinition(..)+  , InputObjectTypeDefinition(..)+  , InputObjectFieldDefinition(..)+  -- * Using existing types+  , AnnotatedType(..)+  , ListType(..)+  , NonNullType(..)+  , DefinesTypes(..)+  , doesFragmentTypeApply+  -- * The schema+  , Schema+  , makeSchema+  , lookupType+  ) where++import Protolude hiding (Type)++import qualified Data.Map as Map+import GraphQL.Value (Value)+import GraphQL.Internal.Name (HasName(..), Name, unsafeMakeName)++-- | An entire GraphQL schema.+--+-- This is very much a work in progress. Currently, the only thing we provide+-- is a dictionary mapping type names to their definitions.+newtype Schema = Schema (Map Name TypeDefinition) deriving (Eq, Ord, Show)++-- | Create a schema from the root object.+--+-- This is technically an insufficient API, since not all types in a schema+-- need to be reachable from a single root object. However, it's a start.+makeSchema :: ObjectTypeDefinition -> Schema+makeSchema = Schema . getDefinedTypes++-- | 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@+  --+  -- TODO: This ignores whether a value can define multiple types with the+  -- same name, and further admits the possibility that the name embedded in+  -- the type definition does not match the name in the returned dictionary.+  -- jml would like to have a schema validation phase that eliminates one or+  -- both of these possibilities.+  --+  -- Also pretty much works because we've inlined all our type definitions.+  getDefinedTypes :: t -> Map Name TypeDefinition++data AnnotatedType t = TypeNamed t+                     | TypeList (ListType t)+                     | TypeNonNull (NonNullType t)+                     deriving (Eq, Ord, Show)++-- | Get the type that is being annotated.+getAnnotatedType :: AnnotatedType t -> t+getAnnotatedType (TypeNamed t) = t+getAnnotatedType (TypeList (ListType t)) = getAnnotatedType t+getAnnotatedType (TypeNonNull (NonNullTypeNamed t)) = t+getAnnotatedType (TypeNonNull (NonNullTypeList (ListType t))) = getAnnotatedType t++instance HasName t => HasName (AnnotatedType t) where+  getName = getName . getAnnotatedType++newtype ListType t = ListType (AnnotatedType t) deriving (Eq, Ord, Show)++data NonNullType t = NonNullTypeNamed t+                   | NonNullTypeList  (ListType t)+                   deriving (Eq, Ord, Show)++data Type = DefinedType TypeDefinition | BuiltinType Builtin deriving (Eq, Ord, Show)++instance DefinesTypes Type where+  getDefinedTypes (BuiltinType _) = mempty+  getDefinedTypes (DefinedType t) = getDefinedTypes t++instance HasName Type where+  getName (DefinedType x) = getName x+  getName (BuiltinType x) = getName x++data TypeDefinition = TypeDefinitionObject        ObjectTypeDefinition+                    | TypeDefinitionInterface     InterfaceTypeDefinition+                    | TypeDefinitionUnion         UnionTypeDefinition+                    | TypeDefinitionScalar        ScalarTypeDefinition+                    | TypeDefinitionEnum          EnumTypeDefinition+                    | TypeDefinitionInputObject   InputObjectTypeDefinition+                    | TypeDefinitionTypeExtension TypeExtensionDefinition+                      deriving (Eq, Ord, Show)++instance HasName TypeDefinition where+  getName (TypeDefinitionObject x) = getName x+  getName (TypeDefinitionInterface x) = getName x+  getName (TypeDefinitionUnion x) = getName x+  getName (TypeDefinitionScalar x) = getName x+  getName (TypeDefinitionEnum x) = getName x+  getName (TypeDefinitionInputObject x) = getName x+  getName (TypeDefinitionTypeExtension x) = getName x++instance DefinesTypes TypeDefinition where+  getDefinedTypes defn =+    case defn of+      TypeDefinitionObject x -> getDefinedTypes x+      TypeDefinitionInterface x -> getDefinedTypes x+      TypeDefinitionUnion x -> getDefinedTypes x+      TypeDefinitionScalar x  -> getDefinedTypes x+      TypeDefinitionEnum x -> getDefinedTypes x+      TypeDefinitionInputObject _ -> mempty+      TypeDefinitionTypeExtension _ ->+        panic "TODO: we should remove the 'extend' behaviour entirely"++data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces (NonEmptyList FieldDefinition)+                            deriving (Eq, Ord, Show)++instance HasName ObjectTypeDefinition where+  getName (ObjectTypeDefinition name _ _) = name++instance DefinesTypes ObjectTypeDefinition where+  getDefinedTypes obj@(ObjectTypeDefinition name interfaces fields) =+    Map.singleton name (TypeDefinitionObject obj) <>+    foldMap getDefinedTypes interfaces <>+    foldMap getDefinedTypes fields++type Interfaces = [InterfaceTypeDefinition]++data FieldDefinition = FieldDefinition Name [ArgumentDefinition] (AnnotatedType Type)+                       deriving (Eq, Ord, Show)++instance HasName FieldDefinition where+  getName (FieldDefinition name _ _) = name++instance DefinesTypes FieldDefinition where+  getDefinedTypes (FieldDefinition _ _ retVal) = getDefinedTypes (getAnnotatedType retVal)++data ArgumentDefinition = ArgumentDefinition Name (AnnotatedType InputType) (Maybe DefaultValue)+                          deriving (Eq, Ord, Show)++instance HasName ArgumentDefinition where+  getName (ArgumentDefinition name _ _) = name++data InterfaceTypeDefinition = InterfaceTypeDefinition Name (NonEmptyList FieldDefinition)+                               deriving (Eq, Ord, Show)++instance HasName InterfaceTypeDefinition where+  getName (InterfaceTypeDefinition name _) = name++instance DefinesTypes InterfaceTypeDefinition where+  getDefinedTypes i@(InterfaceTypeDefinition name fields) = Map.singleton name (TypeDefinitionInterface i) <> foldMap getDefinedTypes fields++data UnionTypeDefinition = UnionTypeDefinition Name (NonEmptyList ObjectTypeDefinition)+                           deriving (Eq, Ord, Show)++instance HasName UnionTypeDefinition where+  getName (UnionTypeDefinition name _) = name++instance DefinesTypes UnionTypeDefinition where+  getDefinedTypes defn@(UnionTypeDefinition name objs) =+    Map.singleton name (TypeDefinitionUnion defn) <>+    foldMap getDefinedTypes objs++newtype ScalarTypeDefinition = ScalarTypeDefinition Name+                             deriving (Eq, Ord, Show)++instance HasName ScalarTypeDefinition where+  getName (ScalarTypeDefinition name) = name++instance DefinesTypes ScalarTypeDefinition where+  getDefinedTypes defn = Map.singleton (getName defn) (TypeDefinitionScalar defn)++-- | Types that are built into GraphQL.+--+-- The GraphQL spec refers to these as+-- \"[scalars](https://facebook.github.io/graphql/#sec-Scalars)\".+data Builtin+  -- | A signed 32‐bit numeric non‐fractional value+  = GInt+  -- | True or false+  | GBool+  -- | Textual data represented as UTF-8 character sequences+  | GString+  -- | Signed double‐precision fractional values as specified by [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point)+  | GFloat+  -- | A unique identifier, often used to refetch an object or as the key for a cache+  | GID deriving (Eq, Ord, Show)++instance HasName Builtin where+  getName = unsafeMakeName . getBuiltinName+    where+      getBuiltinName GInt = "Int"+      getBuiltinName GBool = "Boolean"+      getBuiltinName GString = "String"+      getBuiltinName GFloat = "Float"+      getBuiltinName GID = "ID"++data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition]+                          deriving (Eq, Ord, Show)++instance HasName EnumTypeDefinition where+  getName (EnumTypeDefinition name _) = name++instance DefinesTypes EnumTypeDefinition where+  getDefinedTypes enum = Map.singleton (getName enum) (TypeDefinitionEnum enum)++newtype EnumValueDefinition = EnumValueDefinition Name+                              deriving (Eq, Ord, Show)++instance HasName EnumValueDefinition where+  getName (EnumValueDefinition name) = name++data InputObjectTypeDefinition = InputObjectTypeDefinition Name (NonEmptyList InputObjectFieldDefinition)+                                 deriving (Eq, Ord, Show)++instance HasName InputObjectTypeDefinition where+  getName (InputObjectTypeDefinition name _) = name++data InputObjectFieldDefinition = InputObjectFieldDefinition Name (AnnotatedType InputType) (Maybe DefaultValue)+                                  deriving (Eq, Ord, Show) -- XXX: spec is unclear about default value for input object field definitions++instance HasName InputObjectFieldDefinition where+  getName (InputObjectFieldDefinition name _ _) = name++newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition+                                  deriving (Eq, Ord, Show)++instance HasName TypeExtensionDefinition where+  getName (TypeExtensionDefinition obj) = getName obj++data InputType = DefinedInputType InputTypeDefinition | BuiltinInputType Builtin deriving (Eq, Ord, Show)++instance HasName InputType where+  getName (DefinedInputType x) = getName x+  getName (BuiltinInputType x) = getName x++data InputTypeDefinition+  = InputTypeDefinitionObject        InputObjectTypeDefinition+  | InputTypeDefinitionScalar        ScalarTypeDefinition+  | InputTypeDefinitionEnum          EnumTypeDefinition+  deriving (Eq, Ord, Show)++instance HasName InputTypeDefinition where+  getName (InputTypeDefinitionObject x) = getName x+  getName (InputTypeDefinitionScalar x) = getName x+  getName (InputTypeDefinitionEnum x) = getName x++-- | 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+-- some sort of default value.+--+-- Arguments (see 'ArgumentDefinition') and fields within input objects (see+-- 'InputObjectFieldDefinition') can have default values. These are allowed to+-- be any kind of literal.+type DefaultValue = Value+++-- | Does the given object type match the given type condition.+--+-- See <https://facebook.github.io/graphql/#sec-Field-Collection>+--+-- @+-- DoesFragmentTypeApply(objectType, fragmentType)+--   If fragmentType is an Object Type:+--     if objectType and fragmentType are the same type, return true, otherwise return false.+--   If fragmentType is an Interface Type:+--     if objectType is an implementation of fragmentType, return true otherwise return false.+--   If fragmentType is a Union:+--     if objectType is a possible type of fragmentType, return true otherwise return false.+-- @+doesFragmentTypeApply :: ObjectTypeDefinition -> TypeDefinition -> Bool+doesFragmentTypeApply objectType fragmentType =+  case fragmentType of+    TypeDefinitionObject obj -> obj == objectType+    TypeDefinitionInterface interface -> objectType `implements` interface+    TypeDefinitionUnion union -> objectType `branchOf` union+    _ -> False+  where+    implements (ObjectTypeDefinition _ interfaces _) int = int `elem` interfaces+    branchOf obj (UnionTypeDefinition _ (NonEmptyList branches)) = obj `elem` branches
+ src/GraphQL/Internal/Syntax/AST.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module GraphQL.Internal.Syntax.AST+  ( Name(unName)+  , nameParser+  , QueryDocument(..)+  , SchemaDocument(..)+  , Definition(..)+  , OperationDefinition(..)+  , Node(..)+  , getNodeName+  , VariableDefinition(..)+  , Variable(..)+  , SelectionSet+  , Selection(..)+  , Field(..)+  , Alias+  , Argument(..)+  , FragmentSpread(..)+  , InlineFragment(..)+  , FragmentDefinition(..)+  , TypeCondition+  , Value(..)+  , StringValue(..)+  , ListValue(..)+  , ObjectValue(..)+  , ObjectField(..)+  , DefaultValue+  , Directive(..)+  , Type(..)+  , NamedType(..)+  , ListType(..)+  , NonNullType(..)+  , TypeDefinition(..)+  , ObjectTypeDefinition(..)+  , Interfaces+  , FieldDefinition(..)+  , ArgumentsDefinition+  , InputValueDefinition(..)+  , InterfaceTypeDefinition(..)+  , UnionTypeDefinition(..)+  , ScalarTypeDefinition(..)+  , EnumTypeDefinition(..)+  , EnumValueDefinition(..)+  , InputObjectTypeDefinition(..)+  , TypeExtensionDefinition(..)+  ) where++import Protolude hiding (Type)++import qualified Data.Aeson as Aeson+import qualified Data.Attoparsec.Text as A+import Data.Char (isDigit)+import Test.QuickCheck (Arbitrary(..), elements, listOf, oneof)++import GraphQL.Internal.Arbitrary (arbitraryText)+import GraphQL.Internal.Syntax.Tokens (tok)++-- * Name++-- | A name in GraphQL.+--+-- https://facebook.github.io/graphql/#sec-Names+newtype Name = Name { unName :: Text } deriving (Eq, Ord, Show)++instance Aeson.ToJSON Name where+  toJSON = Aeson.toJSON . unName++instance Arbitrary Name where+  arbitrary = do+    initial <- elements alpha+    rest <- listOf (elements (alpha <> numeric))+    pure (Name (toS (initial:rest)))+    where+      alpha = ['A'..'Z'] <> ['a'..'z'] <> ['_']+      numeric = ['0'..'9']++-- | Parser for 'Name'.+nameParser :: A.Parser Name+nameParser = Name <$> tok ((<>) <$> A.takeWhile1 isA_z+                                <*> A.takeWhile ((||) <$> isDigit <*> isA_z))+  where+    -- `isAlpha` handles many more Unicode Chars+    isA_z = A.inClass $ '_' : ['A'..'Z'] <> ['a'..'z']++-- * Documents++-- | A 'QueryDocument' is something a user might send us.+--+-- https://facebook.github.io/graphql/#sec-Language.Query-Document+newtype QueryDocument = QueryDocument { getDefinitions :: [Definition] } deriving (Eq,Show)++data Definition = DefinitionOperation OperationDefinition+                | DefinitionFragment  FragmentDefinition+                deriving (Eq,Show)++-- | A 'SchemaDocument' is a document that defines a GraphQL schema.+--+-- https://facebook.github.io/graphql/#sec-Type-System+newtype SchemaDocument = SchemaDocument [TypeDefinition] deriving (Eq, Show)++data OperationDefinition+  = Query Node+  | Mutation Node+  | AnonymousQuery SelectionSet+  deriving (Eq,Show)++data Node = Node Name [VariableDefinition] [Directive] SelectionSet+            deriving (Eq,Show)++-- TODO: Just make Node implement HasName.+getNodeName :: Node -> Name+getNodeName (Node name _ _ _) = name++data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)+                          deriving (Eq,Show)++newtype Variable = Variable Name deriving (Eq, Ord, Show)++instance Arbitrary Variable where+  arbitrary = Variable <$> arbitrary++type SelectionSet = [Selection]++data Selection = SelectionField Field+               | SelectionFragmentSpread FragmentSpread+               | SelectionInlineFragment InlineFragment+                 deriving (Eq,Show)++data Field = Field (Maybe Alias) Name [Argument] [Directive] SelectionSet+             deriving (Eq,Show)++type Alias = Name++data Argument = Argument Name Value deriving (Eq,Show)++-- * Fragments++data FragmentSpread = FragmentSpread Name [Directive]+                      deriving (Eq,Show)++data InlineFragment =+  InlineFragment (Maybe TypeCondition) [Directive] SelectionSet+  deriving (Eq,Show)++data FragmentDefinition =+  FragmentDefinition Name TypeCondition [Directive] SelectionSet+  deriving (Eq,Show)++type TypeCondition = NamedType++-- * Values++data Value = ValueVariable Variable+           | ValueInt Int32+           -- GraphQL Float is double precison+           | ValueFloat Double+           | ValueBoolean Bool+           | ValueString StringValue+           | ValueEnum Name+           | ValueList ListValue+           | ValueObject ObjectValue+           | ValueNull+           deriving (Eq, Show)++instance Arbitrary Value where+  arbitrary = oneof [ ValueVariable <$> arbitrary+                    , ValueInt <$> arbitrary+                    , ValueFloat <$> arbitrary+                    , ValueBoolean <$> arbitrary+                    , ValueString <$> arbitrary+                    , ValueEnum <$> arbitrary+                    , ValueList <$> arbitrary+                    , ValueObject <$> arbitrary+                    , pure ValueNull+                    ]++newtype StringValue = StringValue Text deriving (Eq,Show)++instance Arbitrary StringValue where+  arbitrary = StringValue <$> arbitraryText++newtype ListValue = ListValue [Value] deriving (Eq,Show)++instance Arbitrary ListValue where+  arbitrary = ListValue <$> listOf arbitrary++newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show)++instance Arbitrary ObjectValue where+  arbitrary = ObjectValue <$> listOf arbitrary++data ObjectField = ObjectField Name Value deriving (Eq,Show)++instance Arbitrary ObjectField where+  arbitrary = ObjectField <$> arbitrary <*> arbitrary++type DefaultValue = Value++-- * Directives++data Directive = Directive Name [Argument] deriving (Eq,Show)++-- * Type Reference++data Type = TypeNamed NamedType+          | TypeList ListType+          | TypeNonNull NonNullType+            deriving (Eq, Ord, Show)++newtype NamedType = NamedType Name deriving (Eq, Ord, Show)++newtype ListType = ListType Type deriving (Eq, Ord, Show)++data NonNullType = NonNullTypeNamed NamedType+                 | NonNullTypeList  ListType+                   deriving (Eq, Ord, Show)++-- * Type definition++data TypeDefinition = TypeDefinitionObject        ObjectTypeDefinition+                    | TypeDefinitionInterface     InterfaceTypeDefinition+                    | TypeDefinitionUnion         UnionTypeDefinition+                    | TypeDefinitionScalar        ScalarTypeDefinition+                    | TypeDefinitionEnum          EnumTypeDefinition+                    | TypeDefinitionInputObject   InputObjectTypeDefinition+                    | TypeDefinitionTypeExtension TypeExtensionDefinition+                      deriving (Eq,Show)++data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces [FieldDefinition]+                            deriving (Eq,Show)++type Interfaces = [NamedType]++data FieldDefinition = FieldDefinition Name ArgumentsDefinition Type+                       deriving (Eq,Show)++type ArgumentsDefinition = [InputValueDefinition]++data InputValueDefinition = InputValueDefinition Name Type (Maybe DefaultValue)+                            deriving (Eq,Show)++data InterfaceTypeDefinition = InterfaceTypeDefinition Name [FieldDefinition]+                               deriving (Eq,Show)++data UnionTypeDefinition = UnionTypeDefinition Name [NamedType]+                           deriving (Eq,Show)++newtype ScalarTypeDefinition = ScalarTypeDefinition Name+                             deriving (Eq,Show)++data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition]+                          deriving (Eq,Show)++newtype EnumValueDefinition = EnumValueDefinition Name+                              deriving (Eq,Show)++data InputObjectTypeDefinition = InputObjectTypeDefinition Name [InputValueDefinition]+                                 deriving (Eq,Show)++newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition+                                  deriving (Eq,Show)
+ src/GraphQL/Internal/Syntax/Encoder.hs view
@@ -0,0 +1,248 @@+module GraphQL.Internal.Syntax.Encoder+  ( queryDocument+  , schemaDocument+  , value+  ) where++import Protolude hiding (Type, intercalate)++import qualified Data.Aeson as Aeson+import Data.Text (Text, cons, intercalate, pack, snoc)++import qualified GraphQL.Internal.Syntax.AST as AST++-- * Document++queryDocument :: AST.QueryDocument -> Text+queryDocument (AST.QueryDocument defs) = (`snoc` '\n') . mconcat $ definition <$> defs++definition :: AST.Definition -> Text+definition (AST.DefinitionOperation x) = operationDefinition x+definition (AST.DefinitionFragment  x) = fragmentDefinition x++schemaDocument :: AST.SchemaDocument -> Text+schemaDocument (AST.SchemaDocument defs) = (`snoc` '\n') . mconcat $ typeDefinition <$> defs++operationDefinition :: AST.OperationDefinition -> Text+operationDefinition (AST.Query    n) = "query "    <> node n+operationDefinition (AST.Mutation n) = "mutation " <> node n+operationDefinition (AST.AnonymousQuery ss) = selectionSet ss++node :: AST.Node -> Text+node (AST.Node name vds ds ss) =+     AST.unName name+  <> optempty variableDefinitions vds+  <> optempty directives ds+  <> selectionSet ss++variableDefinitions :: [AST.VariableDefinition] -> Text+variableDefinitions = parensCommas variableDefinition++variableDefinition :: AST.VariableDefinition -> Text+variableDefinition (AST.VariableDefinition var ty dv) =+  variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv++defaultValue :: AST.DefaultValue -> Text+defaultValue val = "=" <> value val++variable :: AST.Variable -> Text+variable (AST.Variable name) = "$" <> AST.unName name++selectionSet :: AST.SelectionSet -> Text+selectionSet = bracesCommas selection++selection :: AST.Selection -> Text+selection (AST.SelectionField          x) = field x+selection (AST.SelectionInlineFragment x) = inlineFragment x+selection (AST.SelectionFragmentSpread x) = fragmentSpread x++field :: AST.Field -> Text+field (AST.Field alias name args ds ss) =+       optempty (`snoc` ':') (maybe mempty AST.unName alias)+    <> AST.unName name+    <> optempty arguments args+    <> optempty directives ds+    <> optempty selectionSet ss++arguments :: [AST.Argument] -> Text+arguments = parensCommas argument++argument :: AST.Argument -> Text+argument (AST.Argument name v) = AST.unName name <> ":" <> value v++-- * Fragments++fragmentSpread :: AST.FragmentSpread -> Text+fragmentSpread (AST.FragmentSpread name ds) =+  "..." <> AST.unName name <> optempty directives ds++inlineFragment :: AST.InlineFragment -> Text+inlineFragment (AST.InlineFragment (Just (AST.NamedType tc)) ds ss) =+  "... on " <> AST.unName tc+            <> optempty directives ds+            <> optempty selectionSet ss+inlineFragment (AST.InlineFragment Nothing ds ss) =+  "... " <> optempty directives ds+         <> optempty selectionSet ss++fragmentDefinition :: AST.FragmentDefinition -> Text+fragmentDefinition (AST.FragmentDefinition name (AST.NamedType tc) ds ss) =+  "fragment " <> AST.unName name <> " on " <> AST.unName tc+              <> optempty directives ds+              <> selectionSet ss++-- * Values++value :: AST.Value -> Text+value (AST.ValueVariable x) = variable x+-- TODO: This will be replaced with `decimal` Buidler+value (AST.ValueInt      x) = pack $ show x+-- TODO: This will be replaced with `decimal` Buidler+value (AST.ValueFloat    x) = pack $ show x+value (AST.ValueBoolean  x) = booleanValue x+value (AST.ValueString   x) = stringValue x+value (AST.ValueEnum     x) = AST.unName x+value (AST.ValueList     x) = listValue x+value (AST.ValueObject   x) = objectValue x+value AST.ValueNull = "null"++booleanValue :: Bool -> Text+booleanValue True  = "true"+booleanValue False = "false"++-- TODO: Escape characters+stringValue :: AST.StringValue -> Text+stringValue (AST.StringValue v) = toS $ Aeson.encode v++listValue :: AST.ListValue -> Text+listValue (AST.ListValue vs) = bracketsCommas value vs++objectValue :: AST.ObjectValue -> Text+objectValue (AST.ObjectValue ofs) = bracesCommas objectField ofs++objectField :: AST.ObjectField -> Text+objectField (AST.ObjectField name v) = AST.unName name <> ":" <> value v++-- * Directives++directives :: [AST.Directive] -> Text+directives = spaces directive++directive :: AST.Directive -> Text+directive (AST.Directive name args) = "@" <> AST.unName name <> optempty arguments args++-- * Type Reference++type_ :: AST.Type -> Text+type_ (AST.TypeNamed (AST.NamedType x)) = AST.unName x+type_ (AST.TypeList x) = listType x+type_ (AST.TypeNonNull x) = nonNullType x++namedType :: AST.NamedType -> Text+namedType (AST.NamedType name) = AST.unName name++listType :: AST.ListType -> Text+listType (AST.ListType ty) = brackets (type_ ty)++nonNullType :: AST.NonNullType -> Text+nonNullType (AST.NonNullTypeNamed (AST.NamedType x)) = AST.unName x <> "!"+nonNullType (AST.NonNullTypeList  x) = listType x <> "!"++typeDefinition :: AST.TypeDefinition -> Text+typeDefinition (AST.TypeDefinitionObject        x) = objectTypeDefinition x+typeDefinition (AST.TypeDefinitionInterface     x) = interfaceTypeDefinition x+typeDefinition (AST.TypeDefinitionUnion         x) = unionTypeDefinition x+typeDefinition (AST.TypeDefinitionScalar        x) = scalarTypeDefinition x+typeDefinition (AST.TypeDefinitionEnum          x) = enumTypeDefinition x+typeDefinition (AST.TypeDefinitionInputObject   x) = inputObjectTypeDefinition x+typeDefinition (AST.TypeDefinitionTypeExtension x) = typeExtensionDefinition x++objectTypeDefinition :: AST.ObjectTypeDefinition -> Text+objectTypeDefinition (AST.ObjectTypeDefinition name ifaces fds) =+  "type " <> AST.unName name+          <> optempty (spaced . interfaces) ifaces+          <> optempty fieldDefinitions fds++interfaces :: AST.Interfaces -> Text+interfaces = ("implements " <>) . spaces namedType++fieldDefinitions :: [AST.FieldDefinition] -> Text+fieldDefinitions = bracesCommas fieldDefinition++fieldDefinition :: AST.FieldDefinition -> Text+fieldDefinition (AST.FieldDefinition name args ty) =+  AST.unName name <> optempty argumentsDefinition args+                       <> ":"+                       <> type_ ty++argumentsDefinition :: AST.ArgumentsDefinition -> Text+argumentsDefinition = parensCommas inputValueDefinition++interfaceTypeDefinition :: AST.InterfaceTypeDefinition -> Text+interfaceTypeDefinition (AST.InterfaceTypeDefinition name fds) =+  "interface " <> AST.unName name <> fieldDefinitions fds++unionTypeDefinition :: AST.UnionTypeDefinition -> Text+unionTypeDefinition (AST.UnionTypeDefinition name ums) =+  "union " <> AST.unName name <> "=" <> unionMembers ums++unionMembers :: [AST.NamedType] -> Text+unionMembers = intercalate "|" . fmap namedType++scalarTypeDefinition :: AST.ScalarTypeDefinition -> Text+scalarTypeDefinition (AST.ScalarTypeDefinition name) = "scalar " <> AST.unName name++enumTypeDefinition :: AST.EnumTypeDefinition -> Text+enumTypeDefinition (AST.EnumTypeDefinition name evds) =+  "enum " <> AST.unName name+          <> bracesCommas enumValueDefinition evds++enumValueDefinition :: AST.EnumValueDefinition -> Text+enumValueDefinition (AST.EnumValueDefinition name) = AST.unName name++inputObjectTypeDefinition :: AST.InputObjectTypeDefinition -> Text+inputObjectTypeDefinition (AST.InputObjectTypeDefinition name ivds) =+  "input " <> AST.unName name <> inputValueDefinitions ivds++inputValueDefinitions :: [AST.InputValueDefinition] -> Text+inputValueDefinitions = bracesCommas inputValueDefinition++inputValueDefinition :: AST.InputValueDefinition -> Text+inputValueDefinition (AST.InputValueDefinition name ty dv) =+  AST.unName name <> ":" <> type_ ty <> maybe mempty defaultValue dv++typeExtensionDefinition :: AST.TypeExtensionDefinition -> Text+typeExtensionDefinition (AST.TypeExtensionDefinition otd) =+  "extend " <> objectTypeDefinition otd++-- * Internal++spaced :: Text -> Text+spaced = cons '\SP'++between :: Char -> Char -> Text -> Text+between open close = cons open . (`snoc` close)++parens :: Text -> Text+parens = between '(' ')'++brackets :: Text -> Text+brackets = between '[' ']'++braces :: Text -> Text+braces = between '{' '}'++spaces :: (a -> Text) -> [a] -> Text+spaces f = intercalate "\SP" . fmap f++parensCommas :: (a -> Text) -> [a] -> Text+parensCommas f = parens . intercalate "," . fmap f++bracketsCommas :: (a -> Text) -> [a] -> Text+bracketsCommas f = brackets . intercalate "," . fmap f++bracesCommas :: (a -> Text) -> [a] -> Text+bracesCommas f = braces . intercalate "," . fmap f++optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b+optempty f xs = if xs == mempty then mempty else f xs
+ src/GraphQL/Internal/Syntax/Parser.hs view
@@ -0,0 +1,333 @@+{-# LANGUAGE FlexibleContexts #-}+module GraphQL.Internal.Syntax.Parser+  ( queryDocument+  , schemaDocument+  , value+  ) where++import Protolude hiding (Type, takeWhile)++import Control.Applicative ((<|>), empty, many, optional)+import Control.Monad (fail)+import Data.Aeson.Parser (jstring)+import Data.Scientific (floatingOrInteger)+import Data.Text (find)+import qualified Data.Attoparsec.ByteString as A+import Data.Attoparsec.Text+  ( Parser+  , (<?>)+  , anyChar+  , char+  , match+  , many1+  , option+  , scan+  , scientific+  , sepBy1+  )++import qualified GraphQL.Internal.Syntax.AST as AST+import GraphQL.Internal.Syntax.Tokens (tok, whiteSpace)++-- * Document++queryDocument :: Parser AST.QueryDocument+queryDocument = whiteSpace *> (AST.QueryDocument <$> many1 definition) <?> "query document error!"++-- | Parser for a schema document.+schemaDocument :: Parser AST.SchemaDocument+schemaDocument = whiteSpace *> (AST.SchemaDocument <$> many1 typeDefinition) <?> "type document error"++definition :: Parser AST.Definition+definition = AST.DefinitionOperation <$> operationDefinition+         <|> AST.DefinitionFragment  <$> fragmentDefinition+         <?> "definition error!"++operationDefinition :: Parser AST.OperationDefinition+operationDefinition =+      AST.Query    <$ tok "query"    <*> node+  <|> AST.Mutation <$ tok "mutation" <*> node+  <|> (AST.AnonymousQuery <$> selectionSet)+  <?> "operationDefinition error!"++node :: Parser AST.Node+node = AST.Node <$> AST.nameParser+                <*> optempty variableDefinitions+                <*> optempty directives+                <*> selectionSet++variableDefinitions :: Parser [AST.VariableDefinition]+variableDefinitions = parens (many1 variableDefinition)++variableDefinition :: Parser AST.VariableDefinition+variableDefinition =+  AST.VariableDefinition <$> variable+                         <*  tok ":"+                         <*> type_+                         <*> optional defaultValue++defaultValue :: Parser AST.DefaultValue+defaultValue = tok "=" *> value++variable :: Parser AST.Variable+variable = AST.Variable <$ tok "$" <*> AST.nameParser++selectionSet :: Parser AST.SelectionSet+selectionSet = braces $ many1 selection++selection :: Parser AST.Selection+selection = AST.SelectionField <$> field+            -- Inline first to catch `on` case+        <|> AST.SelectionInlineFragment <$> inlineFragment+        <|> AST.SelectionFragmentSpread <$> fragmentSpread+        <?> "selection error!"++field :: Parser AST.Field+field = AST.Field <$> option empty (pure <$> alias)+                  <*> AST.nameParser+                  <*> optempty arguments+                  <*> optempty directives+                  <*> optempty selectionSet++alias :: Parser AST.Alias+alias = AST.nameParser <* tok ":"++arguments :: Parser [AST.Argument]+arguments = parens $ many1 argument++argument :: Parser AST.Argument+argument = AST.Argument <$> AST.nameParser <* tok ":" <*> value++-- * Fragments++fragmentSpread :: Parser AST.FragmentSpread+-- TODO: Make sure it fails when `... on`.+-- See https://facebook.github.io/graphql/#FragmentSpread+fragmentSpread = AST.FragmentSpread+  <$  tok "..."+  <*> AST.nameParser+  <*> optempty directives++-- InlineFragment tried first in order to guard against 'on' keyword+inlineFragment :: Parser AST.InlineFragment+inlineFragment = AST.InlineFragment+  <$  tok "..."+  <*> optional (tok "on" *> typeCondition)+  <*> optempty directives+  <*> selectionSet++fragmentDefinition :: Parser AST.FragmentDefinition+fragmentDefinition = AST.FragmentDefinition+  <$  tok "fragment"+  <*> AST.nameParser+  <*  tok "on"+  <*> typeCondition+  <*> optempty directives+  <*> selectionSet++typeCondition :: Parser AST.TypeCondition+typeCondition = namedType++-- * Values++-- This will try to pick the first type it can parse. If you are working with+-- explicit types use the `typedValue` parser.+value :: Parser AST.Value+value = tok (AST.ValueVariable <$> (variable <?> "variable")+  <|> (number <?> "number")+  <|> AST.ValueNull     <$  tok "null"+  <|> AST.ValueBoolean  <$> (booleanValue <?> "booleanValue")+  <|> AST.ValueString   <$> (stringValue <?> "stringValue")+  -- `true` and `false` have been tried before+  <|> AST.ValueEnum     <$> (AST.nameParser <?> "name")+  <|> AST.ValueList     <$> (listValue <?> "listValue")+  <|> AST.ValueObject   <$> (objectValue <?> "objectValue")+  <?> "value error!")+  where+    number =  do+      (numText, num) <- match (tok scientific)+      case (Data.Text.find (== '.') numText, floatingOrInteger num) of+        (Just _, Left r) -> pure (AST.ValueFloat r)+        (Just _, Right i) -> pure (AST.ValueFloat (fromIntegral i))+        -- TODO: Handle maxBound, Int32 in spec.+        (Nothing, Left r) -> pure (AST.ValueInt (floor r))+        (Nothing, Right i) -> pure (AST.ValueInt i)++booleanValue :: Parser Bool+booleanValue = True  <$ tok "true"+   <|> False <$ tok "false"++stringValue :: Parser AST.StringValue+stringValue = do+  parsed <- char '"' *> jstring_+  case unescapeText parsed of+    Left err -> fail err+    Right escaped -> pure (AST.StringValue escaped)+  where+    -- | Parse a string without a leading quote, ignoring any escaped characters.+    jstring_ :: Parser Text+    jstring_ = scan startState go <* anyChar++    startState = False+    go a c+      | a = Just False+      | c == '"' = Nothing+      | otherwise = let a' = c == backslash+                    in Just a'+      where backslash = '\\'++    -- | Unescape a string.+    --+    -- Turns out this is really tricky, so we're going to cheat by+    -- reconstructing a literal string (by putting quotes around it) and+    -- delegating all the hard work to Aeson.+    unescapeText str = A.parseOnly jstring ("\"" <> toS str <> "\"")++-- Notice it can be empty+listValue :: Parser AST.ListValue+listValue = AST.ListValue <$> brackets (many value)++-- Notice it can be empty+objectValue :: Parser AST.ObjectValue+objectValue = AST.ObjectValue <$> braces (many (objectField <?> "objectField"))++objectField :: Parser AST.ObjectField+objectField = AST.ObjectField <$> AST.nameParser <* tok ":" <*> value++-- * Directives++directives :: Parser [AST.Directive]+directives = many1 directive++directive :: Parser AST.Directive+directive = AST.Directive+  <$  tok "@"+  <*> AST.nameParser+  <*> optempty arguments++-- * Type Reference++type_ :: Parser AST.Type+type_ = AST.TypeList    <$> listType+    <|> AST.TypeNonNull <$> nonNullType+    <|> AST.TypeNamed   <$> namedType+    <?> "type_ error!"++namedType :: Parser AST.NamedType+namedType = AST.NamedType <$> AST.nameParser++listType :: Parser AST.ListType+listType = AST.ListType <$> brackets type_++nonNullType :: Parser AST.NonNullType+nonNullType = AST.NonNullTypeNamed <$> namedType <* tok "!"+          <|> AST.NonNullTypeList  <$> listType  <* tok "!"+          <?> "nonNullType error!"++-- * Type Definition++typeDefinition :: Parser AST.TypeDefinition+typeDefinition =+      AST.TypeDefinitionObject        <$> objectTypeDefinition+  <|> AST.TypeDefinitionInterface     <$> interfaceTypeDefinition+  <|> AST.TypeDefinitionUnion         <$> unionTypeDefinition+  <|> AST.TypeDefinitionScalar        <$> scalarTypeDefinition+  <|> AST.TypeDefinitionEnum          <$> enumTypeDefinition+  <|> AST.TypeDefinitionInputObject   <$> inputObjectTypeDefinition+  <|> AST.TypeDefinitionTypeExtension <$> typeExtensionDefinition+  <?> "typeDefinition error!"++objectTypeDefinition :: Parser AST.ObjectTypeDefinition+objectTypeDefinition = AST.ObjectTypeDefinition+  <$  tok "type"+  <*> AST.nameParser+  <*> optempty interfaces+  <*> fieldDefinitions++interfaces :: Parser AST.Interfaces+interfaces = tok "implements" *> many1 namedType++fieldDefinitions :: Parser [AST.FieldDefinition]+fieldDefinitions = braces $ many1 fieldDefinition++fieldDefinition :: Parser AST.FieldDefinition+fieldDefinition = AST.FieldDefinition+  <$> AST.nameParser+  <*> optempty argumentsDefinition+  <*  tok ":"+  <*> type_++argumentsDefinition :: Parser AST.ArgumentsDefinition+argumentsDefinition = parens $ many1 inputValueDefinition++interfaceTypeDefinition :: Parser AST.InterfaceTypeDefinition+interfaceTypeDefinition = AST.InterfaceTypeDefinition+  <$  tok "interface"+  <*> AST.nameParser+  <*> fieldDefinitions++unionTypeDefinition :: Parser AST.UnionTypeDefinition+unionTypeDefinition = AST.UnionTypeDefinition+  <$  tok "union"+  <*> AST.nameParser+  <*  tok "="+  <*> unionMembers++unionMembers :: Parser [AST.NamedType]+unionMembers = namedType `sepBy1` tok "|"++scalarTypeDefinition :: Parser AST.ScalarTypeDefinition+scalarTypeDefinition = AST.ScalarTypeDefinition+  <$  tok "scalar"+  <*> AST.nameParser++enumTypeDefinition :: Parser AST.EnumTypeDefinition+enumTypeDefinition = AST.EnumTypeDefinition+  <$  tok "enum"+  <*> AST.nameParser+  <*> enumValueDefinitions++enumValueDefinitions :: Parser [AST.EnumValueDefinition]+enumValueDefinitions = braces $ many1 enumValueDefinition++enumValueDefinition :: Parser AST.EnumValueDefinition+enumValueDefinition = AST.EnumValueDefinition <$> AST.nameParser++inputObjectTypeDefinition :: Parser AST.InputObjectTypeDefinition+inputObjectTypeDefinition = AST.InputObjectTypeDefinition+  <$  tok "input"+  <*> AST.nameParser+  <*> inputValueDefinitions++inputValueDefinitions :: Parser [AST.InputValueDefinition]+inputValueDefinitions = braces $ many1 inputValueDefinition++inputValueDefinition :: Parser AST.InputValueDefinition+inputValueDefinition = AST.InputValueDefinition+  <$> AST.nameParser+  <*  tok ":"+  <*> type_+  <*> optional defaultValue++typeExtensionDefinition :: Parser AST.TypeExtensionDefinition+typeExtensionDefinition = AST.TypeExtensionDefinition+  <$  tok "extend"+  <*> objectTypeDefinition++-- * Internal++parens :: Parser a -> Parser a+parens = between "(" ")"++braces :: Parser a -> Parser a+braces = between "{" "}"++brackets :: Parser a -> Parser a+brackets = between "[" "]"++between :: Parser Text -> Parser Text -> Parser a -> Parser a+between open close p = tok open *> p <* tok close++-- `empty` /= `pure mempty` for `Parser`.+optempty :: Monoid a => Parser a -> Parser a+optempty = option mempty
+ src/GraphQL/Internal/Syntax/Tokens.hs view
@@ -0,0 +1,24 @@+-- | Basic tokenising used by parser.+module GraphQL.Internal.Syntax.Tokens+  ( tok+  , whiteSpace+  ) where++import Protolude+import Data.Attoparsec.Text+  ( Parser+  , anyChar+  , endOfLine+  , peekChar+  , manyTill+  )+import Data.Char (isSpace)++tok :: Parser a -> Parser a+tok p = p <* whiteSpace++whiteSpace :: Parser ()+whiteSpace = peekChar >>= traverse_ (\c ->+  if isSpace c || c == ','+    then anyChar *> whiteSpace+    else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace)
+ src/GraphQL/Internal/Validation.hs view
@@ -0,0 +1,879 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE KindSignatures #-}+-- | Transform GraphQL query documents from AST into valid structures+--+-- This corresponds roughly to the+-- [Validation](https://facebook.github.io/graphql/#sec-Validation) section of+-- the specification, except where noted.+--+-- One core difference is that this module doesn't attempt to do any+-- type-level validation, as we attempt to defer all of that to the Haskell+-- type checker.+--+-- Deliberately not going to do:+--+--   * field selections on compound types <https://facebook.github.io/graphql/#sec-Field-Selections-on-Objects-Interfaces-and-Unions-Types>+--   * leaf field selections <https://facebook.github.io/graphql/#sec-Leaf-Field-Selections>+--   * argument names <https://facebook.github.io/graphql/#sec-Argument-Names>+--   * argument value type correctness <https://facebook.github.io/graphql/#sec-Argument-Values-Type-Correctness>+--   * fragment spread type existence <https://facebook.github.io/graphql/#sec-Fragment-Spread-Type-Existence>+--   * fragments on compound types <https://facebook.github.io/graphql/#sec-Fragments-On-Composite-Types>+--   * fragment spread is possible <https://facebook.github.io/graphql/#sec-Fragment-spread-is-possible>+--   * directives are defined <https://facebook.github.io/graphql/#sec-Directives-Are-Defined>+--   * directives are in valid locations <https://facebook.github.io/graphql/#sec-Directives-Are-In-Valid-Locations>+--   * variable default values are correctly typed <https://facebook.github.io/graphql/#sec-Variable-Default-Values-Are-Correctly-Typed>+--   * variables are input types <https://facebook.github.io/graphql/#sec-Variables-Are-Input-Types>+--   * all variable usages are allowed <https://facebook.github.io/graphql/#sec-All-Variable-Usages-are-Allowed>+--+-- Because all of the above rely on type checking.+module GraphQL.Internal.Validation+  ( ValidationError(..)+  , ValidationErrors+  , QueryDocument(..)+  , validate+  , getErrors+  -- * Operating on validated documents+  , Operation+  , getSelectionSet+  -- * Executing validated documents+  , VariableDefinition(..)+  , VariableValue+  , Variable+  , AST.Type(..)+  -- * Resolving queries+  , SelectionSetByType+  , SelectionSet(..)+  , getSelectionSetForType+  , Field+  , lookupArgument+  , getSubSelectionSet+  , ResponseKey+  , getResponseKey+  -- * Exported for testing+  , findDuplicates+  ) where++import Protolude++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as Map+import qualified Data.Set as Set+import GraphQL.Internal.Name (HasName(..), Name)+import qualified GraphQL.Internal.Syntax.AST as AST+-- Directly import things from the AST that do not need validation, so that+-- @AST.Foo@ in a type signature implies that something hasn't been validated.+import GraphQL.Internal.Syntax.AST (Alias, Variable, NamedType(..))+import GraphQL.Internal.OrderedMap (OrderedMap)+import qualified GraphQL.Internal.OrderedMap as OrderedMap+import GraphQL.Internal.Output (GraphQLError(..))+import GraphQL.Internal.Schema+  ( TypeDefinition+  , ObjectTypeDefinition+  , Schema+  , doesFragmentTypeApply+  , lookupType+  )+import GraphQL.Value+  ( Value+  , Value'+  , ConstScalar+  , UnresolvedVariableValue+  , astToVariableValue+  )++-- | A valid query document.+--+-- Construct this using 'validate' on an 'AST.QueryDocument'.+data QueryDocument value+  -- | The query document contains a single anonymous operation.+  = LoneAnonymousOperation (Operation value)+  -- | The query document contains multiple uniquely-named operations.+  | MultipleOperations (Operations value)+  deriving (Eq, Show)++data Operation value+  = Query VariableDefinitions (Directives value) (SelectionSetByType value)+  | Mutation 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)++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++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++-- | Get the selection set for an operation.+getSelectionSet :: Operation value -> SelectionSetByType value+getSelectionSet (Query _ _ ss) = ss+getSelectionSet (Mutation _ _ ss) = ss++-- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'.+type OperationType value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value++type Operations value = Map Name (Operation value)++-- | Turn a parsed document into a known valid one.+--+-- The document is known to be syntactically valid, as we've got its AST.+-- Here, we confirm that it's semantically valid (modulo types).+validate :: Schema -> AST.QueryDocument -> Either (NonEmpty ValidationError) (QueryDocument VariableValue)+validate schema (AST.QueryDocument defns) = runValidator $ do+  let (operations, fragments) = splitBy splitDefns defns+  let (anonymous, named) = splitBy splitOps operations+  (frags, visitedFrags) <- resolveFragmentDefinitions =<< validateFragmentDefinitions schema fragments+  case (anonymous, named) of+    ([], ops) -> do+      (validOps, usedFrags) <- runStateT (validateOperations schema frags ops) mempty+      assertAllFragmentsUsed frags (visitedFrags <> usedFrags)+      resolvedOps <- traverse validateOperation validOps+      pure (MultipleOperations resolvedOps)+    ([x], []) -> do+      (ss, usedFrags) <- runStateT (validateSelectionSet schema frags x) mempty+      assertAllFragmentsUsed frags (visitedFrags <> usedFrags)+      validValuesSS <- validateValues ss+      resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS+      pure (LoneAnonymousOperation (Query emptyVariableDefinitions emptyDirectives resolvedValuesSS))+    _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst named))++  where+    splitBy :: (a -> Either b c) -> [a] -> ([b], [c])+    splitBy f xs = partitionEithers (map f xs)++    splitDefns (AST.DefinitionOperation op) = Left op+    splitDefns (AST.DefinitionFragment frag) = Right frag++    splitOps (AST.AnonymousQuery ss) = Left ss+    splitOps (AST.Query node@(AST.Node name _ _ _)) = Right (name, (Query, node))+    splitOps (AST.Mutation node@(AST.Node name _ _ _)) = Right (name, (Mutation, node))++    assertAllFragmentsUsed :: Fragments value -> Set Name -> Validation ()+    assertAllFragmentsUsed fragments used =+      let unused = Map.keysSet fragments `Set.difference` used+      in unless (Set.null unused) (throwE (UnusedFragments unused))++-- * Operations++validateOperations :: Schema -> Fragments AST.Value -> [(Name, (OperationType AST.Value, AST.Node))] -> StateT (Set Name) Validation (Operations AST.Value)+validateOperations schema fragments ops = do+  deduped <- lift (mapErrors DuplicateOperation (makeMap ops))+  traverse validateNode deduped+  where+    validateNode (operationType, AST.Node _ vars directives ss) =+      operationType <$> lift (validateVariableDefinitions 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+  -- 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+++-- * Selection sets++-- https://facebook.github.io/graphql/#sec-Field-Selection-Merging+-- https://facebook.github.io/graphql/#sec-Executing-Selection-Sets+--   1. the selection set is turned into a grouped field set;+--   2. each represented field in the grouped field set produces an entry into+--      a response map.+-- https://facebook.github.io/graphql/#sec-Field-Collection+++-- | Resolve all the fragments in a selection set and make sure the names,+-- arguments, and directives are all valid.+--+-- Runs in 'StateT', collecting a set of names of 'FragmentDefinition' that+-- have been used by this selection set.+--+-- We do this /before/ validating the values (since that's much easier once+-- everything is in a nice structure and away from the AST), which means we+-- can't yet evaluate directives.+validateSelectionSet :: Schema -> Fragments AST.Value -> [AST.Selection] -> StateT (Set Name) Validation (SelectionSetByType AST.Value)+validateSelectionSet schema fragments selections = do+  unresolved <- lift $ traverse (validateSelection schema) selections+  resolved <- traverse (resolveSelection fragments) unresolved+  lift $ groupByResponseKey resolved++-- | A selection set, almost fully validated.+--+-- Sub-selection sets might not be validated.+newtype SelectionSet value = SelectionSet (OrderedMap ResponseKey (Field value)) deriving (Eq, Ord, Show)++newtype SelectionSetByType value+  = SelectionSetByType (OrderedMap ResponseKey (OrderedMap (Set TypeDefinition) (Field value)))+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++-- | A 'ResponseKey' is the key under which a field appears in a response. If+-- there's an alias, it's the alias, if not, it's the field name.+type ResponseKey = Name++-- | A field ready to be resolved.+data Field value+  = Field+  { name :: Name+  , arguments :: Arguments value+  , subSelectionSet :: Maybe (SelectionSetByType value)+  } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance HasName (Field value) where+  getName = name++-- | Get the value of an argument in a field.+lookupArgument :: Field value -> Name -> Maybe value+lookupArgument (Field _ (Arguments args) _) name = Map.lookup name args++-- | Get the selection set within a field.+getSubSelectionSet :: Field value -> Maybe (SelectionSetByType value)+getSubSelectionSet = subSelectionSet++-- | Merge two execution fields. Assumes that they are fields for the same+-- response key on the same type (i.e. that they are fields we would actually+-- rationally want to merge).+mergeFields :: Eq value => Field value -> Field value -> Validation (Field value)+mergeFields field1 field2 = do+  unless (name field1 == name field2) $ throwE (MismatchedNames (name field1) (name field2))+  unless (arguments field1 == arguments field2) $ throwE (MismatchedArguments (name field1))+  case (subSelectionSet field1, subSelectionSet field2) of+    (Nothing, Nothing) ->+      pure Field { name = name field1+                          , arguments = arguments field1+                          , subSelectionSet = Nothing+                          }+    (Just ss1, Just ss2) -> do+      mergedSet <- mergeSelectionSets ss1 ss2+      pure Field { name = name field1+                          , arguments = arguments field1+                          , subSelectionSet = Just mergedSet+                          }+    _ -> throwE (IncompatibleFields (name field1))++  where+    mergeSelectionSets :: Eq value+                       => SelectionSetByType value+                       -> SelectionSetByType value+                       -> Validation (SelectionSetByType value)+    mergeSelectionSets (SelectionSetByType ss1) (SelectionSetByType ss2) =+      SelectionSetByType <$> OrderedMap.unionWithM (OrderedMap.unionWithM mergeFields) ss1 ss2++-- | Once we know the GraphQL type of the object that a selection set (i.e. a+-- 'SelectionSetByType') is for, we can eliminate all the irrelevant types and+-- present a single, flattened map of 'ResponseKey' to 'Field'.+getSelectionSetForType+  :: Eq value+  => ObjectTypeDefinition -- ^ The type of the object that the selection set is for+  -> SelectionSetByType value -- ^ A selection set with type conditions, obtained from the validation process+  -> Either ValidationErrors (SelectionSet value) -- ^ A flattened+  -- selection set without type conditions. It's possible that some of the+  -- fields in various types are not mergeable, in which case, we'll return a+  -- validation error.+getSelectionSetForType objectType (SelectionSetByType ss) = runValidator $+  SelectionSet . OrderedMap.catMaybes <$> traverse mergeFieldsForType ss+  where+    mergeFieldsForType fieldMap = do+      let matching = filter (satisfiesType . fst) (OrderedMap.toList fieldMap)+      case map snd matching of+        [] -> pure Nothing+        x:xs -> Just <$> foldlM mergeFields x xs++    satisfiesType = all (doesFragmentTypeApply objectType) . Set.toList+++-- | Flatten the selection and group it by response key and then type+-- conditions.+--+-- Doesn't do any validation at all. Just provides a list of "execution+-- values" which are the possible things that might be executed, depending on+-- the type.+--+-- XXX: This is so incredibly complex. No doubt there's a way to simplify, but+-- jml can't see it right now.+groupByResponseKey :: Eq value => [Selection' FragmentSpread value] -> Validation (SelectionSetByType value)+groupByResponseKey selectionSet = SelectionSetByType <$>+  flattenSelectionSet mempty selectionSet+  where+    -- | Given a currently "active" type condition, and a single selection,+    -- return a map of response keys to validated fields, grouped by types:+    -- essentially a SelectionSetByType without the wrapping+    -- constructor.+    --+    -- The "active" type condition is the type condition of the selection set+    -- that contains the selection.+    byKey :: Eq value+          => Set TypeDefinition+          -> Selection' FragmentSpread value+          -> Validation (OrderedMap ResponseKey (OrderedMap (Set TypeDefinition) (Field value)))+    byKey typeConds (SelectionField field@(Field' _ name arguments _ ss))+      = case ss of+          [] -> pure $ OrderedMap.singleton (getResponseKey field) . OrderedMap.singleton typeConds .  Field name arguments $ Nothing+          _ -> OrderedMap.singleton (getResponseKey field) . OrderedMap.singleton typeConds . Field name arguments . Just <$> groupByResponseKey ss+    byKey typeConds (SelectionFragmentSpread (FragmentSpread _ _ (FragmentDefinition _ typeCond _ ss)))+      = flattenSelectionSet (typeConds <> Set.singleton typeCond) ss+    byKey typeConds (SelectionInlineFragment (InlineFragment (Just typeCond) _ ss))+      = flattenSelectionSet (typeConds <> Set.singleton typeCond) ss+    byKey typeConds (SelectionInlineFragment (InlineFragment Nothing _ ss))+      = flattenSelectionSet typeConds ss++    flattenSelectionSet :: Eq value+                        => Set TypeDefinition+                        -> [Selection' FragmentSpread value]+                        -> Validation (OrderedMap ResponseKey (OrderedMap (Set TypeDefinition) (Field value)))+    flattenSelectionSet typeConds ss = do+      groupedByKey <- traverse (byKey typeConds) ss+      OrderedMap.unionsWithM (OrderedMap.unionWithM mergeFields) groupedByKey++-- * Selections++-- $fragmentSpread+--+-- The @spread@ type variable is for the type used to "fragment spreads", i.e.+-- references to fragments. It's a variable because we do multiple traversals+-- of the selection graph.+--+-- The first pass (see 'validateSelection') ensures all the arguments and+-- directives are valid. This is applied to all selections, including those+-- that make up fragment definitions (see 'validateFragmentDefinitions'). At+-- this stage, @spread@ will be 'UnresolvedFragmentSpread'.+--+-- Once we have a known-good map of fragment definitions, we can do the next+-- phase of validation, which checks that references to fragments exist, that+-- all fragments are used, and that we don't have circular references.+--+-- This is encoded as a type variable because we want to provide evidence that+-- references in fragment spreads can be resolved, and what better way to do+-- so than including the resolved fragment in the type. Thus, @spread@ will be+-- 'FragmentSpread', following this module's convention that unadorned names+-- imply that everything is valid.++-- | A GraphQL selection.+data Selection' (spread :: * -> *) value+  = SelectionField (Field' spread value)+  | SelectionFragmentSpread (spread value)+  | SelectionInlineFragment (InlineFragment spread value)+  deriving (Eq, Show, Functor, Foldable, Traversable)++-- | A field in a selection set, which itself might have children which might+-- have fragment spreads.+data Field' spread value+  = Field' (Maybe Alias) Name (Arguments value) (Directives value) [Selection' spread value]+  deriving (Eq, Show)++-- | Get the response key of a field.+--+-- \"A field’s response key is its alias if an alias is provided, and it is+-- otherwise the field’s name.\"+--+-- <https://facebook.github.io/graphql/#sec-Field-Alias>+getResponseKey :: Field' spread value -> ResponseKey+getResponseKey (Field' alias name _ _ _) = fromMaybe name alias++instance HasName (Field' spread value) where+  getName (Field' _ name _ _ _) = name++instance Functor spread => Functor (Field' spread) where+  fmap f (Field' alias name arguments directives selectionSet) =+    Field' alias name (fmap f arguments) (fmap f directives) (map (fmap f) selectionSet)++instance Foldable spread => Foldable (Field' spread) where+  foldMap f (Field' _ _ arguments directives selectionSet) =+    mconcat [ foldMap f arguments+            , foldMap f directives+            , mconcat (map (foldMap f) selectionSet)+            ]++instance Traversable spread => Traversable (Field' spread) where+  traverse f (Field' alias name arguments directives selectionSet) =+    Field' alias name <$> traverse f arguments+                      <*> traverse f directives+                      <*> traverse (traverse f) selectionSet++-- | A fragment spread that has a valid set of directives, but may or may not+-- refer to a fragment that actually exists.+data UnresolvedFragmentSpread value+  = UnresolvedFragmentSpread Name (Directives value)+  deriving (Eq, Show, Functor)++instance Foldable UnresolvedFragmentSpread where+  foldMap f (UnresolvedFragmentSpread _ directives) = foldMap f directives++instance Traversable UnresolvedFragmentSpread where+  traverse f (UnresolvedFragmentSpread name directives) = UnresolvedFragmentSpread name <$> traverse f directives++-- | A fragment spread that refers to fragments which are known to exist.+data FragmentSpread value+  = FragmentSpread Name (Directives value) (FragmentDefinition FragmentSpread value)+  deriving (Eq, Show)++instance Functor FragmentSpread where+  fmap f (FragmentSpread name directives definition) = FragmentSpread name (fmap f directives) (fmap f definition)++instance Foldable FragmentSpread where+  foldMap f (FragmentSpread _ directives fragment) = foldMap f directives `mappend` foldMap f fragment++instance Traversable FragmentSpread where+  traverse f (FragmentSpread name directives definition) =+    FragmentSpread name <$> traverse f directives <*> traverse f definition++-- | An inline fragment, which itself can contain fragment spreads.+data InlineFragment spread value+  = InlineFragment (Maybe TypeDefinition) (Directives value) [Selection' spread value]+  deriving (Eq, Show)++instance Functor spread => Functor (InlineFragment spread) where+  fmap f (InlineFragment typeDefn directives selectionSet) =+    InlineFragment typeDefn (fmap f directives) (map (fmap f) selectionSet)++instance Foldable spread => Foldable (InlineFragment spread) where+  foldMap f (InlineFragment _ directives selectionSet) =+    foldMap f directives `mappend` mconcat (map (foldMap f) selectionSet)++instance Traversable spread => Traversable (InlineFragment spread) where+  traverse f (InlineFragment typeDefn directives selectionSet) =+    InlineFragment typeDefn <$> traverse f directives+                            <*> traverse (traverse f) selectionSet++-- | Traverse through every fragment spread in a selection.+--+-- The given function @f@ is applied to each fragment spread. The rest of the+-- selection remains unchanged.+--+-- Note that this is essentially a definition of 'Traversable' for+-- 'Selection'. However, we probably also want to have other kinds of+-- traversals (e.g. for transforming values), so best not to bless one kind+-- with a type class.+traverseFragmentSpreads :: Applicative f => (a value -> f (b value)) -> Selection' a value -> f (Selection' b value)+traverseFragmentSpreads f selection =+  case selection of+    SelectionField (Field' alias name args directives ss) ->+      SelectionField <$> (Field' alias name args directives <$> childSegments ss)+    SelectionFragmentSpread x ->+      SelectionFragmentSpread <$> f x+    SelectionInlineFragment (InlineFragment typeCond directives ss) ->+      SelectionInlineFragment <$> (InlineFragment typeCond directives <$> childSegments ss)+  where+    childSegments = traverse (traverseFragmentSpreads f)++-- | Ensure a selection has valid arguments and directives.+validateSelection :: Schema -> AST.Selection -> Validation (Selection' UnresolvedFragmentSpread AST.Value)+validateSelection schema selection =+  case selection of+    AST.SelectionField (AST.Field alias name args directives ss) ->+      SelectionField <$> (Field' alias name+                           <$> validateArguments args+                           <*> validateDirectives directives+                           <*> childSegments ss)+    AST.SelectionFragmentSpread (AST.FragmentSpread name directives) ->+      SelectionFragmentSpread <$> (UnresolvedFragmentSpread name <$> validateDirectives directives)+    AST.SelectionInlineFragment (AST.InlineFragment typeCond directives ss) ->+      SelectionInlineFragment <$> (InlineFragment+                                    <$> traverse (validateTypeCondition schema) typeCond+                                    <*> validateDirectives directives+                                    <*> childSegments ss)+  where+    childSegments = traverse (validateSelection schema)++-- | Resolve the fragment references in a selection, accumulating a set of+-- the fragment names that we have resolved.+--+-- We're doing a standard depth-first traversal of fragment references, where+-- references are by name, so the set of names can be thought of as a record+-- of visited references.+resolveSelection :: Fragments a -> Selection' UnresolvedFragmentSpread a -> StateT (Set Name) Validation (Selection' FragmentSpread a)+resolveSelection fragments = traverseFragmentSpreads resolveFragmentSpread+  where+    resolveFragmentSpread (UnresolvedFragmentSpread name directive) = do+      case Map.lookup name fragments of+        Nothing -> lift (throwE (NoSuchFragment name))+        Just fragment -> do+          modify (Set.insert name)+          pure (FragmentSpread name directive fragment)++-- * Fragment definitions++-- | A validated fragment definition.+--+-- @spread@ indicates whether references to other fragment definitions have+-- been resolved.+data FragmentDefinition spread value+  = FragmentDefinition Name TypeDefinition (Directives value) [Selection' spread value]+  deriving (Eq, Show)++type Fragments value = Map Name (FragmentDefinition FragmentSpread value)++instance Functor spread => Functor (FragmentDefinition spread) where+  fmap f (FragmentDefinition name typeDefn directives selectionSet) =+    FragmentDefinition name typeDefn (fmap f directives) (map (fmap f) selectionSet)++instance Foldable spread => Foldable (FragmentDefinition spread) where+  foldMap f (FragmentDefinition _ _ directives selectionSet) =+    foldMap f directives `mappend` mconcat (map (foldMap f) selectionSet)++instance Traversable spread => Traversable (FragmentDefinition spread) where+  traverse f (FragmentDefinition name typeDefn directives selectionSet) =+    FragmentDefinition name typeDefn <$> traverse f directives+                                     <*> traverse (traverse f) selectionSet++-- | Ensure fragment definitions are uniquely named, and that their arguments+-- and directives are sane.+--+-- <https://facebook.github.io/graphql/#sec-Fragment-Name-Uniqueness>+validateFragmentDefinitions :: Schema -> [AST.FragmentDefinition] -> Validation (Map Name (FragmentDefinition UnresolvedFragmentSpread AST.Value))+validateFragmentDefinitions schema frags = do+  defns <- traverse validateFragmentDefinition frags+  mapErrors DuplicateFragmentDefinition (makeMap [(name, value) | value@(FragmentDefinition name _ _ _) <- defns])+  where+    validateFragmentDefinition (AST.FragmentDefinition name typeCond directives ss) = do+      FragmentDefinition name+        <$> validateTypeCondition schema typeCond+        <*> validateDirectives directives+        <*> traverse (validateSelection schema) ss++-- | Validate a type condition that appears in a query.+validateTypeCondition :: Schema -> AST.TypeCondition -> Validation TypeDefinition+validateTypeCondition schema (NamedType typeCond) =+  case lookupType schema typeCond of+    Nothing -> throwE (TypeConditionNotFound typeCond)+    Just typeDefn -> pure typeDefn++-- | Resolve all references to fragments inside fragment definitions.+--+-- Guarantees that fragment spreads refer to fragments that have been defined,+-- and that there are no circular references.+--+-- Returns the resolved fragment definitions and a set of the names of all+-- defined fragments that were referred to by other fragments. This is to be+-- used to guarantee that all defined fragments are used (c.f.+-- <https://facebook.github.io/graphql/#sec-Fragments-Must-Be-Used>).+--+-- <https://facebook.github.io/graphql/#sec-Fragment-spread-target-defined>+-- <https://facebook.github.io/graphql/#sec-Fragment-spreads-must-not-form-cycles>+resolveFragmentDefinitions :: Map Name (FragmentDefinition UnresolvedFragmentSpread value) -> Validation (Fragments value, Set Name)+resolveFragmentDefinitions allFragments =+  splitResult <$> traverse resolveFragment allFragments+  where+    -- The result of our computation is a map from names of fragment+    -- definitions to the resolved fragment and visited names. We want to+    -- split out the visited names and combine them so that later we can+    -- report on the _un_visited names.+    splitResult mapWithVisited = (map fst mapWithVisited, foldMap snd mapWithVisited)++    -- | Resolves all references to fragments in a fragment definition,+    -- returning the resolved fragment and a set of visited names.+    resolveFragment frag = runStateT (resolveFragment' frag) mempty++    resolveFragment' (FragmentDefinition name cond directives ss) =+      FragmentDefinition name cond directives <$> traverse (traverseFragmentSpreads resolveSpread) ss++    resolveSpread (UnresolvedFragmentSpread name directives) = do+      visited <- Set.member name <$> get+      when visited (lift (throwE (CircularFragmentSpread name)))+      case Map.lookup name allFragments of+        Nothing -> lift (throwE (NoSuchFragment name))+        Just definition -> do+          modify (Set.insert name)+          FragmentSpread name directives <$> resolveFragment' definition++-- * Arguments++-- | The set of arguments for a given field, directive, etc.+--+-- Note that the 'value' can be a variable.+newtype Arguments value = Arguments (Map Name value) deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++-- | Turn a set of arguments from the AST into a guaranteed unique set of arguments.+--+-- <https://facebook.github.io/graphql/#sec-Argument-Uniqueness>+validateArguments :: [AST.Argument] -> Validation (Arguments AST.Value)+validateArguments args = Arguments <$> mapErrors DuplicateArgument (makeMap [(name, value) | AST.Argument name value <- args])++-- * Variables++-- | Defines a variable within the context of an operation.+--+-- See <https://facebook.github.io/graphql/#sec-Language.Variables>+data VariableDefinition+  = VariableDefinition+    { variable :: Variable -- ^ The name of the variable+    , variableType :: AST.Type -- ^ The type of the variable+    , defaultValue :: Maybe Value -- ^ An optional default value for the variable+    } deriving (Eq, Ord, Show)++type VariableDefinitions = Map Variable VariableDefinition++getDefinedVariables :: VariableDefinitions -> Set Variable+getDefinedVariables = Map.keysSet++-- | A GraphQL value which might contain some defined variables.+type VariableValue = Value' (Either VariableDefinition ConstScalar)++emptyVariableDefinitions :: VariableDefinitions+emptyVariableDefinitions = mempty++-- | Ensure that a set of variable definitions is valid.+validateVariableDefinitions :: [AST.VariableDefinition] -> Validation VariableDefinitions+validateVariableDefinitions vars = do+  validatedDefns <- traverse validateVariableDefinition 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++-- | Ensure that a default value contains no variables.+validateDefaultValue :: AST.DefaultValue -> Validation Value+validateDefaultValue defaultValue =+  case astToVariableValue defaultValue of+    Nothing -> throwE $ InvalidValue defaultValue+    Just value ->+      for value $+      \case+        Left _ -> throwE $ InvalidDefaultValue defaultValue+        Right constant -> pure constant+++-- | Get all the variables referred to in a thing what contains variables.+getVariables :: Foldable f => f UnresolvedVariableValue -> Set Variable+getVariables = foldMap valueToVariable+  where+    valueToVariable = foldMap (either Set.singleton (const Set.empty))++-- | Make sure all the values are valid.+validateValues :: Traversable f => f AST.Value -> Validation (f UnresolvedVariableValue)+validateValues = traverse toVariableValue+  where+    toVariableValue astValue =+      case astToVariableValue astValue of+        Just value -> pure value+        Nothing -> throwE (InvalidValue astValue)++-- | Make sure each variable has a definition, and each definition a variable.+resolveVariables :: Traversable f => VariableDefinitions -> f UnresolvedVariableValue -> Validation (f VariableValue)+resolveVariables definitions = traverse resolveVariableValue+  where+    resolveVariableValue = traverse resolveVariable+    resolveVariable (Left variable) =+      case Map.lookup variable definitions of+        Nothing -> throwE (UndefinedVariable variable)+        Just defn -> pure (Left defn)+    resolveVariable (Right constant) = pure (Right constant)+++-- * Directives++-- | A directive is a way of changing the run-time behaviour+newtype Directives value = Directives (Map Name (Arguments value)) deriving (Eq, Ord, Show, Foldable, Functor, Traversable)++emptyDirectives :: Directives value+emptyDirectives = Directives Map.empty++-- | Ensure that the directives in a given place are valid.+--+-- Doesn't check to see if directives are defined & doesn't check to see if+-- they are in valid locations, because we don't have access to the schema at+-- this point.+--+-- <https://facebook.github.io/graphql/#sec-Directives-Are-Unique-Per-Location>+validateDirectives :: [AST.Directive] -> Validation (Directives AST.Value)+validateDirectives directives = do+  items <- traverse validateDirective directives+  Directives <$> mapErrors DuplicateDirective (makeMap items)+  where+    validateDirective (AST.Directive name args) = (,) name <$> validateArguments args++-- TODO: There's a chunk of duplication around "this collection of things has+-- unique names". Fix that.++-- TODO: Might be nice to have something that goes from a validated document+-- back to the AST. This would be especially useful for encoding, so we could+-- debug by looking at GraphQL rather than data types.++-- * Validation errors++-- | Errors arising from validating a document.+data ValidationError+  -- | 'DuplicateOperation' means there was more than one operation defined+  -- with the given name.+  --+  -- <https://facebook.github.io/graphql/#sec-Operation-Name-Uniqueness>+  = DuplicateOperation Name+  -- | 'MixedAnonymousOperations' means there was more than one operation+  -- defined in a document with an anonymous operation.+  --+  -- <https://facebook.github.io/graphql/#sec-Lone-Anonymous-Operation>+  | MixedAnonymousOperations Int [Name]+  -- | 'DuplicateArgument' means that multiple copies of the same argument was+  -- given to the same field, directive, etc.+  | DuplicateArgument Name+  -- | 'DuplicateFragmentDefinition' means that there were more than one+  -- fragment defined with the same name.+  | DuplicateFragmentDefinition Name+  -- | 'NoSuchFragment' means there was a reference to a fragment in a+  -- fragment spread but we couldn't find any fragment with that name.+  | NoSuchFragment Name+  -- | 'DuplicateDirective' means there were two copies of the same directive+  -- given in the same place.+  --+  -- <https://facebook.github.io/graphql/#sec-Directives-Are-Unique-Per-Location>+  | DuplicateDirective Name+  -- | There were multiple variables defined with the same name.+  | DuplicateVariableDefinition Variable+  -- | 'CircularFragmentSpread' means that a fragment definition contains a+  -- fragment spread that itself is a fragment definition that contains a+  -- fragment spread referring to the /first/ fragment spread.+  | CircularFragmentSpread Name+  -- | 'UnusedFragments' means that fragments were defined that weren't used.+  -- <https://facebook.github.io/graphql/#sec-Fragments-Must-Be-Used>+  | UnusedFragments (Set Name)+  -- | Variables were defined without being used.+  -- <https://facebook.github.io/graphql/#sec-All-Variables-Used>+  | UnusedVariables (Set Variable)+  -- | A variable was used without being defined.+  -- <https://facebook.github.io/graphql/#sec-All-Variable-Uses-Defined>+  | UndefinedVariable Variable+  -- | Value in AST wasn't valid.+  | InvalidValue AST.Value+  -- | Default value in AST contained variables.+  | InvalidDefaultValue AST.Value+  -- | Two different names given for the same response key.+  | MismatchedNames Name Name+  -- | Two different sets of arguments given for the same response key.+  | MismatchedArguments Name+  -- | Two fields had the same response key, one was a leaf, the other was not.+  | IncompatibleFields Name+  -- | There's a type condition that's not present in the schema.+  | TypeConditionNotFound Name+  deriving (Eq, Show)++instance GraphQLError ValidationError where+  formatError (DuplicateOperation name) = "More than one operation named '" <> show name <> "'"+  formatError (MixedAnonymousOperations n names)+    | n > 1 && null names = "Multiple anonymous operations defined. Found " <> show n+    | otherwise = "Document contains both anonymous operations (" <> show n <> ") and named operations (" <> show names <> ")"+  formatError (DuplicateArgument name) = "More than one argument named '" <> show name <> "'"+  formatError (DuplicateFragmentDefinition name) = "More than one fragment named '" <> show name <> "'"+  formatError (NoSuchFragment name) = "No fragment named '" <> show name <> "'"+  formatError (DuplicateDirective name) = "More than one directive named '" <> show name <> "'"+  formatError (DuplicateVariableDefinition name) = "More than one variable defined with name '" <> show name <> "'"+  formatError (CircularFragmentSpread name) = "Fragment '" <> show name <> "' contains a fragment spread that refers back to itself."+  formatError (UnusedFragments names) = "Fragments defined but not used: " <> show names+  formatError (UnusedVariables names) = "Variables defined but not used: " <> show names+  formatError (UndefinedVariable variable) = "No definition for variable: " <> show variable+  formatError (InvalidValue value) = "Invalid value (maybe an object has duplicate field names?): " <> show value+  formatError (InvalidDefaultValue value) = "Invalid default value, contains variables: " <> show value+  formatError (MismatchedNames name1 name2) = "Two different names given for same response key: " <> show name1 <> ", " <> show name2+  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."++type ValidationErrors = NonEmpty ValidationError++-- | Type alias for our most common kind of validator.+type Validation = Validator ValidationError++-- | Identify all of the validation errors in @doc@.+--+-- An empty list means no errors.+--+-- <https://facebook.github.io/graphql/#sec-Validation>+getErrors :: Schema -> AST.QueryDocument -> [ValidationError]+getErrors schema doc =+  case validate schema doc of+    Left errors -> NonEmpty.toList errors+    Right _ -> []++-- * Helper functions++-- | Return a list of all the elements with duplicates. The list of duplicates+-- itself will not contain duplicates.+--+-- prop> \xs -> findDuplicates @Int xs == ordNub (findDuplicates @Int xs)+findDuplicates :: Ord a => [a] -> [a]+findDuplicates xs = findDups (sort xs)+  where+    findDups [] = []+    findDups [_] = []+    findDups (x:ys@(y:zs))+      | x == y = x:findDups (dropWhile (== x) zs)+      | otherwise = findDups ys++-- | Create a map from a list of key-value pairs.+--+-- Returns a list of duplicates on 'Left' if there are duplicates.+makeMap :: Ord key => [(key, value)] -> Validator key (Map key value)+makeMap entries =+  case NonEmpty.nonEmpty (findDuplicates (map fst entries)) of+    Nothing -> pure (Map.fromList entries)+    Just dups -> throwErrors dups++-- * Error handling++-- | A 'Validator' is a value that can either be valid or have a non-empty+-- list of errors.+newtype Validator e a = Validator { runValidator :: Either (NonEmpty e) a } deriving (Eq, Show, Functor, Monad)++-- | Throw a single validation error.+throwE :: e -> Validator e a+throwE e = throwErrors (e :| [])++-- | Throw multiple validation errors. There must be at least one.+throwErrors :: NonEmpty e -> Validator e a+throwErrors = Validator . Left++-- | Map over each individual error on a validation. Useful for composing+-- validations.+--+-- This is /somewhat/ like 'first', but 'Validator' is not, and cannot be, a+-- 'Bifunctor', because the left-hand side is specialized to @NonEmpty e@,+-- rather than plain @e@. Also, whatever function were passed to 'first' would+-- get the whole non-empty list, whereas 'mapErrors' works on one element at a+-- time.+--+-- >>> mapErrors (+1) (pure "hello")+-- Validator {runValidator = Right "hello"}+-- >>> mapErrors (+1) (throwE 2)+-- Validator {runValidator = Left (3 :| [])}+-- >>> mapErrors (+1) (throwErrors (NonEmpty.fromList [3, 5]))+-- Validator {runValidator = Left (4 :| [6])}+mapErrors :: (e1 -> e2) -> Validator e1 a -> Validator e2 a+mapErrors f (Validator (Left es)) = Validator (Left (map f es))+mapErrors _ (Validator (Right x)) = Validator (Right x)++-- | The applicative on Validator allows multiple potentially-valid values to+-- be composed, and ensures that *all* validation errors bubble up.+instance Applicative (Validator e) where+  pure x = Validator (Right x)+  Validator (Left e1) <*> (Validator (Left e2)) = Validator (Left (e1 <> e2))+  Validator (Left e) <*> _ = Validator (Left e)+  Validator _ <*> (Validator (Left e)) = Validator (Left e)+  Validator (Right f) <*> Validator (Right x) = Validator (Right (f x))
+ src/GraphQL/Resolver.hs view
@@ -0,0 +1,535 @@+{-# 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++module GraphQL.Resolver+  ( ResolverError(..)+  , HasResolver(..)+  , (:<>)(..)+  , Defaultable(..)+  , 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)++import qualified Data.Text as Text+import qualified Data.List.NonEmpty as NonEmpty+import GHC.TypeLits (KnownSymbol, TypeError, ErrorMessage(..), Symbol, symbolVal)+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+  )++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 =+    "Triet 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)++-- | Specify a default value for a type in a GraphQL schema.+--+-- GraphQL schema can have default values in certain places. For example,+-- arguments to fields can have default values. Because we cannot lift+-- arbitrary values to the type level, we need some way of getting at those+-- values. This typeclass provides the means.+--+-- To specify a default, implement this typeclass.+--+-- The default implementation is to say that there *is* no default for this+-- type.+class Defaultable a where+  -- | defaultFor returns the value to be used when no value has been given.+  defaultFor :: Name -> Maybe a+  defaultFor _ = empty++-- | Called when the schema expects an input argument @name@ of type @a@ but+-- @name@ has not been provided.+valueMissing :: Defaultable a => Name -> Either ResolverError a+valueMissing name = maybe (Left (ValueMissing name)) Right (defaultFor name)++instance Defaultable Int32++instance Defaultable Double++instance Defaultable Bool++instance Defaultable Text++instance Defaultable (Maybe a) where+  -- | The default for @Maybe a@ is @Nothing@.+  defaultFor _ = pure Nothing++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) = enum+  resolve handler Nothing = (pure . ok . GValue.ValueEnum . API.enumToValue) handler+  resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss)++-- TODO: This is our handler for `Maybe a`, which is currently used to+-- implement nullable types. It's *probably* broken, in that it's discarding+-- the selection set. <https://github.com/jml/graphql-api/issues/102>+instance forall m hg. (HasResolver m hg, Functor m, ToValue (Maybe hg)) => HasResolver m (Maybe hg) where+  type Handler m (Maybe hg) = m (Maybe hg)+  resolve handler _ =  map (ok . toValue) handler++-- 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+  , 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+  , 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
+ src/GraphQL/Value.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- | Literal GraphQL values.+module GraphQL.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)
+ src/GraphQL/Value/FromValue.hs view
@@ -0,0 +1,135 @@+{-# 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(..))++-- * 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 <> 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 = undefined
+ src/GraphQL/Value/ToValue.hs view
@@ -0,0 +1,57 @@+{-# 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
+ tests/ASTTests.hs view
@@ -0,0 +1,164 @@+{-# 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, unsafeMakeName)+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 = unsafeMakeName "dog"++someName :: Name+someName = unsafeMakeName "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 (unsafeMakeName "s")+                       (AST.ValueString (AST.StringValue "\224\225v^6{FPDk\DC3\a")),+                       AST.ObjectField (unsafeMakeName "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 anonymous query 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 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 (unsafeMakeName "getName") [] []+                         [ AST.SelectionField+                           (AST.Field Nothing dog [] []+                            [ AST.SelectionField+                              (AST.Field Nothing (unsafeMakeName "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 (unsafeMakeName "houseTrainedQuery")+                            [ AST.VariableDefinition+                                (AST.Variable (unsafeMakeName "atOtherHomes"))+                                (AST.TypeNamed (AST.NamedType (unsafeMakeName "Boolean")))+                                (Just (AST.ValueBoolean True))+                            ] []+                            [ AST.SelectionField+                                (AST.Field Nothing dog [] []+                                 [ AST.SelectionField+                                     (AST.Field Nothing (unsafeMakeName "isHousetrained")+                                      [ AST.Argument (unsafeMakeName "atOtherHomes")+                                          (AST.ValueVariable (AST.Variable (unsafeMakeName "atOtherHomes")))+                                      ] [] [])+                                 ])+                            ]))+                     ]+      parsed `shouldBe` expected
+ tests/Doctests.hs view
@@ -0,0 +1,21 @@+module Main (main) where++import Protolude++import Test.DocTest++main :: IO ()+main = doctest $ ["-isrc"] <> options <> files+  where+    options = map ("-X" <>) extensions+    -- These must match the extensions in package.yaml.+    extensions = [ "NoImplicitPrelude"+                 , "OverloadedStrings"+                 , "RecordWildCards"+                 , "TypeApplications"+                 , "DataKinds"+                 ]+    -- library code and examples+    files = [ "src/"+            , "examples/"+            ]
+ tests/EndToEndTests.hs view
@@ -0,0 +1,329 @@+{-# 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 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+
+ tests/ExampleSchema.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++-- | An example GraphQL schema, used in our end-to-end tests.+--+-- Based on the example schema given in the GraphQL spec. See+-- <https://facebook.github.io/graphql/#sec-Validation>.+--+-- Here's the full schema:+--+-- @+-- enum DogCommand { SIT, DOWN, HEEL }+--+-- type Dog implements Pet {+--   name: String!+--   nickname: String+--   barkVolume: Int+--   doesKnowCommand(dogCommand: DogCommand!): Boolean!+--   isHousetrained(atOtherHomes: Boolean): Boolean!+--   owner: Human+-- }+--+-- interface Sentient {+--   name: String!+-- }+--+-- interface Pet {+--   name: String!+-- }+--+-- type Alien implements Sentient {+--   name: String!+--   homePlanet: String+-- }+--+-- type Human implements Sentient {+--   name: String!+-- }+--+-- enum CatCommand { JUMP }+--+-- type Cat implements Pet {+--   name: String!+--   nickname: String+--   doesKnowCommand(catCommand: CatCommand!): Boolean!+--   meowVolume: Int+-- }+--+-- union CatOrDog = Cat | Dog+-- union DogOrHuman = Dog | Human+-- union HumanOrAlien = Human | Alien+-- @+--+-- Unlike the spec, we don't define a @QueryRoot@ type here, instead+-- encouraging test modules to define their own as appropriate to their needs.+--+-- We'll repeat bits of the schema below, explaining how they translate into+-- Haskell as we go.++module ExampleSchema+  ( DogCommand(..)+  , Dog+  , Sentient+  , Pet+  , Alien+  , Human+  , CatCommand(..)+  , Cat+  , CatOrDog+  , DogOrHuman+  , HumanOrAlien+  ) where++import Protolude hiding (Enum)++import GraphQL.API+  ( GraphQLEnum(..)+  , Enum+  , Object+  , Field+  , Argument+  , Interface+  , Union+  , (:>)+  )+-- XXX: This really shouldn't be part of Resolver, since whether or not a+-- thing has a default is part of the API / Schema definition.+import GraphQL.Resolver (Defaultable(..))+import GraphQL.Value (pattern ValueEnum, unName)+import GraphQL.Value.ToValue (ToValue(..))++-- | A command that can be given to a 'Dog'.+--+-- @+-- enum DogCommand { SIT, DOWN, HEEL }+-- @+--+-- To define this in Haskell we need to do three things:+--+--  1. Define a sum type with nullary constructors to represent the enum+--     (here, 'DogCommandEnum')+--  2. Make it an instance of 'GraphQLEnum'+--  3. Wrap the sum type in 'Enum', e.g. @Enum "DogCommand" DogCommandEnum@+--     so it can be placed in a schema.+data DogCommand = Sit | Down | Heel deriving (Show, Eq, Ord, Generic)++instance GraphQLEnum DogCommand++-- TODO: Probably shouldn't have to do this for enums.+instance ToValue DogCommand where+  toValue = ValueEnum . enumToValue++-- | A dog.+--+-- This is an example of a GraphQL \"object\".+--+-- @+-- type Dog implements Pet {+--   name: String!+--   nickname: String+--   barkVolume: Int+--   doesKnowCommand(dogCommand: DogCommand!): Boolean!+--   isHousetrained(atOtherHomes: Boolean): Boolean!+--   owner: Human+-- }+-- @+--+-- To define it in Haskell, we use 'Object'. The first argument is the name of+-- the object (here, @"Dog"@). The second is a list of interfaces implemented+-- by the object (here, only 'Pet').+--+-- The third, final, and most interesting argument is the list of fields the+-- object has. Fields can look one of two ways:+--+-- @+-- Field "name" Text+-- @+--+-- for a field that takes no arguments. This field would be called @name@ and+-- is guaranteed to return some text if queried.+--+-- A field that takes arguments looks like this:+--+-- @+-- Argument "dogCommand" DogCommand :> Field "doesKnowCommand" Bool+-- @+--+-- Here, the field is named @doesKnowCommand@ and it takes a single+-- argument--a 'DogCommand'--and returns a 'Bool'. Note that this is in+-- reverse order to the GraphQL schema, which represents this field as:+--+-- @+--   doesKnowCommand(dogCommand: DogCommand!): Boolean!+-- @+--+-- Also note that all fields and arguments are "non-null" by default. If you+-- want a field to be nullable, give it a 'Maybe' type, e.g.+--+-- @+--   nickname: String+-- @+--+-- @nickname@ is nullable, so we represent the field in Haskell as:+--+-- @+--   Field "nickname" (Maybe Text)+-- @+type Dog = Object "Dog" '[Pet]+  '[ Field "name" Text+   , Field "nickname" (Maybe Text)+   , Field "barkVolume" Int32+   , Argument "dogCommand" (Enum "DogCommand" DogCommand) :> Field "doesKnowCommand" Bool+   , Argument "atOtherHomes" (Maybe Bool) :> Field "isHouseTrained" Bool+   , 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.+--+-- @+-- interface Sentient {+--   name: String!+-- }+-- @+type Sentient = Interface "Sentient" '[Field "name" Text]++-- | Pets have names too.+--+-- This defines an interface, 'Pet', that objects can implement.+--+-- @+-- interface Pet {+--   name: String!+-- }+-- @+type Pet = Interface "Pet" '[Field "name" Text]++-- | An alien.+--+-- See 'Dog' for more details on how to define an object type for GraphQL.+--+-- @+-- type Alien implements Sentient {+--   name: String!+--   homePlanet: String+-- }+-- @+type Alien = Object "Alien" '[Sentient]+  '[ Field "name" Text+   , Field "homePlanet" (Maybe Text)+   ]++-- | Humans are sentient.+--+-- See 'Dog' for more details on how to define an object type for GraphQL.+--+-- @+-- type Human implements Sentient {+--   name: String!+-- }+-- @+type Human = Object "Human" '[Sentient]+  '[ Field "name" Text+   ]++-- TODO: Extend example to cover unions, interfaces and lists by giving humans+-- a list of pets and a list of cats & dogs.++-- | Cats can jump.+--+-- See 'DogCommandEnum' for more details on defining an enum for GraphQL.+--+-- The interesting thing about 'CatCommandEnum' is that it's an enum that has+-- only one possible value.+--+-- @+-- enum CatCommand { JUMP }+-- @+data CatCommand = Jump deriving Generic++instance GraphQLEnum CatCommand++-- | A cat.+--+-- See 'Dog' for more details on how to define an object type for GraphQL.+--+-- @+-- type Cat implements Pet {+--   name: String!+--   nickname: String+--   doesKnowCommand(catCommand: CatCommand!): Boolean!+--   meowVolume: Int+-- }+-- @+type Cat = Object "Cat" '[Pet]+  '[ Field "name" Text+   , Field "nickName" (Maybe Text)+   , Argument "catCommand" (Enum "CatCommand" CatCommand) :> Field "doesKnowCommand" Bool+   , Field "meowVolume" Int32+   ]++-- | Either a cat or a dog. (Pick dog, dogs are awesome).+--+-- A 'Union' is used when you want to return one of short list of known+-- types.+--+-- You define them in GraphQL like so:+--+-- @+-- union CatOrDog = Cat | Dog+-- @+--+-- To translate this to Haskell, define a new type using 'Union'. The first+-- argument is the name of the union, here @"CatOrDog"@, and the second+-- argument is the list of possible types of the union. These must be objects,+-- defined with 'Object'.+type CatOrDog = Union "CatOrDog" '[Cat, Dog]++-- | Either a dog or a human. (Pick dog, dogs are awesome).+--+-- See 'CatOrDog' for more details on defining a union.+--+-- @+-- union DogOrHuman = Dog | Human+-- @+type DogOrHuman = Union "DogOrHuman" '[Dog, Human]++-- | Either a human or an alien. (Pick dog, dogs are awesome).+--+-- See 'CatOrDog' for more details on defining a union.+--+-- @+-- union HumanOrAlien = Human | Alien+-- @+type HumanOrAlien = Union "HumanOrAlien" '[Human, Alien]
+ tests/Examples/InputObject.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveGeneric #-}++module Examples.InputObject where+import Protolude hiding (Enum)++import GraphQL+import GraphQL.API+import GraphQL.Resolver (Handler, Defaultable(..))+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
+ tests/Examples/UnionExample.hs view
@@ -0,0 +1,52 @@+{-# 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 } } }"
+ tests/OrderedMapTests.hs view
@@ -0,0 +1,43 @@+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
+ tests/ResolverTests.hs view
@@ -0,0 +1,52 @@+{-# 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+  , (:>)+  )+import GraphQL.Resolver+  ( Handler+  , ResolverError(..)+  , (:<>)(..)+  )+import GraphQL.Internal.Name (unsafeMakeName)+import GraphQL.Internal.Output (singleError)++-- 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))++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 (unsafeMakeName "not_a_field"))+    it "complains about missing argument" $ do+      Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t }")+      errs `shouldBe` singleError (ValueMissing (unsafeMakeName "x"))
+ tests/SchemaTests.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# 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.Name (unsafeMakeName)+import GraphQL.Internal.Schema+  ( EnumTypeDefinition(..)+  , EnumValueDefinition(..)+  , FieldDefinition(..)+  , ObjectTypeDefinition(..)+  , NonEmptyList(..)+  , InterfaceTypeDefinition(..)+  , AnnotatedType(..)+  , ListType(..)+  , UnionTypeDefinition(..)+  , Type(..)+  , 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 (unsafeMakeName "hello") [] (TypeNonNull (NonNullTypeNamed (BuiltinType GInt))))+  describe "Interface" $+    it "encodes correctly" $ do+    getInterfaceDefinition @Sentient `shouldBe`+      Right (InterfaceTypeDefinition+        (unsafeMakeName "Sentient")+        (NonEmptyList [FieldDefinition (unsafeMakeName "name") [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))]))+  describe "full example" $+    it "encodes correctly" $ do+    getDefinition @Human `shouldBe`+      Right (ObjectTypeDefinition (unsafeMakeName "Human")+        [ InterfaceTypeDefinition (unsafeMakeName "Sentient") (+            NonEmptyList [FieldDefinition (unsafeMakeName "name") [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))])+        ]+        (NonEmptyList [FieldDefinition (unsafeMakeName "name") [] (TypeNonNull (NonNullTypeNamed (BuiltinType GString)))]))+  describe "output Enum" $+    it "encodes correctly" $ do+    getAnnotatedType @(Enum "DogCommand" DogCommand) `shouldBe`+       Right (TypeNonNull (NonNullTypeNamed (DefinedType (TypeDefinitionEnum (EnumTypeDefinition (unsafeMakeName "DogCommand")+         [ EnumValueDefinition (unsafeMakeName "Sit")+         , EnumValueDefinition (unsafeMakeName "Down")+         , EnumValueDefinition (unsafeMakeName "Heel")+         ])))))+  describe "Union type" $+    it "encodes correctly" $ do+    getAnnotatedType @CatOrDog `shouldBe`+      TypeNamed . DefinedType . TypeDefinitionUnion . UnionTypeDefinition (unsafeMakeName "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)))))
+ tests/Spec.hs view
@@ -0,0 +1,34 @@+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 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+      ]
+ tests/ValidationTests.hs view
@@ -0,0 +1,93 @@+{-# 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, unsafeMakeName)+import qualified GraphQL.Internal.Syntax.AST as AST+import GraphQL.Internal.Schema (Schema)+import GraphQL.Internal.Validation+  ( ValidationError(..)+  , findDuplicates+  , getErrors+  )++me :: Name+me = unsafeMakeName "me"++someName :: Name+someName = unsafeMakeName "name"++-- | Schema used for these tests. Since none of them do type-level stuff, we+-- don't need to define it.+schema :: Schema+schema = undefined++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 "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
+ tests/ValueTests.hs view
@@ -0,0 +1,71 @@+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.Internal.Name (unsafeMakeName)+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 [ (unsafeMakeName "foo", toValue @Int32 1)+                                      , (unsafeMakeName "bar",toValue @Int32 2)]+      let (Just bar) = objectFromList [ (unsafeMakeName "bar", toValue @Text "cow")+                                      , (unsafeMakeName "baz",toValue @Int32 3)]+      let observed = unionObjects [foo, bar]+      observed `shouldBe` Nothing+    it "merges objects with unique keys" $ do+      let (Just foo) = objectFromList [(unsafeMakeName "foo", toValue @Int32 1)]+      let (Just bar) = objectFromList [ (unsafeMakeName "bar", toValue @Text "cow")+                                      , (unsafeMakeName "baz",toValue @Int32 3)]+      let (Just expected) = objectFromList [ (unsafeMakeName "foo", toValue @Int32 1)+                                           , (unsafeMakeName "bar", toValue @Text "cow")+                                           , (unsafeMakeName "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 (unsafeMakeName "foo") (AST.ValueString (AST.StringValue "bar"))+                                  , AST.ObjectField (unsafeMakeName "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]