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
instance tune SetLayout //Set layout algorithm
instance tune AfterLayout //Apply a modification after a layout has been run
instance tune ModifyLayout //Modify the existing layout
/**
* Fine tune evaluation behaviour
*/
instance tune LazyRefresh
......@@ -222,11 +222,12 @@ where
# rep = parallelRep desc taskId repOpts entries
# values = map (toValueAndTime o fst) entries
# stable = all (isStable o snd) values
# refreshSensitive = foldr (\(e,_) s -> s || refreshSensitive e) False entries
# ts = foldr max 0 [ts:map fst values]
# ts = case event of
(FocusEvent focusId) = if (focusId == taskId) taskTime ts
_ = ts
= (ValueResult (Value values stable) {TaskInfo|lastEvent=ts} (finalizeRep repOpts rep) (TCParallel taskId ts),{iworld & localLists = 'Map'.put taskId (map fst entries) localLists})
= (ValueResult (Value values stable) {TaskInfo|lastEvent=ts,refreshSensitive=refreshSensitive} (finalizeRep repOpts rep) (TCParallel taskId ts),{iworld & localLists = 'Map'.put taskId (map fst entries) localLists})
//Cleanup
eval event repOpts (TCDestroy (TCParallel taskId ts)) iworld=:{localLists}
# entries = fromMaybe [] ('Map'.get taskId localLists)
......@@ -239,56 +240,76 @@ where
= (exception "Corrupt task state in parallel", iworld)
evalParTasks :: !TaskId !Event !*IWorld -> (!Maybe (TaskResult [(TaskTime,TaskValue a)]),![(!TaskListEntry,!Maybe TaskRep)],!*IWorld) | iTask a
evalParTasks taskId event iworld=:{localLists}
= evalFrom 0 [] (fromMaybe [] ('Map'.get taskId localLists)) iworld
evalParTasks taskId event iworld=:{localLists,eventRoute}
= evalFrom 0 [] (fromMaybe [] ('Map'.get taskId localLists)) ('Map'.get taskId eventRoute) iworld
where
evalFrom n acc list iworld = case foldl (evalParTask taskId event) (Nothing,acc,iworld) (drop n list) of
evalFrom n acc list mbEventIndex iworld = case foldl (evalParTask taskId event mbEventIndex) (Nothing,acc,iworld) [(i,e) \\ e <- drop n list & i <- [n..]] of
(Just (ExceptionResult e str),acc,iworld) = (Just (ExceptionResult e str),acc,iworld)
(Nothing,acc,iworld=:{localLists})
# nlist = fromMaybe [] ('Map'.get taskId localLists)
| length nlist > length list = evalFrom (length list) acc nlist iworld //Extra branches were added -> evaluate these as well
# lenlist = length list
| length nlist > lenlist = evalFrom lenlist acc nlist Nothing iworld //Extra branches were added -> evaluate these as well
= (Nothing,acc,iworld) //Done
//IMPORTANT: This last rule should never match, but it helps to solve overloading solves overloading
//IMPORTANT: This last rule should never match, but it helps to solve overloading
(Just (ValueResult val info=:{TaskInfo|lastEvent} rep tree),acc,iworld) = (Just (ValueResult (Value [(lastEvent,val)] False) info rep tree),acc,iworld)
evalParTask :: !TaskId !Event !(!Maybe (TaskResult a),![(!TaskListEntry,!Maybe TaskRep)],!*IWorld) !TaskListEntry -> (!Maybe (TaskResult a),![(!TaskListEntry,!Maybe TaskRep)],!*IWorld) | iTask a
evalParTask :: !TaskId !Event !(Maybe Int) !(!Maybe (TaskResult a),![(!TaskListEntry,!Maybe TaskRep)],!*IWorld) !(!Int,!TaskListEntry) -> (!Maybe (TaskResult a),![(!TaskListEntry,!Maybe TaskRep)],!*IWorld) | iTask a
//Evaluate embedded tasks
evalParTask taskId event (Nothing,acc,iworld) {TaskListEntry|entryId,state=EmbeddedState (Task evala :: Task a^) tree, removed=False}
evalParTask taskId event mbEventIndex (Nothing,acc,iworld=:{localTasks}) (index,{TaskListEntry|entryId,state=EmbeddedState,lastEval=ValueResult jsonval info rep tree, removed=False})
# evalNeeded = case mbEventIndex of
Nothing = True//We don't know the event index, so we just have to try
Just eventIndex
| eventIndex == index = True //The event is targeted at this branch, we evaluate
= info.TaskInfo.refreshSensitive //Also evaluate if the branch is refresh sensitive
| evalNeeded
//Evaluate the branch
= case 'Map'.get entryId localTasks of
Just (Task evala :: Task a^)
# (result,iworld) = evala event {TaskRepOpts|useLayout=Nothing,afterLayout=Nothing,modLayout=Nothing,appFinalLayout=False} tree iworld
= case result of
ExceptionResult _ _
= (Just result,acc,iworld)
ValueResult val ts rep tree
ValueResult val info rep tree
# (entry,iworld) = updateListEntryEmbeddedResult taskId entryId result iworld
= (Nothing, acc++[(entry,Just rep)],iworld)
_
= (Nothing,acc,iworld)
| otherwise
# (entry,iworld) = updateListEntryEmbeddedResult taskId entryId (ValueResult jsonval info rep tree) iworld
= (Nothing, acc++[(entry,Just rep)],iworld)
//Copy the last stored result of detached tasks
evalParTask taskId event (Nothing,acc,iworld) {TaskListEntry|entryId,state=DetachedState instanceNo _ _,removed=False}
evalParTask taskId event mbEventIndex (Nothing,acc,iworld) (index,{TaskListEntry|entryId,state=DetachedState instanceNo _ _,removed=False})
# (mbMeta,iworld) = read (taskInstanceMeta instanceNo) iworld
# (mbResult,iworld) = read (taskInstanceResult instanceNo) iworld
= case (mbMeta,mbResult) of
(Ok meta,Ok res)
# (entry,iworld) = updateListEntryDetachedResult taskId entryId res meta.TIMeta.progress meta.TIMeta.management iworld
(Ok meta,Ok result)
# (entry,iworld) = updateListEntryDetachedResult taskId entryId result meta.TIMeta.progress meta.TIMeta.management iworld
= (Nothing,acc++[(entry,Nothing)],iworld)
_ = (Nothing,acc,iworld) //TODO: remove from parallel if it can't be loaded (now it simply keeps the last known result)
//Do nothing if an exeption occurred or marked as removed
evalParTask taskId event (result,acc,iworld) entry = (result,acc,iworld)
evalParTask taskId event mbEventIndex (result,acc,iworld) (index,entry) = (result,acc,iworld)
destroyParTask :: (!Maybe (TaskResult a),!*IWorld) !TaskListEntry -> (!Maybe (TaskResult a),!*IWorld) | iTask a
//Destroy embedded tasks
destroyParTask (_,iworld) {TaskListEntry|entryId,state=EmbeddedState (Task evala :: Task a^) tree}
destroyParTask (_,iworld=:{localTasks}) {TaskListEntry|entryId,state=EmbeddedState,lastEval=ValueResult _ _ _ tree}
= case 'Map'.get entryId localTasks of
Just (Task evala :: Task a^)
# (result,iworld) = evala RefreshEvent {TaskRepOpts|useLayout=Nothing,afterLayout=Nothing,modLayout=Nothing,appFinalLayout=False} (TCDestroy tree) iworld
= case result of
DestroyedResult = (Nothing,iworld)
_ = (Just result,iworld)
_
= (Nothing,iworld)
//Destroy detached tasks (Just delete the instance)
destroyParTask (_,iworld) {TaskListEntry|entryId,state=DetachedState instanceNo _ _}
= (Nothing,deleteInstance instanceNo iworld)
toValueAndTime :: !TaskListEntry -> (!TaskTime,TaskValue a) | iTask a
toValueAndTime {TaskListEntry|result=TIValue val _,lastEvent} = (lastEvent,deserialize val)
toValueAndTime {TaskListEntry|lastEval=ValueResult val _ _ _,lastEvent} = (lastEvent,deserialize val)
where
deserialize (Value json stable) = case fromJSON json of
Nothing = NoValue
......@@ -302,45 +323,45 @@ where
# after = afterLayout repOpts
# listId = toString taskId
# parts = [(uiDefSetAttribute LAST_EVENT_ATTRIBUTE (toString lastEvent) (uiDefSetAttribute CREATED_AT_ATTRIBUTE (toString createdAt) (uiDefSetAttribute TASK_ATTRIBUTE (toString entryId) def)))
\\ ({TaskListEntry|entryId,state=EmbeddedState _ _,result=TIValue val _,createdAt,lastEvent,removed=False},Just (TaskRep def _)) <- entries | not (isStable val)]
\\ ({TaskListEntry|entryId,state=EmbeddedState,lastEval=ValueResult val _ _ _,createdAt,lastEvent,removed=False},Just (TaskRep def _)) <- entries | not (isStable val)]
= TaskRep (after (layout.Layout.parallel (toPrompt desc) parts)) []
isStable (Value _ stable) = stable
isStable _ = False
refreshSensitive {TaskListEntry|lastEval=ValueResult _ {TaskInfo|refreshSensitive} _ _} = refreshSensitive
refreshSensitive _ = True
//Helper function to help type inferencing a little
fixOverloading :: (TaskResult a) [(!ParallelTaskType,!ParallelTask a)] !b -> b
fixOverloading _ _ x = x
//SHARED HELPER FUNCTIONS
appendTaskToList :: !TaskId !(!ParallelTaskType,!ParallelTask a) !*IWorld -> (!TaskId,!*IWorld) | iTask a
appendTaskToList taskId=:(TaskId parent _) (parType,parTask) iworld=:{taskTime,currentUser,currentDateTime}
appendTaskToList taskId=:(TaskId parent _) (parType,parTask) iworld=:{taskTime,currentUser,currentDateTime,localTasks}
# (list,iworld) = loadTaskList taskId iworld
# (taskIda,state,iworld) = case parType of
Embedded
# (taskIda,iworld) = getNextTaskId iworld
# task = parTask (parListShare taskId)
= (taskIda, EmbeddedState (dynamic task :: Task a^) (TCInit taskIda taskTime),iworld)
= (taskIda, EmbeddedState, {iworld & localTasks = 'Map'.put taskIda (dynamic task :: Task a^) localTasks})
Detached management
# task = parTask (parListShare taskId)
# progress = {issuedAt=currentDateTime,issuedBy=currentUser,stable=True,firstEvent=Nothing,latestEvent=Nothing,latestAttributes='Map'.newMap}
# (taskIda=:TaskId instanceNo _,iworld) = createTopTaskInstance task management currentUser parent iworld
= (taskIda,DetachedState instanceNo progress management, iworld)
# result = TIValue NoValue taskTime
# entry = {entryId = taskIda, state = state, result = result, attributes = 'Map'.newMap, createdAt = taskTime, lastEvent = taskTime, removed = False}
# lastEval = ValueResult NoValue {TaskInfo|lastEvent=taskTime,refreshSensitive=True} noRep (TCInit taskIda taskTime)
# entry = {entryId = taskIda, state = state, lastEval = lastEval, attributes = 'Map'.newMap, createdAt = taskTime, lastEvent = taskTime, removed = False}
# iworld = storeTaskList taskId (list ++ [entry]) iworld
= (taskIda, iworld)
updateListEntryEmbeddedResult :: !TaskId !TaskId (TaskResult a) !*IWorld -> (!TaskListEntry,!*IWorld) | iTask a
updateListEntryEmbeddedResult listId entryId result iworld
= updateListEntry listId entryId (\e=:{TaskListEntry|state,lastEvent} ->
{TaskListEntry|e & state = newTree state result, result = serialize result, attributes = newAttr result, lastEvent = maxTime lastEvent result}) iworld
{TaskListEntry|e & lastEval= wrap result, attributes = newAttr result, lastEvent = maxTime lastEvent result}) iworld
where
serialize (ValueResult val {TaskInfo|lastEvent} _ _) = TIValue (fmap toJSON val) lastEvent
serialize (ExceptionResult e str) = TIException e str
newTree (EmbeddedState task _) (ValueResult _ _ _ tree) = EmbeddedState task tree
newTree cur _ = cur
wrap (ValueResult val info rep tree) = ValueResult (fmap toJSON val) info rep tree
wrap (ExceptionResult e str) = ExceptionResult e str
newAttr (ValueResult _ _ (TaskRep def _) _) = uiDefAttributes def
newAttr _ = 'Map'.newMap
......@@ -348,12 +369,12 @@ where
maxTime cur (ValueResult _ {TaskInfo|lastEvent} _ _) = max cur lastEvent
maxTime cur _ = cur
updateListEntryDetachedResult :: !TaskId !TaskId TIResult !ProgressMeta !ManagementMeta !*IWorld -> (!TaskListEntry,!*IWorld)
updateListEntryDetachedResult listId entryId result progress management iworld
updateListEntryDetachedResult :: !TaskId !TaskId (TaskResult JSONNode) !ProgressMeta !ManagementMeta !*IWorld -> (!TaskListEntry,!*IWorld)
updateListEntryDetachedResult listId entryId lastEval progress management iworld
= updateListEntry listId entryId update iworld
where
update e=:{TaskListEntry|state=DetachedState no _ _}
= {TaskListEntry| e & state = DetachedState no progress management,result = result, attributes = progress.latestAttributes}
= {TaskListEntry| e & state = DetachedState no progress management, lastEval = lastEval, attributes = progress.latestAttributes}
update e = e
markListEntryRemoved :: !TaskId !TaskId !*IWorld -> *IWorld
......@@ -457,22 +478,21 @@ where
//Load instance
# (meta,iworld) = readRegister currentInstance (taskInstanceMeta instanceNo) iworld
# (result,iworld) = readRegister currentInstance (taskInstanceResult instanceNo) iworld
# (rep,iworld) = readRegister currentInstance (taskInstanceRep instanceNo) iworld
# layout = repLayout repOpts
= case (meta,result,rep) of
(_,Ok (TIValue (Value _ True) _),_)
= (ValueResult (Value WOFinished True) {TaskInfo|lastEvent=ts} (finalizeRep repOpts noRep) tree, iworld)
(_,Ok (TIException _ _),_)
= (ValueResult (Value WOExcepted True) {TaskInfo|lastEvent=ts} (finalizeRep repOpts noRep) tree, iworld)
(Ok meta=:{TIMeta|worker=Just worker},_,Ok (TaskRep def parts))
= case (meta,result) of
(_,Ok (ValueResult (Value _ True) _ _ _))
= (ValueResult (Value WOFinished True) {TaskInfo|lastEvent=ts,refreshSensitive=False} (finalizeRep repOpts noRep) tree, iworld)
(_,Ok (ExceptionResult _ _))
= (ValueResult (Value WOExcepted True) {TaskInfo|lastEvent=ts,refreshSensitive=False} (finalizeRep repOpts noRep) tree, iworld)
(Ok meta=:{TIMeta|worker=Just worker},Ok (ValueResult _ _ (TaskRep def parts) _))
| worker == currentUser
# rep = finalizeRep repOpts (TaskRep (layout.Layout.workOn def meta) parts)
= (ValueResult (Value WOActive False) {TaskInfo|lastEvent=ts} rep tree, iworld)
= (ValueResult (Value WOActive False) {TaskInfo|lastEvent=ts,refreshSensitive=True} rep tree, iworld)
| otherwise
# rep = finalizeRep repOpts (TaskRep (layout.Layout.workOn (inUseDef worker) meta) parts)
= (ValueResult (Value (WOInUse worker) False) {TaskInfo|lastEvent=ts} rep tree, iworld)
= (ValueResult (Value (WOInUse worker) False) {TaskInfo|lastEvent=ts,refreshSensitive=False} rep tree, iworld)
_
= (ValueResult (Value WODeleted True) {TaskInfo|lastEvent=ts} (finalizeRep repOpts noRep) tree, iworld)
= (ValueResult (Value WODeleted True) {TaskInfo|lastEvent=ts,refreshSensitive=False} (finalizeRep repOpts noRep) tree, iworld)
eval event repOpts (TCDestroy (TCBasic taskId _ _ _)) iworld=:{currentInstance}
= (DestroyedResult,iworld)
......@@ -553,3 +573,11 @@ where
eval` event repOpts=:{modLayout=Just g} state iworld
= eval event {TaskRepOpts|repOpts & modLayout = Just (g o f)} state iworld
instance tune LazyRefresh
where
tune _ (Task eval) = Task eval`
where
eval` event repOpts state iworld
= case (eval event repOpts state iworld) of
(ValueResult value info rep tree,iworld) = (ValueResult value {TaskInfo|info&refreshSensitive=False} rep tree, iworld)
(res,iworld) = (res,iworld)
......@@ -55,7 +55,8 @@ where
eval event repOpts (TCInit taskId=:(TaskId instanceNo _) ts) iworld
# (val,iworld) = 'SharedDataSource'.readRegister instanceNo shared iworld
# 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)
= (res,iworld)
eval event repAs (TCDestroy _) iworld = (DestroyedResult,iworld)
......@@ -80,7 +81,7 @@ where
# (nv,nmask,nts,iworld) = matchAndApplyEvent event taskId taskTime v mask ts iworld
//Load next r from shared value
# (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
//Apply refresh function if r or v changed
# changed = (nts =!= ts) || (nr =!= r)
......@@ -90,7 +91,8 @@ where
# validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# 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)
......
......@@ -63,7 +63,7 @@ where
//Check for its result
eval event repOpts state=:(TCBasic taskId lastEvent encv stable) iworld=:{world}
| 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
= case fromJSON encv of
Just (Right outfile)
......@@ -78,7 +78,7 @@ where
# prompt = toPrompt desc
# editor = {UIControlSequence| attributes = 'Map'.newMap, controls = controls, direction = Vertical}
# 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
| isError res
//Failed to read file
......@@ -90,7 +90,9 @@ where
Just async
| async.AsyncResult.success
# 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
= (exception (CallFailed (async.AsyncResult.exitcode,"callProcess: " +++ async.AsyncResult.message)), {IWorld|iworld & world = world})
//Error during initialization
......
......@@ -42,7 +42,7 @@ where
# validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# 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)
refresh_fun l nr nv nmask valid
......@@ -84,7 +84,7 @@ where
# validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# 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)
refresh_fun l nr nv nmask valid
......@@ -123,7 +123,7 @@ where
# validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# 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)
refresh_fun r
......@@ -151,7 +151,7 @@ where
# validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# 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)
refresh_fun l v m ok
......@@ -181,7 +181,7 @@ where
# validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# 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)
refresh_fun l v m ok
......@@ -210,7 +210,7 @@ where
# validity = verifyMaskedValue nv nmask
# (rep,iworld) = visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
# 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)
matchAndApplyEvent (EditEvent taskId name value) matchId taskTime v mask ts iworld
......
......@@ -703,6 +703,10 @@ instance descr Attribute
instance descr Att
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
//****************************************************************************//
......
......@@ -54,6 +54,8 @@ initIWorld sdkPath world
,nextTaskNo = 0
,localShares = newMap
,localLists = newMap
,localTasks = newMap
,eventRoute = newMap
,readShares = []
,sessions = newMap
,uis = newMap
......
......@@ -27,6 +27,8 @@ from HttpServer import class HttpEnv
, nextTaskNo :: !TaskNo // The next task number to assign
, localShares :: !Map TaskId JSONNode // The set of locally shared values
, 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
, sessions :: !Map SessionId InstanceNo // Index of sessions to instance numbers
, uis :: !Map SessionId (!Int,!UIDef) // Previous ui versions to optimize output sent to clients
......
......@@ -7,6 +7,7 @@ definition module Task
import SystemTypes, HTTP, GenVisualize, iTaskClass, GenRecord
from TaskState import :: TaskTree
from LayoutCombinators import :: Layout
from Map import :: Map
derive JSONEncode Task
derive JSONDecode Task
......@@ -35,8 +36,8 @@ derive gPutRecordFields Task
| DestroyedResult //If a task finalizes and cleaned up it gives this result
:: TaskInfo =
{ 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
{ lastEvent :: !TaskTime //When was the last edit, action or focus event in this task
, refreshSensitive :: !Bool //Can refresh events change the value or ui of this task (e.g. because shared data is read)
}
:: TaskRepOpts =
......
......@@ -10,11 +10,11 @@ mkInstantTask :: (TaskId *IWorld -> (!MaybeError (Dynamic,String) a,!*IWorld)) -
mkInstantTask iworldfun = Task (evalOnce iworldfun)
where
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)
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)
evalOnce f _ _ (TCDestroy _) iworld = (DestroyedResult,iworld)
......
......@@ -22,8 +22,7 @@ createSessionTaskInstance task event iworld=:{currentDateTime,taskTime}
# meta = createMeta instanceNo (Just sessionId) 0 (Just worker) mmeta pmeta
# (_,iworld) = 'SharedDataSource'.write meta (taskInstanceMeta instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createReduct instanceNo task taskTime) (taskInstanceReduct instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createResult taskTime) (taskInstanceResult instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createRep) (taskInstanceRep instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createResult instanceNo taskTime) (taskInstanceResult instanceNo) iworld
//Register the sessionId -> instanceNo relation
# iworld = registerSession sessionId instanceNo iworld
//Evaluate once
......@@ -42,8 +41,7 @@ createTopTaskInstance task mmeta issuer parent iworld=:{currentDateTime,taskTim
# meta = createMeta instanceNo Nothing parent Nothing mmeta pmeta
# (_,iworld) = 'SharedDataSource'.write meta (taskInstanceMeta instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createReduct instanceNo task taskTime) (taskInstanceReduct instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createResult taskTime) (taskInstanceResult instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createRep) (taskInstanceRep instanceNo) iworld
# (_,iworld) = 'SharedDataSource'.write (createResult instanceNo taskTime) (taskInstanceResult instanceNo) iworld
= (TaskId instanceNo 0, iworld)
createMeta :: !InstanceNo (Maybe SessionId) InstanceNo !(Maybe User) !ManagementMeta !ProgressMeta -> TIMeta
......@@ -52,7 +50,7 @@ createMeta instanceNo sessionId parent worker mmeta pmeta
createReduct :: !InstanceNo !(Task a) !TaskTime -> TIReduct | iTask a
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
toJSONTask (Task eval) = Task eval`
where
......@@ -60,11 +58,8 @@ where
(ValueResult val ts rep tree,iworld) = (ValueResult (fmap toJSON val) ts rep tree, iworld)
(ExceptionResult e str,iworld) = (ExceptionResult e str,iworld)
createResult :: TaskTime -> TIResult
createResult taskTime = TIValue NoValue taskTime
createRep :: TIRep
createRep = TaskRep (UIControlGroup {UIControlGroup|attributes='Map'.newMap, controls=[],direction = Vertical,actions = []}) []
createResult :: !InstanceNo !TaskTime -> TaskResult JSONNode
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)
//Evaluate a session task instance when a new event is received from a client
evalSessionTaskInstance :: !SessionId !Event !*IWorld -> (!MaybeErrorString (!TaskResult JSONNode, !InstanceNo, !SessionId), !*IWorld)
......@@ -128,22 +123,26 @@ evalTaskInstance event instanceNo iworld=:{currentDateTime,currentUser,currentIn
# meta=:{TIMeta|sessionId,parent,worker=Just worker,progress} = fromOk meta
# (reduct, iworld) = 'SharedDataSource'.read (taskInstanceReduct instanceNo) 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
| isError result = (liftError result, iworld)
= case fromOk result of
(TIException e msg) = (Ok (ExceptionResult e msg), iworld)
(TIValue val _)
(ExceptionResult e msg) = (Ok (ExceptionResult e msg), iworld)
(ValueResult val _ _ tree)
//Eval instance
# repAs = {TaskRepOpts|useLayout=Nothing,afterLayout=Nothing,modLayout=Nothing,appFinalLayout=isJust sessionId}
//Update current process id & eval stack in iworld
# taskId = TaskId instanceNo 0
# eventRoute = determineEventRoute event lists
# iworld = {iworld & currentInstance = instanceNo
, currentUser = worker
, nextTaskNo = reduct.TIReduct.nextTaskNo
, taskTime = reduct.TIReduct.nextTaskTime
, localShares = shares
, localLists = lists}
, localLists = lists
, localTasks = tasks
, eventRoute = eventRoute
}
//Clear the instance's registrations for share changes
# iworld = clearShareRegistrations instanceNo iworld
//Apply task's eval function and take updated nextTaskId from iworld
......@@ -158,18 +157,18 @@ evalTaskInstance event instanceNo iworld=:{currentDateTime,currentUser,currentIn
# (nextTaskNo,iworld) = getNextTaskNo iworld
# (shares,iworld) = getLocalShares 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
//Store the result
# (_,iworld) = 'SharedDataSource'.writeFilterMsg (taskres result) ((<>) instanceNo) (taskInstanceResult instanceNo) iworld //TODO Check error
//Store the representation
# (_,iworld) = 'SharedDataSource'.writeFilterMsg (taskrep result) ((<>) instanceNo) (taskInstanceRep instanceNo) iworld //TODO Check error
# (_,iworld) = 'SharedDataSource'.writeFilterMsg result ((<>) instanceNo) (taskInstanceResult instanceNo) iworld //TODO Check error
//Return the result
= (Ok result, iworld)
where
getNextTaskNo iworld=:{IWorld|nextTaskNo} = (nextTaskNo,iworld)
getLocalShares iworld=:{IWorld|localShares} = (localShares,iworld)
getLocalLists iworld=:{IWorld|localLists} = (localLists,iworld)
getLocalTasks iworld=:{IWorld|localTasks} = (localTasks,iworld)
updateProgress now result progress
# progress = {progress & firstEvent = Just (fromMaybe now progress.firstEvent), latestEvent = Just now}
......@@ -179,14 +178,40 @@ where
(ValueResult _ _ (TaskRep ui _) _) = {progress & stable = False, latestAttributes = uiDefAttributes ui}
_ = {progress & stable = False}
tasktree (ValueResult _ _ _ tree) = tree
tasktree (ExceptionResult _ _) = TCNop
determineEventRoute :: Event (Map TaskId [TaskListEntry]) -> Map TaskId Int
determineEventRoute RefreshEvent _ = 'Map'.newMap
determineEventRoute (EditEvent id _ _) lists = determineEventRoute` id ('Map'.toList lists)
determineEventRoute (ActionEvent id _) lists = determineEventRoute` id ('Map'.toList lists)
determineEventRoute (FocusEvent id) lists = determineEventRoute` id ('Map'.toList lists)
//TODO: Optimize this search function
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