@@ -398,18 +398,20 @@ evalContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do
398398 if expectedArgCount /= actualArgCount then
399399 pure (Just (FunctionArgumentCountMismatch expectedArgCount actualArgCount))
400400 else do
401− {-
402− mapM_ (\(expType, actType) -> case atomTypeVerify expType actType of
403− Left err -> pure (Just err)
404− Right _ -> pure Nothing) (safeInit (zip (dbcFuncType func) atomTypes))
405− -}
406− let eAtomArgs = map (\arg -> evalState (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs
401+
402+ let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of
403+ Left err -> Just err
404+ Right _ -> Nothing) (safeInit (zip (dbcFuncType func) atomTypes))
405+ typeErrors = catMaybes mValidTypes
406+ eAtomArgs = map (\arg -> evalState (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs
407407 if length (lefts eAtomArgs) > 1 then
408408 pure (Just (MultipleErrors (lefts eAtomArgs)))
409− else do
410− let newContext = evalDatabaseContextFunction func (rights eAtomArgs) context
411− put newContext
412− pure Nothing
409+ else if length typeErrors > 1 then
410+ pure (Just (MultipleErrors typeErrors))
411+ else do
412+ let newContext = evalDatabaseContextFunction func (rights eAtomArgs) context
413+ put newContext
414+ pure Nothing
413415
414416evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
415417evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = do
@@ -445,32 +447,42 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcNam
445447evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) = do
446448 case mScriptSession of
447449 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
448− Just scriptSession -> do
449− res <- try $ runGhc (Just libdir) $ do
450− setSession (hscEnv scriptSession)
451− eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script
452− pure $ case eCompiledFunc of
453− Left err -> Left (ScriptError err)
454− Right compiledFunc -> do
455− funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext)) funcType
456− let updatedDBCFuncs = HS.insert newDBCFunc (dbcFunctions currentContext)
457− newContext = currentContext { dbcFunctions = updatedDBCFuncs }
458− dbcFuncs = dbcFunctions currentContext
459− newDBCFunc = DatabaseContextFunction {
460− dbcFuncName = funcName,
461− dbcFuncType = funcAtomType,
462− dbcFuncBody = DatabaseContextFunctionBody (Just script) compiledFunc
463− }
450+ Just scriptSession -> do
451+ --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext
452+ let last2Args = take 2 (reverse funcType)
453+ atomArgs = take (length funcType - 2) funcType
454+ dbContextTypeCons = ADTypeConstructor "DatabaseContext" []
455+ expectedType = "DatabaseContextExpr -> DatabaseContextExpr"
456+ actualType = show funcType
457+ if last2Args /= replicate 2 dbContextTypeCons then
458+ pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))
459+ else do
460+ res <- try $ runGhc (Just libdir) $ do
461+ setSession (hscEnv scriptSession)
462+ eCompiledFunc <- compileScript (dbcFunctionBodyType scriptSession) script
463+ pure $ case eCompiledFunc of
464+ Left err -> Left (ScriptError err)
465+ Right compiledFunc -> do
466+ --if we are here, we have validated that the written function type is X -> DatabaseContext -> DatabaseContext, so we need to munge the first elements into an array
467+ funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext)) atomArgs
468+ let updatedDBCFuncs = HS.insert newDBCFunc (dbcFunctions currentContext)
469+ newContext = currentContext { dbcFunctions = updatedDBCFuncs }
470+ dbcFuncs = dbcFunctions currentContext
471+ newDBCFunc = DatabaseContextFunction {
472+ dbcFuncName = funcName,
473+ dbcFuncType = funcAtomType,
474+ dbcFuncBody = DatabaseContextFunctionBody (Just script) compiledFunc
475+ }
464476 -- check if the name is already in use
465− if HS.member funcName (HS.map dbcFuncName dbcFuncs) then
466− Left (FunctionNameInUseError funcName)
467− else do
468− Right newContext
469− case res of
470− Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
471− Right eContext -> case eContext of
472− Left err -> pure (Left err)
473− Right context' -> pure (Right context')
477+ if HS.member funcName (HS.map dbcFuncName dbcFuncs) then
478+ Left (FunctionNameInUseError funcName)
479+ else do
480+ Right newContext
481+ case res of
482+ Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))
483+ Right eContext -> case eContext of
484+ Left err -> pure (Left err)
485+ Right context' -> pure (Right context')
474486
475487
476488updateTupleWithAtomExprs :: (M.Map AttributeName AtomExpr) -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple
@@ -626,7 +638,7 @@ evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do
626638 runExceptT $ do
627639 let functions = atomFunctions context
628640 func <- either throwE pure (atomFunctionForName funcName functions)
629− let expectedArgCount = length (atomFuncType func) - 1
641+ let expectedArgCount = length (atomFuncType func)
630642 actualArgCount = length argTypes
631643 safeInit [_] = []
632644 safeInit [] = [] -- different behavior from normal init