{-# LANGUAGE CPP #-}
module ProjectM36.DatabaseContextFunction where
--implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
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 })
           }
  ]
                                
--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).
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"])