{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# 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
  { forall (stage :: Stage). Fragment stage -> FragmentName
fragmentName :: FragmentName,
    forall (stage :: Stage). Fragment stage -> TypeName
fragmentType :: TypeName,
    forall (stage :: Stage). Fragment stage -> Position
fragmentPosition :: Position,
    forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection :: SelectionSet stage,
    forall (stage :: Stage). Fragment stage -> Directives stage
fragmentDirectives :: Directives stage
  }
  deriving (Int -> Fragment stage -> ShowS
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
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, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (stage :: Stage) (m :: * -> *).
Quote m =>
Fragment stage -> m Exp
forall (stage :: Stage) (m :: * -> *).
Quote m =>
Fragment stage -> Code m (Fragment stage)
forall (m :: * -> *). Quote m => Fragment stage -> m Exp
forall (m :: * -> *).
Quote m =>
Fragment stage -> Code m (Fragment stage)
liftTyped :: forall (m :: * -> *).
Quote m =>
Fragment stage -> Code m (Fragment stage)
$cliftTyped :: forall (stage :: Stage) (m :: * -> *).
Quote m =>
Fragment stage -> Code m (Fragment stage)
lift :: forall (m :: * -> *). Quote m => Fragment stage -> m Exp
$clift :: forall (stage :: Stage) (m :: * -> *).
Quote m =>
Fragment stage -> m Exp
Lift, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (stage :: Stage) x. Rep (Fragment stage) x -> Fragment stage
forall (stage :: Stage) x. Fragment stage -> Rep (Fragment stage) x
$cto :: forall (stage :: Stage) x. Rep (Fragment stage) x -> Fragment stage
$cfrom :: forall (stage :: Stage) x. Fragment stage -> Rep (Fragment stage) x
Generic, forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall (stage :: Stage). Eq (Fragment stage)
forall (stage :: Stage). Int -> Fragment stage -> Int
forall (stage :: Stage). Fragment stage -> Int
hash :: Fragment stage -> Int
$chash :: forall (stage :: Stage). Fragment stage -> Int
hashWithSalt :: Int -> Fragment stage -> Int
$chashWithSalt :: forall (stage :: Stage). Int -> Fragment stage -> Int
Hashable)

-- ERRORs
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 " forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg FragmentName
fragmentName 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 = 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 -> Maybe (SelectionSet 'VALID)
defaultSelection :: Maybe (SelectionSet VALID),
      SelectionContent 'VALID -> UnionSelection 'VALID
conditionalSelections :: UnionSelection VALID
    } ->
    SelectionContent VALID

instance Hashable (SelectionContent s) where
  hashWithSalt :: Int -> SelectionContent s -> Int
hashWithSalt Int
s SelectionContent s
SelectionField = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Int
1 :: Int)
  hashWithSalt Int
s (SelectionSet MergeMap (ALLOW_DUPLICATES s) FieldName (Selection s)
x) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Int
2 :: Int, MergeMap (ALLOW_DUPLICATES s) FieldName (Selection s)
x)
  hashWithSalt Int
