git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/lib/ProjectM36/AtomFunction.hs
84 lines 4.4 kB history raw
1module ProjectM36.AtomFunction where
2import ProjectM36.Base
3import ProjectM36.Error
4import ProjectM36.Relation
5import ProjectM36.AtomType
6import ProjectM36.AtomFunctionError
7import ProjectM36.ScriptSession
8import qualified ProjectM36.Attribute as A
9import qualified Data.HashSet as HS
10import qualified Data.Text as T
13foldAtomFuncType :: AtomType -> AtomType -> [AtomType]
14--the underscore in the attribute name means that any attributes are acceptable
15foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType]
17atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction
18atomFunctionForName funcName funcSet = if HS.null foundFunc then
19 Left $ NoSuchFunctionError funcName
20 else
21 Right $ head $ HS.toList foundFunc
22 where
23 foundFunc = HS.filter (\(AtomFunction name _ _) -> name == funcName) funcSet
25-- | Create a junk named atom function for use with searching for an already existing function in the AtomFunctions HashSet.
26emptyAtomFunction :: AtomFunctionName -> AtomFunction
27emptyAtomFunction name = AtomFunction { atomFuncName = name,
28 atomFuncType = [TypeVariableType "a", TypeVariableType "a"],
29 atomFuncBody = AtomFunctionBody Nothing (\(x:_) -> pure x) }
32-- | AtomFunction constructor for compiled-in functions.
33compiledAtomFunction :: AtomFunctionName -> [AtomType] -> AtomFunctionBodyType -> AtomFunction
34compiledAtomFunction name aType body = AtomFunction { atomFuncName = name,
35 atomFuncType = aType,
36 atomFuncBody = AtomFunctionBody Nothing body }
38--the atom function really should offer some way to return an error
39evalAtomFunction :: AtomFunction -> [Atom] -> Either AtomFunctionError Atom
40evalAtomFunction func args = case atomFuncBody func of
41 (AtomFunctionBody _ f) -> f args
43--expect "Int -> Either AtomFunctionError Int"
44--return "Int -> Int" for funcType
45extractAtomFunctionType :: [TypeConstructor] -> Either RelationalError [TypeConstructor]
46extractAtomFunctionType typeIn = do
47 let atomArgs = take (length typeIn - 1) typeIn
48 --expected atom ret value - used to make funcType
49 lastArg = take 1 (reverse typeIn)
50 case lastArg of
51 [ADTypeConstructor "Either"
52 [ADTypeConstructor "AtomFunctionError" [],
53 atomRetArg]] ->
54 pure (atomArgs ++ [atomRetArg])
55 otherType ->
56 Left (ScriptError (TypeCheckCompilationError "function returning \"Either AtomFunctionError a\"" (show otherType)))
58isScriptedAtomFunction :: AtomFunction -> Bool
59isScriptedAtomFunction func = case atomFuncBody func of
60 AtomFunctionBody (Just _) _ -> True
61 AtomFunctionBody Nothing _ -> False
63atomFunctionScript :: AtomFunction -> Maybe AtomFunctionBodyScript
64atomFunctionScript func = case atomFuncBody func of
65 AtomFunctionBody script _ -> script
67-- | Create a 'DatabaseContextIOExpr' which can be used to load a new atom function written in Haskell and loaded at runtime.
68createScriptedAtomFunction :: AtomFunctionName -> [TypeConstructor] -> TypeConstructor -> AtomFunctionBodyScript -> DatabaseContextIOExpr
69createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName (
70 argsType ++ [ADTypeConstructor "Either" [
71 ADTypeConstructor "AtomFunctionError" [],
72 retType]])
74loadAtomFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [AtomFunction])
75loadAtomFunctions = loadFunction
77atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation
78atomFunctionsAsRelation funcs = mkRelationFromList attrs tups
79 where tups = map atomFuncToTuple (HS.toList funcs)
80 attrs = A.attributesFromList [Attribute "name" TextAtomType,
81 Attribute "arguments" TextAtomType]
82 atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),
83 TextAtom (atomFuncTypeToText aFunc)]
84 atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc))