diff options
Diffstat (limited to 'src/Language')
| -rw-r--r-- | src/Language/GraphQL.hs | 2 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST.hs | 110 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Core.hs | 104 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Encoder.hs (renamed from src/Language/GraphQL/Encoder.hs) | 140 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Lexer.hs (renamed from src/Language/GraphQL/Lexer.hs) | 10 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Parser.hs (renamed from src/Language/GraphQL/Parser.hs) | 30 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Transform.hs | 220 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute.hs | 5 | ||||
| -rw-r--r-- | src/Language/GraphQL/Schema.hs | 62 | ||||
| -rw-r--r-- | src/Language/GraphQL/Trans.hs | 16 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type.hs | 6 |
11 files changed, 331 insertions, 374 deletions
diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index c33eb95..afce8aa 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -10,7 +10,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.Text as T import Language.GraphQL.Error import Language.GraphQL.Execute -import Language.GraphQL.Parser +import Language.GraphQL.AST.Parser import qualified Language.GraphQL.Schema as Schema import Text.Megaparsec (parse) diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs index 6794ae3..44bf969 100644 --- a/src/Language/GraphQL/AST.hs +++ b/src/Language/GraphQL/AST.hs @@ -5,14 +5,11 @@ module Language.GraphQL.AST ( Alias , Argument(..) - , Arguments , Definition(..) , Directive(..) - , Directives , Document , Field(..) , FragmentDefinition(..) - , FragmentName , FragmentSpread(..) , InlineFragment(..) , Name @@ -27,22 +24,23 @@ module Language.GraphQL.AST , TypeCondition , Value(..) , VariableDefinition(..) - , VariableDefinitions ) where import Data.Int (Int32) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) -import Language.GraphQL.AST.Core ( Alias - , Name - , TypeCondition - ) -- * Document -- | GraphQL document. type Document = NonEmpty Definition +-- | Name +type Name = Text + +-- | Directive. +data Directive = Directive Name [Argument] deriving (Eq, Show) + -- * Operations -- | Top-level definition of a document, either an operation or a fragment. @@ -68,7 +66,7 @@ data OperationType = Query | Mutation deriving (Eq, Show) -- * Selections --- | "Top-level" selection, selection on a operation. +-- | "Top-level" selection, selection on an operation or fragment. type SelectionSet = NonEmpty Selection -- | Field selection. @@ -83,18 +81,56 @@ data Selection -- * Field --- | GraphQL field. +-- | Single GraphQL field. +-- +-- The only required property of a field is its name. Optionally it can also +-- have an alias, arguments or a list of subfields. +-- +-- Given the following query: +-- +-- @ +-- { +-- zuck: user(id: 4) { +-- id +-- name +-- } +-- } +-- @ +-- +-- * "user", "id" and "name" are field names. +-- * "user" has two subfields, "id" and "name". +-- * "zuck" is an alias for "user". "id" and "name" have no aliases. +-- * "id: 4" is an argument for "user". "id" and "name" don't have any +-- arguments. data Field = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt deriving (Eq, Show) --- * Arguments - --- | Argument list. -{-# DEPRECATED Arguments "Use [Argument] instead" #-} -type Arguments = [Argument] +-- | Alternative field name. +-- +-- @ +-- { +-- smallPic: profilePic(size: 64) +-- bigPic: profilePic(size: 1024) +-- } +-- @ +-- +-- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic", +-- used to distinquish between profile pictures with different arguments +-- (sizes). +type Alias = Name --- | Argument. +-- | Single argument. +-- +-- @ +-- { +-- user(id: 4) { +-- name +-- } +-- } +-- @ +-- +-- Here "id" is an argument for the field "user" and its value is 4. data Argument = Argument Name Value deriving (Eq,Show) -- * Fragments @@ -111,21 +147,18 @@ data FragmentDefinition = FragmentDefinition Name TypeCondition [Directive] SelectionSet deriving (Eq, Show) -{-# DEPRECATED FragmentName "Use Name instead" #-} -type FragmentName = Name - --- * Input values +-- * Inputs -- | Input value. -data Value = ValueVariable Name - | ValueInt Int32 - | ValueFloat Double - | ValueString Text - | ValueBoolean Bool - | ValueNull - | ValueEnum Name - | ValueList [Value] - | ValueObject [ObjectField] +data Value = Variable Name + | Int Int32 + | Float Double + | String Text + | Boolean Bool + | Null + | Enum Name + | List [Value] + | Object [ObjectField] deriving (Eq, Show) -- | Key-value pair. @@ -133,17 +166,12 @@ data Value = ValueVariable Name -- A list of 'ObjectField's represents a GraphQL object type. data ObjectField = ObjectField Name Value deriving (Eq, Show) --- * Variables - --- | Variable definition list. -{-# DEPRECATED VariableDefinitions "Use [VariableDefinition] instead" #-} -type VariableDefinitions = [VariableDefinition] - -- | Variable definition. data VariableDefinition = VariableDefinition Name Type (Maybe Value) deriving (Eq, Show) --- * Input types +-- | Type condition. +type TypeCondition = Name -- | Type representation. data Type = TypeNamed Name @@ -151,17 +179,7 @@ data Type = TypeNamed Name | TypeNonNull NonNullType deriving (Eq, Show) - -- | Helper type to represent Non-Null types and lists of such types. data NonNullType = NonNullTypeNamed Name | NonNullTypeList Type deriving (Eq, Show) - --- * Directives - --- | Directive list. -{-# DEPRECATED Directives "Use [Directive] instead" #-} -type Directives = [Directive] - --- | Directive. -data Directive = Directive Name [Argument] deriving (Eq, Show) diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs index a2a53be..f7a008f 100644 --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -6,7 +6,6 @@ module Language.GraphQL.AST.Core , Field(..) , Fragment(..) , Name - , ObjectField(..) , Operation(..) , Selection(..) , TypeCondition @@ -14,12 +13,12 @@ module Language.GraphQL.AST.Core ) where import Data.Int (Int32) +import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty) -import Data.String +import Data.Sequence (Seq) +import Data.String (IsString(..)) import Data.Text (Text) - --- | Name -type Name = Text +import Language.GraphQL.AST (Alias, Name, TypeCondition) -- | GraphQL document is a non-empty list of operations. type Document = NonEmpty Operation @@ -28,87 +27,21 @@ type Document = NonEmpty Operation -- -- Currently only queries and mutations are supported. data Operation - = Query (Maybe Text) (NonEmpty Selection) - | Mutation (Maybe Text) (NonEmpty Selection) + = Query (Maybe Text) (Seq Selection) + | Mutation (Maybe Text) (Seq Selection) deriving (Eq, Show) --- | A single GraphQL field. --- --- Only required property of a field, is its name. Optionally it can also have --- an alias, arguments or a list of subfields. --- --- Given the following query: --- --- @ --- { --- zuck: user(id: 4) { --- id --- name --- } --- } --- @ --- --- * "user", "id" and "name" are field names. --- * "user" has two subfields, "id" and "name". --- * "zuck" is an alias for "user". "id" and "name" have no aliases. --- * "id: 4" is an argument for "name". "id" and "name don't have any --- arguments. -data Field = Field (Maybe Alias) Name [Argument] [Selection] deriving (Eq, Show) - --- | Alternative field name. --- --- @ --- { --- smallPic: profilePic(size: 64) --- bigPic: profilePic(size: 1024) --- } --- @ --- --- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic", --- used to distinquish between profile pictures with different arguments --- (sizes). -type Alias = Name +-- | Single GraphQL field. +data Field + = Field (Maybe Alias) Name [Argument] (Seq Selection) + deriving (Eq, Show) -- | Single argument. --- --- @ --- { --- user(id: 4) { --- name --- } --- } --- @ --- --- Here "id" is an argument for the field "user" and its value is 4. data Argument = Argument Name Value deriving (Eq, Show) --- | Represents accordingly typed GraphQL values. -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 - --- | Key-value pair. --- --- A list of 'ObjectField's represents a GraphQL object type. -data ObjectField = ObjectField Name Value deriving (Eq, Show) - --- | Type condition. -type TypeCondition = Name - -- | Represents fragments and inline fragments. data Fragment - = Fragment TypeCondition (NonEmpty Selection) + = Fragment TypeCondition (Seq Selection) deriving (Eq, Show) -- | Single selection element. @@ -116,3 +49,18 @@ data Selection = SelectionFragment Fragment | SelectionField Field deriving (Eq, Show) + +-- | Represents accordingly typed GraphQL values. +data Value + = Int Int32 + | Float Double -- ^ GraphQL Float is double precision + | String Text + | Boolean Bool + | Null + | Enum Name + | List [Value] + | Object (HashMap Name Value) + deriving (Eq, Show) + +instance IsString Value where + fromString = String . fromString diff --git a/src/Language/GraphQL/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index b3ec655..afc425f 100644 --- a/src/Language/GraphQL/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ExplicitForAll #-} -- | This module defines a minifier and a printer for the @GraphQL@ language. -module Language.GraphQL.Encoder +module Language.GraphQL.AST.Encoder ( Formatter , definition , directive @@ -21,12 +21,12 @@ import qualified Data.Text.Lazy as Text.Lazy import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Builder.Int (decimal) import Data.Text.Lazy.Builder.RealFloat (realFloat) -import Language.GraphQL.AST +import qualified Language.GraphQL.AST as Full --- | Instructs the encoder whether a GraphQL should be minified or pretty --- printed. --- --- Use 'pretty' and 'minified' to construct the formatter. +-- | Instructs the encoder whether the GraphQL document should be minified or +-- pretty printed. +-- +-- Use 'pretty' or 'minified' to construct the formatter. data Formatter = Minified | Pretty Word @@ -39,38 +39,38 @@ pretty = Pretty 0 minified :: Formatter minified = Minified --- | Converts a 'Document' into a string. -document :: Formatter -> Document -> Text +-- | Converts a 'Full.Document' into a string. +document :: Formatter -> Full.Document -> Text document formatter defs | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument | Minified <-formatter = Text.Lazy.snoc (mconcat encodeDocument) '\n' where encodeDocument = NonEmpty.toList $ definition formatter <$> defs --- | Converts a 'Definition' into a string. -definition :: Formatter -> Definition -> Text +-- | Converts a 'Full.Definition' into a string. +definition :: Formatter -> Full.Definition -> Text definition formatter x | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n' | Minified <- formatter = encodeDefinition x where - encodeDefinition (DefinitionOperation operation) + encodeDefinition (Full.DefinitionOperation operation) = operationDefinition formatter operation - encodeDefinition (DefinitionFragment fragment) + encodeDefinition (Full.DefinitionFragment fragment) = fragmentDefinition formatter fragment -operationDefinition :: Formatter -> OperationDefinition -> Text -operationDefinition formatter (OperationSelectionSet sels) +operationDefinition :: Formatter -> Full.OperationDefinition -> Text +operationDefinition formatter (Full.OperationSelectionSet sels) = selectionSet formatter sels -operationDefinition formatter (OperationDefinition Query name vars dirs sels) +operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels) = "query " <> node formatter name vars dirs sels -operationDefinition formatter (OperationDefinition Mutation name vars dirs sels) +operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels) = "mutation " <> node formatter name vars dirs sels node :: Formatter - -> Maybe Name - -> [VariableDefinition] - -> [Directive] - -> SelectionSet + -> Maybe Full.Name + -> [Full.VariableDefinition] + -> [Full.Directive] + -> Full.SelectionSet -> Text node formatter name vars dirs sels = Text.Lazy.fromStrict (fold name) @@ -79,39 +79,39 @@ node formatter name vars dirs sels <> eitherFormat formatter " " mempty <> selectionSet formatter sels -variableDefinitions :: Formatter -> [VariableDefinition] -> Text +variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Text variableDefinitions formatter = parensCommas formatter $ variableDefinition formatter -variableDefinition :: Formatter -> VariableDefinition -> Text -variableDefinition formatter (VariableDefinition var ty dv) +variableDefinition :: Formatter -> Full.VariableDefinition -> Text +variableDefinition formatter (Full.VariableDefinition var ty dv) = variable var <> eitherFormat formatter ": " ":" <> type' ty <> maybe mempty (defaultValue formatter) dv -defaultValue :: Formatter -> Value -> Text +defaultValue :: Formatter -> Full.Value -> Text defaultValue formatter val = eitherFormat formatter " = " "=" <> value formatter val -variable :: Name -> Text +variable :: Full.Name -> Text variable var = "$" <> Text.Lazy.fromStrict var -selectionSet :: Formatter -> SelectionSet -> Text +selectionSet :: Formatter -> Full.SelectionSet -> Text selectionSet formatter = bracesList formatter (selection formatter) . NonEmpty.toList -selectionSetOpt :: Formatter -> SelectionSetOpt -> Text +selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Text selectionSetOpt formatter = bracesList formatter $ selection formatter -selection :: Formatter -> Selection -> Text +selection :: Formatter -> Full.Selection -> Text selection formatter = Text.Lazy.append indent . f where - f (SelectionField x) = field incrementIndent x - f (SelectionInlineFragment x) = inlineFragment incrementIndent x - f (SelectionFragmentSpread x) = fragmentSpread incrementIndent x + f (Full.SelectionField x) = field incrementIndent x + f (Full.SelectionInlineFragment x) = inlineFragment incrementIndent x + f (Full.SelectionFragmentSpread x) = fragmentSpread incrementIndent x incrementIndent | Pretty n <- formatter = Pretty $ n + 1 | otherwise = Minified @@ -119,8 +119,8 @@ selection formatter = Text.Lazy.append indent . f | Pretty n <- formatter = Text.Lazy.replicate (fromIntegral $ n + 1) " " | otherwise = mempty -field :: Formatter -> Field -> Text -field formatter (Field alias name args dirs selso) +field :: Formatter -> Full.Field -> Text +field formatter (Full.Field alias name args dirs selso) = optempty (`Text.Lazy.append` colon) (Text.Lazy.fromStrict $ fold alias) <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args @@ -132,31 +132,31 @@ field formatter (Field alias name args dirs selso) | null selso = mempty | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso -arguments :: Formatter -> [Argument] -> Text +arguments :: Formatter -> [Full.Argument] -> Text arguments formatter = parensCommas formatter $ argument formatter -argument :: Formatter -> Argument -> Text -argument formatter (Argument name v) +argument :: Formatter -> Full.Argument -> Text +argument formatter (Full.Argument name v) = Text.Lazy.fromStrict name <> eitherFormat formatter ": " ":" <> value formatter v -- * Fragments -fragmentSpread :: Formatter -> FragmentSpread -> Text -fragmentSpread formatter (FragmentSpread name ds) +fragmentSpread :: Formatter -> Full.FragmentSpread -> Text +fragmentSpread formatter (Full.FragmentSpread name ds) = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds -inlineFragment :: Formatter -> InlineFragment -> Text -inlineFragment formatter (InlineFragment tc dirs sels) +inlineFragment :: Formatter -> Full.InlineFragment -> Text +inlineFragment formatter (Full.InlineFragment tc dirs sels) = "... on " <> Text.Lazy.fromStrict (fold tc) <> directives formatter dirs <> eitherFormat formatter " " mempty <> selectionSet formatter sels -fragmentDefinition :: Formatter -> FragmentDefinition -> Text -fragmentDefinition formatter (FragmentDefinition name tc dirs sels) +fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Text +fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels) = "fragment " <> Text.Lazy.fromStrict name <> " on " <> Text.Lazy.fromStrict tc <> optempty (directives formatter) dirs @@ -165,26 +165,26 @@ fragmentDefinition formatter (FragmentDefinition name tc dirs sels) -- * Miscellaneous --- | Converts a 'Directive' into a string. -directive :: Formatter -> Directive -> Text -directive formatter (Directive name args) +-- | Converts a 'Full.Directive' into a string. +directive :: Formatter -> Full.Directive -> Text +directive formatter (Full.Directive name args) = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args -directives :: Formatter -> [Directive] -> Text +directives :: Formatter -> [Full.Directive] -> Text directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter) directives Minified = spaces (directive Minified) --- | Converts a 'Value' into a string. -value :: Formatter -> Value -> Text -value _ (ValueVariable x) = variable x -value _ (ValueInt x) = toLazyText $ decimal x -value _ (ValueFloat x) = toLazyText $ realFloat x -value _ (ValueBoolean x) = booleanValue x -value _ ValueNull = mempty -value _ (ValueString x) = stringValue $ Text.Lazy.fromStrict x -value _ (ValueEnum x) = Text.Lazy.fromStrict x -value formatter (ValueList x) = listValue formatter x -value formatter (ValueObject x) = objectValue formatter x +-- | Converts a 'Full.Value' into a string. +value :: Formatter -> Full.Value -> Text +value _ (Full.Variable x) = variable x +value _ (Full.Int x) = toLazyText $ decimal x +value _ (Full.Float x) = toLazyText $ realFloat x +value _ (Full.Boolean x) = booleanValue x +value _ Full.Null = mempty +value _ (Full.String x) = stringValue $ Text.Lazy.fromStrict x +value _ (Full.Enum x) = Text.Lazy.fromStrict x +value formatter (Full.List x) = listValue formatter x +value formatter (Full.Object x) = objectValue formatter x booleanValue :: Bool -> Text booleanValue True = "true" @@ -196,10 +196,10 @@ stringValue . Text.Lazy.replace "\"" "\\\"" . Text.Lazy.replace "\\" "\\\\" -listValue :: Formatter -> [Value] -> Text +listValue :: Formatter -> [Full.Value] -> Text listValue formatter = bracketsCommas formatter $ value formatter -objectValue :: Formatter -> [ObjectField] -> Text +objectValue :: Formatter -> [Full.ObjectField] -> Text objectValue formatter = intercalate $ objectField formatter where intercalate f @@ -208,26 +208,26 @@ objectValue formatter = intercalate $ objectField formatter . fmap f -objectField :: Formatter -> ObjectField -> Text -objectField formatter (ObjectField name v) +objectField :: Formatter -> Full.ObjectField -> Text +objectField formatter (Full.ObjectField name v) = Text.Lazy.fromStrict name <> colon <> value formatter v where colon | Pretty _ <- formatter = ": " | Minified <- formatter = ":" --- | Converts a 'Type' a type into a string. -type' :: Type -> Text -type' (TypeNamed x) = Text.Lazy.fromStrict x -type' (TypeList x) = listType x -type' (TypeNonNull x) = nonNullType x +-- | Converts a 'Full.Type' a type into a string. +type' :: Full.Type -> Text +type' (Full.TypeNamed x) = Text.Lazy.fromStrict x +type' (Full.TypeList x) = listType x +type' (Full.TypeNonNull x) = nonNullType x -listType :: Type -> Text +listType :: Full.Type -> Text listType x = brackets (type' x) -nonNullType :: NonNullType -> Text -nonNullType (NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!" -nonNullType (NonNullTypeList x) = listType x <> "!" +nonNullType :: Full.NonNullType -> Text +nonNullType (Full.NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!" +nonNullType (Full.NonNullTypeList x) = listType x <> "!" -- * Internal diff --git a/src/Language/GraphQL/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index dc000b5..e4d64ca 100644 --- a/src/Language/GraphQL/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -3,7 +3,7 @@ -- | This module defines a bunch of small parsers used to parse individual -- lexemes. -module Language.GraphQL.Lexer +module Language.GraphQL.AST.Lexer ( Parser , amp , at @@ -89,12 +89,12 @@ symbol :: T.Text -> Parser T.Text symbol = Lexer.symbol spaceConsumer -- | Parser for "!". -bang :: Parser Char -bang = char '!' +bang :: Parser T.Text +bang = symbol "!" -- | Parser for "$". -dollar :: Parser Char -dollar = char '$' +dollar :: Parser T.Text +dollar = symbol "$" -- | Parser for "@". at :: Parser Char diff --git a/src/Language/GraphQL/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index bbe1de7..1505615 100644 --- a/src/Language/GraphQL/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} -- | @GraphQL@ document parser. -module Language.GraphQL.Parser +module Language.GraphQL.AST.Parser ( document ) where @@ -11,7 +11,7 @@ import Control.Applicative ( Alternative(..) ) import Data.List.NonEmpty (NonEmpty(..)) import Language.GraphQL.AST -import Language.GraphQL.Lexer +import Language.GraphQL.AST.Lexer import Text.Megaparsec ( lookAhead , option , try @@ -105,16 +105,16 @@ typeCondition = symbol "on" *> name -- * Input Values value :: Parser Value -value = ValueVariable <$> variable - <|> ValueFloat <$> try float - <|> ValueInt <$> integer - <|> ValueBoolean <$> booleanValue - <|> ValueNull <$ symbol "null" - <|> ValueString <$> blockString - <|> ValueString <$> string - <|> ValueEnum <$> try enumValue - <|> ValueList <$> listValue - <|> ValueObject <$> objectValue +value = Variable <$> variable + <|> Float <$> try float + <|> Int <$> integer + <|> Boolean <$> booleanValue + <|> Null <$ symbol "null" + <|> String <$> blockString + <|> String <$> string + <|> Enum <$> try enumValue + <|> List <$> listValue + <|> Object <$> objectValue <?> "value error!" where booleanValue :: Parser Bool @@ -152,9 +152,9 @@ defaultValue = equals *> value -- * Input Types type_ :: Parser Type -type_ = try (TypeNamed <$> name <* but "!") - <|> TypeList <$> brackets type_ - <|> TypeNonNull <$> nonNullType +type_ = try (TypeNonNull <$> nonNullType) + <|> TypeList <$> brackets type_ + <|> TypeNamed <$> name <?> "type_ error!" nonNullType :: Parser NonNullType diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs index 3aa31b0..95cdfbb 100644 --- a/src/Language/GraphQL/AST/Transform.hs +++ b/src/Language/GraphQL/AST/Transform.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ExplicitForAll #-} -- | After the document is parsed, before getting executed the AST is -- transformed into a similar, simpler AST. This module is responsible for @@ -7,130 +8,143 @@ module Language.GraphQL.AST.Transform ( document ) where -import Control.Applicative (empty) -import Data.Bifunctor (first) -import Data.Either (partitionEithers) -import Data.Foldable (fold, foldMap) -import Data.List.NonEmpty (NonEmpty) +import Control.Arrow (first) +import Control.Monad (foldM, unless) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Trans.State (StateT, evalStateT, gets, modify) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import qualified Data.List.NonEmpty as NonEmpty -import Data.Monoid (Alt(Alt,getAlt), (<>)) +import Data.Sequence (Seq, (<|), (><)) import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.AST.Core as Core import qualified Language.GraphQL.Schema as Schema --- | Replaces a fragment name by a list of 'Core.Field'. If the name doesn't --- match an empty list is returned. -type Fragmenter = Core.Name -> [Core.Field] +-- | Associates a fragment name with a list of 'Core.Field's. +data Replacement = Replacement + { fragments :: HashMap Core.Name (Seq Core.Selection) + , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition + } + +type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a -- | Rewrites the original syntax tree into an intermediate representation used -- for query execution. document :: Schema.Subs -> Full.Document -> Maybe Core.Document -document subs doc = operations subs fr ops +document subs document' = + flip runReaderT subs + $ evalStateT (collectFragments >> operations operationDefinitions) + $ Replacement HashMap.empty fragmentTable where - (fr, ops) = first foldFrags - . partitionEithers - . NonEmpty.toList - $ defrag subs - <$> doc - - foldFrags :: [Fragmenter] -> Fragmenter - foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs + (fragmentTable, operationDefinitions) = foldr defragment mempty document' + defragment (Full.DefinitionOperation definition) acc = + (definition :) <$> acc + defragment (Full.DefinitionFragment definition) acc = + let (Full.FragmentDefinition name _ _ _) = definition + in first (HashMap.insert name definition) acc -- * Operation -- TODO: Replace Maybe by MonadThrow CustomError -operations - :: Schema.Subs - -> Fragmenter - -> [Full.OperationDefinition] - -> Maybe Core.Document -operations subs fr = NonEmpty.nonEmpty . fmap (operation subs fr) - -operation - :: Schema.Subs - -> Fragmenter - -> Full.OperationDefinition - -> Core.Operation -operation subs fr (Full.OperationSelectionSet sels) = - operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels +operations :: [Full.OperationDefinition] -> TransformT Core.Document +operations operations' = do + coreOperations <- traverse operation operations' + lift . lift $ NonEmpty.nonEmpty coreOperations + +operation :: Full.OperationDefinition -> TransformT Core.Operation +operation (Full.OperationSelectionSet sels) = + operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels -- TODO: Validate Variable definitions with substituter -operation subs fr (Full.OperationDefinition Full.Query name _vars _dirs sels) = - Core.Query name $ appendSelection subs fr sels -operation subs fr (Full.OperationDefinition Full.Mutation name _vars _dirs sels) = - Core.Mutation name $ appendSelection subs fr sels - -selection - :: Schema.Subs - -> Fragmenter - -> Full.Selection - -> Either [Core.Selection] Core.Selection -selection subs fr (Full.SelectionField fld) - = Right $ Core.SelectionField $ field subs fr fld -selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) - = Left $ Core.SelectionField <$> fr name -selection subs fr (Full.SelectionInlineFragment fragment) +operation (Full.OperationDefinition Full.Query name _vars _dirs sels) = + Core.Query name <$> appendSelection sels +operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) = + Core.Mutation name <$> appendSelection sels + +selection :: + Full.Selection -> + TransformT (Either (Seq Core.Selection) Core.Selection) +selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld +selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do + fragments' <- gets fragments + Left <$> maybe lookupDefinition liftJust (HashMap.lookup name fragments') + where + lookupDefinition :: TransformT (Seq Core.Selection) + lookupDefinition = do + fragmentDefinitions' <- gets fragmentDefinitions + found <- lift . lift $ HashMap.lookup name fragmentDefinitions' + fragmentDefinition found +selection (Full.SelectionInlineFragment fragment) | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment = Right - $ Core.SelectionFragment - $ Core.Fragment typeCondition - $ appendSelection subs fr selectionSet + . Core.SelectionFragment + . Core.Fragment typeCondition + <$> appendSelection selectionSet | (Full.InlineFragment Nothing _ selectionSet) <- fragment - = Left $ NonEmpty.toList $ appendSelection subs fr selectionSet + = Left <$> appendSelection selectionSet -- * 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' - | name == name' = selection' <$> do - selections <- NonEmpty.toList $ selection subs mempty <$> sels - either id pure selections - | otherwise = empty +-- | Extract fragment definitions into a single 'HashMap'. +collectFragments :: TransformT () +collectFragments = do + fragDefs <- gets fragmentDefinitions + let nextValue = head $ HashMap.elems fragDefs + unless (HashMap.null fragDefs) $ do + _ <- fragmentDefinition nextValue + collectFragments + +fragmentDefinition :: + Full.FragmentDefinition -> + TransformT (Seq Core.Selection) +fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do + modify deleteFragmentDefinition + newValue <- appendSelection selections + modify $ insertFragment newValue + liftJust newValue where - selection' (Core.SelectionField field') = field' - selection' _ = error "Fragments within fragments are not supported yet" + deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') = + Replacement fragments' $ HashMap.delete name fragmentDefinitions' + insertFragment newValue (Replacement fragments' fragmentDefinitions') = + let newFragments = HashMap.insert name newValue fragments' + in Replacement newFragments fragmentDefinitions' + +field :: Full.Field -> TransformT Core.Field +field (Full.Field a n args _dirs sels) = do + arguments <- traverse argument args + selection' <- appendSelection sels + return $ Core.Field a n arguments selection' + +argument :: Full.Argument -> TransformT Core.Argument +argument (Full.Argument n v) = Core.Argument n <$> value v + +value :: Full.Value -> TransformT Core.Value +value (Full.Variable n) = do + substitute' <- lift ask + lift . lift $ substitute' n +value (Full.Int i) = pure $ Core.Int i +value (Full.Float f) = pure $ Core.Float f +value (Full.String x) = pure $ Core.String x +value (Full.Boolean b) = pure $ Core.Boolean b +value Full.Null = pure Core.Null +value (Full.Enum e) = pure $ Core.Enum e +value (Full.List l) = + Core.List <$> traverse value l +value (Full.Object o) = + Core.Object . HashMap.fromList <$> traverse objectField o + +objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value) +objectField (Full.ObjectField n v) = (n,) <$> value v -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) +appendSelection :: + Traversable t => + t Full.Selection -> + TransformT (Seq Core.Selection) +appendSelection = foldM go mempty where - go :: Full.Selection -> [Core.Selection] -> [Core.Selection] - go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = ((Core.SelectionField <$> 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 + go acc sel = append acc <$> selection sel + append acc (Left list) = list >< acc + append acc (Right one) = one <| acc -appendSelection :: - Schema.Subs -> - Fragmenter -> - NonEmpty Full.Selection -> - NonEmpty Core.Selection -appendSelection subs fr = NonEmpty.fromList - . foldr (either (++) (:) . selection subs fr) [] +liftJust :: forall a. a -> TransformT a +liftJust = lift . lift . Just diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 9228dd5..59e85bf 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -8,6 +8,7 @@ module Language.GraphQL.Execute import Control.Monad.IO.Class (MonadIO) import qualified Data.Aeson as Aeson +import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE import Data.Text (Text) @@ -71,6 +72,6 @@ operation :: MonadIO m -> AST.Core.Operation -> m Aeson.Value operation schema (AST.Core.Query _ flds) - = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds)) + = runCollectErrs (Schema.resolve (toList schema) flds) operation schema (AST.Core.Mutation _ flds) - = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds)) + = runCollectErrs (Schema.resolve (toList schema) flds) diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index 112847f..afe068f 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -4,17 +4,12 @@ -- functions for defining and manipulating schemas. module Language.GraphQL.Schema ( Resolver - , Schema , Subs , object , objectA , scalar , scalarA - , enum - , enumA , resolve - , wrappedEnum - , wrappedEnumA , wrappedObject , wrappedObjectA , wrappedScalar @@ -28,23 +23,19 @@ module Language.GraphQL.Schema import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Reader (runReaderT) import Data.Foldable (find, fold) -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.Sequence (Seq) import Data.Text (Text) import qualified Data.Text as T +import Language.GraphQL.AST.Core import Language.GraphQL.Error import Language.GraphQL.Trans -import Language.GraphQL.Type -import Language.GraphQL.AST.Core - -{-# DEPRECATED Schema "Use NonEmpty (Resolver m) instead" #-} --- | A GraphQL schema. --- @m@ is usually expected to be an instance of 'MonadIO'. -type Schema m = NonEmpty (Resolver m) +import qualified Language.GraphQL.Type as Type -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error -- information (if an error has occurred). @m@ is usually expected to be an @@ -69,7 +60,7 @@ objectA name f = Resolver name $ resolveFieldValue f resolveRight -- | Like 'object' but also taking 'Argument's and can be null or a list of objects. wrappedObjectA :: MonadIO m - => Name -> ([Argument] -> ActionT m (Wrapping [Resolver m])) -> Resolver m + => Name -> ([Argument] -> ActionT m (Type.Wrapping [Resolver m])) -> Resolver m wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld@(Field _ _ _ sels) resolver @@ -77,7 +68,7 @@ wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight -- | Like 'object' but can be null or a list of objects. wrappedObject :: MonadIO m - => Name -> ActionT m (Wrapping [Resolver m]) -> Resolver m + => Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m wrappedObject name = wrappedObjectA name . const -- | A scalar represents a primitive value, like a string or an integer. @@ -91,54 +82,31 @@ 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. +-- | Like 'scalar' but also taking 'Argument's and can be null or a list of scalars. wrappedScalarA :: (MonadIO m, Aeson.ToJSON a) - => Name -> ([Argument] -> ActionT m (Wrapping a)) -> Resolver m + => Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight where - resolveRight fld (Named result) = withField (return result) fld - resolveRight fld Null + resolveRight fld (Type.Named result) = withField (return result) fld + resolveRight fld Type.Null = return $ HashMap.singleton (aliasOrName fld) Aeson.Null - resolveRight fld (List result) = withField (return result) fld + resolveRight fld (Type.List result) = withField (return result) fld -- | Like 'scalar' but can be null or a list of scalars. wrappedScalar :: (MonadIO m, Aeson.ToJSON a) - => Name -> ActionT m (Wrapping a) -> Resolver m + => Name -> ActionT m (Type.Wrapping a) -> Resolver m wrappedScalar name = wrappedScalarA name . const -{-# DEPRECATED enum "Use scalar instead" #-} -enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m -enum name = enumA name . const - -{-# DEPRECATED enumA "Use scalarA instead" #-} -enumA :: MonadIO m => Name -> ([Argument] -> ActionT m [Text]) -> Resolver m -enumA name f = Resolver name $ resolveFieldValue f resolveRight - where - resolveRight fld resolver = withField (return resolver) fld - -{-# DEPRECATED wrappedEnumA "Use wrappedScalarA instead" #-} -wrappedEnumA :: MonadIO m - => Name -> ([Argument] -> 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 - -{-# DEPRECATED wrappedEnum "Use wrappedScalar instead" #-} -wrappedEnum :: MonadIO m => Name -> ActionT m (Wrapping [Text]) -> Resolver m -wrappedEnum name = wrappedEnumA name . const - resolveFieldValue :: MonadIO 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 + result <- lift $ reader . runExceptT . runActionT $ f args either resolveLeft (resolveRight fld) result where + reader = flip runReaderT $ Context mempty resolveLeft err = do _ <- addErrMsg err return $ HashMap.singleton (aliasOrName fld) Aeson.Null @@ -153,7 +121,7 @@ withField v fld -- 'Resolver' to each 'Field'. Resolves into a value containing the -- resolved 'Field', or a null value and error information. resolve :: MonadIO m - => [Resolver m] -> [Selection] -> CollectErrsT m Aeson.Value + => [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers where resolveTypeName (Resolver "__typename" f) = do diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs index eb78911..4232e75 100644 --- a/src/Language/GraphQL/Trans.hs +++ b/src/Language/GraphQL/Trans.hs @@ -1,6 +1,7 @@ -- | Monad transformer stack used by the @GraphQL@ resolvers. module Language.GraphQL.Trans ( ActionT(..) + , Context(Context) ) where import Control.Applicative (Alternative(..)) @@ -8,10 +9,19 @@ import Control.Monad (MonadPlus(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Reader (ReaderT) +import Data.HashMap.Strict (HashMap) import Data.Text (Text) +import Language.GraphQL.AST.Core (Name, Value) --- | Monad transformer stack used by the resolvers to provide error handling. -newtype ActionT m a = ActionT { runActionT :: ExceptT Text m a } +-- | Resolution context holds resolver arguments. +newtype Context = Context (HashMap Name Value) + +-- | Monad transformer stack used by the resolvers to provide error handling +-- and resolution context (resolver arguments). +newtype ActionT m a = ActionT + { runActionT :: ExceptT Text (ReaderT Context m) a + } instance Functor m => Functor (ActionT m) where fmap f = ActionT . fmap f . runActionT @@ -25,7 +35,7 @@ instance Monad m => Monad (ActionT m) where (ActionT action) >>= f = ActionT $ action >>= runActionT . f instance MonadTrans ActionT where - lift = ActionT . lift + lift = ActionT . lift . lift instance MonadIO m => MonadIO (ActionT m) where liftIO = lift . liftIO diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs index 3f91e50..c8a9997 100644 --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -1,11 +1,9 @@ --- | Definitions for @GraphQL@ type system. +-- | Definitions for @GraphQL@ input types. module Language.GraphQL.Type ( Wrapping(..) ) where -import Data.Aeson as Aeson ( ToJSON - , toJSON - ) +import Data.Aeson as Aeson (ToJSON, toJSON) import qualified Data.Aeson as Aeson -- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping |