diff options
| author | Eugen Wissner <belka@caraus.de> | 2019-07-07 06:31:53 +0200 |
|---|---|---|
| committer | Eugen Wissner <belka@caraus.de> | 2019-07-07 06:31:53 +0200 |
| commit | 22d4a4e583d8075fc71cddc22566f41fc5a698dc (patch) | |
| tree | 116b444d7b465aadf8a33a22fdd2a6db6994e7c0 /src/Data/GraphQL | |
| parent | 1431db7e634e5447375e1c598f4336f499384730 (diff) | |
| download | graphql-22d4a4e583d8075fc71cddc22566f41fc5a698dc.tar.gz | |
Change the main namespace to Language.GraphQL
Diffstat (limited to 'src/Data/GraphQL')
| -rw-r--r-- | src/Data/GraphQL/AST.hs | 131 | ||||
| -rw-r--r-- | src/Data/GraphQL/AST/Core.hs | 38 | ||||
| -rw-r--r-- | src/Data/GraphQL/AST/Transform.hs | 123 | ||||
| -rw-r--r-- | src/Data/GraphQL/Encoder.hs | 179 | ||||
| -rw-r--r-- | src/Data/GraphQL/Error.hs | 57 | ||||
| -rw-r--r-- | src/Data/GraphQL/Execute.hs | 38 | ||||
| -rw-r--r-- | src/Data/GraphQL/Parser.hs | 183 | ||||
| -rw-r--r-- | src/Data/GraphQL/Schema.hs | 172 |
8 files changed, 0 insertions, 921 deletions
diff --git a/src/Data/GraphQL/AST.hs b/src/Data/GraphQL/AST.hs deleted file mode 100644 index 3378655..0000000 --- a/src/Data/GraphQL/AST.hs +++ /dev/null @@ -1,131 +0,0 @@ --- | This module defines an abstract syntax tree for the @GraphQL@ language based on --- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>. --- --- Target AST for Parser. - -module Data.GraphQL.AST where - -import Data.Int (Int32) -import Data.List.NonEmpty (NonEmpty) -import Data.Text (Text) - --- * Name - -type Name = Text - --- * Document - -type Document = NonEmpty Definition - --- * Operations - -data Definition = DefinitionOperation OperationDefinition - | DefinitionFragment FragmentDefinition - deriving (Eq,Show) - -data OperationDefinition = OperationSelectionSet SelectionSet - | OperationDefinition OperationType - (Maybe Name) - VariableDefinitions - Directives - SelectionSet - deriving (Eq,Show) - -data OperationType = Query | Mutation deriving (Eq,Show) - --- * SelectionSet - -type SelectionSet = NonEmpty Selection - -type SelectionSetOpt = [Selection] - -data Selection = SelectionField Field - | SelectionFragmentSpread FragmentSpread - | SelectionInlineFragment InlineFragment - deriving (Eq,Show) - --- * Field - -data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt - deriving (Eq,Show) - -type Alias = Name - --- * Arguments - -type Arguments = [Argument] - -data Argument = Argument Name Value deriving (Eq,Show) - --- * Fragments - -data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show) - -data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet - deriving (Eq,Show) - -data FragmentDefinition = - FragmentDefinition FragmentName TypeCondition Directives SelectionSet - deriving (Eq,Show) - -type FragmentName = Name - -type TypeCondition = Name - --- Input Values - -data Value = ValueVariable Variable - | ValueInt IntValue - | ValueFloat FloatValue - | ValueString StringValue - | ValueBoolean BooleanValue - | ValueNull - | ValueEnum EnumValue - | ValueList ListValue - | ValueObject ObjectValue - deriving (Eq,Show) - -type IntValue = Int32 - --- GraphQL Float is double precison -type FloatValue = Double - -type StringValue = Text - -type BooleanValue = Bool - -type EnumValue = Name - -type ListValue = [Value] - -type ObjectValue = [ObjectField] - -data ObjectField = ObjectField Name Value deriving (Eq,Show) - --- * Variables - -type VariableDefinitions = [VariableDefinition] - -data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue) - deriving (Eq,Show) - -type Variable = Name - -type DefaultValue = Value - --- * Input Types - -data Type = TypeNamed Name - | TypeList Type - | TypeNonNull NonNullType - deriving (Eq,Show) - -data NonNullType = NonNullTypeNamed Name - | NonNullTypeList Type - deriving (Eq,Show) - --- * Directives - -type Directives = [Directive] - -data Directive = Directive Name [Argument] deriving (Eq,Show) diff --git a/src/Data/GraphQL/AST/Core.hs b/src/Data/GraphQL/AST/Core.hs deleted file mode 100644 index f0c617c..0000000 --- a/src/Data/GraphQL/AST/Core.hs +++ /dev/null @@ -1,38 +0,0 @@ --- | This is the AST meant to be executed. -module Data.GraphQL.AST.Core where - -import Data.Int (Int32) -import Data.List.NonEmpty (NonEmpty) -import Data.String - -import Data.Text (Text) - -type Name = Text - -type Document = NonEmpty Operation - -data Operation = Query (NonEmpty Field) - | Mutation (NonEmpty Field) - deriving (Eq,Show) - -data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show) - -type Alias = Name - -data Argument = Argument Name Value deriving (Eq,Show) - -data Value = ValueInt Int32 - -- GraphQL Float is double precision - | ValueFloat Double - | ValueString Text - | ValueBoolean Bool - | ValueNull - | ValueEnum Name - | ValueList [Value] - | ValueObject [ObjectField] - deriving (Eq,Show) - -instance IsString Value where - fromString = ValueString . fromString - -data ObjectField = ObjectField Name Value deriving (Eq,Show) diff --git a/src/Data/GraphQL/AST/Transform.hs b/src/Data/GraphQL/AST/Transform.hs deleted file mode 100644 index af55772..0000000 --- a/src/Data/GraphQL/AST/Transform.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Data.GraphQL.AST.Transform where - -import Control.Applicative (empty) -import Control.Monad ((<=<)) -import Data.Bifunctor (first) -import Data.Either (partitionEithers) -import Data.Foldable (fold, foldMap) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Monoid (Alt(Alt,getAlt), (<>)) - -import Data.Text (Text) - -import qualified Data.GraphQL.AST as Full -import qualified Data.GraphQL.AST.Core as Core -import qualified Data.GraphQL.Schema as Schema - -type Name = Text - --- | Replaces a fragment name by a list of 'Field'. If the name doesn't match an --- empty list is returned. -type Fragmenter = Name -> [Core.Field] - --- TODO: Replace Maybe by MonadThrow with CustomError -document :: Schema.Subs -> Full.Document -> Maybe Core.Document -document subs doc = operations subs fr ops - where - (fr, ops) = first foldFrags - . partitionEithers - . NonEmpty.toList - $ defrag subs - <$> doc - - foldFrags :: [Fragmenter] -> Fragmenter - foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs - --- * Operation - --- TODO: Replace Maybe by MonadThrow CustomError -operations - :: Schema.Subs - -> Fragmenter - -> [Full.OperationDefinition] - -> Maybe Core.Document -operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr) - --- TODO: Replace Maybe by MonadThrow CustomError -operation - :: Schema.Subs - -> Fragmenter - -> Full.OperationDefinition - -> Maybe Core.Operation -operation subs fr (Full.OperationSelectionSet sels) = - operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels --- TODO: Validate Variable definitions with substituter -operation subs fr (Full.OperationDefinition ot _n _vars _dirs sels) = - case ot of - Full.Query -> Core.Query <$> node - Full.Mutation -> Core.Mutation <$> node - where - node = traverse (hush . selection subs fr) sels - -selection - :: Schema.Subs - -> Fragmenter - -> Full.Selection - -> Either [Core.Field] Core.Field -selection subs fr (Full.SelectionField fld) = - Right $ field subs fr fld -selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) = - Left $ fr n -selection _ _ (Full.SelectionInlineFragment _) = - error "Inline fragments not supported yet" - --- * Fragment replacement - --- | Extract Fragments into a single Fragmenter function and a Operation --- Definition. -defrag - :: Schema.Subs - -> Full.Definition - -> Either Fragmenter Full.OperationDefinition -defrag _ (Full.DefinitionOperation op) = - Right op -defrag subs (Full.DefinitionFragment fragDef) = - Left $ fragmentDefinition subs fragDef - -fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter -fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name' = - -- TODO: Support fragments within fragments. Fold instead of map. - if name == name' - then either id pure =<< NonEmpty.toList (selection subs mempty <$> sels) - else empty - -field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field -field subs fr (Full.Field a n args _dirs sels) = - Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels) - where - go :: Full.Selection -> [Core.Field] -> [Core.Field] - go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = (fr name <>) - go sel = (either id pure (selection subs fr sel) <>) - -argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument -argument subs (Full.Argument n v) = Core.Argument n <$> value subs v - -value :: Schema.Subs -> Full.Value -> Maybe Core.Value -value subs (Full.ValueVariable n) = subs n -value _ (Full.ValueInt i) = pure $ Core.ValueInt i -value _ (Full.ValueFloat f) = pure $ Core.ValueFloat f -value _ (Full.ValueString x) = pure $ Core.ValueString x -value _ (Full.ValueBoolean b) = pure $ Core.ValueBoolean b -value _ Full.ValueNull = pure Core.ValueNull -value _ (Full.ValueEnum e) = pure $ Core.ValueEnum e -value subs (Full.ValueList l) = - Core.ValueList <$> traverse (value subs) l -value subs (Full.ValueObject o) = - Core.ValueObject <$> traverse (objectField subs) o - -objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField -objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v - -hush :: Either a b -> Maybe b -hush = either (const Nothing) Just diff --git a/src/Data/GraphQL/Encoder.hs b/src/Data/GraphQL/Encoder.hs deleted file mode 100644 index 924bdea..0000000 --- a/src/Data/GraphQL/Encoder.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | This module defines a printer for the @GraphQL@ language. -module Data.GraphQL.Encoder where - -import Data.Foldable (fold) -import Data.Monoid ((<>)) -import qualified Data.List.NonEmpty as NonEmpty (toList) - -import Data.Text (Text, cons, intercalate, pack, snoc) - -import Data.GraphQL.AST - --- * Document - -document :: Document -> Text -document defs = (`snoc` '\n') . mconcat . NonEmpty.toList $ definition <$> defs - -definition :: Definition -> Text -definition (DefinitionOperation x) = operationDefinition x -definition (DefinitionFragment x) = fragmentDefinition x - -operationDefinition :: OperationDefinition -> Text -operationDefinition (OperationSelectionSet sels) = selectionSet sels -operationDefinition (OperationDefinition Query name vars dirs sels) = - "query " <> node (fold name) vars dirs sels -operationDefinition (OperationDefinition Mutation name vars dirs sels) = - "mutation " <> node (fold name) vars dirs sels - -node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text -node name vars dirs sels = - name - <> optempty variableDefinitions vars - <> optempty directives dirs - <> selectionSet sels - -variableDefinitions :: [VariableDefinition] -> Text -variableDefinitions = parensCommas variableDefinition - -variableDefinition :: VariableDefinition -> Text -variableDefinition (VariableDefinition var ty dv) = - variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv - -defaultValue :: DefaultValue -> Text -defaultValue val = "=" <> value val - -variable :: Variable -> Text -variable var = "$" <> var - -selectionSet :: SelectionSet -> Text -selectionSet = bracesCommas selection . NonEmpty.toList - -selectionSetOpt :: SelectionSetOpt -> Text -selectionSetOpt = bracesCommas selection - -selection :: Selection -> Text -selection (SelectionField x) = field x -selection (SelectionInlineFragment x) = inlineFragment x -selection (SelectionFragmentSpread x) = fragmentSpread x - -field :: Field -> Text -field (Field alias name args dirs selso) = - optempty (`snoc` ':') (fold alias) - <> name - <> optempty arguments args - <> optempty directives dirs - <> optempty selectionSetOpt selso - -arguments :: [Argument] -> Text -arguments = parensCommas argument - -argument :: Argument -> Text -argument (Argument name v) = name <> ":" <> value v - --- * Fragments - -fragmentSpread :: FragmentSpread -> Text -fragmentSpread (FragmentSpread name ds) = - "..." <> name <> optempty directives ds - -inlineFragment :: InlineFragment -> Text -inlineFragment (InlineFragment tc dirs sels) = - "... on " <> fold tc - <> directives dirs - <> selectionSet sels - -fragmentDefinition :: FragmentDefinition -> Text -fragmentDefinition (FragmentDefinition name tc dirs sels) = - "fragment " <> name <> " on " <> tc - <> optempty directives dirs - <> selectionSet sels - --- * Values - -value :: Value -> Text -value (ValueVariable x) = variable x --- TODO: This will be replaced with `decimal` Builder -value (ValueInt x) = pack $ show x --- TODO: This will be replaced with `decimal` Builder -value (ValueFloat x) = pack $ show x -value (ValueBoolean x) = booleanValue x -value ValueNull = mempty -value (ValueString x) = stringValue x -value (ValueEnum x) = x -value (ValueList x) = listValue x -value (ValueObject x) = objectValue x - -booleanValue :: Bool -> Text -booleanValue True = "true" -booleanValue False = "false" - --- TODO: Escape characters -stringValue :: Text -> Text -stringValue = quotes - -listValue :: ListValue -> Text -listValue = bracketsCommas value - -objectValue :: ObjectValue -> Text -objectValue = bracesCommas objectField - -objectField :: ObjectField -> Text -objectField (ObjectField name v) = name <> ":" <> value v - --- * Directives - -directives :: [Directive] -> Text -directives = spaces directive - -directive :: Directive -> Text -directive (Directive name args) = "@" <> name <> optempty arguments args - --- * Type Reference - -type_ :: Type -> Text -type_ (TypeNamed x) = x -type_ (TypeList x) = listType x -type_ (TypeNonNull x) = nonNullType x - -listType :: Type -> Text -listType x = brackets (type_ x) - -nonNullType :: NonNullType -> Text -nonNullType (NonNullTypeNamed x) = x <> "!" -nonNullType (NonNullTypeList x) = listType x <> "!" - --- * 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 '{' '}' - -quotes :: Text -> Text -quotes = 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 diff --git a/src/Data/GraphQL/Error.hs b/src/Data/GraphQL/Error.hs deleted file mode 100644 index 08d1622..0000000 --- a/src/Data/GraphQL/Error.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Data.GraphQL.Error - ( parseError - , CollectErrsT - , addErr - , addErrMsg - , runCollectErrs - , runAppendErrs - ) where - -import qualified Data.Aeson as Aeson -import Data.Text (Text, pack) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State ( StateT - , modify - , runStateT - ) - --- | Wraps a parse error into a list of errors. -parseError :: Applicative f => String -> f Aeson.Value -parseError s = - pure $ Aeson.object [("errors", Aeson.toJSON [makeErrorMsg $ pack s])] - --- | A wrapper to pass error messages around. -type CollectErrsT m = StateT [Aeson.Value] m - --- | Adds an error to the list of errors. -addErr :: Monad m => Aeson.Value -> CollectErrsT m () -addErr v = modify (v :) - -makeErrorMsg :: Text -> Aeson.Value -makeErrorMsg s = Aeson.object [("message", Aeson.toJSON s)] - --- | Convenience function for just wrapping an error message. -addErrMsg :: Monad m => Text -> CollectErrsT m () -addErrMsg = addErr . makeErrorMsg - --- | Appends the given list of errors to the current list of errors. -appendErrs :: Monad m => [Aeson.Value] -> CollectErrsT m () -appendErrs errs = modify (errs ++) - --- | Runs the given query computation, but collects the errors into an error --- list, which is then sent back with the data. -runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value -runCollectErrs res = do - (dat, errs) <- runStateT res [] - if null errs - then return $ Aeson.object [("data", dat)] - else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)] - --- | Runs the given computation, collecting the errors and appending them --- to the previous list of errors. -runAppendErrs :: Monad m => CollectErrsT m a -> CollectErrsT m a -runAppendErrs f = do - (v, errs) <- lift $ runStateT f [] - appendErrs errs - return v diff --git a/src/Data/GraphQL/Execute.hs b/src/Data/GraphQL/Execute.hs deleted file mode 100644 index e6bb1c9..0000000 --- a/src/Data/GraphQL/Execute.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | This module provides the function to execute a @GraphQL@ request -- --- according to a 'Schema'. -module Data.GraphQL.Execute (execute) where - -import Control.Monad (MonadPlus(..)) -import Data.GraphQL.Error -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty (NonEmpty((:|))) -import qualified Data.Aeson as Aeson -import qualified Data.GraphQL.AST as AST -import qualified Data.GraphQL.AST.Core as AST.Core -import qualified Data.GraphQL.AST.Transform as Transform -import Data.GraphQL.Schema (Schema) -import qualified Data.GraphQL.Schema as Schema - --- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a --- @GraphQL@ 'document'. The substitution is applied to the document using --- 'rootFields', and the 'Schema''s resolvers are applied to the resulting fields. --- --- Returns the result of the query against the 'Schema' wrapped in a /data/ field, or --- errors wrapped in an /errors/ field. -execute - :: (MonadPlus m) - => Schema m -> Schema.Subs -> AST.Document -> m Aeson.Value -execute schema subs doc = do - coreDocument <- maybe mzero pure (Transform.document subs doc) - document schema coreDocument - -document :: MonadPlus m => Schema m -> AST.Core.Document -> m Aeson.Value -document schema (op :| []) = operation schema op -document _ _ = error "Multiple operations not supported yet" - -operation :: MonadPlus m => Schema m -> AST.Core.Operation -> m Aeson.Value -operation schema (AST.Core.Query flds) - = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds)) -operation schema (AST.Core.Mutation flds) - = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds)) diff --git a/src/Data/GraphQL/Parser.hs b/src/Data/GraphQL/Parser.hs deleted file mode 100644 index fc04595..0000000 --- a/src/Data/GraphQL/Parser.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -module Data.GraphQL.Parser where - -import Control.Applicative ( Alternative(..) - , optional - ) -import Data.GraphQL.AST -import Language.GraphQL.Lexer -import Data.List.NonEmpty (NonEmpty(..)) -import Text.Megaparsec ( lookAhead - , option - , try - , (<?>) - ) - -document :: Parser Document -document = spaceConsumer >> lexeme (manyNE definition) - -definition :: Parser Definition -definition = DefinitionOperation <$> operationDefinition - <|> DefinitionFragment <$> fragmentDefinition - <?> "definition error!" - -operationDefinition :: Parser OperationDefinition -operationDefinition = OperationSelectionSet <$> selectionSet - <|> OperationDefinition <$> operationType - <*> optional name - <*> opt variableDefinitions - <*> opt directives - <*> selectionSet - <?> "operationDefinition error" - -operationType :: Parser OperationType -operationType = Query <$ symbol "query" - <|> Mutation <$ symbol "mutation" - <?> "operationType error" - --- * SelectionSet - -selectionSet :: Parser SelectionSet -selectionSet = braces $ manyNE selection - -selectionSetOpt :: Parser SelectionSetOpt -selectionSetOpt = braces $ some selection - -selection :: Parser Selection -selection = SelectionField <$> field - <|> try (SelectionFragmentSpread <$> fragmentSpread) - <|> SelectionInlineFragment <$> inlineFragment - <?> "selection error!" - --- * Field - -field :: Parser Field -field = Field <$> optional alias - <*> name - <*> opt arguments - <*> opt directives - <*> opt selectionSetOpt - -alias :: Parser Alias -alias = try $ name <* colon - --- * Arguments - -arguments :: Parser Arguments -arguments = parens $ some argument - -argument :: Parser Argument -argument = Argument <$> name <* colon <*> value - --- * Fragments - -fragmentSpread :: Parser FragmentSpread -fragmentSpread = FragmentSpread <$ spread - <*> fragmentName - <*> opt directives - -inlineFragment :: Parser InlineFragment -inlineFragment = InlineFragment <$ spread - <*> optional typeCondition - <*> opt directives - <*> selectionSet - -fragmentDefinition :: Parser FragmentDefinition -fragmentDefinition = FragmentDefinition - <$ symbol "fragment" - <*> name - <*> typeCondition - <*> opt directives - <*> selectionSet - -fragmentName :: Parser FragmentName -fragmentName = but (symbol "on") *> name - -typeCondition :: Parser TypeCondition -typeCondition = symbol "on" *> name - --- * Input Values - -value :: Parser Value -value = ValueVariable <$> variable - <|> ValueFloat <$> try float - <|> ValueInt <$> integer - <|> ValueBoolean <$> booleanValue - <|> ValueNull <$ symbol "null" - <|> ValueString <$> string - <|> ValueString <$> blockString - <|> ValueEnum <$> try enumValue - <|> ValueList <$> listValue - <|> ValueObject <$> objectValue - <?> "value error!" - where - booleanValue :: Parser Bool - booleanValue = True <$ symbol "true" - <|> False <$ symbol "false" - - enumValue :: Parser Name - enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name - - listValue :: Parser [Value] - listValue = brackets $ some value - - objectValue :: Parser [ObjectField] - objectValue = braces $ some objectField - -objectField :: Parser ObjectField -objectField = ObjectField <$> name <* symbol ":" <*> value - --- * Variables - -variableDefinitions :: Parser VariableDefinitions -variableDefinitions = parens $ some variableDefinition - -variableDefinition :: Parser VariableDefinition -variableDefinition = VariableDefinition <$> variable - <* colon - <*> type_ - <*> optional defaultValue -variable :: Parser Variable -variable = dollar *> name - -defaultValue :: Parser DefaultValue -defaultValue = equals *> value - --- * Input Types - -type_ :: Parser Type -type_ = try (TypeNamed <$> name <* but "!") - <|> TypeList <$> brackets type_ - <|> TypeNonNull <$> nonNullType - <?> "type_ error!" - -nonNullType :: Parser NonNullType -nonNullType = NonNullTypeNamed <$> name <* bang - <|> NonNullTypeList <$> brackets type_ <* bang - <?> "nonNullType error!" - --- * Directives - -directives :: Parser Directives -directives = some directive - -directive :: Parser Directive -directive = Directive - <$ at - <*> name - <*> opt arguments - --- * Internal - -opt :: Monoid a => Parser a -> Parser a -opt = option mempty - --- Hack to reverse parser success -but :: Parser a -> Parser () -but pn = False <$ lookAhead pn <|> pure True >>= \case - False -> empty - True -> pure () - -manyNE :: Alternative f => f a -> f (NonEmpty a) -manyNE p = (:|) <$> p <*> many p diff --git a/src/Data/GraphQL/Schema.hs b/src/Data/GraphQL/Schema.hs deleted file mode 100644 index 56a9061..0000000 --- a/src/Data/GraphQL/Schema.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | This module provides a representation of a @GraphQL@ Schema in addition to --- functions for defining and manipulating Schemas. -module Data.GraphQL.Schema - ( Resolver - , Schema - , Subs - , object - , objectA - , scalar - , scalarA - , enum - , enumA - , resolve - , wrappedEnum - , wrappedEnumA - , wrappedObject - , wrappedObjectA - , wrappedScalar - , wrappedScalarA - -- * AST Reexports - , Field - , Argument(..) - , Value(..) - ) where - -import Control.Monad (MonadPlus(..)) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (runExceptT) -import Data.Foldable ( find - , fold - ) -import Data.GraphQL.Error -import Data.List.NonEmpty (NonEmpty) -import Data.Maybe (fromMaybe) -import qualified Data.Aeson as Aeson -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Text (Text) -import qualified Data.Text as T -import Language.GraphQL.Trans -import Language.GraphQL.Type -import Data.GraphQL.AST.Core - --- | A GraphQL schema. --- @f@ is usually expected to be an instance of 'Alternative'. -type Schema m = NonEmpty (Resolver m) - --- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information --- (or 'empty'). @m@ is usually expected to be an instance of 'MonadPlus'. -data Resolver m = Resolver - Text -- ^ Name - (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver - -type Fields = [Field] - -type Arguments = [Argument] - --- | Variable substitution function. -type Subs = Name -> Maybe Value - --- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. -object :: MonadPlus m => Name -> ActionT m [Resolver m] -> Resolver m -object name = objectA name . const - --- | Like 'object' but also taking 'Argument's. -objectA :: MonadPlus m - => Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m -objectA name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld - --- | Like 'object' but also taking 'Argument's and can be null or a list of objects. -wrappedObjectA :: MonadPlus m - => Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m -wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld@(Field _ _ _ sels) resolver - = withField (traverse (`resolve` sels) resolver) fld - --- | Like 'object' but can be null or a list of objects. -wrappedObject :: MonadPlus m - => Name -> ActionT m (Wrapping [Resolver m]) -> Resolver m -wrappedObject name = wrappedObjectA name . const - --- | A scalar represents a primitive value, like a string or an integer. -scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m -scalar name = scalarA name . const - --- | Like 'scalar' but also taking 'Argument's. -scalarA :: (MonadPlus m, Aeson.ToJSON a) - => Name -> (Arguments -> ActionT m a) -> Resolver m -scalarA name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld result = withField (return result) fld - --- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars. -wrappedScalarA :: (MonadPlus m, Aeson.ToJSON a) - => Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m -wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld (Named result) = withField (return result) fld - resolveRight fld Null - = return $ HashMap.singleton (aliasOrName fld) Aeson.Null - resolveRight fld (List result) = withField (return result) fld - --- | Like 'scalar' but can be null or a list of scalars. -wrappedScalar :: (MonadPlus m, Aeson.ToJSON a) - => Name -> ActionT m (Wrapping a) -> Resolver m -wrappedScalar name = wrappedScalarA name . const - --- | Represents one of a finite set of possible values. --- Used in place of a 'scalar' when the possible responses are easily enumerable. -enum :: MonadPlus m => Name -> ActionT m [Text] -> Resolver m -enum name = enumA name . const - --- | Like 'enum' but also taking 'Argument's. -enumA :: MonadPlus m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m -enumA name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld resolver = withField (return resolver) fld - --- | Like 'enum' but also taking 'Argument's and can be null or a list of enums. -wrappedEnumA :: MonadPlus m - => Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m -wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld (Named resolver) = withField (return resolver) fld - resolveRight fld Null - = return $ HashMap.singleton (aliasOrName fld) Aeson.Null - resolveRight fld (List resolver) = withField (return resolver) fld - --- | Like 'enum' but can be null or a list of enums. -wrappedEnum :: MonadPlus m => Name -> ActionT m (Wrapping [Text]) -> Resolver m -wrappedEnum name = wrappedEnumA name . const - -resolveFieldValue :: MonadPlus m - => ([Argument] -> ActionT m a) - -> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value)) - -> Field - -> CollectErrsT m (HashMap Text Aeson.Value) -resolveFieldValue f resolveRight fld@(Field _ _ args _) = do - result <- lift $ runExceptT . runActionT $ f args - either resolveLeft (resolveRight fld) result - where - resolveLeft err = do - _ <- addErrMsg err - return $ HashMap.singleton (aliasOrName fld) Aeson.Null - --- | Helper function to facilitate 'Argument' handling. -withField :: (MonadPlus m, Aeson.ToJSON a) - => CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value) -withField v fld - = HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v - --- | 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 :: MonadPlus m - => [Resolver m] -> Fields -> CollectErrsT m Aeson.Value -resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers - where - tryResolvers fld = mplus (maybe mzero (tryResolver fld) $ find (compareResolvers fld) resolvers) $ errmsg fld - compareResolvers (Field _ name _ _) (Resolver name' _) = name == name' - tryResolver fld (Resolver _ resolver) = resolver fld - errmsg fld@(Field _ name _ _) = do - addErrMsg $ T.unwords ["field", name, "not resolved."] - return $ HashMap.singleton (aliasOrName fld) Aeson.Null - -aliasOrName :: Field -> Text -aliasOrName (Field alias name _ _) = fromMaybe name alias |
