AST.Transform: Pass down a reader
The reader contains variable substitution functions and fragments.
This commit is contained in:
parent
73fc334bf8
commit
b77da3d492
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
operations :: [Full.OperationDefinition] -> TransformT Core.Document
|
||||
operations operations' = do
|
||||
coreOperations <- traverse operation operations'
|
||||
lift $ 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
|
||||
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
|
||||
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 :: Schema.Subs -> Full.Argument -> Maybe Core.Argument
|
||||
argument subs (Full.Argument n v) = Core.Argument n <$> value subs v
|
||||
argument :: Full.Argument -> TransformT Core.Argument
|
||||
argument (Full.Argument n v) = Core.Argument n <$> value 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
|
||||
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 :: Schema.Subs -> Full.ObjectField -> Maybe (Core.Name, Core.Value)
|
||||
objectField subs (Full.ObjectField n v) = (n,) <$> value subs v
|
||||
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:
|
||||
- .
|
||||
|
||||
Loading…
Reference in New Issue
Block a user