diff options
| -rw-r--r-- | src/Language/GraphQL/AST.hs | 4 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Encoder.hs | 10 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Transform.hs | 160 | ||||
| -rw-r--r-- | stack.yaml | 2 |
4 files changed, 83 insertions, 93 deletions
diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs index b2feb4d..44bf969 100644 --- a/src/Language/GraphQL/AST.hs +++ b/src/Language/GraphQL/AST.hs @@ -66,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. @@ -100,7 +100,7 @@ data Selection -- * "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 +-- * "id: 4" is an argument for "user". "id" and "name" don't have any -- arguments. data Field = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index a8f6ca4..a345ca4 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -39,7 +39,7 @@ pretty = Pretty 0 minified :: Formatter minified = Minified --- | Converts a 'Document' into a string. +-- | Converts a 'Full.Document' into a string. document :: Formatter -> Full.Document -> Text document formatter defs | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument @@ -47,7 +47,7 @@ document formatter defs where encodeDocument = NonEmpty.toList $ definition formatter <$> defs --- | Converts a 'Definition' into a string. +-- | Converts a 'Full.Definition' into a string. definition :: Formatter -> Full.Definition -> Text definition formatter x | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n' @@ -165,7 +165,7 @@ fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels) -- * Miscellaneous --- | Converts a 'Directive' into a string. +-- | 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 @@ -174,7 +174,7 @@ 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. +-- | 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 @@ -216,7 +216,7 @@ objectField formatter (Full.ObjectField name v) | Pretty _ <- formatter = ": " | Minified <- formatter = ":" --- | Converts a 'Type' a type into a string. +-- | 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 diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs index ea90bab..965d883 100644 --- a/src/Language/GraphQL/AST/Transform.hs +++ b/src/Language/GraphQL/AST/Transform.hs @@ -7,7 +7,9 @@ module Language.GraphQL.AST.Transform ( document ) where -import Data.Foldable (fold) +import Control.Monad (foldM) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.List.NonEmpty (NonEmpty) @@ -19,59 +21,54 @@ import qualified Language.GraphQL.Schema as Schema -- | Associates a fragment name with a list of 'Core.Field's. type Fragments = HashMap Core.Name (NonEmpty Core.Field) +data Replacement = Replacement + { substitute :: Schema.Subs + , fragments :: Fragments + } + +type TransformT a = ReaderT Replacement 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 = - case fragments of - Just fragments' -> operations subs fragments' operations' - Nothing -> Nothing + (runReaderT (operations operations') . Replacement subs) =<< fragments' where - (fragments, operations') = foldr (defrag subs) (Just HashMap.empty, []) + (fragments', operations') = foldr (defrag subs) (Just HashMap.empty, []) $ NonEmpty.toList doc -- * Operation -- TODO: Replace Maybe by MonadThrow CustomError -operations :: - Schema.Subs -> - Fragments -> - [Full.OperationDefinition] -> - Maybe Core.Document -operations subs fragments operations' = do - coreOperations <- traverse (operation subs fragments) operations' - NonEmpty.nonEmpty coreOperations - -operation :: - Schema.Subs -> - Fragments -> - Full.OperationDefinition -> - Maybe Core.Operation -operation subs fragments (Full.OperationSelectionSet sels) = - operation subs fragments $ Full.OperationDefinition Full.Query mempty mempty mempty sels +operations :: [Full.OperationDefinition] -> TransformT Core.Document +operations operations' = do + coreOperations <- traverse operation operations' + 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 fragments (Full.OperationDefinition Full.Query name _vars _dirs sels) = - Core.Query name <$> appendSelection subs fragments sels -operation subs fragments (Full.OperationDefinition Full.Mutation name _vars _dirs sels) = - Core.Mutation name <$> appendSelection subs fragments sels +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 :: - Schema.Subs -> - Fragments -> Full.Selection -> - Maybe (Either (NonEmpty Core.Selection) Core.Selection) -selection subs fragments (Full.SelectionField fld) - = Right . Core.SelectionField <$> field subs fragments fld -selection _ fragments (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) - = Left . fmap Core.SelectionField <$> HashMap.lookup name fragments -selection subs fragments (Full.SelectionInlineFragment fragment) + TransformT (Either (NonEmpty Core.Selection) Core.Selection) +selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld +selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do + fragments' <- asks fragments + lift $ Left . fmap Core.SelectionField <$> HashMap.lookup name fragments' +selection (Full.SelectionInlineFragment fragment) | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment = Right . Core.SelectionFragment . Core.Fragment typeCondition - <$> appendSelection subs fragments selectionSet + <$> appendSelection selectionSet | (Full.InlineFragment Nothing _ selectionSet) <- fragment - = Left <$> appendSelection subs fragments selectionSet + = Left <$> appendSelection selectionSet -- * Fragment replacement @@ -81,74 +78,67 @@ defrag :: Full.Definition -> (Maybe Fragments, [Full.OperationDefinition]) -> (Maybe Fragments, [Full.OperationDefinition]) -defrag _ (Full.DefinitionOperation op) (fragments, operations') = - (fragments, op : operations') -defrag subs (Full.DefinitionFragment fragDef) (Just fragments, operations') = - (fragmentDefinition subs fragments fragDef, operations') +defrag _ (Full.DefinitionOperation op) (fragments', operations') = + (fragments', op : operations') +defrag subs (Full.DefinitionFragment fragDef) (Just fragments', operations') = + (runReaderT (fragmentDefinition fragDef) (Replacement subs fragments'), operations') defrag _ _ (Nothing, operations') = (Nothing, operations') -fragmentDefinition :: - Schema.Subs -> - Fragments -> - Full.FragmentDefinition -> - Maybe Fragments -fragmentDefinition subs fragments (Full.FragmentDefinition name _tc _dirs sels) = do +fragmentDefinition :: Full.FragmentDefinition -> TransformT Fragments +fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) = do emitted <- emitValue - newValue <- traverse extractField emitted - Just $ HashMap.insert name newValue fragments + newValue <- lift $ traverse extractField emitted + fragments' <- asks fragments + lift . Just $ HashMap.insert name newValue fragments' where - emitValue :: Maybe (NonEmpty Core.Selection) emitValue = do - selections <- traverse (selection subs fragments) sels + selections <- traverse selection sels pure $ selections >>= either id pure extractField :: Core.Selection -> Maybe Core.Field extractField (Core.SelectionField field') = Just field' extractField _ = Nothing -- Fragments within fragments are not supported yet -field :: Schema.Subs -> Fragments -> Full.Field -> Maybe Core.Field -field subs fragments (Full.Field a n args _dirs sels) = - Core.Field a n (fold $ argument subs `traverse` args) - <$> appendSelectionOpt subs fragments sels - -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.Variable n) = subs 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 subs (Full.List l) = - Core.List <$> traverse (value subs) l -value subs (Full.Object o) = - Core.Object . HashMap.fromList <$> traverse (objectField subs) o - -objectField :: Schema.Subs -> Full.ObjectField -> Maybe (Core.Name, Core.Value) -objectField subs (Full.ObjectField n v) = (n,) <$> value subs v +field :: Full.Field -> TransformT Core.Field +field (Full.Field a n args _dirs sels) = do + arguments <- traverse argument args + selection' <- appendSelectionOpt 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' <- asks substitute + 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 appendSelectionOpt :: Traversable t => - Schema.Subs -> - Fragments -> t Full.Selection -> - Maybe [Core.Selection] -appendSelectionOpt subs fragments = foldr go (Just []) + TransformT [Core.Selection] +appendSelectionOpt = foldM go [] where - go :: Full.Selection -> Maybe [Core.Selection] -> Maybe [Core.Selection] - go _ Nothing = Nothing - go sel (Just acc) = append acc <$> selection subs fragments sel + go acc sel = append acc <$> selection sel append acc (Left list) = NonEmpty.toList list <> acc append acc (Right one) = one : acc appendSelection :: - Schema.Subs -> - Fragments -> NonEmpty Full.Selection -> - Maybe (NonEmpty Core.Selection) -appendSelection subs fragments fullSelection = do - coreSelection <-appendSelectionOpt subs fragments fullSelection - NonEmpty.nonEmpty coreSelection + TransformT (NonEmpty Core.Selection) +appendSelection fullSelection = do + coreSelection <-appendSelectionOpt fullSelection + lift $ NonEmpty.nonEmpty coreSelection @@ -1,4 +1,4 @@ -resolver: lts-14.12 +resolver: lts-14.13 packages: - . |