{-# 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 = forall a. a -> FunctionBody a
FunctionBuiltInBody

emptyDatabaseContextFunction :: FunctionName -> DatabaseContextFunction
emptyDatabaseContextFunction :: TypeConstructorName -> DatabaseContextFunction
emptyDatabaseContextFunction TypeConstructorName
name = Function { 
  funcName :: TypeConstructorName
funcName = TypeConstructorName
name,
  funcType :: [AtomType]
funcType = [],
  funcBody :: DatabaseContextFunctionBody
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody (\[Atom]
_ DatabaseContext
ctx -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseContext
ctx)
  }

databaseContextFunctionForName :: FunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction
databaseContextFunctionForName :: TypeConstructorName
-> DatabaseContextFunctions
-> Either RelationalError DatabaseContextFunction
databaseContextFunctionForName TypeConstructorName
funcName' DatabaseContextFunctions
funcs = if forall a. HashSet a -> Bool
HS.null DatabaseContextFunctions
foundFunc then
                                                   forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ TypeConstructorName -> RelationalError
NoSuchFunctionError TypeConstructorName
funcName'
                                                else
                                                  forall a b. b -> Either a b
Right (forall a. [a] -> a
head (forall a. HashSet a -> [a]
HS.toList DatabaseContextFunctions
foundFunc))
  where
    foundFunc :: DatabaseContextFunctions
foundFunc = forall a. (a -> Bool) -> HashSet a -> HashSet a
HS.filter (\DatabaseContextFunction
f -> forall a. Function a -> TypeConstructorName
funcName DatabaseContextFunction
f forall a. Eq a => a -> a -> Bool
== TypeConstructorName
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 -> forall a b. a -> Either a b
Left (DatabaseContextFunctionError -> RelationalError
DatabaseContextFunctionUserError DatabaseContextFunctionError
err)
    Right DatabaseContext
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseContext
c
  where
   f :: DatabaseContextFunctionBodyType
f = forall a. FunctionBody a -> a
function (forall a. Function a -> FunctionBody a
funcBody DatabaseContextFunction
func)
   
basicDatabaseContextFunctions :: DatabaseContextFunctions
basicDatabaseContextFunctions :: DatabaseContextFunctions
basicDatabaseContextFunctions = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [
  Function { funcName :: TypeConstructorName
funcName = TypeConstructorName
"deleteAll",
             funcType :: [AtomType]
funcType = [],
             funcBody :: DatabaseContextFunctionBody
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody (\[Atom]
_ DatabaseContext
ctx -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ DatabaseContext
ctx { 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 = forall a. (a -> Bool) -> HashSet a -> HashSet a
HS.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatabaseContextFunction -> Bool
isScriptedDatabaseContextFunction) DatabaseContextFunctions
basicDatabaseContextFunctions
                                
isScriptedDatabaseContextFunction :: DatabaseContextFunction -> Bool
isScriptedDatabaseContextFunction :: DatabaseContextFunction -> Bool
isScriptedDatabaseContextFunction DatabaseContextFunction
func = forall a. Maybe a -> Bool
isJust (forall a. Function a -> Maybe TypeConstructorName
functionScript DatabaseContextFunction
func)
  
databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor
databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor
databaseContextFunctionReturnType TypeConstructor
tCons = forall a.
TypeConstructorName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor TypeConstructorName
"Either" [
  forall a.
TypeConstructorName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor TypeConstructorName
"DatabaseContextFunctionError" [],
  TypeConstructor
tCons]
                                          
createScriptedDatabaseContextFunction :: FunctionName -> [TypeConstructor] -> TypeConstructor -> FunctionBodyScript -> DatabaseContextIOExpr
createScriptedDatabaseContextFunction :: TypeConstructorName
-> [TypeConstructor]
-> TypeConstructor
-> TypeConstructorName
-> DatabaseContextIOExpr
createScriptedDatabaseContextFunction TypeConstructorName
funcName' [TypeConstructor]
argsIn TypeConstructor
retArg = forall a.
TypeConstructorName
-> [TypeConstructor]
-> TypeConstructorName
-> DatabaseContextIOExprBase a
AddDatabaseContextFunction TypeConstructorName
funcName' ([TypeConstructor]
argsIn 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 [TypeConstructorName -> AtomType -> Attribute
Attribute TypeConstructorName
"name" AtomType
TextAtomType,
                                  TypeConstructorName -> AtomType -> Attribute
Attribute TypeConstructorName
"arguments" AtomType
TextAtomType]
    tups :: [[Atom]]
tups = forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Function a -> [Atom]
dbcFuncToTuple (forall a. HashSet a -> [a]
HS.toList DatabaseContextFunctions
dbcFuncs)
    dbcFuncToTuple :: Function a -> [Atom]
dbcFuncToTuple Function a
func = [TypeConstructorName -> Atom
TextAtom (forall a. Function a -> TypeConstructorName
funcName Function a
func),
                           TypeConstructorName -> Atom
TextAtom ([AtomType] -> TypeConstructorName
dbcTextType (forall a. Function a -> [AtomType]
funcType Function a
func))]
    dbcTextType :: [AtomType] -> TypeConstructorName
dbcTextType [AtomType]
typ = TypeConstructorName -> [TypeConstructorName] -> TypeConstructorName
T.intercalate TypeConstructorName
" -> " (forall a b. (a -> b) -> [a] -> [b]
map AtomType -> TypeConstructorName
prettyAtomType [AtomType]
typ forall a. [a] -> [a] -> [a]
++ [TypeConstructorName
"DatabaseContext", TypeConstructorName
"DatabaseContext"])