{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Data.Morpheus.Validation.Query.UnionSelection
( validateUnionSelection,
)
where
import Control.Monad ((>=>))
import Data.Morpheus.Error.Selection (unknownSelectionField)
import Data.Morpheus.Internal.Utils
( Failure (..),
elems,
empty,
fromElems,
selectOr,
singleton,
)
import Data.Morpheus.Types.Internal.AST
( DataUnion,
FieldsDefinition,
Fragment (..),
OUT,
RAW,
Ref (..),
Selection (..),
SelectionContent (..),
SelectionSet,
SelectionSet,
TypeName,
UnionTag (..),
VALID,
)
import qualified Data.Morpheus.Types.Internal.AST.MergeSet as MS
( join,
)
import Data.Morpheus.Types.Internal.Validation
( SelectionValidator,
askScopeTypeName,
askTypeMember,
)
import Data.Morpheus.Validation.Query.Fragment
( castFragmentType,
resolveSpread,
)
type TypeDef = (TypeName, FieldsDefinition OUT)
exploreUnionFragments ::
[TypeName] ->
Selection RAW ->
SelectionValidator [Fragment]
exploreUnionFragments unionTags = splitFrag
where
packFragment fragment = [fragment]
splitFrag ::
Selection RAW -> SelectionValidator [Fragment]
splitFrag (Spread _ ref) = packFragment <$> resolveSpread unionTags ref
splitFrag Selection {selectionName = "__typename", selectionContent = SelectionField} = pure []
splitFrag Selection {selectionName, selectionPosition} = do
typeName <- askScopeTypeName
failure $ unknownSelectionField typeName (Ref selectionName selectionPosition)
splitFrag (InlineFragment fragment) =
packFragment
<$> castFragmentType Nothing (fragmentPosition fragment) unionTags fragment
tagUnionFragments ::
[TypeDef] -> [Fragment] -> [(TypeDef, [Fragment])]
tagUnionFragments types fragments =
filter notEmpty $
map categorizeType types
where
notEmpty = not . null . snd
categorizeType :: (TypeName, FieldsDefinition OUT) -> (TypeDef, [Fragment])
categorizeType datatype = (datatype, filter matches fragments)
where
matches fragment = fragmentType fragment == fst datatype
validateCluster ::
(TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID)) ->
SelectionSet RAW ->
[(TypeDef, [Fragment])] ->
SelectionValidator (SelectionContent VALID)
validateCluster validator __typename = traverse _validateCluster >=> fmap UnionSelection . fromElems
where
_validateCluster :: (TypeDef, [Fragment]) -> SelectionValidator UnionTag
_validateCluster (unionType, fragmets) = do
fragmentSelections <- MS.join (__typename : map fragmentSelection fragmets)
UnionTag (fst unionType) <$> validator unionType fragmentSelections
validateUnionSelection ::
(TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID)) ->
SelectionSet RAW ->
DataUnion ->
SelectionValidator (SelectionContent VALID)
validateUnionSelection validate selectionSet members = do
let (__typename :: SelectionSet RAW) = selectOr empty singleton "__typename" selectionSet
unionTypes <- traverse askTypeMember members
spreads <- concat <$> traverse (exploreUnionFragments members) (elems selectionSet)
let categories = tagUnionFragments unionTypes spreads
validateCluster validate __typename categories