summaryrefslogtreecommitdiff
path: root/src/Data/Morpheus/Execution/Client/Selection.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/Morpheus/Execution/Client/Selection.hs')
-rw-r--r--src/Data/Morpheus/Execution/Client/Selection.hs308
1 files changed, 191 insertions, 117 deletions
diff --git a/src/Data/Morpheus/Execution/Client/Selection.hs b/src/Data/Morpheus/Execution/Client/Selection.hs
index 184a41e..e683f41 100644
--- a/src/Data/Morpheus/Execution/Client/Selection.hs
+++ b/src/Data/Morpheus/Execution/Client/Selection.hs
@@ -8,133 +8,207 @@ module Data.Morpheus.Execution.Client.Selection
( operationTypes
) where
-import Data.Semigroup ((<>))
-import Data.Text (Text, unpack)
+import Data.Semigroup ((<>))
+import Data.Text (Text, pack, unpack)
--
-- MORPHEUS
-import Data.Morpheus.Error.Utils (globalErrorMessage)
-import Data.Morpheus.Types.Internal.AST.Operation (Operation (..), ValidOperation, Variable (..),
- VariableDefinitions)
-import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..))
-import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataLeaf (..),
- DataTyCon (..), DataTypeLib (..), TypeAlias (..),
- allDataTypes)
-import Data.Morpheus.Types.Internal.DataD (ConsD (..), TypeD (..))
-import Data.Morpheus.Types.Internal.Validation (GQLErrors, Validation)
-import Data.Morpheus.Validation.Internal.Utils (lookupType)
+import Data.Morpheus.Error.Utils (globalErrorMessage)
+import Data.Morpheus.Execution.Internal.GraphScanner (LibUpdater, resolveUpdates)
+import Data.Morpheus.Execution.Internal.Utils (nameSpaceType)
+import Data.Morpheus.Types.Internal.AST.Operation (DefaultValue, Operation (..), ValidOperation,
+ Variable (..), VariableDefinitions)
+import Data.Morpheus.Types.Internal.AST.Selection (Selection (..), SelectionRec (..), SelectionSet)
+import Data.Morpheus.Types.Internal.Data (DataField (..), DataFullType (..), DataLeaf (..),
+ DataTyCon (..), DataTypeKind (..), DataTypeLib (..),
+ Key, TypeAlias (..), allDataTypes)
+import Data.Morpheus.Types.Internal.DataD (ConsD (..), GQLTypeD (..), TypeD (..))
+import Data.Morpheus.Types.Internal.Validation (GQLErrors, Validation)
+import Data.Morpheus.Validation.Internal.Utils (lookupType)
+import Data.Set (fromList, toList)
+
+removeDuplicates :: [Text] -> [Text]
+removeDuplicates = toList . fromList
compileError :: Text -> GQLErrors
compileError x = globalErrorMessage $ "Unhandled Compile Time Error: \"" <> x <> "\" ;"
-operationTypes :: DataTypeLib -> VariableDefinitions -> ValidOperation -> Validation ([TypeD], [TypeD])
+operationTypes :: DataTypeLib -> VariableDefinitions -> ValidOperation -> Validation (Maybe TypeD, [GQLTypeD])
operationTypes lib variables = genOperation
where
- queryDataType = OutputObject $ snd $ query lib
- -----------------------------------------------------
- typeByField :: Text -> DataFullType -> Validation DataFullType
- typeByField key datatype = fst <$> lookupFieldType datatype key
- ------------------------------------------------------
- lookupFieldType :: DataFullType -> Text -> Validation (DataFullType, TypeAlias)
- lookupFieldType (OutputObject DataTyCon {typeData}) key =
- case lookup key typeData of
- Just DataField {fieldType = alias@TypeAlias {aliasTyCon}} -> trans <$> getType lib aliasTyCon
- where trans x = (x, alias {aliasTyCon = typeFrom x, aliasArgs = Nothing})
- Nothing -> Left (compileError key)
- lookupFieldType _ key = Left (compileError key)
- -----------------------------------------------------
genOperation Operation {operationName, operationSelection} = do
- argTypes <- rootArguments (operationName <> "Args")
- queryTypes <- genRecordType operationName queryDataType operationSelection
- pure (argTypes, queryTypes)
- -------------------------------------------{--}
- genInputType :: Text -> Validation [TypeD]
- genInputType name = getType lib name >>= subTypes
+ (queryTypes, enums) <- genRecordType [] operationName queryDataType operationSelection
+ inputTypeRequests <- resolveUpdates [] $ map (scanInputTypes lib . variableType . snd) variables
+ inputTypesAndEnums <- buildListedTypes (inputTypeRequests <> enums)
+ pure (rootArguments (operationName <> "Args"), queryTypes <> inputTypesAndEnums)
where
- subTypes (InputObject DataTyCon {typeName, typeData}) = do
- types <- concat <$> mapM toInputTypeD typeData
- fields <- traverse toFieldD typeData
- pure $ typeD fields : types
- where
- typeD fields = TypeD {tName = unpack typeName, tCons = [ConsD {cName = unpack typeName, cFields = fields}]}
- ---------------------------------------------------------------
- toInputTypeD :: (Text, DataField) -> Validation [TypeD]
- toInputTypeD (_, DataField {fieldType}) = genInputType $ aliasTyCon fieldType
- ----------------------------------------------------------------
- toFieldD :: (Text, DataField) -> Validation DataField
- toFieldD (_, field@DataField {fieldType}) = do
- aliasTyCon <- typeFrom <$> getType lib (aliasTyCon fieldType)
- pure $ field {fieldType = fieldType {aliasTyCon}}
- subTypes (Leaf x) = buildLeaf x
- subTypes _ = pure []
- -------------------------------------------
- rootArguments :: Text -> Validation [TypeD]
- rootArguments name = do
- types <- concat <$> mapM (genInputType . variableType . snd) variables
- pure $ typeD : types
+ queryDataType = OutputObject $ snd $ query lib
+ -------------------------------------------------------------------------
+ buildListedTypes = fmap concat . traverse (buildInputType lib) . removeDuplicates
+ -------------------------------------------------------------------------
+ -- generates argument types for Operation Head
+ rootArguments :: Text -> Maybe TypeD
+ rootArguments argsName
+ | null variables = Nothing
+ | otherwise = Just rootArgumentsType
+ ------------------------------------------
where
- typeD :: TypeD
- typeD = TypeD {tName = unpack name, tCons = [ConsD {cName = unpack name, cFields = map fieldD variables}]}
- ---------------------------------------
- fieldD :: (Text, Variable ()) -> DataField
- fieldD (key, Variable {variableType, variableTypeWrappers}) =
- DataField
- { fieldName = key
- , fieldArgs = []
- , fieldArgsType = Nothing
- , fieldType =
- TypeAlias {aliasWrappers = variableTypeWrappers, aliasTyCon = variableType, aliasArgs = Nothing}
- , fieldHidden = False
+ rootArgumentsType :: TypeD
+ rootArgumentsType =
+ TypeD
+ { tName = unpack argsName
+ , tNamespace = []
+ , tCons = [ConsD {cName = unpack argsName, cFields = map fieldD variables}]
}
- -------------------------------------------
- getCon name dataType selectionSet = do
- cFields <- genFields dataType selectionSet
- subTypes <- newFieldTypes dataType selectionSet
- pure (ConsD {cName = unpack name, cFields}, subTypes)
- ---------------------------------------------------------------------------------------------
- where
- genFields datatype = mapM typeNameFromField
where
- typeNameFromField :: (Text, Selection) -> Validation DataField
- typeNameFromField (fieldName, Selection {selectionRec = SelectionAlias {aliasFieldName}}) = do
- fieldType <- snd <$> lookupFieldType datatype aliasFieldName
- pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False}
- typeNameFromField (fieldName, _) = do
- fieldType <- snd <$> lookupFieldType datatype fieldName
- pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False}
- --------------------------------------------
- genRecordType name dataType selectionSet = do
- (con, subTypes) <- getCon name dataType selectionSet
- pure $ TypeD {tName = unpack name, tCons = [con]} : subTypes
- ------------------------------------------------------------------------------------------------------------
- newFieldTypes parentType = fmap concat <$> mapM validateSelection
+ fieldD :: (Text, Variable DefaultValue) -> DataField
+ fieldD (key, Variable {variableType, variableTypeWrappers}) =
+ DataField
+ { fieldName = key
+ , fieldArgs = []
+ , fieldArgsType = Nothing
+ , fieldType =
+ TypeAlias {aliasWrappers = variableTypeWrappers, aliasTyCon = variableType, aliasArgs = Nothing}
+ , fieldHidden = False
+ }
+ ---------------------------------------------------------
+ -- generates selection Object Types
+ genRecordType :: [Key] -> Key -> DataFullType -> SelectionSet -> Validation ([GQLTypeD], [Text])
+ genRecordType path name dataType recordSelSet = do
+ (con, subTypes, requests) <- genConsD (unpack name) dataType recordSelSet
+ pure
+ ( GQLTypeD
+ { typeD = TypeD {tName, tNamespace = map unpack path, tCons = [con]}
+ , typeKindD = KindObject Nothing
+ , typeArgD = []
+ } :
+ subTypes
+ , requests)
where
- validateSelection :: (Text, Selection) -> Validation [TypeD]
- validateSelection (key, Selection {selectionRec = SelectionField}) =
- key `typeByField` parentType >>= buildSelField
- where
- buildSelField (Leaf x) = buildLeaf x
- buildSelField _ = Left $ compileError "Invalid schema Expected scalar"
- validateSelection (key, Selection {selectionRec = SelectionSet selectionSet}) = do
- datatype <- key `typeByField` parentType
- genRecordType (typeFrom datatype) datatype selectionSet
- validateSelection (_, selection@Selection {selectionRec = SelectionAlias {aliasFieldName, aliasSelection}}) =
- validateSelection (aliasFieldName, selection {selectionRec = aliasSelection})
- validateSelection (key, Selection {selectionRec = UnionSelection unionSelections}) = do
- unionTypeName <- typeFrom <$> key `typeByField` parentType
- (tCons, subTypes) <- unzip <$> mapM getUnionType unionSelections
- pure $ TypeD {tName = unpack unionTypeName, tCons} : concat subTypes
+ tName = unpack name
+ genConsD :: String -> DataFullType -> SelectionSet -> Validation (ConsD, [GQLTypeD], [Text])
+ genConsD cName datatype selSet = do
+ cFields <- traverse genField selSet
+ (subTypes, requests) <- newFieldTypes datatype selSet
+ pure (ConsD {cName, cFields}, concat subTypes, concat requests)
+ ---------------------------------------------------------------------------------------------
where
- getUnionType (typeKey, selSet) = do
- conDatatype <- getType lib typeKey
- getCon typeKey conDatatype selSet
+ genField :: (Text, Selection) -> Validation DataField
+ genField (fieldName, sel) = genFieldD sel
+ where
+ fieldPath = path <> [fieldName]
+ -------------------------------
+ genFieldD Selection {selectionRec = SelectionAlias {aliasFieldName}} = do
+ fieldType <- snd <$> lookupFieldType lib fieldPath datatype aliasFieldName
+ pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False}
+ genFieldD _ = do
+ fieldType <- snd <$> lookupFieldType lib fieldPath datatype fieldName
+ pure $ DataField {fieldName, fieldArgs = [], fieldArgsType = Nothing, fieldType, fieldHidden = False}
+ ------------------------------------------------------------------------------------------------------------
+ newFieldTypes :: DataFullType -> SelectionSet -> Validation ([[GQLTypeD]], [[Text]])
+ newFieldTypes parentType seSet = unzip <$> mapM valSelection seSet
+ where
+ valSelection selection@(selKey, _) = do
+ let (key, sel) = getSelectionFieldKey selection
+ fieldDatatype <- fst <$> lookupFieldType lib fieldPath parentType key
+ validateSelection fieldDatatype sel
+ --------------------------------------------------------------------
+ where
+ fieldPath = path <> [selKey]
+ --------------------------------------------------------------------
+ validateSelection :: DataFullType -> Selection -> Validation ([GQLTypeD], [Text])
+ validateSelection dType Selection {selectionRec = SelectionField} = do
+ lName <- withLeaf (pure . leafName) dType
+ pure ([], lName)
+ --withLeaf buildLeaf dType
+ validateSelection dType Selection {selectionRec = SelectionSet selectionSet} =
+ genRecordType fieldPath (typeFrom [] dType) dType selectionSet
+ validateSelection dType aliasSel@Selection {selectionRec = SelectionAlias {aliasSelection}} =
+ validateSelection dType aliasSel {selectionRec = aliasSelection}
+ ---- UNION
+ validateSelection dType Selection {selectionRec = UnionSelection unionSelections} = do
+ (tCons, subTypes, requests) <- unzip3 <$> mapM getUnionType unionSelections
+ pure
+ ( GQLTypeD
+ { typeD =
+ TypeD {tNamespace = map unpack fieldPath, tName = unpack $ typeFrom [] dType, tCons}
+ , typeKindD = KindUnion
+ , typeArgD = []
+ } :
+ concat subTypes
+ , concat requests)
+ where
+ getUnionType (selectedTyName, selectionVariant) = do
+ conDatatype <- getType lib selectedTyName
+ genConsD (unpack selectedTyName) conDatatype selectionVariant
-buildLeaf :: DataLeaf -> Validation [TypeD]
-buildLeaf (LeafEnum DataTyCon {typeName, typeData}) =
- pure [TypeD {tName = unpack typeName, tCons = map enumOption typeData}]
+scanInputTypes :: DataTypeLib -> Key -> LibUpdater [Key]
+scanInputTypes lib name collected
+ | name `elem` collected = pure collected
+ | otherwise = getType lib name >>= scanType
where
- enumOption name = ConsD {cName = unpack name, cFields = []}
-buildLeaf _ = pure []
+ scanType (InputObject DataTyCon {typeData}) = resolveUpdates (name : collected) (map toInputTypeD typeData)
+ where
+ toInputTypeD :: (Text, DataField) -> LibUpdater [Key]
+ toInputTypeD (_, DataField {fieldType = TypeAlias {aliasTyCon}}) = scanInputTypes lib aliasTyCon
+ scanType (Leaf leaf) = pure (collected <> leafName leaf)
+ scanType _ = pure collected
+
+buildInputType :: DataTypeLib -> Text -> Validation [GQLTypeD]
+buildInputType lib name = getType lib name >>= subTypes
+ where
+ subTypes (InputObject DataTyCon {typeName, typeData}) = do
+ fields <- traverse toFieldD typeData
+ pure
+ [ GQLTypeD
+ { typeD =
+ TypeD
+ { tName = unpack typeName
+ , tNamespace = []
+ , tCons = [ConsD {cName = unpack typeName, cFields = fields}]
+ }
+ , typeArgD = []
+ , typeKindD = KindInputObject
+ }
+ ]
+ ----------------------------------------------------------------
+ where
+ toFieldD :: (Text, DataField) -> Validation DataField
+ toFieldD (_, field@DataField {fieldType}) = do
+ aliasTyCon <- typeFrom [] <$> getType lib (aliasTyCon fieldType)
+ pure $ field {fieldType = fieldType {aliasTyCon}}
+ subTypes (Leaf (LeafEnum DataTyCon {typeName, typeData})) =
+ pure
+ [ GQLTypeD
+ { typeD = TypeD {tName = unpack typeName, tNamespace = [], tCons = map enumOption typeData}
+ , typeArgD = []
+ , typeKindD = KindEnum
+ }
+ ]
+ where
+ enumOption eName = ConsD {cName = unpack eName, cFields = []}
+ subTypes _ = pure []
+
+lookupFieldType :: DataTypeLib -> [Key] -> DataFullType -> Text -> Validation (DataFullType, TypeAlias)
+lookupFieldType lib path (OutputObject DataTyCon {typeData}) key =
+ case lookup key typeData of
+ Just DataField {fieldType = alias@TypeAlias {aliasTyCon}} -> trans <$> getType lib aliasTyCon
+ where trans x = (x, alias {aliasTyCon = typeFrom path x, aliasArgs = Nothing})
+ Nothing -> Left (compileError key)
+lookupFieldType _ _ _ key = Left (compileError key)
+
+getSelectionFieldKey :: (Key, Selection) -> (Key, Selection)
+getSelectionFieldKey (_, selection@Selection {selectionRec = SelectionAlias {aliasFieldName, aliasSelection}}) =
+ (aliasFieldName, selection {selectionRec = aliasSelection})
+getSelectionFieldKey sel = sel
+
+withLeaf :: (DataLeaf -> Validation b) -> DataFullType -> Validation b
+withLeaf f (Leaf x) = f x
+withLeaf _ _ = Left $ compileError "Invalid schema Expected scalar"
+
+leafName :: DataLeaf -> [Text]
+leafName (LeafEnum DataTyCon {typeName}) = [typeName]
+leafName _ = []
getType :: DataTypeLib -> Text -> Validation DataFullType
getType lib typename = lookupType (compileError typename) (allDataTypes lib) typename
@@ -147,13 +221,13 @@ isPrimitive "String" = True
isPrimitive "ID" = True
isPrimitive _ = False
-typeFrom :: DataFullType -> Text
-typeFrom (Leaf (BaseScalar x)) = typeName x
-typeFrom (Leaf (CustomScalar DataTyCon {typeName}))
+typeFrom :: [Key] -> DataFullType -> Text
+typeFrom _ (Leaf (BaseScalar x)) = typeName x
+typeFrom _ (Leaf (CustomScalar DataTyCon {typeName}))
| isPrimitive typeName = typeName
| otherwise = "ScalarValue"
-typeFrom (Leaf (LeafEnum x)) = typeName x
-typeFrom (InputObject x) = typeName x
-typeFrom (OutputObject x) = typeName x
-typeFrom (Union x) = typeName x
-typeFrom (InputUnion x) = typeName x
+typeFrom _ (Leaf (LeafEnum x)) = typeName x
+typeFrom _ (InputObject x) = typeName x
+typeFrom path (OutputObject x) = pack $ nameSpaceType path $ typeName x
+typeFrom path (Union x) = pack $ nameSpaceType path $ typeName x
+typeFrom _ (InputUnion x) = typeName x