AST.Transform: Pass down a reader

The reader contains variable substitution functions and fragments.
2019-11-06 06:34:36 +01:00
parent 73fc334bf8
commit b77da3d492
4 changed files with 79 additions and 89 deletions
--- 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
--- 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
--- 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
+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
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: lts-14.12
+resolver: lts-14.13

 packages:
 - .