module ProjectM36.AtomFunction where
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.AtomFunctionError
import qualified ProjectM36.Attribute as A
import qualified Data.HashSet as HS
foldAtomFuncType :: AtomType -> AtomType -> [AtomType]
foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType]
atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction
atomFunctionForName funcName funcSet = if HS.null foundFunc then
Left $ NoSuchFunctionError funcName
else
Right $ head $ HS.toList foundFunc
where
foundFunc = HS.filter (\(AtomFunction name _ _) -> name == funcName) funcSet
emptyAtomFunction :: AtomFunctionName -> AtomFunction
emptyAtomFunction name = AtomFunction { atomFuncName = name,
atomFuncType = [TypeVariableType "a", TypeVariableType "a"],
atomFuncBody = AtomFunctionBody Nothing (\(x:_) -> pure x) }
compiledAtomFunction :: AtomFunctionName -> [AtomType] -> AtomFunctionBodyType -> AtomFunction
compiledAtomFunction name aType body = AtomFunction { atomFuncName = name,
atomFuncType = aType,
atomFuncBody = AtomFunctionBody Nothing body }
evalAtomFunction :: AtomFunction -> [Atom] -> Either AtomFunctionError Atom
evalAtomFunction func args = case atomFuncBody func of
(AtomFunctionBody _ f) -> f args
extractAtomFunctionType :: [TypeConstructor] -> Either RelationalError [TypeConstructor]
extractAtomFunctionType typeIn = do
let atomArgs = take (length typeIn 1) typeIn
lastArg = take 1 (reverse typeIn)
case lastArg of
[ADTypeConstructor "Either"
[ADTypeConstructor "AtomFunctionError" [],
atomRetArg]] ->
pure (atomArgs ++ [atomRetArg])
otherType ->
Left (ScriptError (TypeCheckCompilationError "function returning \"Either AtomFunctionError a\"" (show otherType)))
isScriptedAtomFunction :: AtomFunction -> Bool
isScriptedAtomFunction func = case atomFuncBody func of
AtomFunctionBody (Just _) _ -> True
AtomFunctionBody Nothing _ -> False
atomFunctionScript :: AtomFunction -> Maybe AtomFunctionBodyScript
atomFunctionScript func = case atomFuncBody func of
AtomFunctionBody script _ -> script
createScriptedAtomFunction :: AtomFunctionName -> [TypeConstructor] -> TypeConstructor -> AtomFunctionBodyScript -> DatabaseContextIOExpr
createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName (
argsType ++ [ADTypeConstructor "Either" [
ADTypeConstructor "AtomFunctionError" [],
retType]])