{-# LANGUAGE CPP #-}
module ProjectM36.AtomFunction where
import ProjectM36.Base
import ProjectM36.Serialise.Base ()
import ProjectM36.Error
import ProjectM36.Relation
import ProjectM36.AtomType
import ProjectM36.AtomFunctionError
import ProjectM36.Function
import qualified ProjectM36.Attribute as A
import qualified Data.HashSet as HS
import qualified Data.Text as T
import qualified Data.ByteString.Lazy as BL
import Codec.Winery
foldAtomFuncType :: AtomType -> AtomType -> [AtomType]
foldAtomFuncType :: AtomType -> AtomType -> [AtomType]
foldAtomFuncType AtomType
foldType AtomType
returnType = [Attributes -> AtomType
RelationAtomType ([Attribute] -> Attributes
A.attributesFromList [AttributeName -> AtomType -> Attribute
Attribute AttributeName
"_" AtomType
foldType]), AtomType
returnType]
atomFunctionForName :: FunctionName -> AtomFunctions -> Either RelationalError AtomFunction
atomFunctionForName :: AttributeName
-> AtomFunctions -> Either RelationalError AtomFunction
atomFunctionForName AttributeName
funcName' AtomFunctions
funcSet = if AtomFunctions -> Bool
forall a. HashSet a -> Bool
HS.null AtomFunctions
foundFunc then
RelationalError -> Either RelationalError AtomFunction
forall a b. a -> Either a b
Left (RelationalError -> Either RelationalError AtomFunction)
-> RelationalError -> Either RelationalError AtomFunction
forall a b. (a -> b) -> a -> b
$ AttributeName -> RelationalError
NoSuchFunctionError AttributeName
funcName'
else
AtomFunction -> Either RelationalError AtomFunction
forall a b. b -> Either a b
Right (AtomFunction -> Either RelationalError AtomFunction)
-> AtomFunction -> Either RelationalError AtomFunction
forall a b. (a -> b) -> a -> b
$ [AtomFunction] -> AtomFunction
forall a. [a] -> a
head ([AtomFunction] -> AtomFunction) -> [AtomFunction] -> AtomFunction
forall a b. (a -> b) -> a -> b
$ AtomFunctions -> [AtomFunction]
forall a. HashSet a -> [a]
HS.toList AtomFunctions
foundFunc
where
foundFunc :: AtomFunctions
foundFunc = (AtomFunction -> Bool) -> AtomFunctions -> AtomFunctions
forall a. (a -> Bool) -> HashSet a -> HashSet a
HS.filter (\AtomFunction
f -> AtomFunction -> AttributeName
forall a. Function a -> AttributeName
funcName AtomFunction
f AttributeName -> AttributeName -> Bool
forall a. Eq a => a -> a -> Bool
== AttributeName
funcName') AtomFunctions
funcSet
emptyAtomFunction :: FunctionName -> AtomFunction
emptyAtomFunction :: AttributeName -> AtomFunction
emptyAtomFunction AttributeName
name = Function :: forall a.
AttributeName -> [AtomType] -> FunctionBody a -> Function a
Function { funcName :: AttributeName
funcName = AttributeName
name,
funcType :: [AtomType]
funcType = [AttributeName -> AtomType
TypeVariableType AttributeName
"a", AttributeName -> AtomType
TypeVariableType AttributeName
"a"],
funcBody :: FunctionBody AtomFunctionBodyType
funcBody = AtomFunctionBodyType -> FunctionBody AtomFunctionBodyType
forall a. a -> FunctionBody a
FunctionBuiltInBody (\(Atom
x:[Atom]
_) -> Atom -> Either AtomFunctionError Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
x) }
compiledAtomFunction :: FunctionName -> [AtomType] -> AtomFunctionBodyType -> AtomFunction
compiledAtomFunction :: AttributeName -> [AtomType] -> AtomFunctionBodyType -> AtomFunction
compiledAtomFunction AttributeName
name [AtomType]
aType AtomFunctionBodyType
body = Function :: forall a.
AttributeName -> [AtomType] -> FunctionBody a -> Function a
Function { funcName :: AttributeName
funcName = AttributeName
name,
funcType :: [AtomType]
funcType = [AtomType]
aType,
funcBody :: FunctionBody AtomFunctionBodyType
funcBody = AtomFunctionBodyType -> FunctionBody AtomFunctionBodyType
forall a. a -> FunctionBody a
FunctionBuiltInBody AtomFunctionBodyType
body }
evalAtomFunction :: AtomFunction -> [Atom] -> Either AtomFunctionError Atom
evalAtomFunction :: AtomFunction -> AtomFunctionBodyType
evalAtomFunction AtomFunction
func = FunctionBody AtomFunctionBodyType -> AtomFunctionBodyType
forall a. FunctionBody a -> a
function (AtomFunction -> FunctionBody AtomFunctionBodyType
forall a. Function a -> FunctionBody a
funcBody AtomFunction
func)
extractAtomFunctionType :: [TypeConstructor] -> Either RelationalError [TypeConstructor]
[TypeConstructor]
typeIn = do
let atomArgs :: [TypeConstructor]
atomArgs = Int -> [TypeConstructor] -> [TypeConstructor]
forall a. Int -> [a] -> [a]
take ([TypeConstructor] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeConstructor]
typeIn Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [TypeConstructor]
typeIn
lastArg :: [TypeConstructor]
lastArg = Int -> [TypeConstructor] -> [TypeConstructor]
forall a. Int -> [a] -> [a]
take Int
1 ([TypeConstructor] -> [TypeConstructor]
forall a. [a] -> [a]
reverse [TypeConstructor]
typeIn)
case [TypeConstructor]
lastArg of
[ADTypeConstructor AttributeName
"Either"
[ADTypeConstructor AttributeName
"AtomFunctionError" [],
TypeConstructor
atomRetArg]] ->
[TypeConstructor] -> Either RelationalError [TypeConstructor]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TypeConstructor]
atomArgs [TypeConstructor] -> [TypeConstructor] -> [TypeConstructor]
forall a. [a] -> [a] -> [a]
++ [TypeConstructor
atomRetArg])
[TypeConstructor]
otherType ->
RelationalError -> Either RelationalError [TypeConstructor]
forall a b. a -> Either a b
Left (ScriptCompilationError -> RelationalError
ScriptError (String -> String -> ScriptCompilationError
TypeCheckCompilationError String
"function returning \"Either AtomFunctionError a\"" ([TypeConstructor] -> String
forall a. Show a => a -> String
show [TypeConstructor]
otherType)))
isScriptedAtomFunction :: AtomFunction -> Bool
isScriptedAtomFunction :: AtomFunction -> Bool
isScriptedAtomFunction AtomFunction
func = case AtomFunction -> FunctionBody AtomFunctionBodyType
forall a. Function a -> FunctionBody a
funcBody AtomFunction
func of
FunctionScriptBody{} -> Bool
True
FunctionBody AtomFunctionBodyType
_ -> Bool
False
createScriptedAtomFunction :: FunctionName -> [TypeConstructor] -> TypeConstructor -> FunctionBodyScript -> DatabaseContextIOExpr
createScriptedAtomFunction :: AttributeName
-> [TypeConstructor]
-> TypeConstructor
-> AttributeName
-> DatabaseContextIOExpr
createScriptedAtomFunction AttributeName
funcName' [TypeConstructor]
argsType TypeConstructor
retType = AttributeName
-> [TypeConstructor] -> AttributeName -> DatabaseContextIOExpr
forall a.
AttributeName
-> [TypeConstructor]
-> AttributeName
-> DatabaseContextIOExprBase a
AddAtomFunction AttributeName
funcName' (
[TypeConstructor]
argsType [TypeConstructor] -> [TypeConstructor] -> [TypeConstructor]
forall a. [a] -> [a] -> [a]
++ [AttributeName -> [TypeConstructor] -> TypeConstructor
forall a.
AttributeName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor AttributeName
"Either" [
AttributeName -> [TypeConstructor] -> TypeConstructor
forall a.
AttributeName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor AttributeName
"AtomFunctionError" [],
TypeConstructor
retType]])
atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation
atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation
atomFunctionsAsRelation AtomFunctions
funcs = Attributes -> [[Atom]] -> Either RelationalError Relation
mkRelationFromList Attributes
attrs [[Atom]]
tups
where tups :: [[Atom]]
tups = (AtomFunction -> [Atom]) -> [AtomFunction] -> [[Atom]]
forall a b. (a -> b) -> [a] -> [b]
map AtomFunction -> [Atom]
forall a. Function a -> [Atom]
atomFuncToTuple (AtomFunctions -> [AtomFunction]
forall a. HashSet a -> [a]
HS.toList AtomFunctions
funcs)
attrs :: Attributes
attrs = [Attribute] -> Attributes
A.attributesFromList [AttributeName -> AtomType -> Attribute
Attribute AttributeName
"name" AtomType
TextAtomType,
AttributeName -> AtomType -> Attribute
Attribute AttributeName
"arguments" AtomType
TextAtomType]
atomFuncToTuple :: Function a -> [Atom]
atomFuncToTuple Function a
aFunc = [AttributeName -> Atom
TextAtom (Function a -> AttributeName
forall a. Function a -> AttributeName
funcName Function a
aFunc),
AttributeName -> Atom
TextAtom (Function a -> AttributeName
forall a. Function a -> AttributeName
atomFuncTypeToText Function a
aFunc)]
atomFuncTypeToText :: Function a -> AttributeName
atomFuncTypeToText Function a
aFunc = AttributeName -> [AttributeName] -> AttributeName
T.intercalate AttributeName
" -> " ((AtomType -> AttributeName) -> [AtomType] -> [AttributeName]
forall a b. (a -> b) -> [a] -> [b]
map AtomType -> AttributeName
prettyAtomType (Function a -> [AtomType]
forall a. Function a -> [AtomType]
funcType Function a
aFunc))
hashBytes :: AtomFunction -> BL.ByteString
hashBytes :: AtomFunction -> ByteString
hashBytes AtomFunction
func = [ByteString] -> ByteString
BL.fromChunks [AttributeName -> ByteString
forall a. Serialise a => a -> ByteString
serialise (AtomFunction -> AttributeName
forall a. Function a -> AttributeName
funcName AtomFunction
func),
[AtomType] -> ByteString
forall a. Serialise a => a -> ByteString
serialise (AtomFunction -> [AtomType]
forall a. Function a -> [AtomType]
funcType AtomFunction
func),
ByteString
bodyBin
]
where
bodyBin :: ByteString
bodyBin = case AtomFunction -> FunctionBody AtomFunctionBodyType
forall a. Function a -> FunctionBody a
funcBody AtomFunction
func of
FunctionScriptBody AttributeName
mScript AtomFunctionBodyType
_ -> AttributeName -> ByteString
forall a. Serialise a => a -> ByteString
serialise AttributeName
mScript
FunctionBuiltInBody AtomFunctionBodyType
_ -> ByteString
""
FunctionObjectLoadedBody String
f String
m String
n AtomFunctionBodyType
_ -> (String, String, String) -> ByteString
forall a. Serialise a => a -> ByteString
serialise (String
f,String
m,String
n)
externalAtomFunction :: AtomFunctionBodyType -> AtomFunctionBody
externalAtomFunction :: AtomFunctionBodyType -> FunctionBody AtomFunctionBodyType
externalAtomFunction = AtomFunctionBodyType -> FunctionBody AtomFunctionBodyType
forall a. a -> FunctionBody a
FunctionBuiltInBody