git.iko.soy/project-m36
on f7fc888 help sign in
project-m36/src/lib/ProjectM36/AtomFunction.hs
100 lines 4.9 kB history raw
1{-# LANGUAGE CPP #-}
2module ProjectM36.AtomFunction where
3import ProjectM36.Base
4import ProjectM36.Error
5import ProjectM36.Relation
6import ProjectM36.AtomType
7import ProjectM36.AtomFunctionError
8import ProjectM36.ScriptSession
9import qualified ProjectM36.Attribute as A
10import qualified Data.HashSet as HS
11import qualified Data.Text as T
12import qualified Data.ByteString.Lazy as BL
13import Data.Binary as B
15foldAtomFuncType :: AtomType -> AtomType -> [AtomType]
16--the underscore in the attribute name means that any attributes are acceptable
17foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType]
19atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction
20atomFunctionForName funcName funcSet = if HS.null foundFunc then
21 Left $ NoSuchFunctionError funcName
22 else
23 Right $ head $ HS.toList foundFunc
24 where
25 foundFunc = HS.filter (\(AtomFunction name _ _) -> name == funcName) funcSet
27-- | Create a junk named atom function for use with searching for an already existing function in the AtomFunctions HashSet.
28emptyAtomFunction :: AtomFunctionName -> AtomFunction
29emptyAtomFunction name = AtomFunction { atomFuncName = name,
30 atomFuncType = [TypeVariableType "a", TypeVariableType "a"],
31 atomFuncBody = AtomFunctionBody Nothing (\(x:_) -> pure x) }
34-- | AtomFunction constructor for compiled-in functions.
35compiledAtomFunction :: AtomFunctionName -> [AtomType] -> AtomFunctionBodyType -> AtomFunction
36compiledAtomFunction name aType body = AtomFunction { atomFuncName = name,
37 atomFuncType = aType,
38 atomFuncBody = AtomFunctionBody Nothing body }
40--the atom function really should offer some way to return an error
41evalAtomFunction :: AtomFunction -> [Atom] -> Either AtomFunctionError Atom
42evalAtomFunction func args = case atomFuncBody func of
43 (AtomFunctionBody _ f) -> f args
45--expect "Int -> Either AtomFunctionError Int"
46--return "Int -> Int" for funcType
47extractAtomFunctionType :: [TypeConstructor] -> Either RelationalError [TypeConstructor]
48extractAtomFunctionType typeIn = do
49 let atomArgs = take (length typeIn - 1) typeIn
50 --expected atom ret value - used to make funcType
51 lastArg = take 1 (reverse typeIn)
52 case lastArg of
53 [ADTypeConstructor "Either"
54 [ADTypeConstructor "AtomFunctionError" [],
55 atomRetArg]] ->
56 pure (atomArgs ++ [atomRetArg])
57 otherType ->
58 Left (ScriptError (TypeCheckCompilationError "function returning \"Either AtomFunctionError a\"" (show otherType)))
60isScriptedAtomFunction :: AtomFunction -> Bool
61isScriptedAtomFunction func = case atomFuncBody func of
62 AtomFunctionBody (Just _) _ -> True
63 AtomFunctionBody Nothing _ -> False
65atomFunctionScript :: AtomFunction -> Maybe AtomFunctionBodyScript
66atomFunctionScript func = case atomFuncBody func of
67 AtomFunctionBody script _ -> script
69-- | Create a 'DatabaseContextIOExpr' which can be used to load a new atom function written in Haskell and loaded at runtime.
70createScriptedAtomFunction :: AtomFunctionName -> [TypeConstructor] -> TypeConstructor -> AtomFunctionBodyScript -> DatabaseContextIOExpr
71createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName (
72 argsType ++ [ADTypeConstructor "Either" [
73 ADTypeConstructor "AtomFunctionError" [],
74 retType]])
76loadAtomFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [AtomFunction])
77#ifdef PM36_HASKELL_SCRIPTING
78loadAtomFunctions = loadFunction
79#else
80loadAtomFunctions _ _ _ = pure (Left LoadSymbolError)
81#endif
83atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation
84atomFunctionsAsRelation funcs = mkRelationFromList attrs tups
85 where tups = map atomFuncToTuple (HS.toList funcs)
86 attrs = A.attributesFromList [Attribute "name" TextAtomType,
87 Attribute "arguments" TextAtomType]
88 atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),
89 TextAtom (atomFuncTypeToText aFunc)]
90 atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc))
92--for calculating the merkle hash
93hashBytes :: AtomFunction -> BL.ByteString
94hashBytes func = mconcat [B.encode (atomFuncName func),
95 B.encode (atomFuncType func),
96 bodyBin
97 ]
98 where
99 bodyBin = case atomFuncBody func of
100 AtomFunctionBody mScript _ -> B.encode mScript