Coerce variable values

2 files changed, 302 insertions, 7 deletions

diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs
index 016eeb8..5891f71 100644
--- a/src/Language/GraphQL/Type/Definition.hs
+++ b/src/Language/GraphQL/Type/Definition.hs
@@ -1,18 +1,256 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Types representing GraphQL type system.
 module Language.GraphQL.Type.Definition
-    ( ObjectType(..)
+    ( Argument(..)
+    , EnumType(..)
+    , Field(..)
+    , FieldResolver(..)
+    , InputField(..)
+    , InputObjectType(..)
+    , InputType(..)
+    , ObjectType(..)
+    , OutputType(..)
+    , ScalarType(..)
+    , TypeDefinition(..)
+    , pattern EnumInputTypeDefinition
+    , pattern ListInputTypeDefinition
+    , pattern ObjectInputTypeDefinition
+    , pattern ScalarInputTypeDefinition
+    , pattern EnumOutputTypeDefinition
+    , pattern ListOutputTypeDefinition
+    , pattern ObjectOutputTypeDefinition
+    , pattern ScalarOutputTypeDefinition
+    , boolean
+    , float
+    , id
+    , int
+    , string
     ) where
 
+import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
+import Data.Set (Set)
 import Data.Text (Text)
-import Language.GraphQL.Schema
-
-type Fields m = HashMap Text (FieldResolver m)
+import Language.GraphQL.AST.Core (Name, Value)
+import Language.GraphQL.Trans
+import qualified Language.GraphQL.Type as Type
+import Prelude hiding (id)
 
--- | Object Type Definition.
+-- | Object type definition.
 --
 --   Almost all of the GraphQL types you define will be object types. Object
 --   types have a name, but most importantly describe their fields.
 data ObjectType m = ObjectType
     { name :: Text
-    , fields :: Fields m
+    , fields :: HashMap Name (Field m)
     }
+
+-- | Output object field definition.
+data Field m = Field
+    (Maybe Text) (OutputType m) (HashMap Name Argument) (FieldResolver m)
+
+-- | Resolving a field can result in a leaf value or an object, which is
+-- represented as a list of nested resolvers, used to resolve the fields of that
+-- object.
+data FieldResolver m
+    = ValueResolver (ActionT m Aeson.Value)
+    | NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m))))
+
+-- | Field argument definition.
+data Argument = Argument (Maybe Text) InputType (Maybe Value)
+
+-- | Scalar type definition.
+--
+-- The leaf values of any request and input values to arguments are Scalars (or
+-- Enums) .
+data ScalarType = ScalarType Name (Maybe Text)
+
+-- | Enum type definition.
+--
+-- Some leaf values of requests and input values are Enums. GraphQL serializes
+-- Enum values as strings, however internally Enums can be represented by any
+-- kind of type, often integers.
+data EnumType = EnumType Name (Maybe Text) (Set Text)
+
+-- | Single field of an 'InputObjectType'.
+data InputField = InputField (Maybe Text) InputType (Maybe Value)
+
+-- | Input object type definition.
+--
+-- An input object defines a structured collection of fields which may be
+-- supplied to a field argument.
+data InputObjectType = InputObjectType
+    Name (Maybe Text) (HashMap Name InputField)
+
+-- | These types may be used as input types for arguments and directives.
+data InputType
+    = ScalarInputType ScalarType
+    | EnumInputType EnumType
+    | ObjectInputType InputObjectType
+    | ListInputType InputType
+    | NonNullScalarInputType ScalarType
+    | NonNullEnumInputType EnumType
+    | NonNullObjectInputType InputObjectType
+    | NonNullListInputType InputType
+
+-- | These types may be used as output types as the result of fields.
+data OutputType m
+    = ScalarOutputType ScalarType
+    | EnumOutputType EnumType
+    | ObjectOutputType (ObjectType m)
+    | ListOutputType (OutputType m)
+    | NonNullScalarOutputType ScalarType
+    | NonNullEnumOutputType EnumType
+    | NonNullObjectOutputType (ObjectType m)
+    | NonNullListOutputType (OutputType m)
+
+-- | These are all of the possible kinds of types.
+data TypeDefinition m
+    = ScalarTypeDefinition ScalarType
+    | EnumTypeDefinition EnumType
+    | ObjectTypeDefinition (ObjectType m)
+    | InputObjectTypeDefinition InputObjectType
+
+-- | The @String@ scalar type represents textual data, represented as UTF-8
+-- character sequences. The String type is most often used by GraphQL to
+-- represent free-form human-readable text.
+string :: ScalarType
+string = ScalarType "String" (Just description)
+  where
+    description =
+        "The `String` scalar type represents textual data, represented as \
+        \UTF-8 character sequences. The String type is most often used by \
+        \GraphQL to represent free-form human-readable text."
+
+-- | The @Boolean@ scalar type represents @true@ or @false@.
+boolean :: ScalarType
+boolean = ScalarType "Boolean" (Just description)
+  where
+    description = "The `Boolean` scalar type represents `true` or `false`."
+
+-- | The @Int@ scalar type represents non-fractional signed whole numeric
+-- values. Int can represent values between \(-2^{31}\) and \(2^{31 - 1}\).
+int :: ScalarType
+int = ScalarType "Int" (Just description)
+  where
+    description =
+        "The `Int` scalar type represents non-fractional signed whole numeric \
+        \values. Int can represent values between -(2^31) and 2^31 - 1."
+
+-- | The @Float@ scalar type represents signed double-precision fractional
+-- values as specified by
+-- [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point).
+float :: ScalarType
+float = ScalarType "Float" (Just description)
+  where
+    description =
+        "The `Float` scalar type represents signed double-precision fractional \
+        \values as specified by \
+        \[IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point)."
+
+-- | The @ID@ scalar type represents a unique identifier, often used to refetch
+-- an object or as key for a cache. The ID type appears in a JSON response as a
+-- String; however, it is not intended to be human-readable. When expected as an
+-- input type, any string (such as @"4"@) or integer (such as @4@) input value
+-- will be accepted as an ID.
+id :: ScalarType
+id = ScalarType "ID" (Just description)
+  where
+    description =
+        "The `ID` scalar type represents a unique identifier, often used to \
+        \refetch an object or as key for a cache. The ID type appears in a \
+        \JSON response as a String; however, it is not intended to be \
+        \human-readable. When expected as an input type, any string (such as \
+        \`\"4\"`) or integer (such as `4`) input value will be accepted as an ID."
+
+-- | Matches either 'ScalarInputType' or 'NonNullScalarInputType'.
+pattern ScalarInputTypeDefinition :: ScalarType -> InputType
+pattern ScalarInputTypeDefinition scalarType <-
+    (isScalarInputType -> Just scalarType)
+
+-- | Matches either 'EnumInputType' or 'NonNullEnumInputType'.
+pattern EnumInputTypeDefinition :: EnumType -> InputType
+pattern EnumInputTypeDefinition enumType <-
+    (isEnumInputType -> Just enumType)
+
+-- | Matches either 'ObjectInputType' or 'NonNullObjectInputType'.
+pattern ObjectInputTypeDefinition :: InputObjectType -> InputType
+pattern ObjectInputTypeDefinition objectType <-
+    (isObjectInputType -> Just objectType)
+
+-- | Matches either 'ListInputType' or 'NonNullListInputType'.
+pattern ListInputTypeDefinition :: InputType -> InputType
+pattern ListInputTypeDefinition listType <-
+    (isListInputType -> Just listType)
+
+{-# COMPLETE EnumInputTypeDefinition
+    , ListInputTypeDefinition
+    , ObjectInputTypeDefinition
+    , ScalarInputTypeDefinition
+    #-}
+
+pattern ScalarOutputTypeDefinition :: forall m. ScalarType -> OutputType m
+pattern ScalarOutputTypeDefinition scalarType <-
+    (isScalarOutputType -> Just scalarType)
+
+pattern EnumOutputTypeDefinition :: forall m. EnumType -> OutputType m
+pattern EnumOutputTypeDefinition enumType <-
+    (isEnumOutputType -> Just enumType)
+
+pattern ObjectOutputTypeDefinition :: forall m. ObjectType m -> OutputType m
+pattern ObjectOutputTypeDefinition objectType <-
+    (isObjectOutputType -> Just objectType)
+
+pattern ListOutputTypeDefinition :: forall m. OutputType m -> OutputType m
+pattern ListOutputTypeDefinition listType <-
+    (isListOutputType -> Just listType)
+
+{-# COMPLETE ScalarOutputTypeDefinition
+    , EnumOutputTypeDefinition
+    , ObjectOutputTypeDefinition
+    , ListOutputTypeDefinition
+    #-}
+
+isScalarInputType :: InputType -> Maybe ScalarType
+isScalarInputType (ScalarInputType inputType) = Just inputType
+isScalarInputType (NonNullScalarInputType inputType) = Just inputType
+isScalarInputType _ = Nothing
+
+isObjectInputType :: InputType -> Maybe InputObjectType
+isObjectInputType (ObjectInputType inputType) = Just inputType
+isObjectInputType (NonNullObjectInputType inputType) = Just inputType
+isObjectInputType _ = Nothing
+
+isEnumInputType :: InputType -> Maybe EnumType
+isEnumInputType (EnumInputType inputType) = Just inputType
+isEnumInputType (NonNullEnumInputType inputType) = Just inputType
+isEnumInputType _ = Nothing
+
+isListInputType :: InputType -> Maybe InputType
+isListInputType (ListInputType inputType) = Just inputType
+isListInputType (NonNullListInputType inputType) = Just inputType
+isListInputType _ = Nothing
+
+isScalarOutputType :: forall m. OutputType m -> Maybe ScalarType
+isScalarOutputType (ScalarOutputType outputType) = Just outputType
+isScalarOutputType (NonNullScalarOutputType outputType) = Just outputType
+isScalarOutputType _ = Nothing
+
+isObjectOutputType :: forall m. OutputType m -> Maybe (ObjectType m)
+isObjectOutputType (ObjectOutputType outputType) = Just outputType
+isObjectOutputType (NonNullObjectOutputType outputType) = Just outputType
+isObjectOutputType _ = Nothing
+
+isEnumOutputType :: forall m. OutputType m -> Maybe EnumType
+isEnumOutputType (EnumOutputType outputType) = Just outputType
+isEnumOutputType (NonNullEnumOutputType outputType) = Just outputType
+isEnumOutputType _ = Nothing
+
+isListOutputType :: forall m. OutputType m -> Maybe (OutputType m)
+isListOutputType (ListOutputType outputType) = Just outputType
+isListOutputType (NonNullListOutputType outputType) = Just outputType
+isListOutputType _ = Nothing
diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs
index f830c26..fa44694 100644
--- a/src/Language/GraphQL/Type/Schema.hs
+++ b/src/Language/GraphQL/Type/Schema.hs
@@ -1,11 +1,68 @@
+{-# LANGUAGE ExplicitForAll #-}
+
+-- | Schema Definition.
 module Language.GraphQL.Type.Schema
     ( Schema(..)
+    , collectReferencedTypes
     ) where
 
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Language.GraphQL.AST.Core (Name)
 import Language.GraphQL.Type.Definition
 
--- | Schema Definition
+-- | A Schema is created by supplying the root types of each type of operation,
+--   query and mutation (optional). A schema definition is then supplied to the
+--   validator and executor.
+--
+--   __Note:__ When the schema is constructed, by default only the types that
+--   are reachable by traversing the root types are included, other types must
+--   be explicitly referenced.
 data Schema m = Schema
     { query :: ObjectType m
     , mutation :: Maybe (ObjectType m)
     }
+
+-- | Traverses the schema and finds all referenced types.
+collectReferencedTypes :: forall m. Schema m -> HashMap Name (TypeDefinition m)
+collectReferencedTypes schema =
+    let queryTypes = traverseObjectType (query schema) HashMap.empty
+     in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema
+  where
+    collect traverser typeName element foundTypes =
+        let newMap = HashMap.insert typeName element foundTypes
+         in maybe (traverser newMap) (const foundTypes)
+            $ HashMap.lookup typeName foundTypes
+    visitFields (Field _ outputType arguments _) foundTypes
+        = traverseOutputType outputType
+        $ foldr visitArguments foundTypes arguments
+    visitArguments (Argument _ inputType _) = traverseInputType inputType
+    visitInputFields (InputField _ inputType _) = traverseInputType inputType
+    traverseInputType (ObjectInputTypeDefinition objectType) =
+        let (InputObjectType typeName _ inputFields) = objectType
+            element = InputObjectTypeDefinition objectType
+            traverser = flip (foldr visitInputFields) inputFields
+         in collect traverser typeName element
+    traverseInputType (ListInputTypeDefinition listType) =
+        traverseInputType listType
+    traverseInputType (ScalarInputTypeDefinition scalarType) =
+        let (ScalarType typeName _) = scalarType
+         in collect Prelude.id typeName (ScalarTypeDefinition scalarType)
+    traverseInputType (EnumInputTypeDefinition enumType) =
+        let (EnumType typeName _ _) = enumType
+         in collect Prelude.id typeName (EnumTypeDefinition enumType)
+    traverseOutputType (ObjectOutputTypeDefinition objectType) =
+        traverseObjectType objectType
+    traverseOutputType (ListOutputTypeDefinition listType) =
+        traverseOutputType listType
+    traverseOutputType (ScalarOutputTypeDefinition scalarType) =
+        let (ScalarType typeName _) = scalarType
+         in collect Prelude.id typeName (ScalarTypeDefinition scalarType)
+    traverseOutputType (EnumOutputTypeDefinition enumType) =
+        let (EnumType typeName _ _) = enumType
+         in collect Prelude.id typeName (EnumTypeDefinition enumType)
+    traverseObjectType objectType foundTypes =
+        let (ObjectType typeName objectFields) = objectType
+            element = ObjectTypeDefinition objectType
+            traverser = flip (foldr visitFields) objectFields
+         in collect traverser typeName element foundTypes