Export sum type for all GraphQL types

11 files changed, 159 insertions, 161 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 7cfe229..efcc224 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -12,6 +12,7 @@ and this project adheres to
 - `Execute` reexports `Execute.Coerce`.
 - `Error.Error` is an error representation with a message and source location.
 - `Error.Response` represents a result of running a GraphQL query.
+- `Type.Schema` exports `Type` which lists all types possible in the schema.
 
 ## Changed
 - `Trans.ActionT` has become to `Type.Out.ResolverT`. Since `Type.Out.Resolver`
diff --git a/graphql.cabal b/graphql.cabal
index 7c8737c..e7ac249 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 7101732e7932f4605d0c6ecaf88fd11c1fb6cb8045e6e0f419858cad027f383a
+-- hash: c06170c5fd3d1c3e42fb8c8fde8afd88bf3dd142f6cee1f83128e8d00d443f2d
 
 name:           graphql
 version:        0.8.0.0
@@ -50,12 +50,12 @@ library
       Language.GraphQL.Type
       Language.GraphQL.Type.In
       Language.GraphQL.Type.Out
+      Language.GraphQL.Type.Schema
   other-modules:
       Language.GraphQL.Execute.Execution
       Language.GraphQL.Execute.Transform
       Language.GraphQL.Type.Definition
-      Language.GraphQL.Type.Directive
-      Language.GraphQL.Type.Schema
+      Language.GraphQL.Type.Internal
   hs-source-dirs:
       src
   build-depends:
diff --git a/package.yaml b/package.yaml
index af29c48..88b238c 100644
--- a/package.yaml
+++ b/package.yaml
@@ -43,8 +43,7 @@ library:
   - Language.GraphQL.Execute.Execution
   - Language.GraphQL.Execute.Transform
   - Language.GraphQL.Type.Definition
-  - Language.GraphQL.Type.Directive
-  - Language.GraphQL.Type.Schema
+  - Language.GraphQL.Type.Internal
 
 tests:
   tasty:
diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs
index 4c37f6a..b36be9c 100644
--- a/src/Language/GraphQL/Error.hs
+++ b/src/Language/GraphQL/Error.hs
@@ -79,8 +79,8 @@ singleError :: Serialize a => Text -> Response a
 singleError message = Response null $ Seq.singleton $ makeErrorMessage message
 
 -- | Convenience function for just wrapping an error message.
-addErrMsg :: Monad m => Text -> CollectErrsT m ()
-addErrMsg = addErr . makeErrorMessage
+addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
+addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null
 
 -- | @GraphQL@ error.
 data Error = Error
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index 2b12c43..e9ba4a7 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -25,6 +25,7 @@ import qualified Language.GraphQL.Execute.Transform as Transform
 import qualified Language.GraphQL.Type as Type
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
+import Language.GraphQL.Type.Internal
 import Language.GraphQL.Type.Schema
 import Prelude hiding (null)
 
@@ -108,12 +109,12 @@ executeField fieldDefinition prev fields = do
     let Out.Field _ fieldType argumentDefinitions resolver = fieldDefinition
     let (Transform.Field _ _ arguments' _ :| []) = fields
     case coerceArgumentValues argumentDefinitions arguments' of
-        Nothing -> errmsg "Argument coercing failed."
+        Nothing -> addErrMsg "Argument coercing failed."
         Just argumentValues -> do
             answer <- lift $ resolveFieldValue prev argumentValues resolver
             case answer of
                 Right result -> completeValue fieldType fields result
-                Left errorMessage -> errmsg errorMessage
+                Left errorMessage -> addErrMsg errorMessage
 
 completeValue :: (Monad m, Serialize a)
     => Out.Type m
@@ -136,7 +137,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
     let Type.EnumType _ _ enumMembers = enumType
      in if HashMap.member enum enumMembers
         then coerceResult outputType $ Enum enum
-        else errmsg "Value completion failed."
+        else addErrMsg "Value completion failed."
 completeValue (Out.ObjectBaseType objectType) fields result =
     executeSelectionSet result objectType $ mergeSelectionSets fields
 completeValue (Out.InterfaceBaseType interfaceType) fields result
@@ -146,7 +147,7 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result
         case concreteType of
             Just objectType -> executeSelectionSet result objectType
                 $ mergeSelectionSets fields
-            Nothing -> errmsg "Value completion failed."
+            Nothing -> addErrMsg "Value completion failed."
 completeValue (Out.UnionBaseType unionType) fields result
     | Type.Object objectMap <- result = do
         let abstractType = AbstractUnionType unionType
@@ -154,8 +155,8 @@ completeValue (Out.UnionBaseType unionType) fields result
         case concreteType of
             Just objectType -> executeSelectionSet result objectType
                 $ mergeSelectionSets fields
-            Nothing -> errmsg "Value completion failed."
-completeValue _ _ _ = errmsg "Value completion failed."
+            Nothing -> addErrMsg "Value completion failed."
+completeValue _ _ _ = addErrMsg "Value completion failed."
 
 mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m)
 mergeSelectionSets = foldr forEach mempty
