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