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