git.iko.soy/project-m36
on e5bb4e5 help sign in
project-m36/src/lib/ProjectM36/DatabaseContextFunction.hs
91 lines 4.7 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.Serialise.Base ()
7import ProjectM36.Attribute as A
8import ProjectM36.Relation
9import ProjectM36.AtomType
10import qualified Data.HashSet as HS
11import qualified Data.Map as M
12import ProjectM36.ScriptSession
13import qualified Data.Text as T
14import qualified Data.ByteString.Lazy as BL
15import Codec.Winery
17emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction
18emptyDatabaseContextFunction name = DatabaseContextFunction {
19 dbcFuncName = name,
20 dbcFuncType = [],
21 dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> pure ctx)
22 }
24databaseContextFunctionForName :: DatabaseContextFunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction
25databaseContextFunctionForName funcName funcs = if HS.null foundFunc then
26 Left $ NoSuchFunctionError funcName
27 else
28 Right (head (HS.toList foundFunc))
29 where
30 foundFunc = HS.filter (\(DatabaseContextFunction name _ _) -> name == funcName) funcs
32evalDatabaseContextFunction :: DatabaseContextFunction -> [Atom] -> DatabaseContext -> Either RelationalError DatabaseContext
33evalDatabaseContextFunction func args ctx = case dbcFuncBody func of
34 (DatabaseContextFunctionBody _ f) -> case f args ctx of
35 Left err -> Left (DatabaseContextFunctionUserError err)
36 Right c -> pure c
38basicDatabaseContextFunctions :: DatabaseContextFunctions
39basicDatabaseContextFunctions = HS.fromList [
40 DatabaseContextFunction { dbcFuncName = "deleteAll",
41 dbcFuncType = [],
42 dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> pure $ ctx { relationVariables = M.empty })
43 }
44 ]
46--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).
47precompiledDatabaseContextFunctions :: DatabaseContextFunctions
48precompiledDatabaseContextFunctions = HS.filter (not . isScriptedDatabaseContextFunction) basicDatabaseContextFunctions
50isScriptedDatabaseContextFunction :: DatabaseContextFunction -> Bool
51isScriptedDatabaseContextFunction func = case dbcFuncBody func of
52 DatabaseContextFunctionBody (Just _) _ -> True
53 DatabaseContextFunctionBody Nothing _ -> False
55databaseContextFunctionScript :: DatabaseContextFunction -> Maybe DatabaseContextFunctionBodyScript
56databaseContextFunctionScript func = case dbcFuncBody func of
57 DatabaseContextFunctionBody script _ -> script
59databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor
60databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [
61 ADTypeConstructor "DatabaseContextFunctionError" [],
62 tCons]
64createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr
65createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg])
67loadDatabaseContextFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [DatabaseContextFunction])
68#ifdef PM36_HASKELL_SCRIPTING
69loadDatabaseContextFunctions = loadFunction
70#else
71loadDatabaseContextFunctions _ _ _ = pure (Left LoadSymbolError)
72#endif
74databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation
75databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups
76 where
77 attrs = A.attributesFromList [Attribute "name" TextAtomType,
78 Attribute "arguments" TextAtomType]
79 tups = map dbcFuncToTuple (HS.toList dbcFuncs)
80 dbcFuncToTuple func = [TextAtom (dbcFuncName func),
81 TextAtom (dbcTextType (dbcFuncType func))]
82 dbcTextType typ = T.intercalate " -> " (map prettyAtomType typ ++ ["DatabaseContext", "DatabaseContext"])
84-- for merkle hash
85hashBytes :: DatabaseContextFunction -> BL.ByteString
86hashBytes func = BL.fromChunks [fname, ftype, fbody]
87 where
88 fname = serialise (dbcFuncName func)
89 ftype = serialise (dbcFuncType func)
90 fbody = case dbcFuncBody func of
91 DatabaseContextFunctionBody mBody _ -> serialise mBody