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