@@ -163,16 +164,13 @@ mergeSelectionSets = foldr forEach mempty
     forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =
         selectionSet <> fieldSelectionSet
 
-errmsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
-errmsg errorMessage = addErrMsg errorMessage >> pure null
-
 coerceResult :: (Monad m, Serialize a)
     => Out.Type m
     -> Output a
     -> CollectErrsT m a
 coerceResult outputType result
     | Just serialized <- serialize outputType result = pure serialized
-    | otherwise = errmsg "Result coercion failed."
+    | otherwise = addErrMsg "Result coercion failed."
 
 -- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
 -- each field to each 'Transform.Selection'. Resolves into a value containing
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 79ee855..30d5130 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -45,10 +45,10 @@ import qualified Data.Text as Text
 import qualified Language.GraphQL.AST as Full
 import Language.GraphQL.AST (Name)
 import qualified Language.GraphQL.Execute.Coerce as Coerce
-import Language.GraphQL.Type.Directive (Directive(..))
-import qualified Language.GraphQL.Type.Directive as Directive
+import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type as Type
 import qualified Language.GraphQL.Type.In as In
+import Language.GraphQL.Type.Internal
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema
 
@@ -285,7 +285,7 @@ selection (Full.Field alias name arguments' directives' selections) =
     maybe (Left mempty) (Right . SelectionField) <$> do
         fieldArguments <- foldM go HashMap.empty arguments'
         fieldSelections <- appendSelection selections
-        fieldDirectives <- Directive.selection <$> directives directives'
+        fieldDirectives <- Definition.selection <$> directives directives'
         let field' = Field alias name fieldArguments fieldSelections
         pure $ field' <$ fieldDirectives
   where
