We planned to upgrade GitLab and Mattermost to the latest version this Friday morning (early). You may experience some downtime!

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