AST.Transform: Pass down a reader

The reader contains variable substitution functions and fragments.

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

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

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
+    (runReaderT (operations operations') . Replacement subs) =<< fragments'
-      Just fragments' -> operations subs fragments' operations'
-      Nothing -> Nothing
   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 ::
+operations :: [Full.OperationDefinition] -> TransformT Core.Document
-    Schema.Subs ->
+operations operations' = do
-    Fragments ->
+    coreOperations <- traverse operation operations'
-    [Full.OperationDefinition] ->
+    lift $ NonEmpty.nonEmpty coreOperations
-    Maybe Core.Document
-operations subs fragments operations' = do
-    coreOperations <- traverse (operation subs fragments) operations'
-    NonEmpty.nonEmpty coreOperations
 
-operation ::
+operation :: Full.OperationDefinition -> TransformT Core.Operation
-    Schema.Subs ->
+operation (Full.OperationSelectionSet sels) =
-    Fragments ->
+    operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
-    Full.OperationDefinition ->
-    Maybe Core.Operation
-operation subs fragments (Full.OperationSelectionSet sels) =
-  operation subs fragments $ 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) =
+operation (Full.OperationDefinition Full.Query name _vars _dirs sels) =
-    Core.Query name <$> appendSelection subs fragments sels
+    Core.Query name <$> appendSelection sels
-operation subs fragments (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
+operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
-    Core.Mutation name <$> appendSelection subs fragments sels
+    Core.Mutation name <$> appendSelection sels
 
 selection ::
-    Schema.Subs ->
-    Fragments ->
     Full.Selection ->
-    Maybe (Either (NonEmpty Core.Selection) Core.Selection)
+    TransformT (Either (NonEmpty Core.Selection) Core.Selection)
-selection subs fragments (Full.SelectionField fld)
+selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld
-    = Right . Core.SelectionField <$> field subs fragments fld
+selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do
-selection _ fragments (Full.SelectionFragmentSpread (Full.FragmentSpread name _))
+    fragments' <- asks fragments
-    = Left . fmap Core.SelectionField <$> HashMap.lookup name fragments
+    lift $ Left . fmap Core.SelectionField <$> HashMap.lookup name fragments'
-selection subs fragments (Full.SelectionInlineFragment fragment)
+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') =
+defrag _ (Full.DefinitionOperation op) (fragments', operations') =
-    (fragments, op : operations')
+    (fragments', op : operations')
-defrag subs (Full.DefinitionFragment fragDef) (Just fragments, operations') =
+defrag subs (Full.DefinitionFragment fragDef) (Just fragments', operations') =
-    (fragmentDefinition subs fragments fragDef, operations')
+    (runReaderT (fragmentDefinition fragDef) (Replacement subs fragments'), operations')
 defrag _ _ (Nothing, operations') =
     (Nothing, operations')
 
-fragmentDefinition ::
+fragmentDefinition :: Full.FragmentDefinition -> TransformT Fragments
-    Schema.Subs ->
+fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) = do
-    Fragments ->
-    Full.FragmentDefinition ->
-    Maybe Fragments
-fragmentDefinition subs fragments (Full.FragmentDefinition name _tc _dirs sels) = do
     emitted <- emitValue
-    newValue <- traverse extractField emitted
+    newValue <- lift $ traverse extractField emitted
-    Just $ HashMap.insert name newValue fragments
+    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 :: Full.Field -> TransformT Core.Field
-field subs fragments (Full.Field a n args _dirs sels) =
+field (Full.Field a n args _dirs sels) = do
-    Core.Field a n (fold $ argument subs `traverse` args)
+    arguments <- traverse argument args
-    <$> appendSelectionOpt subs fragments sels
+    selection' <- appendSelectionOpt sels
+    return $ Core.Field a n arguments selection'
 
-argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument
+argument :: Full.Argument -> TransformT Core.Argument
-argument subs (Full.Argument n v) = Core.Argument n <$> value subs v
+argument (Full.Argument n v) = Core.Argument n <$> value v
 
-value :: Schema.Subs -> Full.Value -> Maybe Core.Value
+value :: Full.Value -> TransformT Core.Value
-value subs (Full.Variable n) = subs n
+value (Full.Variable n) = do
-value _    (Full.Int      i) = pure $ Core.Int i
+    substitute' <- asks substitute
-value _    (Full.Float    f) = pure $ Core.Float f
+    lift $ substitute' n
-value _    (Full.String   x) = pure $ Core.String x
+value (Full.Int i) = pure $ Core.Int i
-value _    (Full.Boolean  b) = pure $ Core.Boolean b
+value (Full.Float f) = pure $ Core.Float f
-value _     Full.Null        = pure   Core.Null
+value (Full.String x) = pure $ Core.String x
-value _    (Full.Enum     e) = pure $ Core.Enum e
+value (Full.Boolean b) = pure $ Core.Boolean b
-value subs (Full.List     l) =
+value Full.Null = pure   Core.Null
-    Core.List <$> traverse (value subs) l
+value (Full.Enum e) = pure $ Core.Enum e
-value subs (Full.Object   o) =
+value (Full.List l) =
-    Core.Object . HashMap.fromList <$> traverse (objectField subs) o
+    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 :: Full.ObjectField -> TransformT (Core.Name, Core.Value)
-objectField subs (Full.ObjectField n v) = (n,) <$> value subs v
+objectField (Full.ObjectField n v) = (n,) <$> value v
 
 appendSelectionOpt ::
     Traversable t =>
-    Schema.Subs ->
-    Fragments ->
     t Full.Selection ->
-    Maybe [Core.Selection]
+    TransformT [Core.Selection]
-appendSelectionOpt subs fragments = foldr go (Just [])
+appendSelectionOpt = foldM go []
   where
-    go :: Full.Selection -> Maybe [Core.Selection] -> Maybe [Core.Selection]
+    go acc sel = append acc <$> selection sel
-    go _ Nothing = Nothing
-    go sel (Just acc) = append acc <$> selection subs fragments 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)
+    TransformT (NonEmpty Core.Selection)
-appendSelection subs fragments fullSelection = do
+appendSelection fullSelection = do
-    coreSelection <-appendSelectionOpt subs fragments fullSelection
+    coreSelection <-appendSelectionOpt fullSelection
-    NonEmpty.nonEmpty coreSelection
+    lift $ NonEmpty.nonEmpty coreSelection

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-14.12
+resolver: lts-14.13
 
 packages:
 - .