{-# LANGUAGE TemplateHaskell #-}

-- | This module implements /fragment inlining/, which converts all fragment
-- spreads in a GraphQL query to inline fragments. For example, given a query like
--
-- > query {
-- >   users {
-- >     id
-- >     ...userFields
-- >   }
-- > }
-- >
-- > fragment userFields on User {
-- >   name
-- >   favoriteColor
-- > }
--
-- the fragment inliner will convert it to this:
--
-- > query {
-- >   users {
-- >     id
-- >     ... on User {
-- >       name
-- >       favoriteColor
-- >     }
-- >   }
-- > }
--
-- This is a straightforward and mechanical transformation, but it simplifies
-- further processing, since we catch unbound fragments and recursive fragment
-- definitions early in the pipeline, so parsing does not have to worry about it.
-- In that sense, fragment inlining is similar to the variable resolution pass
-- performed by "Hasura.GraphQL.Execute.Resolve", but for fragment definitions
-- rather than variables.
module Hasura.GraphQL.Execute.Inline
  ( InlineMT,
    InlineM,
    inlineSelectionSet,
    inlineField,
    runInlineMT,
    runInlineM,
  )
where

import Control.Lens
import Data.HashMap.Strict.Extended qualified as HashMap
import Data.HashSet qualified as Set
import Data.List qualified as L
import Data.Text qualified as T
import Data.Text.Extended
import Hasura.Base.Error
import Hasura.Prelude
import Hasura.Server.Utils
import Language.GraphQL.Draft.Syntax

-- | Internal bookkeeping used during inlining.
data InlineEnv = InlineEnv
  { -- | All known fragment definitions.
    InlineEnv -> HashMap Name FragmentDefinition
_ieFragmentDefinitions :: HashMap Name FragmentDefinition,
    -- | Fragments we’re currently inlining higher up in the call stack, used to
    -- detect fragment cycles.
    InlineEnv -> [Name]
_ieFragmentStack :: [Name]
  }

-- | Internal bookkeeping used during inlining.
newtype InlineState = InlineState
  { -- | A cache of fragment definitions we’ve already inlined, so we don’t need
    -- to inline them again.
    InlineState -> HashMap Name (InlineFragment NoFragments Name)
_isFragmentCache :: HashMap Name (InlineFragment NoFragments Name)
  }

$(makeLensesFor [("_ieFragmentStack", "ieFragmentStack")] ''InlineEnv)
$(makeLenses ''InlineState)

type MonadInline m =
  ( MonadError QErr m,
    MonadReader InlineEnv m,
    MonadState InlineState m
  )

type InlineMT m a = (MonadError QErr m) => (StateT InlineState (ReaderT InlineEnv m)) a

type InlineM a = InlineMT (Except QErr) a

{-# INLINE runInlineMT #-}
runInlineMT ::
  forall m a.
  (MonadError QErr m) =>
  HashMap Name FragmentDefinition ->
  InlineMT m a ->
  m a
runInlineMT :: forall (m :: * -> *) a.
MonadError QErr m =>
HashMap Name FragmentDefinition -> InlineMT m a -> m a
runInlineMT HashMap Name FragmentDefinition
uniqueFragmentDefinitions =
  (ReaderT InlineEnv m a -> InlineEnv -> m a)
-> InlineEnv -> ReaderT InlineEnv m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip
    ReaderT InlineEnv m a -> InlineEnv -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
    InlineEnv
      { _ieFragmentDefinitions :: HashMap Name FragmentDefinition
_ieFragmentDefinitions = HashMap Name FragmentDefinition
uniqueFragmentDefinitions,
        _ieFragmentStack :: [Name]
_ieFragmentStack = []
      }
    (ReaderT InlineEnv m a -> m a)
-> (StateT InlineState (ReaderT InlineEnv m) a
    -> ReaderT InlineEnv m a)
-> StateT InlineState (ReaderT InlineEnv m) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT InlineState (ReaderT InlineEnv m) a
 -> InlineState -> ReaderT InlineEnv m a)
-> InlineState
-> StateT InlineState (ReaderT InlineEnv m) a
-> ReaderT InlineEnv m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT InlineState (ReaderT InlineEnv m) a
-> InlineState -> ReaderT InlineEnv m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT InlineState {_isFragmentCache :: HashMap Name (InlineFragment NoFragments Name)
_isFragmentCache = HashMap Name (InlineFragment NoFragments Name)
forall a. Monoid a => a
mempty}

{-# INLINE runInlineM #-}
runInlineM ::
  forall a.
  HashMap Name FragmentDefinition ->
  InlineM a ->
  Either QErr a
runInlineM :: forall a.
HashMap Name FragmentDefinition -> InlineM a -> Either QErr a
runInlineM HashMap Name FragmentDefinition
fragments = Except QErr a -> Either QErr a
forall e a. Except e a -> Either e a
runExcept (Except QErr a -> Either QErr a)
-> (StateT InlineState (ReaderT InlineEnv (Except QErr)) a
    -> Except QErr a)
-> StateT InlineState (ReaderT InlineEnv (Except QErr)) a
-> Either QErr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Name FragmentDefinition -> InlineM a -> Except QErr a
forall (m :: * -> *) a.
MonadError QErr m =>
HashMap Name FragmentDefinition -> InlineMT m a -> m a
runInlineMT HashMap Name FragmentDefinition
fragments

-- | Inlines all fragment spreads in a 'SelectionSet'; see the module
-- documentation for "Hasura.GraphQL.Execute.Inline" for details.
inlineSelectionSet ::
  (MonadError QErr m, Foldable t) =>
  t FragmentDefinition ->
  SelectionSet FragmentSpread Name ->
  m (SelectionSet NoFragments Name)
inlineSelectionSet :: forall (m :: * -> *) (t :: * -> *).
(MonadError QErr m, Foldable t) =>
t FragmentDefinition
-> SelectionSet FragmentSpread Name
-> m (SelectionSet NoFragments Name)
inlineSelectionSet t FragmentDefinition
fragmentDefinitions SelectionSet FragmentSpread Name
selectionSet = do
  let fragmentDefinitionMap :: HashMap Name (NonEmpty FragmentDefinition)
fragmentDefinitionMap = (FragmentDefinition -> Name)
-> t FragmentDefinition
-> HashMap Name (NonEmpty FragmentDefinition)
forall k (t :: * -> *) v.
(Hashable k, Foldable t) =>
(v -> k) -> t v -> HashMap k (NonEmpty v)
HashMap.groupOnNE FragmentDefinition -> Name
_fdName t FragmentDefinition
fragmentDefinitions
  HashMap Name FragmentDefinition
uniqueFragmentDefinitions <- ((Name -> NonEmpty FragmentDefinition -> m FragmentDefinition)
 -> HashMap Name (NonEmpty FragmentDefinition)
 -> m (HashMap Name FragmentDefinition))
-> HashMap Name (NonEmpty FragmentDefinition)
-> (Name -> NonEmpty FragmentDefinition -> m FragmentDefinition)
-> m (HashMap Name FragmentDefinition)
forall a b c. (a -> b -> c) -> b -> a -> c
flip
    (Name -> NonEmpty FragmentDefinition -> m FragmentDefinition)
-> HashMap Name (NonEmpty FragmentDefinition)
-> m (HashMap Name FragmentDefinition)
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HashMap.traverseWithKey
    HashMap Name (NonEmpty FragmentDefinition)
fragmentDefinitionMap
    \Name
fragmentName NonEmpty FragmentDefinition
fragmentDefinitions' ->
      case NonEmpty FragmentDefinition
fragmentDefinitions' of
        FragmentDefinition
a :| [] -> FragmentDefinition -> m FragmentDefinition
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return FragmentDefinition
a
        NonEmpty FragmentDefinition
_ -> Code -> Text -> m FragmentDefinition
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ParseFailed (Text -> m FragmentDefinition) -> Text -> m FragmentDefinition
forall a b. (a -> b) -> a -> b
$ Text
"multiple definitions for fragment " Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
fragmentName
  let usedFragmentNames :: HashSet Name
usedFragmentNames = [Name] -> HashSet Name
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ SelectionSet FragmentSpread Name -> [Name]
fragmentsInSelectionSet SelectionSet FragmentSpread Name
selectionSet
      definedFragmentNames :: HashSet Name
definedFragmentNames = [Name] -> HashSet Name
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ HashMap Name FragmentDefinition -> [Name]
forall k v. HashMap k v -> [k]
HashMap.keys HashMap Name FragmentDefinition
uniqueFragmentDefinitions
      -- At the time of writing, this check is disabled using
      -- a local binding because, the master branch doesn't implement this
      -- check.
      -- TODO: Do this check using a feature flag
      isFragmentValidationEnabled :: Bool
isFragmentValidationEnabled = Bool
False
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isFragmentValidationEnabled Bool -> Bool -> Bool
&& (HashSet Name
usedFragmentNames HashSet Name -> HashSet Name -> Bool
forall a. Eq a => a -> a -> Bool
/= HashSet Name
definedFragmentNames))
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ValidationFailed
    (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"following fragment(s) have been defined, but have not been used in the query - "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat
      ( Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
L.intersperse Text
", "
          ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Name -> Text) -> [Name] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Text
unName
          ([Name] -> [Text]) -> [Name] -> [Text]
forall a b. (a -> b) -> a -> b
$ HashSet Name -> [Name]
forall a. HashSet a -> [a]
Set.toList
          (HashSet Name -> [Name]) -> HashSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ HashSet Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
Set.difference HashSet Name
definedFragmentNames HashSet Name
usedFragmentNames
      )
  -- The below code is a manual inlining of 'runInlineMT', as appearently the
  -- inlining optimization does not trigger, even with the INLINE pragma.
  (Selection FragmentSpread Name
 -> StateT
      InlineState (ReaderT InlineEnv m) (Selection NoFragments Name))
-> SelectionSet FragmentSpread Name
-> StateT
     InlineState (ReaderT InlineEnv m) (SelectionSet NoFragments Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Selection FragmentSpread Name
-> StateT
     InlineState (ReaderT InlineEnv m) (Selection NoFragments Name)
forall (m :: * -> *).
MonadInline m =>
Selection FragmentSpread Name -> m (Selection NoFragments Name)
inlineSelection SelectionSet FragmentSpread Name
selectionSet
    StateT
  InlineState (ReaderT InlineEnv m) (SelectionSet NoFragments Name)
-> (StateT
      InlineState (ReaderT InlineEnv m) (SelectionSet NoFragments Name)
    -> ReaderT InlineEnv m (SelectionSet NoFragments Name))
-> ReaderT InlineEnv m (SelectionSet NoFragments Name)
forall a b. a -> (a -> b) -> b
& (StateT
   InlineState (ReaderT InlineEnv m) (SelectionSet NoFragments Name)
 -> InlineState
 -> ReaderT InlineEnv m (SelectionSet NoFragments Name))
-> InlineState
-> StateT
     InlineState (ReaderT InlineEnv m) (SelectionSet NoFragments Name)
-> ReaderT InlineEnv m (SelectionSet NoFragments Name)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  InlineState (ReaderT InlineEnv m) (SelectionSet NoFragments Name)
-> InlineState
-> ReaderT InlineEnv m (SelectionSet NoFragments Name)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT InlineState {_isFragmentCache :: HashMap Name (InlineFragment NoFragments Name)
_isFragmentCache = HashMap Name (InlineFragment NoFragments Name)
forall a. Monoid a => a
mempty}
    ReaderT InlineEnv m (SelectionSet NoFragments Name)
-> (ReaderT InlineEnv m (SelectionSet NoFragments Name)
    -> m (SelectionSet NoFragments Name))
-> m (SelectionSet NoFragments Name)
forall a b. a -> (a -> b) -> b
& (ReaderT InlineEnv m (SelectionSet NoFragments Name)
 -> InlineEnv -> m (SelectionSet NoFragments Name))
-> InlineEnv
-> ReaderT InlineEnv m (SelectionSet NoFragments Name)
-> m (SelectionSet NoFragments Name)
forall a b c. (a -> b -> c) -> b -> a -> c
flip
      ReaderT InlineEnv m (SelectionSet NoFragments Name)
-> InlineEnv -> m (SelectionSet NoFragments Name)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
      InlineEnv
        { _ieFragmentDefinitions :: HashMap Name FragmentDefinition
_ieFragmentDefinitions = HashMap Name FragmentDefinition
uniqueFragmentDefinitions,
          _ieFragmentStack :: [Name]
_ieFragmentStack = []
        }
  where
    fragmentsInSelectionSet :: SelectionSet FragmentSpread Name -> [Name]
    fragmentsInSelectionSet :: SelectionSet FragmentSpread Name -> [Name]
fragmentsInSelectionSet SelectionSet FragmentSpread Name
selectionSet' = (Selection FragmentSpread Name -> [Name])
-> SelectionSet FragmentSpread Name -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Selection FragmentSpread Name -> [Name]
getFragFromSelection SelectionSet FragmentSpread Name
selectionSet'

    getFragFromSelection :: Selection FragmentSpread Name -> [Name]
    getFragFromSelection :: Selection FragmentSpread Name -> [Name]
getFragFromSelection = \case
      SelectionField Field FragmentSpread Name
fld -> SelectionSet FragmentSpread Name -> [Name]
fragmentsInSelectionSet (SelectionSet FragmentSpread Name -> [Name])
-> SelectionSet FragmentSpread Name -> [Name]
forall a b. (a -> b) -> a -> b
$ Field FragmentSpread Name -> SelectionSet FragmentSpread Name
forall (frag :: * -> *) var.
Field frag var -> SelectionSet frag var
_fSelectionSet Field FragmentSpread Name
fld
      SelectionFragmentSpread FragmentSpread Name
fragmentSpread -> [FragmentSpread Name -> Name
forall var. FragmentSpread var -> Name
_fsName FragmentSpread Name
fragmentSpread]
      SelectionInlineFragment InlineFragment FragmentSpread Name
inlineFragment -> SelectionSet FragmentSpread Name -> [Name]
fragmentsInSelectionSet (SelectionSet FragmentSpread Name -> [Name])
-> SelectionSet FragmentSpread Name -> [Name]
forall a b. (a -> b) -> a -> b
$ InlineFragment FragmentSpread Name
-> SelectionSet FragmentSpread Name
forall (frag :: * -> *) var.
InlineFragment frag var -> SelectionSet frag var
_ifSelectionSet InlineFragment FragmentSpread Name
inlineFragment

inlineSelection ::
  (MonadInline m) =>
  Selection FragmentSpread Name ->
  m (Selection NoFragments Name)
inlineSelection :: forall (m :: * -> *).
MonadInline m =>
Selection FragmentSpread Name -> m (Selection NoFragments Name)
inlineSelection (SelectionField Field FragmentSpread Name
field) =
  Text
-> m (Selection NoFragments Name) -> m (Selection NoFragments Name)
forall (m :: * -> *) a. QErrM m => Text -> m a -> m a
withPathK Text
"selectionSet" (m (Selection NoFragments Name) -> m (Selection NoFragments Name))
-> m (Selection NoFragments Name) -> m (Selection NoFragments Name)
forall a b. (a -> b) -> a -> b
$ Field NoFragments Name -> Selection NoFragments Name
forall (frag :: * -> *) var. Field frag var -> Selection frag var
SelectionField (Field NoFragments Name -> Selection NoFragments Name)
-> m (Field NoFragments Name) -> m (Selection NoFragments Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Field FragmentSpread Name -> m (Field NoFragments Name)
forall (m :: * -> *).
MonadInline m =>
Field FragmentSpread Name -> m (Field NoFragments Name)
inlineField Field FragmentSpread Name
field
inlineSelection (SelectionFragmentSpread FragmentSpread Name
spread) =
  Text
-> m (Selection NoFragments Name) -> m (Selection NoFragments Name)
forall (m :: * -> *) a. QErrM m => Text -> m a -> m a
withPathK Text
"selectionSet"
    (m (Selection NoFragments Name) -> m (Selection NoFragments Name))
-> m (Selection NoFragments Name) -> m (Selection NoFragments Name)
forall a b. (a -> b) -> a -> b
$ InlineFragment NoFragments Name -> Selection NoFragments Name
forall (frag :: * -> *) var.
InlineFragment frag var -> Selection frag var
SelectionInlineFragment
    (InlineFragment NoFragments Name -> Selection NoFragments Name)
-> m (InlineFragment NoFragments Name)
-> m (Selection NoFragments Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FragmentSpread Name -> m (InlineFragment NoFragments Name)
forall (m :: * -> *).
MonadInline m =>
FragmentSpread Name -> m (InlineFragment NoFragments Name)
inlineFragmentSpread FragmentSpread Name
spread
inlineSelection (SelectionInlineFragment fragment :: InlineFragment FragmentSpread Name
fragment@InlineFragment {SelectionSet FragmentSpread Name
_ifSelectionSet :: forall (frag :: * -> *) var.
InlineFragment frag var -> SelectionSet frag var
_ifSelectionSet :: SelectionSet FragmentSpread Name
_ifSelectionSet}) = do
  SelectionSet NoFragments Name
selectionSet <- (Selection FragmentSpread Name -> m (Selection NoFragments Name))
-> SelectionSet FragmentSpread Name
-> m (SelectionSet NoFragments Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Selection FragmentSpread Name -> m (Selection NoFragments Name)
forall (m :: * -> *).
MonadInline m =>
Selection FragmentSpread Name -> m (Selection NoFragments Name)
inlineSelection SelectionSet FragmentSpread Name
_ifSelectionSet
  Selection NoFragments Name -> m (Selection NoFragments Name)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Selection NoFragments Name -> m (Selection NoFragments Name))
-> Selection NoFragments Name -> m (Selection NoFragments Name)
forall a b. (a -> b) -> a -> b
$! InlineFragment NoFragments Name -> Selection NoFragments Name
forall (frag :: * -> *) var.
InlineFragment frag var -> Selection frag var
SelectionInlineFragment InlineFragment FragmentSpread Name
fragment {_ifSelectionSet :: SelectionSet NoFragments Name
_ifSelectionSet = SelectionSet NoFragments Name
selectionSet}

{-# INLINE inlineField #-}
inlineField :: (MonadInline m) => Field FragmentSpread Name -> m (Field NoFragments Name)
inlineField :: forall (m :: * -> *).
MonadInline m =>
Field FragmentSpread Name -> m (Field NoFragments Name)
inlineField field :: Field FragmentSpread Name
field@(Field {SelectionSet FragmentSpread Name
_fSelectionSet :: forall (frag :: * -> *) var.
Field frag var -> SelectionSet frag var
_fSelectionSet :: SelectionSet FragmentSpread Name
_fSelectionSet}) = Text -> m (Field NoFragments Name) -> m (Field NoFragments Name)
forall (m :: * -> *) a. QErrM m => Text -> m a -> m a
withPathK (Name -> Text
unName (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Field FragmentSpread Name -> Name
forall (frag :: * -> *) var. Field frag var -> Name
_fName Field FragmentSpread Name
field) (m (Field NoFragments Name) -> m (Field NoFragments Name))
-> m (Field NoFragments Name) -> m (Field NoFragments Name)
forall a b. (a -> b) -> a -> b
$ do
  SelectionSet NoFragments Name
selectionSet <- (Selection FragmentSpread Name -> m (Selection NoFragments Name))
-> SelectionSet FragmentSpread Name
-> m (SelectionSet NoFragments Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Selection FragmentSpread Name -> m (Selection NoFragments Name)
forall (m :: * -> *).
MonadInline m =>
Selection FragmentSpread Name -> m (Selection NoFragments Name)
inlineSelection SelectionSet FragmentSpread Name
_fSelectionSet
  Field NoFragments Name -> m (Field NoFragments Name)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Field NoFragments Name -> m (Field NoFragments Name))
-> Field NoFragments Name -> m (Field NoFragments Name)
forall a b. (a -> b) -> a -> b
$! Field FragmentSpread Name
field {_fSelectionSet :: SelectionSet NoFragments Name
_fSelectionSet = SelectionSet NoFragments Name
selectionSet}

inlineFragmentSpread ::
  (MonadInline m) =>
  FragmentSpread Name ->
  m (InlineFragment NoFragments Name)
inlineFragmentSpread :: forall (m :: * -> *).
MonadInline m =>
FragmentSpread Name -> m (InlineFragment NoFragments Name)
inlineFragmentSpread FragmentSpread {Name
_fsName :: forall var. FragmentSpread var -> Name
_fsName :: Name
_fsName, [Directive Name]
_fsDirectives :: [Directive Name]
_fsDirectives :: forall var. FragmentSpread var -> [Directive var]
_fsDirectives} = do
  InlineEnv {HashMap Name FragmentDefinition
_ieFragmentDefinitions :: InlineEnv -> HashMap Name FragmentDefinition
_ieFragmentDefinitions :: HashMap Name FragmentDefinition
_ieFragmentDefinitions, [Name]
_ieFragmentStack :: InlineEnv -> [Name]
_ieFragmentStack :: [Name]
_ieFragmentStack} <- m InlineEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  InlineState {HashMap Name (InlineFragment NoFragments Name)
_isFragmentCache :: InlineState -> HashMap Name (InlineFragment NoFragments Name)
_isFragmentCache :: HashMap Name (InlineFragment NoFragments Name)
_isFragmentCache} <- m InlineState
forall s (m :: * -> *). MonadState s m => m s
get

  if
    -- If we’ve already inlined this fragment, no need to process it again.
    | Just InlineFragment NoFragments Name
fragment <- Name
-> HashMap Name (InlineFragment NoFragments Name)
-> Maybe (InlineFragment NoFragments Name)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
_fsName HashMap Name (InlineFragment NoFragments Name)
_isFragmentCache ->
        InlineFragment NoFragments Name
-> m (InlineFragment NoFragments Name)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InlineFragment NoFragments Name
 -> m (InlineFragment NoFragments Name))
-> InlineFragment NoFragments Name
-> m (InlineFragment NoFragments Name)
forall a b. (a -> b) -> a -> b
$! InlineFragment NoFragments Name -> InlineFragment NoFragments Name
addSpreadDirectives InlineFragment NoFragments Name
fragment
    -- Fragment cycles are always illegal; see
    -- http://spec.graphql.org/June2018/#sec-Fragment-spreads-must-not-form-cycles
    | ([Name]
fragmentCycle, Name
_ : [Name]
_) <- (Name -> Bool) -> [Name] -> ([Name], [Name])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
_fsName) [Name]
_ieFragmentStack ->
        Code -> Text -> m (InlineFragment NoFragments Name)
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ValidationFailed
          (Text -> m (InlineFragment NoFragments Name))
-> Text -> m (InlineFragment NoFragments Name)
forall a b. (a -> b) -> a -> b
$ Text
"the fragment definition(s) "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> NonEmpty Text -> Text
englishList Text
"and" (Name -> Text
forall a. ToTxt a => a -> Text
toTxt (Name -> Text) -> NonEmpty Name -> NonEmpty Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name
_fsName Name -> [Name] -> NonEmpty Name
forall a. a -> [a] -> NonEmpty a
:| [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
fragmentCycle))
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" form a cycle"
    -- We didn’t hit the fragment cache, so look up the definition and convert
    -- it to an inline fragment.
    | Just FragmentDefinition {Name
_fdTypeCondition :: Name
_fdTypeCondition :: FragmentDefinition -> Name
_fdTypeCondition, SelectionSet FragmentSpread Name
_fdSelectionSet :: SelectionSet FragmentSpread Name
_fdSelectionSet :: FragmentDefinition -> SelectionSet FragmentSpread Name
_fdSelectionSet} <-
        Name -> HashMap Name FragmentDefinition -> Maybe FragmentDefinition
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
_fsName HashMap Name FragmentDefinition
_ieFragmentDefinitions -> Text
-> m (InlineFragment NoFragments Name)
-> m (InlineFragment NoFragments Name)
forall (m :: * -> *) a. QErrM m => Text -> m a -> m a
withPathK (Name -> Text
unName Name
_fsName) (m (InlineFragment NoFragments Name)
 -> m (InlineFragment NoFragments Name))
-> m (InlineFragment NoFragments Name)
-> m (InlineFragment NoFragments Name)
forall a b. (a -> b) -> a -> b
$ do
        SelectionSet NoFragments Name
selectionSet <-
          ASetter InlineEnv InlineEnv [Name] [Name]
-> ([Name] -> [Name])
-> m (SelectionSet NoFragments Name)
-> m (SelectionSet NoFragments Name)
forall s (m :: * -> *) a b r.
MonadReader s m =>
ASetter s s a b -> (a -> b) -> m r -> m r
locally ASetter InlineEnv InlineEnv [Name] [Name]
Lens' InlineEnv [Name]
ieFragmentStack (Name
_fsName Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:)
            (m (SelectionSet NoFragments Name)
 -> m (SelectionSet NoFragments Name))
-> m (SelectionSet NoFragments Name)
-> m (SelectionSet NoFragments Name)
forall a b. (a -> b) -> a -> b
$ (Selection FragmentSpread Name -> m (Selection NoFragments Name))
-> SelectionSet FragmentSpread Name
-> m (SelectionSet NoFragments Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Selection FragmentSpread Name -> m (Selection NoFragments Name)
forall (m :: * -> *).
MonadInline m =>
Selection FragmentSpread Name -> m (Selection NoFragments Name)
inlineSelection SelectionSet FragmentSpread Name
_fdSelectionSet

        let fragment :: InlineFragment NoFragments Name
fragment =
              InlineFragment
                { _ifTypeCondition :: Maybe Name
_ifTypeCondition = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
_fdTypeCondition,
                  -- As far as I can tell, the GraphQL spec says that directives
                  -- on the fragment definition do NOT apply to the fields in its
                  -- selection set.
                  _ifDirectives :: [Directive Name]
_ifDirectives = [],
                  _ifSelectionSet :: SelectionSet NoFragments Name
_ifSelectionSet = SelectionSet NoFragments Name
selectionSet
                }
        (InlineState -> InlineState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((InlineState -> InlineState) -> m ())
-> (InlineState -> InlineState) -> m ()
forall a b. (a -> b) -> a -> b
$ ASetter
  InlineState
  InlineState
  (HashMap Name (InlineFragment NoFragments Name))
  (HashMap Name (InlineFragment NoFragments Name))
-> (HashMap Name (InlineFragment NoFragments Name)
    -> HashMap Name (InlineFragment NoFragments Name))
-> InlineState
-> InlineState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  InlineState
  InlineState
  (HashMap Name (InlineFragment NoFragments Name))
  (HashMap Name (InlineFragment NoFragments Name))
Iso' InlineState (HashMap Name (InlineFragment NoFragments Name))
isFragmentCache ((HashMap Name (InlineFragment NoFragments Name)
  -> HashMap Name (InlineFragment NoFragments Name))
 -> InlineState -> InlineState)
-> (HashMap Name (InlineFragment NoFragments Name)
    -> HashMap Name (InlineFragment NoFragments Name))
-> InlineState
-> InlineState
forall a b. (a -> b) -> a -> b
$ Name
-> InlineFragment NoFragments Name
-> HashMap Name (InlineFragment NoFragments Name)
-> HashMap Name (InlineFragment NoFragments Name)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Name
_fsName InlineFragment NoFragments Name
fragment
        InlineFragment NoFragments Name
-> m (InlineFragment NoFragments Name)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InlineFragment NoFragments Name
 -> m (InlineFragment NoFragments Name))
-> InlineFragment NoFragments Name
-> m (InlineFragment NoFragments Name)
forall a b. (a -> b) -> a -> b
$! InlineFragment NoFragments Name -> InlineFragment NoFragments Name
addSpreadDirectives InlineFragment NoFragments Name
fragment

    -- If we get here, the fragment name is unbound; raise an error.
    -- http://spec.graphql.org/June2018/#sec-Fragment-spread-target-defined
    | Bool
otherwise ->
        Code -> Text -> m (InlineFragment NoFragments Name)
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
ValidationFailed
          (Text -> m (InlineFragment NoFragments Name))
-> Text -> m (InlineFragment NoFragments Name)
forall a b. (a -> b) -> a -> b
$ Text
"reference to undefined fragment "
          Text -> Name -> Text
forall t. ToTxt t => Text -> t -> Text
<>> Name
_fsName
  where
    addSpreadDirectives :: InlineFragment NoFragments Name -> InlineFragment NoFragments Name
addSpreadDirectives InlineFragment NoFragments Name
fragment =
      InlineFragment NoFragments Name
fragment {_ifDirectives :: [Directive Name]
_ifDirectives = InlineFragment NoFragments Name -> [Directive Name]
forall (frag :: * -> *) var.
InlineFragment frag var -> [Directive var]
_ifDirectives InlineFragment NoFragments Name
fragment [Directive Name] -> [Directive Name] -> [Directive Name]
forall a. [a] -> [a] -> [a]
++ [Directive Name]
_fsDirectives}