git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/lib/ProjectM36/DatabaseContextFunction.hs
75 lines 4.2 kB history raw
1module ProjectM36.DatabaseContextFunction where
2--implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
3import ProjectM36.Base
4import ProjectM36.Error
5import ProjectM36.Attribute as A
6import ProjectM36.Relation
7import ProjectM36.AtomType
8import qualified Data.HashSet as HS
9import qualified Data.Map as M
10import ProjectM36.ScriptSession
11import qualified Data.Text as T
13emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction
14emptyDatabaseContextFunction name = DatabaseContextFunction {
15 dbcFuncName = name,
16 dbcFuncType = [],
17 dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> pure ctx)
18 }
20databaseContextFunctionForName :: DatabaseContextFunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction
21databaseContextFunctionForName funcName funcs = if HS.null foundFunc then
22 Left $ NoSuchFunctionError funcName
23 else
24 Right (head (HS.toList foundFunc))
25 where
26 foundFunc = HS.filter (\(DatabaseContextFunction name _ _) -> name == funcName) funcs
28evalDatabaseContextFunction :: DatabaseContextFunction -> [Atom] -> DatabaseContext -> Either RelationalError DatabaseContext
29evalDatabaseContextFunction func args ctx = case dbcFuncBody func of
30 (DatabaseContextFunctionBody _ f) -> case f args ctx of
31 Left err -> Left (DatabaseContextFunctionUserError err)
32 Right c -> pure c
34basicDatabaseContextFunctions :: DatabaseContextFunctions
35basicDatabaseContextFunctions = HS.fromList [
36 DatabaseContextFunction { dbcFuncName = "deleteAll",
37 dbcFuncType = [],
38 dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> pure $ ctx { relationVariables = M.empty })
39 }
40 ]
42--the precompiled functions are special because they cannot be serialized. Their names are therefore used in perpetuity so that the functions can be "serialized" (by name).
43precompiledDatabaseContextFunctions :: DatabaseContextFunctions
44precompiledDatabaseContextFunctions = HS.filter (not . isScriptedDatabaseContextFunction) basicDatabaseContextFunctions
46isScriptedDatabaseContextFunction :: DatabaseContextFunction -> Bool
47isScriptedDatabaseContextFunction func = case dbcFuncBody func of
48 DatabaseContextFunctionBody (Just _) _ -> True
49 DatabaseContextFunctionBody Nothing _ -> False
51databaseContextFunctionScript :: DatabaseContextFunction -> Maybe DatabaseContextFunctionBodyScript
52databaseContextFunctionScript func = case dbcFuncBody func of
53 DatabaseContextFunctionBody script _ -> script
55databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor
56databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [
57 ADTypeConstructor "DatabaseContextFunctionError" [],
58 tCons]
60createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr
61createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg])
63loadDatabaseContextFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [DatabaseContextFunction])
64loadDatabaseContextFunctions = loadFunction
66databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation
67databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups
68 where
69 attrs = A.attributesFromList [Attribute "name" TextAtomType,
70 Attribute "arguments" TextAtomType]
71 tups = map dbcFuncToTuple (HS.toList dbcFuncs)
72 dbcFuncToTuple func = [TextAtom (dbcFuncName func),
73 TextAtom (dbcTextType (dbcFuncType func))]
74 dbcTextType typ = T.intercalate " -> " (map prettyAtomType typ ++ ["DatabaseContext", "DatabaseContext"])