git.iko.soy/project-m36
on fbfa2ea help sign in
project-m36/src/lib/ProjectM36/AtomFunction.hs
67 lines 3.5 kB history raw
1module ProjectM36.AtomFunction where
2import ProjectM36.Base
3import ProjectM36.Error
4import ProjectM36.AtomFunctionError
5import qualified ProjectM36.Attribute as A
6import qualified Data.HashSet as HS
8foldAtomFuncType :: AtomType -> AtomType -> [AtomType]
9foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType]
11atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction
12atomFunctionForName funcName funcSet = if HS.null foundFunc then
13 Left $ NoSuchFunctionError funcName
14 else
15 Right $ head $ HS.toList foundFunc
16 where
17 foundFunc = HS.filter (\(AtomFunction name _ _) -> name == funcName) funcSet
19-- | Create a junk named atom function for use with searching for an already existing function in the AtomFunctions HashSet.
20emptyAtomFunction :: AtomFunctionName -> AtomFunction
21emptyAtomFunction name = AtomFunction { atomFuncName = name,
22 atomFuncType = [TypeVariableType "a", TypeVariableType "a"],
23 atomFuncBody = AtomFunctionBody Nothing (\(x:_) -> pure x) }
26-- | AtomFunction constructor for compiled-in functions.
27compiledAtomFunction :: AtomFunctionName -> [AtomType] -> AtomFunctionBodyType -> AtomFunction
28compiledAtomFunction name aType body = AtomFunction { atomFuncName = name,
29 atomFuncType = aType,
30 atomFuncBody = AtomFunctionBody Nothing body }
32--the atom function really should offer some way to return an error
33evalAtomFunction :: AtomFunction -> [Atom] -> Either AtomFunctionError Atom
34evalAtomFunction func args = case atomFuncBody func of
35 (AtomFunctionBody _ f) -> f args
37--expect "Int -> Either AtomFunctionError Int"
38--return "Int -> Int" for funcType
39extractAtomFunctionType :: [TypeConstructor] -> Either RelationalError [TypeConstructor]
40extractAtomFunctionType typeIn = do
41 let atomArgs = take (length typeIn - 1) typeIn
42 --expected atom ret value - used to make funcType
43 lastArg = take 1 (reverse typeIn)
44 case lastArg of
45 [ADTypeConstructor "Either"
46 [ADTypeConstructor "AtomFunctionError" [],
47 atomRetArg]] ->
48 pure (atomArgs ++ [atomRetArg])
49 otherType ->
50 Left (ScriptError (TypeCheckCompilationError "function returning \"Either AtomFunctionError a\"" (show otherType)))
52isScriptedAtomFunction :: AtomFunction -> Bool
53isScriptedAtomFunction func = case atomFuncBody func of
54 AtomFunctionBody (Just _) _ -> True
55 AtomFunctionBody Nothing _ -> False
57atomFunctionScript :: AtomFunction -> Maybe AtomFunctionBodyScript
58atomFunctionScript func = case atomFuncBody func of
59 AtomFunctionBody script _ -> script
61-- | Create a 'DatabaseContextIOExpr' which can be used to load a new atom function written in Haskell and loaded at runtime.
62createScriptedAtomFunction :: AtomFunctionName -> [TypeConstructor] -> TypeConstructor -> AtomFunctionBodyScript -> DatabaseContextIOExpr
63createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName (
64 argsType ++ [ADTypeConstructor "Either" [
65 ADTypeConstructor "AtomFunctionError" [],
66 retType]])