{-# LANGUAGE CPP #-}
module ProjectM36.DatabaseContextFunction where
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.Serialise.Base ()
import ProjectM36.Attribute as A
import ProjectM36.Relation
import ProjectM36.AtomType
import ProjectM36.Function
import qualified Data.HashSet as HS
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Maybe (isJust)
externalDatabaseContextFunction :: DatabaseContextFunctionBodyType -> DatabaseContextFunctionBody
externalDatabaseContextFunction :: DatabaseContextFunctionBodyType -> DatabaseContextFunctionBody
externalDatabaseContextFunction = DatabaseContextFunctionBodyType -> DatabaseContextFunctionBody
forall a. a -> FunctionBody a
FunctionBuiltInBody
emptyDatabaseContextFunction :: FunctionName -> DatabaseContextFunction
emptyDatabaseContextFunction :: FunctionName -> DatabaseContextFunction
emptyDatabaseContextFunction FunctionName
name = Function :: forall a.
FunctionName -> [AtomType] -> FunctionBody a -> Function a
Function {
funcName :: FunctionName
funcName = FunctionName
name,
funcType :: [AtomType]
funcType = [],
funcBody :: DatabaseContextFunctionBody
funcBody = DatabaseContextFunctionBodyType -> DatabaseContextFunctionBody
forall a. a -> FunctionBody a
FunctionBuiltInBody (\[Atom]
_ DatabaseContext
ctx -> DatabaseContext
-> Either DatabaseContextFunctionError DatabaseContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseContext
ctx)
}
databaseContextFunctionForName :: FunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction
databaseContextFunctionForName :: FunctionName
-> DatabaseContextFunctions
-> Either RelationalError DatabaseContextFunction
databaseContextFunctionForName FunctionName
funcName' DatabaseContextFunctions
funcs = if DatabaseContextFunctions -> Bool
forall a. HashSet a -> Bool
HS.null DatabaseContextFunctions
foundFunc then
RelationalError -> Either RelationalError DatabaseContextFunction
forall a b. a -> Either a b
Left (RelationalError -> Either RelationalError DatabaseContextFunction)
-> RelationalError
-> Either RelationalError DatabaseContextFunction
forall a b. (a -> b) -> a -> b
$ FunctionName -> RelationalError
NoSuchFunctionError FunctionName
funcName'
else
DatabaseContextFunction
-> Either RelationalError DatabaseContextFunction
forall a b. b -> Either a b
Right ([DatabaseContextFunction] -> DatabaseContextFunction
forall a. [a] -> a
head (DatabaseContextFunctions -> [DatabaseContextFunction]
forall a. HashSet a -> [a]
HS.toList DatabaseContextFunctions
foundFunc))
where
foundFunc :: DatabaseContextFunctions
foundFunc = (DatabaseContextFunction -> Bool)
-> DatabaseContextFunctions -> DatabaseContextFunctions
forall a. (a -> Bool) -> HashSet a -> HashSet a
HS.filter (\DatabaseContextFunction
f -> DatabaseContextFunction -> FunctionName
forall a. Function a -> FunctionName
funcName DatabaseContextFunction
f FunctionName -> FunctionName -> Bool
forall a. Eq a => a -> a -> Bool
== FunctionName
funcName') DatabaseContextFunctions
funcs
evalDatabaseContextFunction :: DatabaseContextFunction -> [Atom] -> DatabaseContext -> Either RelationalError DatabaseContext
evalDatabaseContextFunction :: DatabaseContextFunction
-> [Atom]
-> DatabaseContext
-> Either RelationalError DatabaseContext
evalDatabaseContextFunction DatabaseContextFunction
func [Atom]
args DatabaseContext
ctx =
case DatabaseContextFunctionBodyType
f [Atom]
args DatabaseContext
ctx of
Left DatabaseContextFunctionError
err -> RelationalError -> Either RelationalError DatabaseContext
forall a b. a -> Either a b
Left (DatabaseContextFunctionError -> RelationalError
DatabaseContextFunctionUserError DatabaseContextFunctionError
err)
Right DatabaseContext
c -> DatabaseContext -> Either RelationalError DatabaseContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseContext
c
where
f :: DatabaseContextFunctionBodyType
f = DatabaseContextFunctionBody -> DatabaseContextFunctionBodyType
forall a. FunctionBody a -> a
function (DatabaseContextFunction -> DatabaseContextFunctionBody
forall a. Function a -> FunctionBody a
funcBody DatabaseContextFunction
func)
basicDatabaseContextFunctions :: DatabaseContextFunctions
basicDatabaseContextFunctions :: DatabaseContextFunctions
basicDatabaseContextFunctions = [DatabaseContextFunction] -> DatabaseContextFunctions
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [
Function :: forall a.
FunctionName -> [AtomType] -> FunctionBody a -> Function a
Function { funcName :: FunctionName
funcName = FunctionName
"deleteAll",
funcType :: [AtomType]
funcType = [],
funcBody :: DatabaseContextFunctionBody
funcBody = DatabaseContextFunctionBodyType -> DatabaseContextFunctionBody
forall a. a -> FunctionBody a
FunctionBuiltInBody (\[Atom]
_ DatabaseContext
ctx -> DatabaseContext
-> Either DatabaseContextFunctionError DatabaseContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DatabaseContext
-> Either DatabaseContextFunctionError DatabaseContext)
-> DatabaseContext
-> Either DatabaseContextFunctionError DatabaseContext
forall a b. (a -> b) -> a -> b
$ DatabaseContext
ctx { relationVariables :: RelationVariables
relationVariables = RelationVariables
forall k a. Map k a
M.empty })
}
]
precompiledDatabaseContextFunctions :: DatabaseContextFunctions
precompiledDatabaseContextFunctions :: DatabaseContextFunctions
precompiledDatabaseContextFunctions = (DatabaseContextFunction -> Bool)
-> DatabaseContextFunctions -> DatabaseContextFunctions
forall a. (a -> Bool) -> HashSet a -> HashSet a
HS.filter (Bool -> Bool
not (Bool -> Bool)
-> (DatabaseContextFunction -> Bool)
-> DatabaseContextFunction
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatabaseContextFunction -> Bool
isScriptedDatabaseContextFunction) DatabaseContextFunctions
basicDatabaseContextFunctions
isScriptedDatabaseContextFunction :: DatabaseContextFunction -> Bool
isScriptedDatabaseContextFunction :: DatabaseContextFunction -> Bool
isScriptedDatabaseContextFunction DatabaseContextFunction
func = Maybe FunctionName -> Bool
forall a. Maybe a -> Bool
isJust (DatabaseContextFunction -> Maybe FunctionName
forall a. Function a -> Maybe FunctionName
functionScript DatabaseContextFunction
func)
databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor
databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor
databaseContextFunctionReturnType TypeConstructor
tCons = FunctionName -> [TypeConstructor] -> TypeConstructor
forall a.
FunctionName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor FunctionName
"Either" [
FunctionName -> [TypeConstructor] -> TypeConstructor
forall a.
FunctionName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor FunctionName
"DatabaseContextFunctionError" [],
TypeConstructor
tCons]
createScriptedDatabaseContextFunction :: FunctionName -> [TypeConstructor] -> TypeConstructor -> FunctionBodyScript -> DatabaseContextIOExpr
createScriptedDatabaseContextFunction :: FunctionName
-> [TypeConstructor]
-> TypeConstructor
-> FunctionName
-> DatabaseContextIOExpr
createScriptedDatabaseContextFunction FunctionName
funcName' [TypeConstructor]
argsIn TypeConstructor
retArg = FunctionName
-> [TypeConstructor] -> FunctionName -> DatabaseContextIOExpr
forall a.
FunctionName
-> [TypeConstructor] -> FunctionName -> DatabaseContextIOExprBase a
AddDatabaseContextFunction FunctionName
funcName' ([TypeConstructor]
argsIn [TypeConstructor] -> [TypeConstructor] -> [TypeConstructor]
forall a. [a] -> [a] -> [a]
++ [TypeConstructor -> TypeConstructor
databaseContextFunctionReturnType TypeConstructor
retArg])
databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation
databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation
databaseContextFunctionsAsRelation DatabaseContextFunctions
dbcFuncs = Attributes -> [[Atom]] -> Either RelationalError Relation
mkRelationFromList Attributes
attrs [[Atom]]
tups
where
attrs :: Attributes
attrs = [Attribute] -> Attributes
A.attributesFromList [FunctionName -> AtomType -> Attribute
Attribute FunctionName
"name" AtomType
TextAtomType,
FunctionName -> AtomType -> Attribute
Attribute FunctionName
"arguments" AtomType
TextAtomType]
tups :: [[Atom]]
tups = (DatabaseContextFunction -> [Atom])
-> [DatabaseContextFunction] -> [[Atom]]
forall a b. (a -> b) -> [a] -> [b]
map DatabaseContextFunction -> [Atom]
forall a. Function a -> [Atom]
dbcFuncToTuple (DatabaseContextFunctions -> [DatabaseContextFunction]
forall a. HashSet a -> [a]
HS.toList DatabaseContextFunctions
dbcFuncs)
dbcFuncToTuple :: Function a -> [Atom]
dbcFuncToTuple Function a
func = [FunctionName -> Atom
TextAtom (Function a -> FunctionName
forall a. Function a -> FunctionName
funcName Function a
func),
FunctionName -> Atom
TextAtom ([AtomType] -> FunctionName
dbcTextType (Function a -> [AtomType]
forall a. Function a -> [AtomType]
funcType Function a
func))]
dbcTextType :: [AtomType] -> FunctionName
dbcTextType [AtomType]
typ = FunctionName -> [FunctionName] -> FunctionName
T.intercalate FunctionName
" -> " ((AtomType -> FunctionName) -> [AtomType] -> [FunctionName]
forall a b. (a -> b) -> [a] -> [b]
map AtomType -> FunctionName
prettyAtomType [AtomType]
typ [FunctionName] -> [FunctionName] -> [FunctionName]
forall a. [a] -> [a] -> [a]
++ [FunctionName
"DatabaseContext", FunctionName
"DatabaseContext"])