s (UnionSelection Maybe (SelectionSet 'VALID)
x UnionSelection 'VALID
xs) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Int
3 :: Int, Maybe (SelectionSet 'VALID)
x, UnionSelection 'VALID
xs)

renderSelectionSet :: SelectionSet VALID -> Rendering
renderSelectionSet :: SelectionSet 'VALID -> Rendering
renderSelectionSet = forall a. RenderGQL a => [a] -> Rendering
renderObject forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 Maybe (SelectionSet 'VALID)
interfaceFields UnionSelection 'VALID
unionSets) =
    forall a. RenderGQL a => [a] -> Rendering
renderObject [Either (Selection 'VALID) UnionTag]
unionSelectionElements
    where
      unionSelectionElements :: [Either (Selection VALID) UnionTag]
      unionSelectionElements :: [Either (Selection 'VALID) UnionTag]
unionSelectionElements =
        forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList Maybe (SelectionSet 'VALID)
interfaceFields)
          forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right (forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn UnionTag -> TypeName
unionTagName forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UnionSelection 'VALID
unionSets)

instance
  ( Monad m,
    MonadError GQLError m,
    Merge (HistoryT m) (SelectionSet s)
  ) =>
  Merge (HistoryT m) (SelectionContent s)
  where
  merge :: Monad (HistoryT m) =>
SelectionContent s
-> SelectionContent s -> HistoryT m (SelectionContent s)
merge (SelectionSet SelectionSet s
s1) (SelectionSet SelectionSet s
s2) = forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge SelectionSet s
s1 SelectionSet s
s2
  merge (UnionSelection Maybe (SelectionSet 'VALID)
m1 UnionSelection 'VALID
u1) (UnionSelection Maybe (SelectionSet 'VALID)
m2 UnionSelection 'VALID
u2) = Maybe (SelectionSet 'VALID)
-> UnionSelection 'VALID -> SelectionContent 'VALID
UnionSelection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a.
(Merge f a, Monad f) =>
Maybe a -> Maybe a -> f (Maybe a)
withMaybe Maybe (SelectionSet 'VALID)
m1 Maybe (SelectionSet 'VALID)
m2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge UnionSelection 'VALID
u1 UnionSelection 'VALID
u2
  merge SelectionContent s
oldC SelectionContent s
currentC
    | SelectionContent s
oldC forall a. Eq a => a -> a -> Bool
== SelectionContent s
currentC = forall (f :: * -> *) a. Applicative f => a -> f a
pure SelectionContent s
oldC
    | Bool
otherwise = do
        [Ref FieldName]
path <- forall r (m :: * -> *). MonadReader r m => m r
ask
        forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
          ( forall a. Msg a => a -> GQLError
msg (forall (t1 :: NAME) (t2 :: NAME) (t3 :: NAME).
Name t1 -> [Name t2] -> Name t3
intercalate Name Any
"." forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall name. Ref name -> name
refName [Ref FieldName]
path)
              forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall name. Ref name -> Position
refPosition [Ref FieldName]
path
          )

withMaybe :: (Merge f a, Monad f) => Maybe a -> Maybe a -> f (Maybe a)
withMaybe :: forall (f :: * -> *) a.
(Merge f a, Monad f) =>
Maybe a -> Maybe a -> f (Maybe a)
withMaybe (Just a
x) (Just a
y) = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge a
x a
y
withMaybe (Just a
x) Maybe a
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x
withMaybe Maybe a
Nothing (Just a
y) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
y
withMaybe Maybe a
Nothing Maybe a
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

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
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
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, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => UnionTag -> m Exp
forall (m :: * -> *). Quote m => UnionTag -> Code m UnionTag
liftTyped :: forall (m :: * -> *). Quote m => UnionTag -> Code m UnionTag
$cliftTyped :: forall (m :: * -> *). Quote m => UnionTag -> Code m UnionTag
lift :: forall (m :: * -> *). Quote m => UnionTag -> m Exp
$clift :: forall (m :: * -> *). Quote m => UnionTag -> m Exp
Lift, forall x. Rep UnionTag x -> UnionTag
forall x. UnionTag -> Rep UnionTag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UnionTag x -> UnionTag
$cfrom :: forall x. UnionTag -> Rep UnionTag x
Generic, Eq UnionTag
Int -> UnionTag -> Int
UnionTag -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: UnionTag -> Int
$chash :: UnionTag -> Int
hashWithSalt :: Int -> UnionTag -> Int
$chashWithSalt :: Int -> UnionTag -> Int
Hashable)

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 "
      forall a. Semigroup a => a -> a -> a
<> forall a. RenderGQL a => a -> Rendering
renderGQL TypeName
unionTagName
      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 :: forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
GQLError -> HistoryT m a
mergeConflict GQLError
err = do
  [Ref FieldName]
path <- forall r (m :: * -> *). MonadReader r m => m r
ask
  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 :: forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
[Ref FieldName] -> HistoryT m a
__mergeConflict [] = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
err
    __mergeConflict refs :: [Ref FieldName]
refs@(Ref FieldName
rootField : [Ref FieldName]
xs) =
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        (GQLError
renderSubfields forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall name. Ref name -> Position
refPosition [Ref FieldName]
refs forall a. Semigroup a => a -> a -> a
<> GQLError
err)
      where
        fieldConflicts :: Ref a -> GQLError
fieldConflicts Ref a
ref = forall a. Msg a => a -> GQLError
msg (forall name. Ref name -> name
refName Ref a
ref) forall a. Semigroup a => a -> a -> a
<> GQLError
" conflict because "
        renderSubfield :: Ref a -> GQLError -> GQLError
renderSubfield Ref a
ref GQLError
txt = GQLError
txt forall a. Semigroup a => a -> a -> a
<> GQLError
"subfields " forall a. Semigroup a => a -> a -> a
<> forall {a}. Msg a => Ref a -> GQLError
fieldConflicts Ref a
ref
        renderStart :: GQLError
renderStart = GQLError
"Fields " forall a. Semigroup a => a -> a -> a
<> forall {a}. Msg a => Ref a -> GQLError
fieldConflicts Ref FieldName
rootField
        renderSubfields :: GQLError
renderSubfields =
          forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr'
            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 :: Monad (HistoryT m) => UnionTag -> UnionTag -> HistoryT m UnionTag
merge (UnionTag TypeName
oldTag SelectionSet 'VALID
oldSel) (UnionTag TypeName
_ SelectionSet 'VALID
currentSel) =
    TypeName -> SelectionSet 'VALID -> UnionTag
UnionTag TypeName
oldTag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge SelectionSet 'VALID
oldSel 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 :: forall (s :: Stage).
SelectionSet s -> (Maybe (SelectionSet s), Maybe (SelectionSet s))
splitSystemSelection = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Bool
isNotSystemFieldName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). Selection s -> FieldName
selectionName)

data Selection (s :: Stage) where
  Selection ::
    { forall (s :: Stage). Selection s -> Position
selectionPosition :: Position,
      forall (s :: Stage). Selection s -> Maybe FieldName
selectionAlias :: Maybe FieldName,
      forall (s :: Stage). Selection s -> FieldName
selectionName :: FieldName,
      forall (s :: Stage). Selection s -> Arguments s
selectionArguments :: Arguments s,
      forall (s :: Stage). Selection s -> Directives s
selectionDirectives :: Directives s,
      forall (s :: Stage). Selection s -> SelectionContent s
selectionContent :: SelectionContent s,
      forall (s :: Stage). Selection s -> Maybe FragmentName
selectionOrigin :: Maybe FragmentName
    } ->
    Selection s
  InlineFragment :: Fragment RAW -> Selection RAW
  Spread :: Directives RAW -> Ref FragmentName -> Selection RAW

instance Hashable (Selection s) where
  hashWithSalt :: Int -> Selection s -> Int
hashWithSalt Int
s (InlineFragment Fragment 'RAW
x) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Int
1 :: Int, Fragment 'RAW
x)
  hashWithSalt Int
s (Spread Directives 'RAW
x Ref FragmentName
y) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Int
2 :: Int, Directives 'RAW
x, forall name. Ref name -> name
refName Ref FragmentName
y)
  hashWithSalt Int
s Selection {Maybe FieldName
Maybe FragmentName
Directives s
Arguments s
Position
FieldName
SelectionContent s
selectionOrigin :: Maybe FragmentName
selectionContent :: SelectionContent s
selectionDirectives :: Directives s
selectionArguments :: Arguments s
selectionName :: FieldName
selectionAlias :: Maybe FieldName
selectionPosition :: Position
selectionOrigin :: forall (s :: Stage). Selection s -> Maybe FragmentName
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
..} =
    forall a. Hashable a => Int -> a -> Int
hashWithSalt
      Int
s
      ( Int
3 :: Int,
        Maybe FieldName
selectionAlias,
        FieldName
selectionName,
        Arguments s
selectionArguments,
        Directives s
selectionDirectives,
        SelectionContent s
selectionContent
      )

instance RenderGQL (Selection VALID) where
  renderGQL :: Selection 'VALID -> Rendering
renderGQL
    Selection
      { Maybe FieldName
Maybe FragmentName
Directives 'VALID
Arguments 'VALID
Position
FieldName
SelectionContent 'VALID
selectionOrigin :: Maybe FragmentName
selectionContent :: SelectionContent 'VALID
selectionDirectives :: Directives 'VALID
selectionArguments :: Arguments 'VALID
selectionName :: FieldName
selectionAlias :: Maybe FieldName
selectionPosition :: Position
selectionOrigin :: forall (s :: Stage). Selection s -> Maybe FragmentName
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
..
      } =
      forall a. RenderGQL a => a -> Rendering
renderGQL (forall a. a -> Maybe a -> a
fromMaybe FieldName
selectionName Maybe FieldName
selectionAlias)
        forall a. Semigroup a => a -> a -> a
<> forall (s :: Stage). Arguments s -> Rendering
renderArgumentValues Arguments 'VALID
selectionArguments
        forall a. Semigroup a => a -> a -> a
<> forall (s :: Stage). Directives s -> Rendering
renderDirectives Directives 'VALID
selectionDirectives
        forall a. Semigroup a => a -> a -> a
<> 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
      } = 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 "
    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 :: Monad (HistoryT m) =>
Selection s -> Selection s -> HistoryT m (Selection s)
merge = 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 :: forall (m :: * -> *) (s :: Stage).
(Monad m, MonadError GQLError m,
 Merge (HistoryT m) (SelectionSet s)) =>
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 <- 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
      forall a1 (m :: * -> *) a2.
MonadReader [a1] m =>
a1 -> m a2 -> m a2
addPath (forall name. name -> Position -> Ref name
Ref FieldName
selectionName Position
pos1) forall a b. (a -> b) -> a -> b
$ do
        Arguments s
selectionArguments <- ReaderT [Ref FieldName] m (Arguments s)
mergeArguments
        SelectionContent s
selectionContent <- forall (m :: * -> *) a. (Merge m a, Monad m) => a -> a -> m a
merge (forall (s :: Stage). Selection s -> SelectionContent s
selectionContent Selection s
old) (forall (s :: Stage). Selection s -> SelectionContent s
selectionContent Selection s
current)
        Directives s
dirs <- forall (s :: Stage). Selection s -> Directives s
selectionDirectives Selection s
old forall (m :: * -> *) a.
(Merge (HistoryT m) a, Monad m) =>
a -> a -> m a
<:> forall (s :: Stage). Selection s -> Directives s
selectionDirectives Selection s
current
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          Selection
            { selectionAlias :: Maybe FieldName
selectionAlias = Maybe FieldName
mergeAlias,
              selectionPosition :: Position
selectionPosition = Position
pos1,
              selectionDirectives :: Directives s
selectionDirectives = Directives s
dirs,
              selectionOrigin :: Maybe FragmentName
selectionOrigin = forall a. Maybe a
Nothing,
              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
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). Selection s -> Maybe FieldName
selectionAlias) [Selection s
old, Selection s
current] = forall (s :: Stage). Selection s -> Maybe FieldName
selectionAlias Selection s
old
        | Bool
otherwise = forall a. Maybe a
Nothing
      --- arguments must be equal
      mergeArguments :: ReaderT [Ref FieldName] m (Arguments s)
mergeArguments
        | forall (s :: Stage). Selection s -> Arguments s
selectionArguments Selection s
old forall a. Eq a => a -> a -> Bool
== forall (s :: Stage). Selection s -> Arguments s
selectionArguments Selection s
current = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (s :: Stage). Selection s -> Arguments s
selectionArguments Selection s
current
        | Bool
otherwise =
            forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
GQLError -> HistoryT m a
mergeConflict forall a b. (a -> b) -> a -> b
$
              (GQLError
"they have differing arguments. " forall a. Semigroup a => a -> a -> a
<> GQLError
useDifferentAliases)
                forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` [Position
pos1, Position
pos2]
mergeSelection Selection s
x Selection s
y = forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
GQLError -> HistoryT m a
mergeConflict (GQLError
"INTERNAL: can't merge. " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> GQLError
msgValue Selection s
x forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> GQLError
msgValue Selection s
y forall a. Semigroup a => a -> a -> a
<> GQLError
useDifferentAliases)

msgValue :: Show a => a -> GQLError
msgValue :: forall a. Show a => a -> GQLError
msgValue = forall a. Msg a => a -> GQLError
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- fails if alias matches but name not:
--   { user1: user
--     user1: product
--   }
mergeName ::
  (Monad m, MonadError GQLError m, Foldable t) =>
  t Position ->
  Selection s1 ->
  Selection s2 ->
  HistoryT m FieldName
mergeName :: forall (m :: * -> *) (t :: * -> *) (s1 :: Stage) (s2 :: Stage).
(Monad m, MonadError GQLError m, Foldable t) =>
t Position -> Selection s1 -> Selection s2 -> HistoryT m FieldName
mergeName t Position
pos Selection s1
old Selection s2
current
  | forall (s :: Stage). Selection s -> FieldName
selectionName Selection s1
old forall a. Eq a => a -> a -> Bool
== forall (s :: Stage). Selection s -> FieldName
selectionName Selection s2
current = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (s :: Stage). Selection s -> FieldName
selectionName Selection s2
current
  | Bool
otherwise =
      forall (m :: * -> *) a.
(Monad m, MonadError GQLError m) =>
GQLError -> HistoryT m a
mergeConflict forall a b. (a -> b) -> a -> b
$
        ( forall a. Msg a => a -> GQLError
msg (forall (s :: Stage). Selection s -> FieldName
selectionName Selection s1
old)
            forall a. Semigroup a => a -> a -> a
<> GQLError
" and "
            forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg (forall (s :: Stage). Selection s -> FieldName
selectionName Selection s2
current)
            forall a. Semigroup a => a -> a -> a
<> GQLError
" are different fields. "
            forall a. Semigroup a => a -> a -> a
<> GQLError
useDifferentAliases
        )
          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
  { forall (s :: Stage). Operation s -> Position
operationPosition :: Position,
    forall (s :: Stage). Operation s -> OperationType
operationType :: OperationType,
    forall (s :: Stage). Operation s -> Maybe FieldName
operationName :: Maybe FieldName,
    forall (s :: Stage). Operation s -> VariableDefinitions s
operationArguments :: VariableDefinitions s,
    forall (s :: Stage). Operation s -> Directives s
operationDirectives :: Directives s,
    forall (s :: Stage). Operation s -> SelectionSet s
operationSelection :: SelectionSet s
  }
  deriving (Int -> Operation s -> ShowS
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, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (s :: Stage) (m :: * -> *). Quote m => Operation s -> m Exp
forall (s :: Stage) (m :: * -> *).
Quote m =>
Operation s -> Code m (Operation s)
forall (m :: * -> *). Quote m => Operation s -> m Exp
forall (m :: * -> *).
Quote m =>
Operation s -> Code m (Operation s)
liftTyped :: forall (m :: * -> *).
Quote m =>
Operation s -> Code m (Operation s)
$cliftTyped :: forall (s :: Stage) (m :: * -> *).
Quote m =>
Operation s -> Code m (Operation s)
lift :: forall (m :: * -> *). Quote m => Operation s -> m Exp
$clift :: forall (s :: Stage) (m :: * -> *). Quote m => Operation s -> m 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
      } =
      forall a. RenderGQL a => a -> Rendering
renderGQL OperationType
operationType
        forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Rendering
"" ((Rendering
space forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RenderGQL a => a -> Rendering
renderGQL) Maybe FieldName
operationName
        forall a. Semigroup a => a -> a -> a
<> forall (s :: Stage). Directives s -> Rendering
renderDirectives Directives 'VALID
operationDirectives
        forall a. Semigroup a => a -> a -> a
<> SelectionSet 'VALID -> Rendering
renderSelectionSet SelectionSet 'VALID
operationSelection
        forall a. Semigroup a => a -> a -> a
<> Rendering
newline

getOperationName :: Maybe FieldName -> TypeName
getOperationName :: Maybe FieldName -> TypeName
getOperationName = forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeName
"AnonymousOperation" coerce :: forall a b. Coercible a b => a -> b
coerce

getOperationDataType :: MonadError GQLError m => Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID)
getOperationDataType :: forall (m :: * -> *) (s :: Stage).
MonadError GQLError m =>
Operation s -> Schema 'VALID -> m (TypeDefinition OBJECT 'VALID)
getOperationDataType Operation {operationType :: forall (s :: Stage). Operation s -> OperationType
operationType = OperationType
OPERATION_QUERY} Schema 'VALID
lib = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
query Schema 'VALID
lib)
getOperationDataType Operation {operationType :: forall (s :: Stage). Operation s -> OperationType
operationType = OperationType
OPERATION_MUTATION, Position
operationPosition :: Position
operationPosition :: forall (s :: Stage). Operation s -> Position
operationPosition} Schema 'VALID
lib =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Position -> GQLError
mutationIsNotDefined Position
operationPosition) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
mutation Schema 'VALID
lib)
getOperationDataType Operation {operationType :: forall (s :: Stage). Operation s -> OperationType
operationType = OperationType
OPERATION_SUBSCRIPTION, Position
operationPosition :: Position
operationPosition :: forall (s :: Stage). Operation s -> Position
operationPosition} Schema 'VALID
lib =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Position -> GQLError
subscriptionIsNotDefined Position
operationPosition) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s)
subscription Schema 'VALID
lib)