diff options
Diffstat (limited to 'src/Language/GraphQL/Schema.hs')
| -rw-r--r-- | src/Language/GraphQL/Schema.hs | 105 |
1 files changed, 0 insertions, 105 deletions
diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs deleted file mode 100644 index 734f070..0000000 --- a/src/Language/GraphQL/Schema.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE OverloadedStrings #-} - --- | This module provides a representation of a @GraphQL@ Schema in addition to --- functions for defining and manipulating schemas. -module Language.GraphQL.Schema - ( Resolver(..) - , resolve - ) where - -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (runExceptT) -import Control.Monad.Trans.Reader (runReaderT) -import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map.Strict as Map -import Data.Sequence (Seq(..)) -import Data.Text (Text) -import qualified Data.Text as Text -import Language.GraphQL.AST.Document (Name) -import Language.GraphQL.Error -import Language.GraphQL.Execute.Execution -import Language.GraphQL.Execute.Transform -import Language.GraphQL.Trans -import Language.GraphQL.Type.Definition -import qualified Language.GraphQL.Type.Out as Out - --- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error --- information (if an error has occurred). @m@ is an arbitrary monad, usually --- 'IO'. --- --- 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 Resolver m = Resolver Name (ActionT m Value) - -resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a) -resolveFieldValue result (Field _ _ args _) = - flip runReaderT (Context {arguments=args, values=result}) - . runExceptT - . runActionT - -executeField :: Monad m - => Value - -> Out.Field m - -> Field m - -> CollectErrsT m Aeson.Value -executeField prev (Out.Field _ fieldType _ resolver) field = do - answer <- lift $ resolveFieldValue prev field resolver - case answer of - Right result -> completeValue fieldType field result - Left errorMessage -> errmsg errorMessage - -completeValue :: Monad m - => Out.Type m - -> Field m - -> Value - -> CollectErrsT m Aeson.Value -completeValue _ _ Null = pure Aeson.Null -completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer -completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean' -completeValue _ _ (Float float') = pure $ Aeson.toJSON float' -completeValue _ _ (Enum enum) = pure $ Aeson.String enum -completeValue _ _ (String string') = pure $ Aeson.String string' -completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result = - resolve result objectType seqSelection -completeValue (Out.ListBaseType listType) selectionField (List list) = - Aeson.toJSON <$> traverse (completeValue listType selectionField) list -completeValue _ _ _ = errmsg "Value completion failed." - -errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value -errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null - --- | Takes a list of 'Resolver's and a list of 'Field's and applies each --- 'Resolver' to each 'Field'. Resolves into a value containing the --- resolved 'Field', or a null value and error information. -resolve :: Monad m -- executeSelectionSet - => Value - -> Out.ObjectType m - -> Seq (Selection m) - -> CollectErrsT m Aeson.Value -resolve result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do - resolvedValues <- Map.traverseMaybeWithKey forEach - $ collectFields objectType selectionSet - pure $ Aeson.toJSON resolvedValues - where - forEach _responseKey (field :<| _) = - tryResolvers field >>= lift . pure . pure - forEach _ _ = pure Nothing - lookupResolver = flip HashMap.lookup resolvers - tryResolvers fld@(Field _ name _ _) - | Just typeField <- lookupResolver name = - executeField result typeField fld - | otherwise = errmsg $ Text.unwords ["field", name, "not resolved."] - {-tryResolvers (Out.SelectionFragment (Out.Fragment typeCondition selections')) - | Just (Out.Field _ _ _ resolver) <- lookupResolver "__typename" = do - let fakeField = Out.Field Nothing "__typename" mempty mempty - that <- lift $ resolveFieldValue result fakeField resolver - case that of - Right (String typeCondition') - | (Out.CompositeObjectType (Out.ObjectType n _ _ _)) <- typeCondition - , typeCondition' == n -> - fmap fold . traverse tryResolvers $ selections' - _ -> pure mempty - | otherwise = fmap fold . traverse tryResolvers $ selections'-} |