implementation module TaskEval import StdList, StdBool import Error import SystemTypes, IWorld, Task, TaskContext, WorkflowDB from CoreCombinators import >>= from CoreCombinators import :: TaskContainer(..), ::TaskGUI(..), :: ParallelTask(..), :: ParallelControl from TuningCombinators import class tune, instance tune Description, <<@, @>>, :: Description(..) from InteractionTasks import enterInformation, :: LocalViewOn, :: ViewOn from SystemTypes import :: ProcessId(..) from ProcessDB import qualified class ProcessDB(..), instance ProcessDB IWorld from Map import qualified fromList, get, put import iTaskClass from WorkflowAdmin import :: Workflow(..), :: WorkflowTaskContainer(..) ITERATION_THRESHOLD :== 10 createThread :: (Task a) -> Dynamic | iTask a createThread task = (dynamic container :: Container (TaskThread a^) a^) where container = Container {TaskThread|originalTask = task, currentTask = task} createContext :: !ProcessId !Dynamic !ManagerProperties !*IWorld -> (!TaskContext, !*IWorld) createContext processId thread=:(Container {TaskThread|originalTask} :: Container (TaskThread a) a) managerProperties iworld=:{IWorld|timestamp} # originalTaskFuncs = taskFuncs originalTask # (tcontext,iworld) = originalTaskFuncs.initFun (taskNr processId) iworld # properties = { taskProperties = taskProperties originalTask , systemProperties = { taskId = taskNrToString (taskNr processId) , status = Running , issuedAt = timestamp , firstEvent = Nothing , latestEvent = Nothing } , managerProperties = managerProperties } = (TaskContext processId properties 0 (TTCRunning thread tcontext),iworld) where taskNr (WorkflowProcess pid)= [0,pid] taskNr (SessionProcess _) = [0,0] createInstanceFrom :: !WorkflowId !User !(Maybe JSONNode) !*IWorld -> (!MaybeErrorString TaskContext, !*IWorld) createInstanceFrom workflowId worker mbParam iworld = case (getWorkflow workflowId iworld) of (Nothing,iworld) = (Error "No such workflow", iworld) (Just {Workflow|task,managerProperties}, iworld) = case task of WorkflowTask normalTask | isNothing mbParam = createWorkflowContext worker normalTask iworld | otherwise = (Error "Workflow has no parameter", iworld) ParamWorkflowTask paramTask = case mbParam of Just param = case fromJSON param of Just param = createWorkflowContext worker (paramTask param) iworld Nothing = (Error "Invalid argument", iworld) Nothing = createWorkflowContext worker (enterInformation ("Workflow parameter","Enter the parameter of the workflow") [] >>= paramTask) iworld createWorkflowContext :: !User !(Task a) !*IWorld -> (!MaybeErrorString TaskContext, !*IWorld) | iTask a createWorkflowContext worker task iworld # (processId,iworld) = 'ProcessDB'.getNewWorkflowId iworld # (context,iworld) = createContext processId (createThread task) {initManagerProperties & worker = worker} iworld = (Ok context, iworld) //Load an existing task context loadInstance :: !ProcessId !*IWorld -> (!MaybeErrorString TaskContext, !*IWorld) loadInstance processId iworld # (mbContext,iworld) = 'ProcessDB'.getProcessContext processId iworld = case mbContext of Just context = (Ok context, iworld) Nothing = (Error ("Could not load task context for task " +++ toString processId), iworld) editInstance :: !(Maybe EditEvent) !TaskContext !*IWorld -> (!MaybeErrorString TaskContext, !*IWorld) editInstance editEvent context=:(TaskContext processId properties changeNo tcontext) iworld = case tcontext of TTCRunning thread=:(Container {TaskThread|currentTask} :: Container (TaskThread a) a) scontext # editFun = (taskFuncs currentTask).editFun # procId = last (taskNrFromString properties.systemProperties.SystemProperties.taskId) # taskNr = [changeNo,procId] # (scontext,iworld) = case editEvent of Just (ProcessEvent [p,n:steps] event) | p == procId && n == changeNo = editFun taskNr (TaskEvent steps event) scontext iworld | otherwise = editFun taskNr (ProcessEvent [p,n:steps] event) scontext iworld Just (ProcessEvent steps event) = editFun taskNr (ProcessEvent steps event) scontext iworld _ = (scontext, iworld) = (Ok (TaskContext processId properties changeNo (TTCRunning thread scontext)), iworld) _ = (Ok context, iworld) //Evaluate the given context and yield the result of the main task indicated by target evalInstance :: !TaskNr !(Maybe CommitEvent) !TaskContext !*IWorld -> (!MaybeErrorString (TaskResult Dynamic), !TaskContext, !*IWorld) evalInstance target commitEvent context=:(TaskContext processId properties changeNo tcontext) iworld=:{evalStack} = case tcontext of //Eval instance TTCRunning thread=:(Container {TaskThread|currentTask} :: Container (TaskThread a) a) scontext # evalFun = (taskFuncs currentTask).evalFun # (ilayout,playout) = taskLayouters currentTask # pid = last (taskNrFromString properties.systemProperties.SystemProperties.taskId) # taskNr = [changeNo,pid] # taskProperties = currentTask.Task.properties //Update current process id & eval stack in iworld # iworld = {iworld & evalStack = [processId:evalStack]} //Strip the process id and change number from the commit event and switch from ProcessEvent to TaskEvent if it matches # commitEvent = case commitEvent of Just (ProcessEvent [p,n:steps] action) | p == pid && n == changeNo = Just (TaskEvent steps action) | otherwise = Just (ProcessEvent [p,n:steps] action) Just (ProcessEvent steps action) = Just (ProcessEvent steps action) _ = Nothing //Match processId & changeNo in target path //# target = foldr stepTarget [changeNo,pid] target # target = tl (tl target) //TODO: FIGURE OUT WHY IT DOESN'T WORK WHEN FOLDING STEPTARGET //Apply task's eval function # (result,iworld) = evalFun taskNr taskProperties commitEvent target ilayout playout scontext iworld //Restore current process id in iworld # iworld = {iworld & evalStack = evalStack} = case result of TaskBusy tui actions scontext // # properties = setRunning properties # context = TaskContext processId (setRunning properties) changeNo (TTCRunning thread scontext) = (Ok (TaskBusy tui actions scontext), context, iworld) TaskFinished val # context = TaskContext processId (setFinished properties) changeNo (TTCFinished (dynamic val)) = (Ok (TaskFinished (dynamic val)), context, iworld) TaskException e str # context = TaskContext processId (setExcepted properties) changeNo (TTCExcepted str) = (Ok (TaskException e str), context, iworld) TTCFinished r = (Ok (TaskFinished r), context, iworld) TTCExcepted e = (Ok (taskException e), context, iworld) storeInstance :: !TaskContext !*IWorld -> *IWorld storeInstance context=:(TaskContext processId properties changeNo _) iworld = 'ProcessDB'.setProcessContext processId context iworld createTopInstance :: !Int !User !(Maybe JSONNode) !*IWorld -> (!MaybeErrorString (!TaskResult Dynamic, !TaskNr), !*IWorld) createTopInstance workflowId user mbParam iworld # iworld = {iworld & currentUser = user} # (mbContext,iworld) = createInstanceFrom workflowId user mbParam iworld = case mbContext of Error e = (Error e, iworld) Ok context # (mbRes,iworld) = iterateEval [] Nothing context iworld = case mbRes of Ok result = (Ok (result, procNo context), iworld) Error e = (Error e, iworld) where procNo (TaskContext (WorkflowProcess pid) properties _ _) = [pid] createSessionInstance :: !(Task a) !*IWorld -> (!MaybeErrorString (!TaskResult Dynamic, !ProcessId), !*IWorld) | iTask a createSessionInstance task iworld # (sessionId,iworld) = 'ProcessDB'.getNewSessionId iworld # (context, iworld) = createContext sessionId (createThread task) initManagerProperties iworld # (mbRes,iworld) = iterateEval [0,0] Nothing context iworld = case mbRes of Ok result = (Ok (result, sessionId), iworld) Error e = (Error e, iworld) evalTopInstance :: !TaskNr !User !(Maybe EditEvent) !(Maybe CommitEvent) !*IWorld -> (!MaybeErrorString (TaskResult Dynamic), !*IWorld) evalTopInstance target user editEvent commitEvent iworld # iworld = {iworld & currentUser = user} # (mbContext,iworld) = loadInstance processId iworld = case mbContext of Error e = (Error e, iworld) Ok context //Apply edit event (only once) # (mbContext, iworld) = editInstance editEvent context iworld = case mbContext of Error e = (Error e, iworld) Ok context = iterateEval (addChangeNo target context) commitEvent context iworld where //Adds the current changenumber to the target if only a process id is given addChangeNo [processId] (TaskContext _ _ changeNo _) = [changeNo,processId] addChangeNo target _ = target processId = WorkflowProcess (last target) evalSessionInstance :: !ProcessId !(Maybe EditEvent) !(Maybe CommitEvent) !*IWorld -> (!MaybeErrorString (TaskResult Dynamic), !*IWorld) evalSessionInstance sessionId editEvent commitEvent iworld # (mbContext,iworld) = loadInstance sessionId iworld = case mbContext of Error e = (Error e, iworld) Ok context //Apply edit event (only once) # (mbContext, iworld) = editInstance editEvent context iworld = case mbContext of Error e = (Error e, iworld) Ok context = iterateEval [0,0] commitEvent context iworld iterateEval :: !TaskNr !(Maybe CommitEvent) !TaskContext !*IWorld -> (!MaybeErrorString (TaskResult Dynamic), !*IWorld) iterateEval target commitEvent context iworld = eval target commitEvent 1 context iworld where eval :: !TaskNr !(Maybe CommitEvent) !Int !TaskContext !*IWorld -> (!MaybeErrorString (TaskResult Dynamic), !*IWorld) eval target commitEvent iteration context iworld //Initialize the toplevel task list # iworld = {iworld & parallelControls = 'Map'.fromList [(toString GlobalTaskList,(0,[]))]} //Reset read shares list # iworld = {iworld & readShares = Just []} //Evaluate top instance # (mbResult, context, iworld) = evalInstance target commitEvent context iworld = case mbResult of Error e = (Error e, iworld) Ok result //Process controls (eval & store additions/removals) # iworld = processControls iworld //Check for next iteration counter: save or re-evaluate # iworld=:{readShares} = iworld = case result of (TaskBusy _ _ _) | isNothing readShares && iteration < ITERATION_THRESHOLD = eval target Nothing (iteration + 1) context iworld | otherwise # iworld = storeInstance context iworld = (Ok result,iworld) _ # iworld = storeInstance context iworld = (Ok result,iworld) processControls :: !*IWorld -> *IWorld processControls iworld = processControls` [] iworld where processControls` queue iworld //Check for additions/removals in the toplevel task list # (controls, iworld) = getControls iworld //Execute the additions/removals. Additions are appended to the queue to be evaluated # (queue, iworld) = execControls controls queue iworld //Eval an element of the queue and recurse = case queue of [] = iworld [c:cs] //Evaluate and store the context only. We do not want any result # (_,c,iworld) = evalInstance (topTarget c) Nothing c iworld # iworld = storeInstance c iworld = processControls` cs iworld //Extracts controls and resets the toplevel task list getControls iworld=:{parallelControls} = case 'Map'.get (toString GlobalTaskList) parallelControls of Just (_,controls) = (controls, {iworld & parallelControls = 'Map'.put (toString GlobalTaskList)(0,[]) parallelControls}) _ = ([],iworld) execControls [] queue iworld = (queue,iworld) execControls [c:cs] queue iworld=:{currentUser} = case c of AppendTask pid (container :: TaskContainer Void) //Make thread and properties # (thread,managerProperties) = case container of (DetachedTask props,tfun) = (createThread (tfun GlobalTaskList), props) (WindowTask _,tfun) = (createThread (tfun GlobalTaskList),{initManagerProperties & worker = currentUser}) (DialogTask _,tfun) = (createThread (tfun GlobalTaskList),{initManagerProperties & worker = currentUser}) (BodyTask,tfun) = (createThread (tfun GlobalTaskList),{initManagerProperties & worker = currentUser}) (HiddenTask,tfun) = (createThread (tfun GlobalTaskList),{initManagerProperties & worker = currentUser}) //Make context # (context,iworld) = createContext (WorkflowProcess pid) thread managerProperties iworld = execControls cs (queue ++ [context]) iworld //TODO: RemoveTask on the global list _ = execControls cs queue iworld topTarget (TaskContext _ {ProcessProperties|systemProperties=p=:{SystemProperties|taskId}}_ _) = taskNrFromString taskId