git.iko.soy/project-m36
on fbfa2ea help sign in
project-m36/src/lib/ProjectM36/DatabaseContextFunction.hs
56 lines 3.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 qualified Data.HashSet as HS
6import qualified Data.Map as M
8emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction
9emptyDatabaseContextFunction name = DatabaseContextFunction {
10 dbcFuncName = name,
11 dbcFuncType = [],
12 dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> pure ctx)
13 }
15databaseContextFunctionForName :: DatabaseContextFunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction
16databaseContextFunctionForName funcName funcs = if HS.null foundFunc then
17 Left $ NoSuchFunctionError funcName
18 else
19 Right (head (HS.toList foundFunc))
20 where
21 foundFunc = HS.filter (\(DatabaseContextFunction name _ _) -> name == funcName) funcs
23evalDatabaseContextFunction :: DatabaseContextFunction -> [Atom] -> DatabaseContext -> Either RelationalError DatabaseContext
24evalDatabaseContextFunction func args ctx = case dbcFuncBody func of
25 (DatabaseContextFunctionBody _ f) -> case f args ctx of
26 Left err -> Left (DatabaseContextFunctionUserError err)
27 Right c -> pure c
29basicDatabaseContextFunctions :: DatabaseContextFunctions
30basicDatabaseContextFunctions = HS.fromList [
31 DatabaseContextFunction { dbcFuncName = "deleteAll",
32 dbcFuncType = [],
33 dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> pure $ ctx { relationVariables = M.empty })
34 }
35 ]
37--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).
38precompiledDatabaseContextFunctions :: DatabaseContextFunctions
39precompiledDatabaseContextFunctions = HS.filter (not . isScriptedDatabaseContextFunction) basicDatabaseContextFunctions
41isScriptedDatabaseContextFunction :: DatabaseContextFunction -> Bool
42isScriptedDatabaseContextFunction func = case dbcFuncBody func of
43 DatabaseContextFunctionBody (Just _) _ -> True
44 DatabaseContextFunctionBody Nothing _ -> False
46databaseContextFunctionScript :: DatabaseContextFunction -> Maybe DatabaseContextFunctionBodyScript
47databaseContextFunctionScript func = case dbcFuncBody func of
48 DatabaseContextFunctionBody script _ -> script
50databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor
51databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [
52 ADTypeConstructor "DatabaseContextFunctionError" [],
53 tCons]
55createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr
56createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg])