{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Types.Internal.AST.Selection
( Selection (..),
SelectionContent (..),
SelectionSet,
UnionTag (..),
UnionSelection,
Fragment (..),
Fragments,
Operation (..),
Variable (..),
VariableDefinitions,
DefaultValue,
getOperationName,
getOperationDataType,
splitSystemSelection,
)
where
import Control.Monad.Except (MonadError (throwError))
import Data.Foldable (foldr')
import Data.Mergeable
( Merge (..),
MergeMap,
NameCollision (..),
OrdMap,
)
import Data.Mergeable.MergeMap (partition)
import Data.Morpheus.Error.Operation
( mutationIsNotDefined,
subscriptionIsNotDefined,
)
import Data.Morpheus.Internal.Utils
( (<:>),
HistoryT,
KeyOf (..),
addPath,
)
import Data.Morpheus.Rendering.RenderGQL
( RenderGQL (..),
Rendering,
newline,
renderObject,
space,
)
import Data.Morpheus.Types.Internal.AST.Base
( Position,
Ref (..),
)
import Data.Morpheus.Types.Internal.AST.Error
( GQLError,
at,
atPositions,
msg,
)
import Data.Morpheus.Types.Internal.AST.Fields
( Arguments,
Directives,
renderArgumentValues,
renderDirectives,
)
import Data.Morpheus.Types.Internal.AST.Name
( FieldName,
FragmentName,
TypeName,
intercalate,
isNotSystemFieldName,
)
import Data.Morpheus.Types.Internal.AST.OperationType (OperationType (..))
import Data.Morpheus.Types.Internal.AST.Stage
( ALLOW_DUPLICATES,
RAW,
Stage,
VALID,
)
import Data.Morpheus.Types.Internal.AST.TypeCategory
( OBJECT,
)
import Data.Morpheus.Types.Internal.AST.TypeSystem
( Schema (..),
TypeDefinition (..),
)
import Data.Morpheus.Types.Internal.AST.Value
( ResolvedValue,
Variable (..),
VariableDefinitions,
)
import Language.Haskell.TH.Syntax (Lift (..))
import Relude hiding (intercalate, show)
import Prelude (show)
data Fragment (stage :: Stage) = Fragment
{ Fragment stage -> FragmentName
fragmentName :: FragmentName,
Fragment stage -> TypeName
fragmentType :: TypeName,
Fragment stage -> Position
fragmentPosition :: Position,
Fragment stage -> SelectionSet stage
fragmentSelection :: SelectionSet stage,
Fragment stage -> Directives stage
fragmentDirectives :: Directives stage
}
deriving (Int -> Fragment stage -> ShowS
[Fragment stage] -> ShowS
Fragment stage -> String
(Int -> Fragment stage -> ShowS)
-> (Fragment stage -> String)
-> ([Fragment stage] -> ShowS)
-> Show (Fragment stage)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (stage :: Stage). Int -> Fragment stage -> ShowS
forall (stage :: Stage). [Fragment stage] -> ShowS
forall (stage :: Stage). Fragment stage -> String
showList :: [Fragment stage] -> ShowS
$cshowList :: forall (stage :: Stage). [Fragment stage] -> ShowS
show :: Fragment stage -> String
$cshow :: forall (stage :: Stage). Fragment stage -> String
showsPrec :: Int -> Fragment stage -> ShowS
$cshowsPrec :: forall (stage :: Stage). Int -> Fragment stage -> ShowS
Show, Fragment stage -> Fragment stage -> Bool
(Fragment stage -> Fragment stage -> Bool)
-> (Fragment stage -> Fragment stage -> Bool)
-> Eq (Fragment stage)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (stage :: Stage). Fragment stage -> Fragment stage -> Bool
/= :: Fragment stage -> Fragment stage -> Bool
$c/= :: forall (stage :: Stage). Fragment stage -> Fragment stage -> Bool
== :: Fragment stage -> Fragment stage -> Bool
$c== :: forall (stage :: Stage). Fragment stage -> Fragment stage -> Bool
Eq, Fragment stage -> Q Exp
Fragment stage -> Q (TExp (Fragment stage))
(Fragment stage -> Q Exp)
-> (Fragment stage -> Q (TExp (Fragment stage)))
-> Lift (Fragment stage)
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
forall (stage :: Stage). Fragment stage -> Q Exp
forall (stage :: Stage).
Fragment stage -> Q (TExp (Fragment stage))
liftTyped :: Fragment stage -> Q (TExp (Fragment stage))
$cliftTyped :: forall (stage :: Stage).
Fragment stage -> Q (TExp (Fragment stage))
lift :: Fragment stage -> Q Exp
$clift :: forall (stage :: Stage). Fragment stage -> Q Exp
Lift)
instance NameCollision GQLError (Fragment s) where
nameCollision :: Fragment s -> GQLError
nameCollision Fragment {FragmentName
fragmentName :: FragmentName
fragmentName :: forall (stage :: Stage). Fragment stage -> FragmentName
fragmentName, Position
fragmentPosition :: Position
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition} =
(GQLError
"There can be only one fragment named " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> FragmentName -> GQLError
forall a. Msg a => a -> GQLError
msg FragmentName
fragmentName GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
".")
GQLError -> Position -> GQLError
`at` Position
fragmentPosition
instance KeyOf FragmentName (Fragment s) where
keyOf :: Fragment s -> FragmentName
keyOf = Fragment s -> FragmentName
forall (stage :: Stage). Fragment stage -> FragmentName
fragmentName
type Fragments (s :: Stage) = OrdMap FragmentName (Fragment s)
data SelectionContent (s :: Stage) where
SelectionField :: SelectionContent s
SelectionSet :: SelectionSet s -> SelectionContent s
UnionSelection ::
{ SelectionContent VALID -> SelectionSet VALID
defaultSelection :: SelectionSet VALID,
SelectionContent VALID -> UnionSelection VALID
conditionalSelections :: UnionSelection VALID
} ->
SelectionContent VALID
renderSelectionSet :: SelectionSet VALID -> Rendering
renderSelectionSet :: SelectionSet VALID -> Rendering
renderSelectionSet = [Selection VALID] -> Rendering
forall a. RenderGQL a => [a] -> Rendering
renderObject ([Selection VALID] -> Rendering)
-> (MergeMap 'False FieldName (Selection VALID)
-> [Selection VALID])
-> MergeMap 'False FieldName (Selection VALID)
-> Rendering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MergeMap 'False FieldName (Selection VALID) -> [Selection VALID]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
instance RenderGQL (SelectionContent VALID) where
renderGQL :: SelectionContent VALID -> Rendering
renderGQL SelectionContent VALID
SelectionField = Rendering
""
renderGQL (SelectionSet SelectionSet VALID
selSet) = SelectionSet VALID -> Rendering
renderSelectionSet SelectionSet VALID
selSet
renderGQL (UnionSelection SelectionSet VALID
interfaceFields UnionSelection VALID
unionSets) =
[Either (Selection VALID) UnionTag] -> Rendering
forall a. RenderGQL a => [a] -> Rendering
renderObject [Either (Selection VALID) UnionTag]
unionSelectionElements
where
unionSelectionElements :: [Either (Selection VALID) UnionTag]
unionSelectionElements :: [Either (Selection VALID) UnionTag]
unionSelectionElements =
(Selection VALID -> Either (Selection VALID) UnionTag)
-> [Selection VALID] -> [Either (Selection VALID) UnionTag]
forall a b. (a -> b) -> [a] -> [b]
map Selection VALID -> Either (Selection VALID) UnionTag
forall a b. a -> Either a b
Left (MergeMap 'False FieldName (Selection VALID) -> [Selection VALID]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
interfaceFields)
[Either (Selection VALID) UnionTag]
-> [Either (Selection VALID) UnionTag]
-> [Either (Selection VALID) UnionTag]
forall a. Semigroup a => a -> a -> a
<> (UnionTag -> Either (Selection VALID) UnionTag)
-> [UnionTag] -> [Either (Selection VALID) UnionTag]
forall a b. (a -> b) -> [a] -> [b]
map UnionTag -> Either (Selection VALID) UnionTag
forall a b. b -> Either a b
Right ((UnionTag -> TypeName) -> [UnionTag] -> [UnionTag]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn UnionTag -> TypeName
unionTagName ([UnionTag] -> [UnionTag]) -> [UnionTag] -> [UnionTag]
forall a b. (a -> b) -> a -> b
$ MergeMap 'False TypeName UnionTag -> [UnionTag]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList MergeMap 'False TypeName UnionTag
UnionSelection VALID
unionSets)
instance
( Monad m,
MonadError GQLError m,
Merge (HistoryT m) (SelectionSet s)
) =>
Merge (HistoryT m) (SelectionContent s)
where
merge :: SelectionContent s
-> SelectionContent s -> HistoryT m (SelectionContent s)
merge (SelectionSet SelectionSet s
s1) (SelectionSet SelectionSet s
s2) = SelectionSet s -> SelectionContent s
forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet (SelectionSet s -> SelectionContent s)
-> ReaderT [Ref FieldName] m (SelectionSet s)
-> HistoryT m (SelectionContent s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SelectionSet s
-> SelectionSet s -> ReaderT [Ref FieldName] m (SelectionSet s)
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge SelectionSet s
s1 SelectionSet s
s2
merge (UnionSelection SelectionSet VALID
m1 UnionSelection VALID
u1) (UnionSelection SelectionSet VALID
m2 UnionSelection VALID
u2) = MergeMap 'False FieldName (Selection VALID)
-> MergeMap 'False TypeName UnionTag -> SelectionContent s
SelectionSet VALID
-> UnionSelection VALID -> SelectionContent VALID
UnionSelection (MergeMap 'False FieldName (Selection VALID)
-> MergeMap 'False TypeName UnionTag -> SelectionContent s)
-> ReaderT
[Ref FieldName] m (MergeMap 'False FieldName (Selection VALID))
-> ReaderT
[Ref FieldName]
m
(MergeMap 'False TypeName UnionTag -> SelectionContent s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MergeMap 'False FieldName (Selection VALID)
-> MergeMap 'False FieldName (Selection VALID)
-> ReaderT
[Ref FieldName] m (MergeMap 'False FieldName (Selection VALID))
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
m1 MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
m2 ReaderT
[Ref FieldName]
m
(MergeMap 'False TypeName UnionTag -> SelectionContent s)
-> ReaderT [Ref FieldName] m (MergeMap 'False TypeName UnionTag)
-> HistoryT m (SelectionContent s)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MergeMap 'False TypeName UnionTag
-> MergeMap 'False TypeName UnionTag
-> ReaderT [Ref FieldName] m (MergeMap 'False TypeName UnionTag)
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge MergeMap 'False TypeName UnionTag
UnionSelection VALID
u1 MergeMap 'False TypeName UnionTag
UnionSelection VALID
u2
merge SelectionContent s
oldC SelectionContent s
currentC
| SelectionContent s
oldC SelectionContent s -> SelectionContent s -> Bool
forall a. Eq a => a -> a -> Bool
== SelectionContent s
currentC = SelectionContent s -> HistoryT m (SelectionContent s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure SelectionContent s
oldC
| Bool
otherwise = do
[Ref FieldName]
path <- ReaderT [Ref FieldName] m [Ref FieldName]
forall r (m :: * -> *). MonadReader r m => m r
ask
GQLError -> HistoryT m (SelectionContent s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
( Name Any -> GQLError
forall a. Msg a => a -> GQLError
msg (Name Any -> [FieldName] -> Name Any
forall (t1 :: NAME) (t2 :: NAME) (t3 :: NAME).
Name t1 -> [Name t2] -> Name t3
intercalate Name Any
"." ([FieldName] -> Name Any) -> [FieldName] -> Name Any
forall a b. (a -> b) -> a -> b
$ (Ref FieldName -> FieldName) -> [Ref FieldName] -> [FieldName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref FieldName -> FieldName
forall name. Ref name -> name
refName [Ref FieldName]
path)
GQLError -> [Position] -> GQLError
forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` (Ref FieldName -> Position) -> [Ref FieldName] -> [Position]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref FieldName -> Position
forall name. Ref name -> Position
refPosition [Ref FieldName]
path
)
deriving instance Show (SelectionContent a)
deriving instance Eq (SelectionContent a)
deriving instance Lift (SelectionContent a)
data UnionTag = UnionTag
{ UnionTag -> TypeName
unionTagName :: TypeName,
UnionTag -> SelectionSet VALID
unionTagSelection :: SelectionSet VALID
}
deriving (Int -> UnionTag -> ShowS
[UnionTag] -> ShowS
UnionTag -> String
(Int -> UnionTag -> ShowS)
-> (UnionTag -> String) -> ([UnionTag] -> ShowS) -> Show UnionTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnionTag] -> ShowS
$cshowList :: [UnionTag] -> ShowS
show :: UnionTag -> String
$cshow :: UnionTag -> String
showsPrec :: Int -> UnionTag -> ShowS
$cshowsPrec :: Int -> UnionTag -> ShowS
Show, UnionTag -> UnionTag -> Bool
(UnionTag -> UnionTag -> Bool)
-> (UnionTag -> UnionTag -> Bool) -> Eq UnionTag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnionTag -> UnionTag -> Bool
$c/= :: UnionTag -> UnionTag -> Bool
== :: UnionTag -> UnionTag -> Bool
$c== :: UnionTag -> UnionTag -> Bool
Eq, UnionTag -> Q Exp
UnionTag -> Q (TExp UnionTag)
(UnionTag -> Q Exp)
-> (UnionTag -> Q (TExp UnionTag)) -> Lift UnionTag
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UnionTag -> Q (TExp UnionTag)
$cliftTyped :: UnionTag -> Q (TExp UnionTag)
lift :: UnionTag -> Q Exp
$clift :: UnionTag -> Q Exp
Lift)
instance KeyOf TypeName UnionTag where
keyOf :: UnionTag -> TypeName
keyOf = UnionTag -> TypeName
unionTagName
instance RenderGQL UnionTag where
renderGQL :: UnionTag -> Rendering
renderGQL UnionTag {TypeName
unionTagName :: TypeName
unionTagName :: UnionTag -> TypeName
unionTagName, SelectionSet VALID
unionTagSelection :: SelectionSet VALID
unionTagSelection :: UnionTag -> SelectionSet VALID
unionTagSelection} =
Rendering
"... on "
Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> TypeName -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL TypeName
unionTagName
Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> SelectionSet VALID -> Rendering
renderSelectionSet SelectionSet VALID
unionTagSelection
mergeConflict :: (Monad m, MonadError GQLError m) => GQLError -> HistoryT m a
mergeConflict :: GQLError -> HistoryT m a
mergeConflict GQLError
err = do
[Ref FieldName]
path <- ReaderT [Ref FieldName] m [Ref FieldName]
forall r (m :: * -> *). MonadReader r m => m r
ask
[Ref FieldName] -> HistoryT m a
forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
[Ref FieldName] -> HistoryT m a
__mergeConflict [Ref FieldName]
path
where
__mergeConflict :: (Monad m, MonadError GQLError m) => [Ref FieldName] -> HistoryT m a
__mergeConflict :: [Ref FieldName] -> HistoryT m a
__mergeConflict [] = GQLError -> HistoryT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
err
__mergeConflict refs :: [Ref FieldName]
refs@(Ref FieldName
rootField : [Ref FieldName]
xs) =
GQLError -> HistoryT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
(GQLError
renderSubfields GQLError -> [Position] -> GQLError
forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` (Ref FieldName -> Position) -> [Ref FieldName] -> [Position]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref FieldName -> Position
forall name. Ref name -> Position
refPosition [Ref FieldName]
refs GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
err)
where
fieldConflicts :: Ref a -> GQLError
fieldConflicts Ref a
ref = a -> GQLError
forall a. Msg a => a -> GQLError
msg (Ref a -> a
forall name. Ref name -> name
refName Ref a
ref) GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" conflict because "
renderSubfield :: Ref a -> GQLError -> GQLError
renderSubfield Ref a
ref GQLError
txt = GQLError
txt GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"subfields " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Ref a -> GQLError
forall a. Msg a => Ref a -> GQLError
fieldConflicts Ref a
ref
renderStart :: GQLError
renderStart = GQLError
"Fields " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Ref FieldName -> GQLError
forall a. Msg a => Ref a -> GQLError
fieldConflicts Ref FieldName
rootField
renderSubfields :: GQLError
renderSubfields =
(Ref FieldName -> GQLError -> GQLError)
-> GQLError -> [Ref FieldName] -> GQLError
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr'
Ref FieldName -> GQLError -> GQLError
forall a. Msg a => Ref a -> GQLError -> GQLError
renderSubfield
GQLError
renderStart
[Ref FieldName]
xs
instance
( Monad m,
MonadError GQLError m
) =>
Merge (HistoryT m) UnionTag
where
merge :: UnionTag -> UnionTag -> HistoryT m UnionTag
merge (UnionTag TypeName
oldTag SelectionSet VALID
oldSel) (UnionTag TypeName
_ SelectionSet VALID
currentSel) =
TypeName -> SelectionSet VALID -> UnionTag
UnionTag TypeName
oldTag (MergeMap 'False FieldName (Selection VALID) -> UnionTag)
-> ReaderT
[Ref FieldName] m (MergeMap 'False FieldName (Selection VALID))
-> HistoryT m UnionTag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MergeMap 'False FieldName (Selection VALID)
-> MergeMap 'False FieldName (Selection VALID)
-> ReaderT
[Ref FieldName] m (MergeMap 'False FieldName (Selection VALID))
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
oldSel MergeMap 'False FieldName (Selection VALID)
SelectionSet VALID
currentSel
type UnionSelection (s :: Stage) = MergeMap (ALLOW_DUPLICATES s) TypeName UnionTag
type SelectionSet (s :: Stage) = MergeMap (ALLOW_DUPLICATES s) FieldName (Selection s)
splitSystemSelection :: SelectionSet s -> (Maybe (SelectionSet s), Maybe (SelectionSet s))
splitSystemSelection :: SelectionSet s -> (Maybe (SelectionSet s), Maybe (SelectionSet s))
splitSystemSelection = (Selection s -> Bool)
-> SelectionSet s
-> (Maybe (SelectionSet s), Maybe (SelectionSet s))
forall a (dups :: Bool) k.
(a -> Bool)
-> MergeMap dups k a
-> (Maybe (MergeMap dups k a), Maybe (MergeMap dups k a))
partition (Bool -> Bool
not (Bool -> Bool) -> (Selection s -> Bool) -> Selection s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Bool
isNotSystemFieldName (FieldName -> Bool)
-> (Selection s -> FieldName) -> Selection s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selection s -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName)
data Selection (s :: Stage) where
Selection ::
{ Selection s -> Position
selectionPosition :: Position,
Selection s -> Maybe FieldName
selectionAlias :: Maybe FieldName,
Selection s -> FieldName
selectionName :: FieldName,
Selection s -> Arguments s
selectionArguments :: Arguments s,
Selection s -> Directives s
selectionDirectives :: Directives s,
Selection s -> SelectionContent s
selectionContent :: SelectionContent s
} ->
Selection s
InlineFragment :: Fragment RAW -> Selection RAW
Spread :: Directives RAW -> Ref FragmentName -> Selection RAW
instance RenderGQL (Selection VALID) where
renderGQL :: Selection VALID -> Rendering
renderGQL
Selection
{ Maybe FieldName
Directives VALID
Arguments VALID
Position
FieldName
SelectionContent VALID
selectionContent :: SelectionContent VALID
selectionDirectives :: Directives VALID
selectionArguments :: Arguments VALID
selectionName :: FieldName
selectionAlias :: Maybe FieldName
selectionPosition :: Position
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionDirectives :: forall (s :: Stage). Selection s -> Directives s
selectionArguments :: forall (s :: Stage). Selection s -> Arguments s
selectionAlias :: forall (s :: Stage). Selection s -> Maybe FieldName
selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionName :: forall (s :: Stage). Selection s -> FieldName
..
} =
FieldName -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL (FieldName -> Maybe FieldName -> FieldName
forall a. a -> Maybe a -> a
fromMaybe FieldName
selectionName Maybe FieldName
selectionAlias)
Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Arguments VALID -> Rendering
forall (s :: Stage). Arguments s -> Rendering
renderArgumentValues Arguments VALID
selectionArguments
Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Directives VALID -> Rendering
forall (s :: Stage). Directives s -> Rendering
renderDirectives Directives VALID
selectionDirectives
Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> SelectionContent VALID -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL SelectionContent VALID
selectionContent
instance KeyOf FieldName (Selection s) where
keyOf :: Selection s -> FieldName
keyOf
Selection
{ FieldName
selectionName :: FieldName
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionName,
Maybe FieldName
selectionAlias :: Maybe FieldName
selectionAlias :: forall (s :: Stage). Selection s -> Maybe FieldName
selectionAlias
} = FieldName -> Maybe FieldName -> FieldName
forall a. a -> Maybe a -> a
fromMaybe FieldName
selectionName Maybe FieldName
selectionAlias
keyOf Selection s
_ = FieldName
""
useDifferentAliases :: GQLError
useDifferentAliases :: GQLError
useDifferentAliases =
GQLError
"Use different aliases on the "
GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
"fields to fetch both if this was intentional."
instance
( Monad m,
MonadError GQLError m,
Merge (HistoryT m) (SelectionSet s)
) =>
Merge (HistoryT m) (Selection s)
where
merge :: Selection s -> Selection s -> HistoryT m (Selection s)
merge = Selection s -> Selection s -> HistoryT m (Selection s)
forall (m :: * -> *) (s :: Stage).
(Monad m, MonadError GQLError m,
Merge (HistoryT m) (SelectionSet s)) =>
Selection s -> Selection s -> HistoryT m (Selection s)
mergeSelection
mergeSelection ::
( Monad m,
MonadError GQLError m,
Merge (HistoryT m) (SelectionSet s)
) =>
Selection s ->
Selection s ->
HistoryT m (Selection s)
mergeSelection :: Selection s -> Selection s -> HistoryT m (Selection s)
mergeSelection
old :: Selection s
old@Selection {selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition = Position
pos1}
current :: Selection s
current@Selection {selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition = Position
pos2} =
do
FieldName
selectionName <- [Position] -> Selection s -> Selection s -> HistoryT m FieldName
forall (m :: * -> *) (t :: * -> *) (s1 :: Stage) (s2 :: Stage).
(Monad m, MonadError GQLError m, Foldable t) =>
t Position -> Selection s1 -> Selection s2 -> HistoryT m FieldName
mergeName [Position
pos1, Position
pos2] Selection s
old Selection s
current
Ref FieldName
-> HistoryT m (Selection s) -> HistoryT m (Selection s)
forall a1 (m :: * -> *) a2.
MonadReader [a1] m =>
a1 -> m a2 -> m a2
addPath (FieldName -> Position -> Ref FieldName
forall name. name -> Position -> Ref name
Ref FieldName
selectionName Position
pos1) (HistoryT m (Selection s) -> HistoryT m (Selection s))
-> HistoryT m (Selection s) -> HistoryT m (Selection s)
forall a b. (a -> b) -> a -> b
$ do
Arguments s
selectionArguments <- ReaderT [Ref FieldName] m (Arguments s)
mergeArguments
SelectionContent s
selectionContent <- SelectionContent s
-> SelectionContent s
-> ReaderT [Ref FieldName] m (SelectionContent s)
forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge (Selection s -> SelectionContent s
forall (s :: Stage). Selection s -> SelectionContent s
selectionContent Selection s
old) (Selection s -> SelectionContent s
forall (s :: Stage). Selection s -> SelectionContent s
selectionContent Selection s
current)
Directives s
dirs <- Selection s -> Directives s
forall (s :: Stage). Selection s -> Directives s
selectionDirectives Selection s
old Directives s
-> Directives s -> ReaderT [Ref FieldName] m (Directives s)
forall (m :: * -> *) a.
(Merge (HistoryT m) a, Monad m) =>
a -> a -> m a
<:> Selection s -> Directives s
forall (s :: Stage). Selection s -> Directives s
selectionDirectives Selection s
current
Selection s -> HistoryT m (Selection s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Selection s -> HistoryT m (Selection s))
-> Selection s -> HistoryT m (Selection s)
forall a b. (a -> b) -> a -> b
$
Selection :: forall (s :: Stage).
Position
-> Maybe FieldName
-> FieldName
-> Arguments s
-> Directives s
-> SelectionContent s
-> Selection s
Selection
{ selectionAlias :: Maybe FieldName
selectionAlias = Maybe FieldName
mergeAlias,
selectionPosition :: Position
selectionPosition = Position
pos1,
selectionDirectives :: Directives s
selectionDirectives = Directives s
dirs,
Arguments s
FieldName
SelectionContent s
selectionContent :: SelectionContent s
selectionArguments :: Arguments s
selectionName :: FieldName
selectionContent :: SelectionContent s
selectionArguments :: Arguments s
selectionName :: FieldName
..
}
where
mergeAlias :: Maybe FieldName
mergeAlias
| (Selection s -> Bool) -> [Selection s] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe FieldName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FieldName -> Bool)
-> (Selection s -> Maybe FieldName) -> Selection s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selection s -> Maybe FieldName
forall (s :: Stage). Selection s -> Maybe FieldName
selectionAlias) [Selection s
old, Selection s
current] = Selection s -> Maybe FieldName
forall (s :: Stage). Selection s -> Maybe FieldName
selectionAlias Selection s
old
| Bool
otherwise = Maybe FieldName
forall a. Maybe a
Nothing
mergeArguments :: ReaderT [Ref FieldName] m (Arguments s)
mergeArguments
| Selection s -> Arguments s
forall (s :: Stage). Selection s -> Arguments s
selectionArguments Selection s
old Arguments s -> Arguments s -> Bool
forall a. Eq a => a -> a -> Bool
== Selection s -> Arguments s
forall (s :: Stage). Selection s -> Arguments s
selectionArguments Selection s
current = Arguments s -> ReaderT [Ref FieldName] m (Arguments s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arguments s -> ReaderT [Ref FieldName] m (Arguments s))
-> Arguments s -> ReaderT [Ref FieldName] m (Arguments s)
forall a b. (a -> b) -> a -> b
$ Selection s -> Arguments s
forall (s :: Stage). Selection s -> Arguments s
selectionArguments Selection s
current
| Bool
otherwise =
GQLError -> ReaderT [Ref FieldName] m (Arguments s)
forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
GQLError -> HistoryT m a
mergeConflict (GQLError -> ReaderT [Ref FieldName] m (Arguments s))
-> GQLError -> ReaderT [Ref FieldName] m (Arguments s)
forall a b. (a -> b) -> a -> b
$
(GQLError
"they have differing arguments. " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
useDifferentAliases)
GQLError -> [Position] -> GQLError
forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` [Position
pos1, Position
pos2]
mergeSelection Selection s
x Selection s
y = GQLError -> HistoryT m (Selection s)
forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
GQLError -> HistoryT m a
mergeConflict (GQLError
"INTERNAL: can't merge. " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Selection s -> GQLError
forall a. Show a => a -> GQLError
msgValue Selection s
x GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Selection s -> GQLError
forall a. Show a => a -> GQLError
msgValue Selection s
y GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
useDifferentAliases)
msgValue :: Show a => a -> GQLError
msgValue :: a -> GQLError
msgValue = String -> GQLError
forall a. Msg a => a -> GQLError
msg (String -> GQLError) -> (a -> String) -> a -> GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
mergeName ::
(Monad m, MonadError GQLError m, Foldable t) =>
t Position ->
Selection s1 ->
Selection s2 ->
HistoryT m FieldName
mergeName :: t Position -> Selection s1 -> Selection s2 -> HistoryT m FieldName
mergeName t Position
pos Selection s1
old Selection s2
current
| Selection s1 -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection s1
old FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== Selection s2 -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection s2
current = FieldName -> HistoryT m FieldName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName -> HistoryT m FieldName)
-> FieldName -> HistoryT m FieldName
forall a b. (a -> b) -> a -> b
$ Selection s2 -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection s2
current
| Bool
otherwise =
GQLError -> HistoryT m FieldName
forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
GQLError -> HistoryT m a
mergeConflict (GQLError -> HistoryT m FieldName)
-> GQLError -> HistoryT m FieldName
forall a b. (a -> b) -> a -> b
$
( FieldName -> GQLError
forall a. Msg a => a -> GQLError
msg (Selection s1 -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection s1
old)
GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" and "
GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> FieldName -> GQLError
forall a. Msg a => a -> GQLError
msg (Selection s2 -> FieldName
forall (s :: Stage). Selection s -> FieldName
selectionName Selection s2
current)
GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" are different fields. "
GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
useDifferentAliases
)
GQLError -> t Position -> GQLError
forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` t Position
pos
deriving instance Show (Selection a)
deriving instance Lift (Selection a)
deriving instance Eq (Selection a)
type DefaultValue = Maybe ResolvedValue
data Operation (s :: Stage) = Operation
{ Operation s -> Position
operationPosition :: Position,
Operation s -> OperationType
operationType :: OperationType,
Operation s -> Maybe FieldName
operationName :: Maybe FieldName,
Operation s -> VariableDefinitions s
operationArguments :: VariableDefinitions s,
Operation s -> Directives s
operationDirectives :: Directives s,
Operation s -> SelectionSet s
operationSelection :: SelectionSet s
}
deriving (Int -> Operation s -> ShowS
[Operation s] -> ShowS
Operation s -> String
(Int -> Operation s -> ShowS)
-> (Operation s -> String)
-> ([Operation s] -> ShowS)
-> Show (Operation s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Stage). Int -> Operation s -> ShowS
forall (s :: Stage). [Operation s] -> ShowS
forall (s :: Stage). Operation s -> String
showList :: [Operation s] -> ShowS
$cshowList :: forall (s :: Stage). [Operation s] -> ShowS
show :: Operation s -> String
$cshow :: forall (s :: Stage). Operation s -> String
showsPrec :: Int -> Operation s -> ShowS
$cshowsPrec :: forall (s :: Stage). Int -> Operation s -> ShowS
Show, Operation s -> Q Exp
Operation s -> Q (TExp (Operation s))
(Operation s -> Q Exp)
-> (Operation s -> Q (TExp (Operation s))) -> Lift (Operation s)
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
forall (s :: Stage). Operation s -> Q Exp
forall (s :: Stage). Operation s -> Q (TExp (Operation s))
liftTyped :: Operation s -> Q (TExp (Operation s))
$cliftTyped :: forall (s :: Stage). Operation s -> Q (TExp (Operation s))
lift :: Operation s -> Q Exp
$clift :: forall (s :: Stage). Operation s -> Q Exp
Lift)
instance RenderGQL (Operation VALID) where
renderGQL :: Operation VALID -> Rendering
renderGQL
Operation
{ Maybe FieldName
operationName :: Maybe FieldName
operationName :: forall (s :: Stage). Operation s -> Maybe FieldName
operationName,
OperationType
operationType :: OperationType
operationType :: forall (s :: Stage). Operation s -> OperationType
operationType,
Directives VALID
operationDirectives :: Directives VALID
operationDirectives :: forall (s :: Stage). Operation s -> Directives s
operationDirectives,
SelectionSet VALID
operationSelection :: SelectionSet VALID
operationSelection :: forall (s :: Stage). Operation s -> SelectionSet s
operationSelection
} =
OperationType -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL OperationType
operationType
Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
-> (FieldName -> Rendering) -> Maybe FieldName -> Rendering
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rendering
"" ((Rendering
space Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<>) (Rendering -> Rendering)
-> (FieldName -> Rendering) -> FieldName -> Rendering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Rendering
forall a. RenderGQL a => a -> Rendering
renderGQL) Maybe FieldName
operationName
Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Directives VALID -> Rendering
forall (s :: Stage). Directives s -> Rendering
renderDirectives Directives VALID
operationDirectives
Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> SelectionSet VALID -> Rendering
renderSelectionSet SelectionSet VALID
operationSelection
Rendering -> Rendering -> Rendering
forall a. Semigroup a => a -> a -> a
<> Rendering
newline
getOperationName :: Maybe FieldName -> TypeName
getOperationName :: Maybe FieldName -> TypeName
getOperationName = TypeName -> (FieldName -> TypeName) -> Maybe FieldName -> TypeName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeName
"AnonymousOperation" FieldName -> TypeName
coerce
getOperationDataType :: MonadError GQLError m => Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID)
getOperationDataType :: Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID)
getOperationDataType Operation {operationType :: forall (s :: Stage). Operation s -> OperationType
operationType = OperationType
Query} Schema VALID
lib = TypeDefinition OBJECT VALID -> m (TypeDefinition OBJECT VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema VALID -> TypeDefinition OBJECT VALID
forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
query Schema VALID
lib)
getOperationDataType Operation {operationType :: forall (s :: Stage). Operation s -> OperationType
operationType = OperationType
Mutation, Position
operationPosition :: Position
operationPosition :: forall (s :: Stage). Operation s -> Position
operationPosition} Schema VALID
lib =
m (TypeDefinition OBJECT VALID)
-> (TypeDefinition OBJECT VALID -> m (TypeDefinition OBJECT VALID))
-> Maybe (TypeDefinition OBJECT VALID)
-> m (TypeDefinition OBJECT VALID)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GQLError -> m (TypeDefinition OBJECT VALID)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> m (TypeDefinition OBJECT VALID))
-> GQLError -> m (TypeDefinition OBJECT VALID)
forall a b. (a -> b) -> a -> b
$ Position -> GQLError
mutationIsNotDefined Position
operationPosition) TypeDefinition OBJECT VALID -> m (TypeDefinition OBJECT VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema VALID -> Maybe (TypeDefinition OBJECT VALID)
forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
mutation Schema VALID
lib)
getOperationDataType Operation {operationType :: forall (s :: Stage). Operation s -> OperationType
operationType = OperationType
Subscription, Position
operationPosition :: Position
operationPosition :: forall (s :: Stage). Operation s -> Position
operationPosition} Schema VALID
lib =
m (TypeDefinition OBJECT VALID)
-> (TypeDefinition OBJECT VALID -> m (TypeDefinition OBJECT VALID))
-> Maybe (TypeDefinition OBJECT VALID)
-> m (TypeDefinition OBJECT VALID)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (GQLError -> m (TypeDefinition OBJECT VALID)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> m (TypeDefinition OBJECT VALID))
-> GQLError -> m (TypeDefinition OBJECT VALID)
forall a b. (a -> b) -> a -> b
$ Position -> GQLError
subscriptionIsNotDefined Position
operationPosition) TypeDefinition OBJECT VALID -> m (TypeDefinition OBJECT VALID)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema VALID -> Maybe (TypeDefinition OBJECT VALID)
forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
subscription Schema VALID
lib)