Commit 06b527d1 authored by Bas Lijnse's avatar Bas Lijnse

Changed storage and evaluation of parallel tasks. Improves performance, but less than hoped for

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@2406 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent c158703f
...@@ -130,3 +130,8 @@ class tune b :: !b !(Task a) -> Task a ...@@ -130,3 +130,8 @@ class tune b :: !b !(Task a) -> Task a
instance tune SetLayout //Set layout algorithm instance tune SetLayout //Set layout algorithm
instance tune AfterLayout //Apply a modification after a layout has been run instance tune AfterLayout //Apply a modification after a layout has been run
instance tune ModifyLayout //Modify the existing layout instance tune ModifyLayout //Modify the existing layout
/**
* Fine tune evaluation behaviour
*/
instance tune LazyRefresh
This diff is collapsed.
...@@ -55,7 +55,8 @@ where ...@@ -55,7 +55,8 @@ where
eval event repOpts (TCInit taskId=:(TaskId instanceNo _) ts) iworld eval event repOpts (TCInit taskId=:(TaskId instanceNo _) ts) iworld
# (val,iworld) = 'SharedDataSource'.readRegister instanceNo shared iworld # (val,iworld) = 'SharedDataSource'.readRegister instanceNo shared iworld
# res = case val of # res = case val of
Ok val = ValueResult (Value val False) {TaskInfo|lastEvent=ts} (finalizeRep repOpts (TaskRep (UIControlSequence {UIControlSequence|attributes=newMap,controls=[],direction=Vertical}) [])) (TCInit taskId ts) Ok val = ValueResult (Value val False) {TaskInfo|lastEvent=ts,refreshSensitive=True}
(finalizeRep repOpts (TaskRep (UIControlSequence {UIControlSequence|attributes=newMap,controls=[],direction=Vertical}) [])) (TCInit taskId ts)
Error e = exception (SharedException e) Error e = exception (SharedException e)
= (res,iworld) = (res,iworld)
eval event repAs (TCDestroy _) iworld = (DestroyedResult,iworld) eval event repAs (TCDestroy _) iworld = (DestroyedResult,iworld)
...@@ -80,7 +81,7 @@ where ...@@ -80,7 +81,7 @@ where
# (nv,nmask,nts,iworld) = matchAndApplyEvent event taskId taskTime v mask ts iworld # (nv,nmask,nts,iworld) = matchAndApplyEvent event taskId taskTime v mask ts iworld
//Load next r from shared value //Load next r from shared value
# (mbr,iworld) = 'SharedDataSource'.readRegister instanceNo shared iworld # (mbr,iworld) = 'SharedDataSource'.readRegister instanceNo shared iworld
| isError mbr = (exception (fromError mbr),iworld)//could_not_read_shared_in_interact_exception iworld | isError mbr = (exception (fromError mbr),iworld)
# nr = fromOk mbr # nr = fromOk mbr
//Apply refresh function if r or v changed //Apply refresh function if r or v changed
# changed = (nts =!= ts) || (nr =!= r) # changed = (nts =!= ts) || (nr =!= r)
...@@ -90,7 +91,8 @@ where ...@@ -90,7 +91,8 @@ where
# validity = verifyMaskedValue nv nmask # validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld # (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# value = if (isValidMask validity) (Value nl False) NoValue # value = if (isValidMask validity) (Value nl False) NoValue
= (ValueResult value {TaskInfo|lastEvent=nts} (finalizeRep repOpts rep) (TCInteract taskId nts (toJSON nl) (toJSON nr) (toJSON nv) nmask), iworld) = (ValueResult value {TaskInfo|lastEvent=nts,refreshSensitive=True} (finalizeRep repOpts rep)
(TCInteract taskId nts (toJSON nl) (toJSON nr) (toJSON nv) nmask), iworld)
eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld) eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld)
......
...@@ -63,7 +63,7 @@ where ...@@ -63,7 +63,7 @@ where
//Check for its result //Check for its result
eval event repOpts state=:(TCBasic taskId lastEvent encv stable) iworld=:{world} eval event repOpts state=:(TCBasic taskId lastEvent encv stable) iworld=:{world}
| stable | stable
= (ValueResult (Value (fromJust (fromJSON encv)) True) {TaskInfo|lastEvent=lastEvent} (TaskRep (UIControlSequence {UIControlSequence|attributes='Map'.newMap,controls=[],direction=Vertical}) []) state, iworld) = (ValueResult (Value (fromJust (fromJSON encv)) True) {TaskInfo|lastEvent=lastEvent,refreshSensitive=False} (TaskRep (UIControlSequence {UIControlSequence|attributes='Map'.newMap,controls=[],direction=Vertical}) []) state, iworld)
| otherwise | otherwise
= case fromJSON encv of = case fromJSON encv of
Just (Right outfile) Just (Right outfile)
...@@ -78,7 +78,7 @@ where ...@@ -78,7 +78,7 @@ where
# prompt = toPrompt desc # prompt = toPrompt desc
# editor = {UIControlSequence| attributes = 'Map'.newMap, controls = controls, direction = Vertical} # editor = {UIControlSequence| attributes = 'Map'.newMap, controls = controls, direction = Vertical}
# rep = TaskRep (UIControlSequence (layout.Layout.interact prompt editor)) [] # rep = TaskRep (UIControlSequence (layout.Layout.interact prompt editor)) []
= (ValueResult (Value status False) {TaskInfo|lastEvent=lastEvent} rep state,iworld) = (ValueResult (Value status False) {TaskInfo|lastEvent=lastEvent,refreshSensitive=True} rep state,iworld)
# (res, world) = 'File'.readFile outfile world # (res, world) = 'File'.readFile outfile world
| isError res | isError res
//Failed to read file //Failed to read file
...@@ -90,7 +90,9 @@ where ...@@ -90,7 +90,9 @@ where
Just async Just async
| async.AsyncResult.success | async.AsyncResult.success
# result = CompletedProcess async.AsyncResult.exitcode # result = CompletedProcess async.AsyncResult.exitcode
= (ValueResult (Value result True) {TaskInfo|lastEvent=lastEvent} (TaskRep (UIControlSequence {UIControlSequence|attributes = 'Map'.newMap,controls = [],direction = Vertical}) []) (TCBasic taskId lastEvent (toJSON result) True), {IWorld|iworld & world = world}) = (ValueResult (Value result True) {TaskInfo|lastEvent=lastEvent,refreshSensitive=False}
(TaskRep (UIControlSequence {UIControlSequence|attributes = 'Map'.newMap,controls = [],direction = Vertical}) [])
(TCBasic taskId lastEvent (toJSON result) True), {IWorld|iworld & world = world})
| otherwise | otherwise
= (exception (CallFailed (async.AsyncResult.exitcode,"callProcess: " +++ async.AsyncResult.message)), {IWorld|iworld & world = world}) = (exception (CallFailed (async.AsyncResult.exitcode,"callProcess: " +++ async.AsyncResult.message)), {IWorld|iworld & world = world})
//Error during initialization //Error during initialization
......
...@@ -42,7 +42,7 @@ where ...@@ -42,7 +42,7 @@ where
# validity = verifyMaskedValue nv nmask # validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld # (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# value = if (isValidMask validity) (Value nl False) NoValue # value = if (isValidMask validity) (Value nl False) NoValue
= (ValueResult value {TaskInfo|lastEvent=nts} (finalizeRep repOpts rep) (TCInteract2 taskId nts (toJSON nl) (toJSON nr) nmask), iworld) = (ValueResult value {TaskInfo|lastEvent=nts,refreshSensitive=True} (finalizeRep repOpts rep) (TCInteract2 taskId nts (toJSON nl) (toJSON nr) nmask), iworld)
eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld) eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld)
refresh_fun l nr nv nmask valid refresh_fun l nr nv nmask valid
...@@ -84,7 +84,7 @@ where ...@@ -84,7 +84,7 @@ where
# validity = verifyMaskedValue nv nmask # validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld # (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# value = if (isValidMask validity) (Value nl False) NoValue # value = if (isValidMask validity) (Value nl False) NoValue
= (ValueResult value {TaskInfo|lastEvent=nts} (finalizeRep repOpts rep) (TCInteract2 taskId nts (toJSON nl) (toJSON nr) nmask), iworld) = (ValueResult value {TaskInfo|lastEvent=nts,refreshSensitive=True} (finalizeRep repOpts rep) (TCInteract2 taskId nts (toJSON nl) (toJSON nr) nmask), iworld)
eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld) eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld)
refresh_fun l nr nv nmask valid refresh_fun l nr nv nmask valid
...@@ -123,7 +123,7 @@ where ...@@ -123,7 +123,7 @@ where
# validity = verifyMaskedValue nv nmask # validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld # (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# value = if (isValidMask validity) (Value nl False) NoValue # value = if (isValidMask validity) (Value nl False) NoValue
= (ValueResult value {TaskInfo|lastEvent=nts} (finalizeRep repOpts rep) (TCInteract2 taskId nts (toJSON nl) (toJSON nr) nmask), iworld) = (ValueResult value {TaskInfo|lastEvent=nts,refreshSensitive=True} (finalizeRep repOpts rep) (TCInteract2 taskId nts (toJSON nl) (toJSON nr) nmask), iworld)
eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld) eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld)
refresh_fun r refresh_fun r
...@@ -151,7 +151,7 @@ where ...@@ -151,7 +151,7 @@ where
# validity = verifyMaskedValue nv nmask # validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld # (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# value = if (isValidMask validity) (Value nl False) NoValue # value = if (isValidMask validity) (Value nl False) NoValue
= (ValueResult value {TaskInfo|lastEvent=nts} (finalizeRep repOpts rep) (TCInteract1 taskId nts (toJSON nv) nmask), iworld) = (ValueResult value {TaskInfo|lastEvent=nts,refreshSensitive=False} (finalizeRep repOpts rep) (TCInteract1 taskId nts (toJSON nv) nmask), iworld)
eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld) eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld)
refresh_fun l v m ok refresh_fun l v m ok
...@@ -181,7 +181,7 @@ where ...@@ -181,7 +181,7 @@ where
# validity = verifyMaskedValue nv nmask # validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld # (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# value = if (isValidMask validity) (Value nl False) NoValue # value = if (isValidMask validity) (Value nl False) NoValue
= (ValueResult value {TaskInfo|lastEvent=nts} (finalizeRep repOpts rep) (TCInteract1 taskId nts (toJSON nl) nmask), iworld) = (ValueResult value {TaskInfo|lastEvent=nts,refreshSensitive=False} (finalizeRep repOpts rep) (TCInteract1 taskId nts (toJSON nl) nmask), iworld)
eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld) eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld)
refresh_fun l v m ok refresh_fun l v m ok
...@@ -210,7 +210,7 @@ where ...@@ -210,7 +210,7 @@ where
# validity = verifyMaskedValue nv nmask # validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld # (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# value = if (isValidMask validity) (Value nl False) NoValue # value = if (isValidMask validity) (Value nl False) NoValue
= (ValueResult value {TaskInfo|lastEvent=nts} (finalizeRep repOpts rep) (TCInteract1 taskId nts (toJSON nl) nmask), iworld) = (ValueResult value {TaskInfo|lastEvent=nts,refreshSensitive=False} (finalizeRep repOpts rep) (TCInteract1 taskId nts (toJSON nl) nmask), iworld)
eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld) eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld)
matchAndApplyEvent (EditEvent taskId name value) matchId taskTime v mask ts iworld matchAndApplyEvent (EditEvent taskId name value) matchId taskTime v mask ts iworld
......
...@@ -703,6 +703,10 @@ instance descr Attribute ...@@ -703,6 +703,10 @@ instance descr Attribute
instance descr Att instance descr Att
instance descr [d] | descr d instance descr [d] | descr d
//Task evaluation tuning directives, for increasing performance
:: LazyRefresh = LazyRefresh //If you tune a task in a parallel set with this directive, it not be evaluated unless its focused
//****************************************************************************// //****************************************************************************//
// Generic instances for common library types // Generic instances for common library types
//****************************************************************************// //****************************************************************************//
......
...@@ -54,6 +54,8 @@ initIWorld sdkPath world ...@@ -54,6 +54,8 @@ initIWorld sdkPath world
,nextTaskNo = 0 ,nextTaskNo = 0
,localShares = newMap ,localShares = newMap
,localLists = newMap ,localLists = newMap
,localTasks = newMap
,eventRoute = newMap
,readShares = [] ,readShares = []
,sessions = newMap ,sessions = newMap
,uis = newMap ,uis = newMap
......
...@@ -27,6 +27,8 @@ from HttpServer import class HttpEnv ...@@ -27,6 +27,8 @@ from HttpServer import class HttpEnv
, nextTaskNo :: !TaskNo // The next task number to assign , nextTaskNo :: !TaskNo // The next task number to assign
, localShares :: !Map TaskId JSONNode // The set of locally shared values , localShares :: !Map TaskId JSONNode // The set of locally shared values
, localLists :: !Map TaskId [TaskListEntry] // The set of local parallel task lists , localLists :: !Map TaskId [TaskListEntry] // The set of local parallel task lists
, localTasks :: !Map TaskId Dynamic // The set of local parallel tasks
, eventRoute :: !Map TaskId Int // Index of parallel branches the event is targeted at
, readShares :: ![String] // The IDs of shares from which was read , readShares :: ![String] // The IDs of shares from which was read
, sessions :: !Map SessionId InstanceNo // Index of sessions to instance numbers , sessions :: !Map SessionId InstanceNo // Index of sessions to instance numbers
, uis :: !Map SessionId (!Int,!UIDef) // Previous ui versions to optimize output sent to clients , uis :: !Map SessionId (!Int,!UIDef) // Previous ui versions to optimize output sent to clients
......
...@@ -7,6 +7,7 @@ definition module Task ...@@ -7,6 +7,7 @@ definition module Task
import SystemTypes, HTTP, GenVisualize, iTaskClass, GenRecord import SystemTypes, HTTP, GenVisualize, iTaskClass, GenRecord
from TaskState import :: TaskTree from TaskState import :: TaskTree
from LayoutCombinators import :: Layout from LayoutCombinators import :: Layout
from Map import :: Map
derive JSONEncode Task derive JSONEncode Task
derive JSONDecode Task derive JSONDecode Task
...@@ -35,8 +36,8 @@ derive gPutRecordFields Task ...@@ -35,8 +36,8 @@ derive gPutRecordFields Task
| DestroyedResult //If a task finalizes and cleaned up it gives this result | DestroyedResult //If a task finalizes and cleaned up it gives this result
:: TaskInfo = :: TaskInfo =
{ lastEvent :: TaskTime //When was the last edit, action or focus event in this task { lastEvent :: !TaskTime //When was the last edit, action or focus event in this task
// , lastValueChange :: TaskTime //When was the last time this task's value changed , refreshSensitive :: !Bool //Can refresh events change the value or ui of this task (e.g. because shared data is read)
} }
:: TaskRepOpts = :: TaskRepOpts =
......
...@@ -10,11 +10,11 @@ mkInstantTask :: (TaskId *IWorld -> (!MaybeError (Dynamic,String) a,!*IWorld)) - ...@@ -10,11 +10,11 @@ mkInstantTask :: (TaskId *IWorld -> (!MaybeError (Dynamic,String) a,!*IWorld)) -
mkInstantTask iworldfun = Task (evalOnce iworldfun) mkInstantTask iworldfun = Task (evalOnce iworldfun)
where where
evalOnce f _ repOpts (TCInit taskId ts) iworld = case f taskId iworld of evalOnce f _ repOpts (TCInit taskId ts) iworld = case f taskId iworld of
(Ok a,iworld) = (ValueResult (Value a True) {lastEvent=ts} (finalizeRep repOpts rep) (TCStable taskId ts (DeferredJSON a)), iworld) (Ok a,iworld) = (ValueResult (Value a True) {lastEvent=ts,refreshSensitive=False} (finalizeRep repOpts rep) (TCStable taskId ts (DeferredJSON a)), iworld)
(Error (e,s), iworld) = (ExceptionResult e s, iworld) (Error (e,s), iworld) = (ExceptionResult e s, iworld)
evalOnce f _ repOpts state=:(TCStable taskId ts enc) iworld = case fromJSONOfDeferredJSON enc of evalOnce f _ repOpts state=:(TCStable taskId ts enc) iworld = case fromJSONOfDeferredJSON enc of
Just a = (ValueResult (Value a True) {lastEvent=ts} (finalizeRep repOpts rep) state, iworld) Just a = (ValueResult (Value a True) {lastEvent=ts,refreshSensitive=False} (finalizeRep repOpts rep) state, iworld)
Nothing = (exception "Corrupt task result", iworld) Nothing = (exception "Corrupt task result", iworld)
evalOnce f _ _ (TCDestroy _) iworld = (DestroyedResult,iworld) evalOnce f _ _ (TCDestroy _) iworld = (DestroyedResult,iworld)
......
...@@ -22,8 +22,7 @@ createSessionTaskInstance task event iworld=:{currentDateTime,taskTime} ...@@ -22,8 +22,7 @@ createSessionTaskInstance task event iworld=:{currentDateTime,taskTime}
# meta = createMeta instanceNo (Just sessionId) 0 (Just worker) mmeta pmeta # meta = createMeta instanceNo (Just sessionId) 0 (Just worker) mmeta pmeta
# (_,iworld) = 'SharedDataSource'.write meta (taskInstanceMeta instanceNo) iworld # (_,iworld) = 'SharedDataSource'.write meta (taskInstanceMeta instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createReduct instanceNo task taskTime) (taskInstanceReduct instanceNo) iworld # (_,iworld) = 'SharedDataSource'.write (createReduct instanceNo task taskTime) (taskInstanceReduct instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createResult taskTime) (taskInstanceResult instanceNo) iworld # (_,iworld) = 'SharedDataSource'.write (createResult instanceNo taskTime) (taskInstanceResult instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createRep) (taskInstanceRep instanceNo) iworld
//Register the sessionId -> instanceNo relation //Register the sessionId -> instanceNo relation
# iworld = registerSession sessionId instanceNo iworld # iworld = registerSession sessionId instanceNo iworld
//Evaluate once //Evaluate once
...@@ -42,8 +41,7 @@ createTopTaskInstance task mmeta issuer parent iworld=:{currentDateTime,taskTim ...@@ -42,8 +41,7 @@ createTopTaskInstance task mmeta issuer parent iworld=:{currentDateTime,taskTim
# meta = createMeta instanceNo Nothing parent Nothing mmeta pmeta # meta = createMeta instanceNo Nothing parent Nothing mmeta pmeta
# (_,iworld) = 'SharedDataSource'.write meta (taskInstanceMeta instanceNo) iworld # (_,iworld) = 'SharedDataSource'.write meta (taskInstanceMeta instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createReduct instanceNo task taskTime) (taskInstanceReduct instanceNo) iworld # (_,iworld) = 'SharedDataSource'.write (createReduct instanceNo task taskTime) (taskInstanceReduct instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createResult taskTime) (taskInstanceResult instanceNo) iworld # (_,iworld) = 'SharedDataSource'.write (createResult instanceNo taskTime) (taskInstanceResult instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createRep) (taskInstanceRep instanceNo) iworld
= (TaskId instanceNo 0, iworld) = (TaskId instanceNo 0, iworld)
createMeta :: !InstanceNo (Maybe SessionId) InstanceNo !(Maybe User) !ManagementMeta !ProgressMeta -> TIMeta createMeta :: !InstanceNo (Maybe SessionId) InstanceNo !(Maybe User) !ManagementMeta !ProgressMeta -> TIMeta
...@@ -52,7 +50,7 @@ createMeta instanceNo sessionId parent worker mmeta pmeta ...@@ -52,7 +50,7 @@ createMeta instanceNo sessionId parent worker mmeta pmeta
createReduct :: !InstanceNo !(Task a) !TaskTime -> TIReduct | iTask a createReduct :: !InstanceNo !(Task a) !TaskTime -> TIReduct | iTask a
createReduct instanceNo task taskTime createReduct instanceNo task taskTime
= {TIReduct|task=toJSONTask task,nextTaskNo=2,nextTaskTime=1,tree=(TCInit (TaskId instanceNo 0) 1),shares = 'Map'.newMap, lists = 'Map'.newMap} = {TIReduct|task=toJSONTask task,nextTaskNo=2,nextTaskTime=1,shares = 'Map'.newMap, lists = 'Map'.newMap, tasks= 'Map'.newMap}
where where
toJSONTask (Task eval) = Task eval` toJSONTask (Task eval) = Task eval`
where where
...@@ -60,11 +58,8 @@ where ...@@ -60,11 +58,8 @@ where
(ValueResult val ts rep tree,iworld) = (ValueResult (fmap toJSON val) ts rep tree, iworld) (ValueResult val ts rep tree,iworld) = (ValueResult (fmap toJSON val) ts rep tree, iworld)
(ExceptionResult e str,iworld) = (ExceptionResult e str,iworld) (ExceptionResult e str,iworld) = (ExceptionResult e str,iworld)
createResult :: TaskTime -> TIResult createResult :: !InstanceNo !TaskTime -> TaskResult JSONNode
createResult taskTime = TIValue NoValue taskTime createResult instanceNo taskTime = ValueResult NoValue {TaskInfo|lastEvent=taskTime,refreshSensitive=True} (TaskRep (UIControlGroup {UIControlGroup|attributes='Map'.newMap, controls=[],direction = Vertical,actions = []}) []) (TCInit (TaskId instanceNo 0) 1)
createRep :: TIRep
createRep = TaskRep (UIControlGroup {UIControlGroup|attributes='Map'.newMap, controls=[],direction = Vertical,actions = []}) []
//Evaluate a session task instance when a new event is received from a client //Evaluate a session task instance when a new event is received from a client
evalSessionTaskInstance :: !SessionId !Event !*IWorld -> (!MaybeErrorString (!TaskResult JSONNode, !InstanceNo, !SessionId), !*IWorld) evalSessionTaskInstance :: !SessionId !Event !*IWorld -> (!MaybeErrorString (!TaskResult JSONNode, !InstanceNo, !SessionId), !*IWorld)
...@@ -128,22 +123,26 @@ evalTaskInstance event instanceNo iworld=:{currentDateTime,currentUser,currentIn ...@@ -128,22 +123,26 @@ evalTaskInstance event instanceNo iworld=:{currentDateTime,currentUser,currentIn
# meta=:{TIMeta|sessionId,parent,worker=Just worker,progress} = fromOk meta # meta=:{TIMeta|sessionId,parent,worker=Just worker,progress} = fromOk meta
# (reduct, iworld) = 'SharedDataSource'.read (taskInstanceReduct instanceNo) iworld # (reduct, iworld) = 'SharedDataSource'.read (taskInstanceReduct instanceNo) iworld
| isError reduct = (liftError reduct, iworld) | isError reduct = (liftError reduct, iworld)
# reduct=:{TIReduct|task=Task eval,nextTaskNo=curNextTaskNo,nextTaskTime,tree,shares,lists} = fromOk reduct # reduct=:{TIReduct|task=Task eval,nextTaskNo=curNextTaskNo,nextTaskTime,shares,lists,tasks} = fromOk reduct
# (result, iworld) = 'SharedDataSource'.read (taskInstanceResult instanceNo) iworld # (result, iworld) = 'SharedDataSource'.read (taskInstanceResult instanceNo) iworld
| isError result = (liftError result, iworld) | isError result = (liftError result, iworld)
= case fromOk result of = case fromOk result of
(TIException e msg) = (Ok (ExceptionResult e msg), iworld) (ExceptionResult e msg) = (Ok (ExceptionResult e msg), iworld)
(TIValue val _) (ValueResult val _ _ tree)
//Eval instance //Eval instance
# repAs = {TaskRepOpts|useLayout=Nothing,afterLayout=Nothing,modLayout=Nothing,appFinalLayout=isJust sessionId} # repAs = {TaskRepOpts|useLayout=Nothing,afterLayout=Nothing,modLayout=Nothing,appFinalLayout=isJust sessionId}
//Update current process id & eval stack in iworld //Update current process id & eval stack in iworld
# taskId = TaskId instanceNo 0 # taskId = TaskId instanceNo 0
# eventRoute = determineEventRoute event lists
# iworld = {iworld & currentInstance = instanceNo # iworld = {iworld & currentInstance = instanceNo
, currentUser = worker , currentUser = worker
, nextTaskNo = reduct.TIReduct.nextTaskNo , nextTaskNo = reduct.TIReduct.nextTaskNo
, taskTime = reduct.TIReduct.nextTaskTime , taskTime = reduct.TIReduct.nextTaskTime
, localShares = shares , localShares = shares
, localLists = lists} , localLists = lists
, localTasks = tasks
, eventRoute = eventRoute
}
//Clear the instance's registrations for share changes //Clear the instance's registrations for share changes
# iworld = clearShareRegistrations instanceNo iworld # iworld = clearShareRegistrations instanceNo iworld
//Apply task's eval function and take updated nextTaskId from iworld //Apply task's eval function and take updated nextTaskId from iworld
...@@ -158,18 +157,18 @@ evalTaskInstance event instanceNo iworld=:{currentDateTime,currentUser,currentIn ...@@ -158,18 +157,18 @@ evalTaskInstance event instanceNo iworld=:{currentDateTime,currentUser,currentIn
# (nextTaskNo,iworld) = getNextTaskNo iworld # (nextTaskNo,iworld) = getNextTaskNo iworld
# (shares,iworld) = getLocalShares iworld # (shares,iworld) = getLocalShares iworld
# (lists,iworld) = getLocalLists iworld # (lists,iworld) = getLocalLists iworld
# reduct = {TIReduct|reduct & nextTaskNo = nextTaskNo, nextTaskTime = nextTaskTime + 1, tree = tasktree result, shares = shares, lists = lists} # (tasks,iworld) = getLocalTasks iworld
# reduct = {TIReduct|reduct & nextTaskNo = nextTaskNo, nextTaskTime = nextTaskTime + 1, shares = shares, lists = lists, tasks = tasks}
# (_,iworld) = 'SharedDataSource'.writeFilterMsg reduct ((<>) instanceNo) (taskInstanceReduct instanceNo) iworld //TODO Check error # (_,iworld) = 'SharedDataSource'.writeFilterMsg reduct ((<>) instanceNo) (taskInstanceReduct instanceNo) iworld //TODO Check error
//Store the result //Store the result
# (_,iworld) = 'SharedDataSource'.writeFilterMsg (taskres result) ((<>) instanceNo) (taskInstanceResult instanceNo) iworld //TODO Check error # (_,iworld) = 'SharedDataSource'.writeFilterMsg result ((<>) instanceNo) (taskInstanceResult instanceNo) iworld //TODO Check error
//Store the representation
# (_,iworld) = 'SharedDataSource'.writeFilterMsg (taskrep result) ((<>) instanceNo) (taskInstanceRep instanceNo) iworld //TODO Check error
//Return the result //Return the result
= (Ok result, iworld) = (Ok result, iworld)
where where
getNextTaskNo iworld=:{IWorld|nextTaskNo} = (nextTaskNo,iworld) getNextTaskNo iworld=:{IWorld|nextTaskNo} = (nextTaskNo,iworld)
getLocalShares iworld=:{IWorld|localShares} = (localShares,iworld) getLocalShares iworld=:{IWorld|localShares} = (localShares,iworld)
getLocalLists iworld=:{IWorld|localLists} = (localLists,iworld) getLocalLists iworld=:{IWorld|localLists} = (localLists,iworld)
getLocalTasks iworld=:{IWorld|localTasks} = (localTasks,iworld)
updateProgress now result progress updateProgress now result progress
# progress = {progress & firstEvent = Just (fromMaybe now progress.firstEvent), latestEvent = Just now} # progress = {progress & firstEvent = Just (fromMaybe now progress.firstEvent), latestEvent = Just now}
...@@ -179,15 +178,41 @@ where ...@@ -179,15 +178,41 @@ where
(ValueResult _ _ (TaskRep ui _) _) = {progress & stable = False, latestAttributes = uiDefAttributes ui} (ValueResult _ _ (TaskRep ui _) _) = {progress & stable = False, latestAttributes = uiDefAttributes ui}
_ = {progress & stable = False} _ = {progress & stable = False}
tasktree (ValueResult _ _ _ tree) = tree determineEventRoute :: Event (Map TaskId [TaskListEntry]) -> Map TaskId Int
tasktree (ExceptionResult _ _) = TCNop determineEventRoute RefreshEvent _ = 'Map'.newMap
determineEventRoute (EditEvent id _ _) lists = determineEventRoute` id ('Map'.toList lists)
taskres (ValueResult val {TaskInfo|lastEvent} _ _) = TIValue val lastEvent determineEventRoute (ActionEvent id _) lists = determineEventRoute` id ('Map'.toList lists)
taskres (ExceptionResult e str) = TIException e str determineEventRoute (FocusEvent id) lists = determineEventRoute` id ('Map'.toList lists)
taskrep (ValueResult _ _ rep _) = rep //TODO: Optimize this search function
taskrep (ExceptionResult _ str) = TaskRep (UIControlSequence {UIControlSequence|attributes = 'Map'.newMap, controls = [(stringDisplay str, 'Map'.newMap)], direction = Vertical}) [] determineEventRoute` :: TaskId [(TaskId,[TaskListEntry])] -> Map TaskId Int
determineEventRoute` eventId lists = 'Map'.fromList (search eventId)
where
search searchId = case searchInLists searchId lists of
Just (parId, index) = [(parId,index):search parId]
Nothing = []
searchInLists searchId [] = Nothing
searchInLists searchId [(parId,entries):xs] = case [i \\ e <- entries & i <- [0..] | inEntry searchId e] of
[index] = Just (parId,index)
_ = searchInLists searchId xs
inEntry searchId {TaskListEntry|lastEval=ValueResult _ _ _ tree} = inTree searchId tree
inEntry _ _ = False
inTree searchId (TCInit taskId _) = searchId == taskId
inTree searchId (TCBasic taskId _ _ _) = searchId == taskId
inTree searchId (TCInteract taskId _ _ _ _ _) = searchId == taskId
inTree searchId (TCInteract1 taskId _ _ _) = searchId == taskId
inTree searchId (TCInteract2 taskId _ _ _ _) = searchId == taskId
inTree searchId (TCProject taskId _ tree) = searchId == taskId || inTree searchId tree
inTree searchId (TCStep taskId _ (Left tree)) = searchId == taskId || inTree searchId tree
inTree searchId (TCStep taskId _ (Right (_,_,tree))) = searchId == taskId || inTree searchId tree
inTree searchId (TCParallel taskId _) = searchId == taskId
inTree searchId (TCShared taskId _ tree) = searchId == taskId || inTree searchId tree
inTree searchId (TCStable taskId _ _) = searchId == taskId
inTree searchId _ = False
localShare :: !TaskId -> Shared a | iTask a localShare :: !TaskId -> Shared a | iTask a
localShare taskId=:(TaskId instanceNo taskNo) = createChangeOnWriteSDS "localShare" shareKey read write localShare taskId=:(TaskId instanceNo taskNo) = createChangeOnWriteSDS "localShare" shareKey read write
where where
...@@ -255,7 +280,7 @@ where ...@@ -255,7 +280,7 @@ where
(Error _,iworld) (Error _,iworld)
= (Error ("Could not load remote task list " +++ shareKey), iworld) = (Error ("Could not load remote task list " +++ shareKey), iworld)
toItem {TaskListEntry|entryId,state,result=TIValue val ts,attributes} toItem {TaskListEntry|entryId,state,lastEval=ValueResult val _ _ _,attributes}
= {taskId = entryId = {taskId = entryId
,value = deserialize val ,value = deserialize val
,managementMeta = management ,managementMeta = management
......
...@@ -4,12 +4,11 @@ import SystemTypes ...@@ -4,12 +4,11 @@ import SystemTypes
from Task import :: TaskTime, :: TaskResult, :: TaskRep from Task import :: TaskTime, :: TaskResult, :: TaskRep
derive JSONEncode TIMeta, TIReduct, TIResult, TaskTree derive JSONEncode TIMeta, TIReduct, TaskTree
derive JSONDecode TIMeta, TIReduct, TIResult, TaskTree derive JSONDecode TIMeta, TIReduct, TaskTree
//Persistent context of active tasks //Persistent context of active tasks
//Split up version of task instance information //Split up version of task instance information
:: TaskInstance :== (!TIMeta,!TIReduct,!TIResult,!TIRep)
:: TIMeta = :: TIMeta =
{ instanceNo :: !InstanceNo //Unique global identification { instanceNo :: !InstanceNo //Unique global identification
...@@ -26,17 +25,11 @@ derive JSONDecode TIMeta, TIReduct, TIResult, TaskTree ...@@ -26,17 +25,11 @@ derive JSONDecode TIMeta, TIReduct, TIResult, TaskTree
{ task :: !Task JSONNode { task :: !Task JSONNode
, nextTaskNo :: !TaskNo , nextTaskNo :: !TaskNo
, nextTaskTime :: !TaskTime , nextTaskTime :: !TaskTime
, tree :: !TaskTree //Internal task tree state
, shares :: !Map TaskId JSONNode //Locally shared data , shares :: !Map TaskId JSONNode //Locally shared data
, lists :: !Map TaskId [TaskListEntry] //Parallel task lists , lists :: !Map TaskId [TaskListEntry] //Parallel task lists
, tasks :: !Map TaskId Dynamic //Task functions of embedded parallel tasks
} }
:: TIResult
= TIValue !(TaskValue JSONNode) !TaskTime
| TIException !Dynamic !String
:: TIRep :== TaskRep
:: TaskTree :: TaskTree
= TCInit !TaskId !TaskTime //Initial state for all tasks = TCInit !TaskId !TaskTime //Initial state for all tasks
| TCBasic !TaskId !TaskTime !JSONNode !Bool //Encoded value and stable indicator | TCBasic !TaskId !TaskTime !JSONNode !Bool //Encoded value and stable indicator
...@@ -61,13 +54,13 @@ derive JSONDecode DeferredJSON ...@@ -61,13 +54,13 @@ derive JSONDecode DeferredJSON
:: TaskListEntry = :: TaskListEntry =
{ entryId :: !TaskId //Identification of entries in the list (for easy updating) { entryId :: !TaskId //Identification of entries in the list (for easy updating)
, state :: !TaskListEntryState //Tree if embedded, or instance no if detached , state :: !TaskListEntryState //Tree if embedded, or instance no if detached
, result :: !TIResult //Stored result of last evaluation (for detached tasks this is a cached copy) , lastEval :: !TaskResult JSONNode //Result of last evaluation
, attributes :: !Map String String //Stored attributes of last evaluation