@@ -294,7 +294,7 @@ selection (Full.Field alias name arguments' directives' selections) =
 
 selection (Full.FragmentSpread name directives') =
     maybe (Left mempty) (Right . SelectionFragment) <$> do
-        spreadDirectives <- Directive.selection <$> directives directives'
+        spreadDirectives <- Definition.selection <$> directives directives'
         fragments' <- gets fragments
 
         fragmentDefinitions' <- gets fragmentDefinitions
@@ -308,7 +308,7 @@ selection (Full.FragmentSpread name directives') =
                         _ -> lift $ pure  Nothing
                 | otherwise -> lift $ pure  Nothing
 selection (Full.InlineFragment type' directives' selections) = do
-    fragmentDirectives <- Directive.selection <$> directives directives'
+    fragmentDirectives <- Definition.selection <$> directives directives'
     case fragmentDirectives of
         Nothing -> pure $ Left mempty
         _ -> do
@@ -336,11 +336,11 @@ appendSelection = foldM go mempty
     append acc (Left list) = list >< acc
     append acc (Right one) = one <| acc
 
-directives :: [Full.Directive] ->  State (Replacement m) [Directive]
+directives :: [Full.Directive] ->  State (Replacement m) [Definition.Directive]
 directives = traverse directive
   where
     directive (Full.Directive directiveName directiveArguments)
-        = Directive directiveName . Type.Arguments
+        = Definition.Directive directiveName . Type.Arguments
         <$> foldM go HashMap.empty directiveArguments
     go arguments (Full.Argument name value') = do
         substitutedValue <- value value'
diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs
index 40055e7..476fb3a 100644
--- a/src/Language/GraphQL/Type/Definition.hs
+++ b/src/Language/GraphQL/Type/Definition.hs
@@ -3,6 +3,7 @@
 -- | Types that can be used as both input and output types.
 module Language.GraphQL.Type.Definition
     ( Arguments(..)
+    , Directive(..)
     , EnumType(..)
     , EnumValue(..)
     , ScalarType(..)
@@ -12,14 +13,16 @@ module Language.GraphQL.Type.Definition
     , float
     , id
     , int
+    , selection
     , string
     ) where
 
 import Data.Int (Int32)
 import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import Data.String (IsString(..))
 import Data.Text (Text)
-import Language.GraphQL.AST.Document (Name)
+import Language.GraphQL.AST (Name)
 import Prelude hiding (id)
 
 -- | Represents accordingly typed GraphQL values.
@@ -124,3 +127,49 @@ id = ScalarType "ID" (Just description)
         \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."
+
+-- | Directive.
+data Directive = Directive Name Arguments
+    deriving (Eq, Show)
+
+-- | Directive processing status.
+data Status
+    = Skip -- ^ Skip the selection and stop directive processing
+    | Include Directive -- ^ The directive was processed, try other handlers
+    | Continue Directive -- ^ Directive handler mismatch, try other handlers
+
+-- | Takes a list of directives, handles supported directives and excludes them
+--   from the result. If the selection should be skipped, returns 'Nothing'.
+selection :: [Directive] -> Maybe [Directive]
+selection = foldr go (Just [])
+  where
+    go directive' directives' =
+        case (skip . include) (Continue directive') of
+            (Include _) -> directives'
+            Skip -> Nothing
+            (Continue x) -> (x :) <$> directives'
+
+handle :: (Directive -> Status) -> Status -> Status
+handle _ Skip = Skip
+handle handler (Continue directive) = handler directive
+handle handler (Include directive) = handler directive
+
+-- * Directive implementations
+
+skip :: Status -> Status
+skip = handle skip'
+  where
+    skip' directive'@(Directive "skip" (Arguments arguments)) =
+        case HashMap.lookup "if" arguments of
+            (Just (Boolean True)) -> Skip
+            _ -> Include directive'
+    skip' directive' = Continue directive'
+
+include :: Status -> Status
+include = handle include'
+  where
+    include' directive'@(Directive "include" (Arguments arguments)) =
+        case HashMap.lookup "if" arguments of
+            (Just (Boolean True)) -> Include directive'
+            _ -> Skip
+    include' directive' = Continue directive'
diff --git a/src/Language/GraphQL/Type/Directive.hs b/src/Language/GraphQL/Type/Directive.hs
deleted file mode 100644
index 6ff73d4..0000000
--- a/src/Language/GraphQL/Type/Directive.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Language.GraphQL.Type.Directive
-    ( Directive(..)
-    , selection
-    ) where
-
-import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.AST (Name)
-import Language.GraphQL.Type.Definition
-
--- | Directive.
-data Directive = Directive Name Arguments
-    deriving (Eq, Show)
-
--- | Directive processing status.
-data Status
-    = Skip -- ^ Skip the selection and stop directive processing
-    | Include Directive -- ^ The directive was processed, try other handlers
-    | Continue Directive -- ^ Directive handler mismatch, try other handlers
-
--- | Takes a list of directives, handles supported directives and excludes them
---   from the result. If the selection should be skipped, returns 'Nothing'.
-selection :: [Directive] -> Maybe [Directive]
-selection = foldr go (Just [])
-  where
-    go directive' directives' =
-        case (skip . include) (Continue directive') of
-            (Include _) -> directives'
-            Skip -> Nothing
-            (Continue x) -> (x :) <$> directives'
-
-handle :: (Directive -> Status) -> Status -> Status
-handle _ Skip = Skip
-handle handler (Continue directive) = handler directive
-handle handler (Include directive) = handler directive
-
--- * Directive implementations
-
-skip :: Status -> Status
-skip = handle skip'
-  where
-    skip' directive'@(Directive "skip" (Arguments arguments)) =
-        case HashMap.lookup "if" arguments of
-            (Just (Boolean True)) -> Skip
-            _ -> Include directive'
-    skip' directive' = Continue directive'
-
-include :: Status -> Status
-include = handle include'
-  where
-    include' directive'@(Directive "include" (Arguments arguments)) =
-        case HashMap.lookup "if" arguments of
-            (Just (Boolean True)) -> Include directive'
-            _ -> Skip
-    include' directive' = Continue directive'
diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs
new file mode 100644
index 0000000..07dabe6
--- /dev/null
+++ b/src/Language/GraphQL/Type/Internal.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE ExplicitForAll #-}
+
+module Language.GraphQL.Type.Internal
+    ( AbstractType(..)
+    , CompositeType(..)
+    , collectReferencedTypes
+    ) where
+
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Language.GraphQL.AST (Name)
+import qualified Language.GraphQL.Type.Definition as Definition
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
+import Language.GraphQL.Type.Schema
+
+-- | These types may describe the parent context of a selection set.
+data CompositeType m
+    = CompositeUnionType (Out.UnionType m)
+    | CompositeObjectType (Out.ObjectType m)
+    | CompositeInterfaceType (Out.InterfaceType m)
+    deriving Eq
+
+-- | These types may describe the parent context of a selection set.
+data AbstractType m
+    = AbstractUnionType (Out.UnionType m)
+    | AbstractInterfaceType (Out.InterfaceType m)
+    deriving Eq
+
+-- | Traverses the schema and finds all referenced types.
+collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)
+collectReferencedTypes schema =
+    let queryTypes = traverseObjectType (query schema) HashMap.empty
+     in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema
+  where
+    collect traverser typeName element foundTypes
+        | HashMap.member typeName foundTypes = foundTypes
+        | otherwise = traverser $ HashMap.insert typeName element foundTypes
+    visitFields (Out.Field _ outputType arguments _) foundTypes
+        = traverseOutputType outputType
+        $ foldr visitArguments foundTypes arguments
+    visitArguments (In.Argument _ inputType _) = traverseInputType inputType
+    visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
+    traverseInputType (In.InputObjectBaseType objectType) =
+        let (In.InputObjectType typeName _ inputFields) = objectType
+            element = InputObjectType objectType
+            traverser = flip (foldr visitInputFields) inputFields
+         in collect traverser typeName element
+    traverseInputType (In.ListBaseType listType) =
+        traverseInputType listType
+    traverseInputType (In.ScalarBaseType scalarType) =
+        let (Definition.ScalarType typeName _) = scalarType
+         in collect Prelude.id typeName (ScalarType scalarType)
+    traverseInputType (In.EnumBaseType enumType) =
+        let (Definition.EnumType typeName _ _) = enumType
+         in collect Prelude.id typeName (EnumType enumType)
+    traverseOutputType (Out.ObjectBaseType objectType) =
+        traverseObjectType objectType
+    traverseOutputType (Out.InterfaceBaseType interfaceType) =
+        traverseInterfaceType interfaceType
+    traverseOutputType (Out.UnionBaseType unionType) =
+        let (Out.UnionType typeName _ types) = unionType
+            traverser = flip (foldr traverseObjectType) types
+         in collect traverser typeName (UnionType unionType)
+    traverseOutputType (Out.ListBaseType listType) =
+        traverseOutputType listType
+    traverseOutputType (Out.ScalarBaseType scalarType) =
+        let (Definition.ScalarType typeName _) = scalarType
+         in collect Prelude.id typeName (ScalarType scalarType)
+    traverseOutputType (Out.EnumBaseType enumType) =
+        let (Definition.EnumType typeName _ _) = enumType
+         in collect Prelude.id typeName (EnumType enumType)
+    traverseObjectType objectType foundTypes =
+        let (Out.ObjectType typeName _ interfaces fields) = objectType
+            element = ObjectType objectType
+            traverser = polymorphicTraverser interfaces fields
+         in collect traverser typeName element foundTypes
+    traverseInterfaceType interfaceType foundTypes =
+        let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
+            element = InterfaceType interfaceType
+            traverser = polymorphicTraverser interfaces fields
+         in collect traverser typeName element foundTypes
+    polymorphicTraverser interfaces fields
+        = flip (foldr visitFields) fields
+        . flip (foldr traverseInterfaceType) interfaces
diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs
index 4420cbb..8cf0383 100644
--- a/src/Language/GraphQL/Type/Schema.hs
+++ b/src/Language/GraphQL/Type/Schema.hs
@@ -1,18 +1,10 @@
-{-# LANGUAGE ExplicitForAll #-}
-
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
 -- functions for defining and manipulating schemas.
 module Language.GraphQL.Type.Schema
-    ( AbstractType(..)
-    , CompositeType(..)
-    , Schema(..)
+    ( Schema(..)
     , Type(..)
-    , collectReferencedTypes
     ) where
 
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.AST.Document (Name)
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
@@ -27,19 +19,6 @@ data Type m
     | UnionType (Out.UnionType m)
     deriving Eq
 
--- | These types may describe the parent context of a selection set.
-data CompositeType m
-    = CompositeUnionType (Out.UnionType m)
-    | CompositeObjectType (Out.ObjectType m)
-    | CompositeInterfaceType (Out.InterfaceType m)
-    deriving Eq
-
--- | These types may describe the parent context of a selection set.
-data AbstractType m
-    = AbstractUnionType (Out.UnionType m)
-    | AbstractInterfaceType (Out.InterfaceType m)
-    deriving Eq
-
 -- | 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.
@@ -51,60 +30,3 @@ data Schema m = Schema
     { query :: Out.ObjectType m
     , mutation :: Maybe (Out.ObjectType m)
     }
-
--- | Traverses the schema and finds all referenced types.
-collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)
-collectReferencedTypes schema =
-    let queryTypes = traverseObjectType (query schema) HashMap.empty
-     in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema
-  where
-    collect traverser typeName element foundTypes
-        | HashMap.member typeName foundTypes = foundTypes
-        | otherwise = traverser $ HashMap.insert typeName element foundTypes
-    visitFields (Out.Field _ outputType arguments _) foundTypes
-        = traverseOutputType outputType
-        $ foldr visitArguments foundTypes arguments
-    visitArguments (In.Argument _ inputType _) = traverseInputType inputType
-    visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
-    traverseInputType (In.InputObjectBaseType objectType) =
-        let (In.InputObjectType typeName _ inputFields) = objectType
-            element = InputObjectType objectType
-            traverser = flip (foldr visitInputFields) inputFields
-         in collect traverser typeName element
-    traverseInputType (In.ListBaseType listType) =
-        traverseInputType listType
-    traverseInputType (In.ScalarBaseType scalarType) =
-        let (Definition.ScalarType typeName _) = scalarType
-         in collect Prelude.id typeName (ScalarType scalarType)
-    traverseInputType (In.EnumBaseType enumType) =
-        let (Definition.EnumType typeName _ _) = enumType
-         in collect Prelude.id typeName (EnumType enumType)
-    traverseOutputType (Out.ObjectBaseType objectType) =
-        traverseObjectType objectType
-    traverseOutputType (Out.InterfaceBaseType interfaceType) =
-        traverseInterfaceType interfaceType
-    traverseOutputType (Out.UnionBaseType unionType) =
-        let (Out.UnionType typeName _ types) = unionType
-            traverser = flip (foldr traverseObjectType) types
-         in collect traverser typeName (UnionType unionType)
-    traverseOutputType (Out.ListBaseType listType) =
-        traverseOutputType listType
-    traverseOutputType (Out.ScalarBaseType scalarType) =
-        let (Definition.ScalarType typeName _) = scalarType
-         in collect Prelude.id typeName (ScalarType scalarType)
-    traverseOutputType (Out.EnumBaseType enumType) =
-        let (Definition.EnumType typeName _ _) = enumType
-         in collect Prelude.id typeName (EnumType enumType)
-    traverseObjectType objectType foundTypes =
-        let (Out.ObjectType typeName _ interfaces fields) = objectType
-            element = ObjectType objectType
-            traverser = polymorphicTraverser interfaces fields
-         in collect traverser typeName element foundTypes
-    traverseInterfaceType interfaceType foundTypes =
-        let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
-            element = InterfaceType interfaceType
-            traverser = polymorphicTraverser interfaces fields
-         in collect traverser typeName element foundTypes
-    polymorphicTraverser interfaces fields
-        = flip (foldr visitFields) fields
-        . flip (foldr traverseInterfaceType) interfaces
diff --git a/stack.yaml b/stack.yaml
index 6e55f3d..65e78cc 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: lts-16.3
+resolver: lts-16.4
 
 packages:
 - .