git.iko.soy/project-m36
on c54cbec help sign in
project-m36/src/lib/ProjectM36/DatabaseContextFunction.hs
80 lines 4.3 kB history raw
1{-# LANGUAGE CPP #-}
2module ProjectM36.DatabaseContextFunction where
3--implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
4import ProjectM36.Base
5import ProjectM36.Error
6import ProjectM36.Attribute as A
7import ProjectM36.Relation
8import ProjectM36.AtomType
9import qualified Data.HashSet as HS
10import qualified Data.Map as M
11import ProjectM36.ScriptSession
12import qualified Data.Text as T
14emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction
15emptyDatabaseContextFunction name = DatabaseContextFunction {
16 dbcFuncName = name,
17 dbcFuncType = [],
18 dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> pure ctx)
19 }
21databaseContextFunctionForName :: DatabaseContextFunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction
22databaseContextFunctionForName funcName funcs = if HS.null foundFunc then
23 Left $ NoSuchFunctionError funcName
24 else
25 Right (head (HS.toList foundFunc))
26 where
27 foundFunc = HS.filter (\(DatabaseContextFunction name _ _) -> name == funcName) funcs
29evalDatabaseContextFunction :: DatabaseContextFunction -> [Atom] -> DatabaseContext -> Either RelationalError DatabaseContext
30evalDatabaseContextFunction func args ctx = case dbcFuncBody func of
31 (DatabaseContextFunctionBody _ f) -> case f args ctx of
32 Left err -> Left (DatabaseContextFunctionUserError err)
33 Right c -> pure c
35basicDatabaseContextFunctions :: DatabaseContextFunctions
36basicDatabaseContextFunctions = HS.fromList [
37 DatabaseContextFunction { dbcFuncName = "deleteAll",
38 dbcFuncType = [],
39 dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> pure $ ctx { relationVariables = M.empty })
40 }
41 ]
43--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).
44precompiledDatabaseContextFunctions :: DatabaseContextFunctions
45precompiledDatabaseContextFunctions = HS.filter (not . isScriptedDatabaseContextFunction) basicDatabaseContextFunctions
47isScriptedDatabaseContextFunction :: DatabaseContextFunction -> Bool
48isScriptedDatabaseContextFunction func = case dbcFuncBody func of
49 DatabaseContextFunctionBody (Just _) _ -> True
50 DatabaseContextFunctionBody Nothing _ -> False
52databaseContextFunctionScript :: DatabaseContextFunction -> Maybe DatabaseContextFunctionBodyScript
53databaseContextFunctionScript func = case dbcFuncBody func of
54 DatabaseContextFunctionBody script _ -> script
56databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor
57databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [
58 ADTypeConstructor "DatabaseContextFunctionError" [],
59 tCons]
61createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr
62createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg])
64loadDatabaseContextFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [DatabaseContextFunction])
65#ifdef PM36_HASKELL_SCRIPTING
66loadDatabaseContextFunctions = loadFunction
67#else
68loadDatabaseContextFunctions _ _ _ = pure (Left LoadSymbolError)
69#endif
71databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation
72databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups
73 where
74 attrs = A.attributesFromList [Attribute "name" TextAtomType,
75 Attribute "arguments" TextAtomType]
76 tups = map dbcFuncToTuple (HS.toList dbcFuncs)
77 dbcFuncToTuple func = [TextAtom (dbcFuncName func),
78 TextAtom (dbcTextType (dbcFuncType func))]
79 dbcTextType typ = T.intercalate " -> " (map prettyAtomType typ ++ ["DatabaseContext", "DatabaseContext"])