{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Morpheus.Types.Internal.AST.Selection
( Selection (..),
SelectionContent (..),
SelectionSet,
UnionTag (..),
UnionSelection,
Fragment (..),
Fragments,
Operation (..),
Variable (..),
VariableDefinitions,
DefaultValue,
getOperationName,
getOperationDataType,
)
where
import Data.Maybe (fromMaybe, isJust)
import Data.Morpheus.Error.NameCollision
( NameCollision (..),
)
import Data.Morpheus.Error.Operation
( mutationIsNotDefined,
subscriptionIsNotDefined,
)
import Data.Morpheus.Internal.Utils
( Failure (..),
KeyOf (..),
Merge (..),
)
import Data.Morpheus.Types.Internal.AST.Base
( FieldName,
GQLError (..),
GQLErrors,
Message,
OperationType (..),
Position,
RAW,
Ref (..),
Stage,
TypeName (..),
VALID,
intercalateName,
msg,
readName,
)
import Data.Morpheus.Types.Internal.AST.MergeSet
( MergeSet,
)
import Data.Morpheus.Types.Internal.AST.OrderedMap
( OrderedMap,
)
import Data.Morpheus.Types.Internal.AST.TypeSystem
( Arguments,
Directives,
OUT,
Schema (..),
TypeDefinition (..),
)
import Data.Morpheus.Types.Internal.AST.Value
( ResolvedValue,
Variable (..),
VariableDefinitions,
)
import Data.Semigroup ((<>))
import Language.Haskell.TH.Syntax (Lift (..))
data Fragment = Fragment
{ fragmentName :: FieldName,
fragmentType :: TypeName,
fragmentPosition :: Position,
fragmentSelection :: SelectionSet RAW,
fragmentDirectives :: Directives RAW
}
deriving (Show, Eq, Lift)
instance NameCollision Fragment where
nameCollision _ Fragment {fragmentName, fragmentPosition} =
GQLError
{ message = "There can be only one fragment named " <> msg fragmentName <> ".",
locations = [fragmentPosition]
}
instance KeyOf Fragment where
keyOf = fragmentName
type Fragments = OrderedMap FieldName Fragment
data SelectionContent (s :: Stage) where
SelectionField :: SelectionContent s
SelectionSet :: SelectionSet s -> SelectionContent s
UnionSelection :: UnionSelection VALID -> SelectionContent VALID
instance
Merge (SelectionSet s) =>
Merge (SelectionContent s)
where
merge path (SelectionSet s1) (SelectionSet s2) = SelectionSet <$> merge path s1 s2
merge path (UnionSelection u1) (UnionSelection u2) = UnionSelection <$> merge path u1 u2
merge path oldC currC
| oldC == currC = pure oldC
| otherwise =
failure
[ GQLError
{ message = msg (intercalateName "." $ map refName path),
locations = map refPosition path
}
]
deriving instance Show (SelectionContent a)
deriving instance Eq (SelectionContent a)
deriving instance Lift (SelectionContent a)
data UnionTag = UnionTag
{ unionTagName :: TypeName,
unionTagSelection :: SelectionSet VALID
}
deriving (Show, Eq, Lift)
mergeConflict :: [Ref] -> GQLError -> GQLErrors
mergeConflict [] err = [err]
mergeConflict refs@(rootField : xs) err =
[ GQLError
{ message = renderSubfields <> message err,
locations = map refPosition refs <> locations err
}
]
where
fieldConflicts ref = msg (refName ref) <> " conflict because "
renderSubfield ref txt = txt <> "subfields " <> fieldConflicts ref
renderStart = "Fields " <> fieldConflicts rootField
renderSubfields =
foldr
renderSubfield
renderStart
xs
instance Merge UnionTag where
merge path (UnionTag oldTag oldSel) (UnionTag _ currentSel) =
UnionTag oldTag <$> merge path oldSel currentSel
instance KeyOf UnionTag where
type KEY UnionTag = TypeName
keyOf = unionTagName
type UnionSelection (s :: Stage) = MergeSet s UnionTag
type SelectionSet (s :: Stage) = MergeSet s (Selection s)
data Selection (s :: Stage) where
Selection ::
{ selectionName :: FieldName,
selectionAlias :: Maybe FieldName,
selectionPosition :: Position,
selectionArguments :: Arguments s,
selectionContent :: SelectionContent s,
selectionDirectives :: Directives s
} ->
Selection s
InlineFragment :: Fragment -> Selection RAW
Spread :: Directives RAW -> Ref -> Selection RAW
instance KeyOf (Selection s) where
keyOf
Selection
{ selectionName,
selectionAlias
} = fromMaybe selectionName selectionAlias
keyOf _ = ""
useDufferentAliases :: Message
useDufferentAliases =
"Use different aliases on the "
<> "fields to fetch both if this was intentional."
instance
Merge (SelectionSet a) =>
Merge (Selection a)
where
merge
path
old@Selection {selectionPosition = pos1}
current@Selection {selectionPosition = pos2} =
do
selectionName <- mergeName
let currentPath = path <> [Ref selectionName pos1]
selectionArguments <- mergeArguments currentPath
selectionContent <- merge currentPath (selectionContent old) (selectionContent current)
pure $
Selection
{ selectionAlias = mergeAlias,
selectionPosition = pos1,
selectionDirectives = selectionDirectives old <> selectionDirectives current,
..
}
where
mergeName
| selectionName old == selectionName current = pure $ selectionName current
| otherwise =
failure $ mergeConflict path $
GQLError
{ message =
"" <> msg (selectionName old) <> " and " <> msg (selectionName current)
<> " are different fields. "
<> useDufferentAliases,
locations = [pos1, pos2]
}
mergeAlias
| all (isJust . selectionAlias) [old, current] = selectionAlias old
| otherwise = Nothing
mergeArguments currentPath
| selectionArguments old == selectionArguments current = pure $ selectionArguments current
| otherwise =
failure $ mergeConflict currentPath $
GQLError
{ message = "they have differing arguments. " <> useDufferentAliases,
locations = [pos1, pos2]
}
merge path _ _ =
failure $ mergeConflict path $
GQLError
{ message = "INTERNAL: can't merge. " <> useDufferentAliases,
locations = []
}
deriving instance Show (Selection a)
deriving instance Lift (Selection a)
deriving instance Eq (Selection a)
type DefaultValue = Maybe ResolvedValue
data Operation (s :: Stage) = Operation
{ operationName :: Maybe FieldName,
operationType :: OperationType,
operationArguments :: VariableDefinitions s,
operationSelection :: SelectionSet s,
operationPosition :: Position,
operationDirectives :: Directives s
}
deriving (Show, Lift)
getOperationName :: Maybe FieldName -> TypeName
getOperationName = maybe "AnonymousOperation" (TypeName . readName)
getOperationDataType :: Failure GQLErrors m => Operation a -> Schema -> m (TypeDefinition OUT)
getOperationDataType Operation {operationType = Query} lib = pure (query lib)
getOperationDataType Operation {operationType = Mutation, operationPosition} lib =
case mutation lib of
Just x -> pure x
Nothing -> failure $ mutationIsNotDefined operationPosition
getOperationDataType Operation {operationType = Subscription, operationPosition} lib =
case subscription lib of
Just x -> pure x
Nothing -> failure $ subscriptionIsNotDefined operationPosition