forked from OSS/graphql
59 lines
2.2 KiB
Haskell
59 lines
2.2 KiB
Haskell
|
{-# LANGUAGE ExplicitForAll #-}
|
||
|
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
module Language.GraphQL.Execute.Execution
|
||
|
|
( aliasOrName
|
||
|
|
, collectFields
|
||
|
|
) where
|
||
|
|
|
||
|
|
import Data.Map.Strict (Map)
|
||
|
|
import qualified Data.Map.Strict as Map
|
||
|
|
import Data.Maybe (fromMaybe)
|
||
|
|
import Data.Sequence (Seq)
|
||
|
|
import qualified Data.Sequence as Seq
|
||
|
|
import Language.GraphQL.AST.Document (Name)
|
||
|
|
import Language.GraphQL.Execute.Transform
|
||
|
|
import qualified Language.GraphQL.Type.Out as Out
|
||
|
|
import Language.GraphQL.Type.Schema
|
||
|
|
|
||
|
|
collectFields :: Monad m
|
||
|
|
=> Out.ObjectType m
|
||
|
|
-> Seq (Selection m)
|
||
|
|
-> Map Name (Seq (Field m))
|
||
|
|
collectFields objectType = foldl forEach Map.empty
|
||
|
|
where
|
||
|
|
forEach groupedFields (SelectionField field) =
|
||
|
|
let responseKey = aliasOrName field
|
||
|
|
in Map.insertWith (<>) responseKey (Seq.singleton field) groupedFields
|
||
|
|
forEach groupedFields (SelectionFragment selectionFragment)
|
||
|
|
| Fragment fragmentType fragmentSelectionSet <- selectionFragment
|
||
|
|
, doesFragmentTypeApply fragmentType objectType =
|
||
|
|
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
|
||
|
|
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
|
||
|
|
| otherwise = groupedFields
|
||
|
|
|
||
|
|
aliasOrName :: forall m. Field m -> Name
|
||
|
|
aliasOrName (Field alias name _ _) = fromMaybe name alias
|
||
|
|
|
||
|
|
doesFragmentTypeApply :: forall m
|
||
|
|
. CompositeType m
|
||
|
|
-> Out.ObjectType m
|
||
|
|
-> Bool
|
||
|
|
doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
|
||
|
|
let Out.ObjectType fragmentName _ _ _ = fragmentType
|
||
|
|
Out.ObjectType objectName _ _ _ = objectType
|
||
|
|
in fragmentName == objectName
|
||
|
|
doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =
|
||
|
|
let Out.ObjectType _ _ interfaces _ = objectType
|
||
|
|
in foldr instanceOf False interfaces
|
||
|
|
where
|
||
|
|
instanceOf (Out.InterfaceType that _ interfaces _) acc =
|
||
|
|
let Out.InterfaceType this _ _ _ = fragmentType
|
||
|
|
in acc || foldr instanceOf (this == that) interfaces
|
||
|
|
doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
|
||
|
|
let Out.UnionType _ _ members = fragmentType
|
||
|
|
in foldr instanceOf False members
|
||
|
|
where
|
||
|
|
instanceOf (Out.ObjectType that _ _ _) acc =
|
||
|
|
let Out.ObjectType this _ _ _ = objectType
|
||
|
|
in acc || this == that
|