implementation module CoreCombinators import StdList, StdTuple, StdMisc, StdBool, StdOrdList import Task, TaskContext, TaskStore, Util, HTTP, GenUpdate, GenEq, Store, SystemTypes, Time, Text, Shared, Func, Tuple, List import iTaskClass, InteractionTasks, LayoutCombinators, TUIDefinition from Map import qualified get, put, del from StdFunc import id, const, o, seq from IWorld import :: IWorld(..) from iTasks import JSONEncode, JSONDecode, dynamicJSONEncode, dynamicJSONDecode from TaskEval import taskListShare from CoreTasks import return from SharedDataSource import :: RWRes(..), readWrite, getIds, :: ShareId derive class iTask ParallelTaskType getNextTaskId :: *IWorld -> (!TaskId,!*IWorld) getNextTaskId iworld=:{evalStack=[TaskId topNo _:_],nextTaskNo} = (TaskId topNo nextTaskNo, {IWorld|iworld & nextTaskNo = nextTaskNo + 1}) getNextTaskId iworld = abort "Empty evaluation stack" transform :: ((Maybe a) -> Maybe b) !(Task a) -> Task b | iTask a & iTask b transform f task=:{Task|evalFun} = {Task|task & evalFun = evalFun`} where evalFun` eEvent cEvent repAs cxt iworld = case evalFun eEvent cEvent repAs cxt iworld of (TaskUnstable mba rep cxt, iworld) = (TaskUnstable (f mba) rep cxt, iworld) (TaskStable a rep cxt, iworld) = case f (Just a) of (Just b) = (TaskStable b rep cxt, iworld) Nothing = (taskException "Task with permanent invalid result", iworld) (TaskException e str, iworld) = (TaskException e str, iworld) project :: ((Maybe a) r -> Maybe w) (ReadWriteShared r w) (Task a) -> Task a | iTask a project projection share taska = mkTask init eval where init taskId iworld # (taskIda,iworld) = getNextTaskId iworld # (inita,iworld) = taska.initFun taskId iworld = (TCProject taskId JSONNull inita, iworld) //Eval task and check for change eval eEvent cEvent repAs (TCProject taskId prev cxta) iworld # (resa, iworld) = taska.evalFun eEvent cEvent (matchTarget (subRepAs repAs taska) taskId) cxta iworld = case resa of TaskUnstable mba rep ncxta | changed prev mba = projectOnShare mba (TaskUnstable mba rep (TCProject taskId (toJSON mba) ncxta)) iworld | otherwise = (TaskUnstable mba rep (TCProject taskId prev ncxta), iworld) TaskStable a rep ncxta | changed prev (Just a) = projectOnShare (Just a) (TaskStable a rep (TCProject taskId (toJSON (Just a)) ncxta)) iworld | otherwise = (TaskStable a rep (TCProject taskId prev ncxta), iworld) TaskException e str = (TaskException e str,iworld) subRepAs (RepAsService target) _ = (RepAsService target) subRepAs (RepAsTUI target mbLayout) task=:{layout} = case mbLayout of Nothing = RepAsTUI target layout Just overwrite = RepAsTUI target (Just overwrite) changed encprev cur = case fromJSON encprev of Nothing = fixme where fixme = True //THIS ASSUMPTION DOES NOT ALWAYS HOLD! Consider changed when parsing fails Just prev = prev =!= cur projectOnShare mba result iworld = case readWrite (\r _ -> case projection mba r of Just w = Write w Void; Nothing = YieldResult Void) share iworld of (Ok _,iworld) = (result,iworld) (Error e,iworld) = (taskException e,iworld) step :: (Task a) [TaskStep a b] -> Task b | iTask a & iTask b step taska conts = mkTask init eval where init taskId iworld # (taskIda,iworld) = getNextTaskId iworld # (inita,iworld) = taska.initFun taskIda iworld = (TCStep taskId (Left inita), iworld) //Eval left-hand side eval eEvent cEvent repAs (TCStep taskId (Left cxta)) iworld # (resa, iworld) = taska.evalFun eEvent cEvent (matchTarget (subRepAs repAs taska) taskId) cxta iworld # mbcommit = case cEvent of (Just (TaskEvent t action)) | t == taskId = Just action _ = Nothing # mbCont = case resa of TaskUnstable mba rep ncxta = case searchContInstable mba mbcommit conts of Nothing = Left (TaskUnstable Nothing (addStepActions taskId repAs rep mba) (TCStep taskId (Left ncxta))) Just rewrite = Right rewrite TaskStable a rep ncxta = case searchContStable a mbcommit conts of Nothing = Left (TaskUnstable Nothing (addStepActions taskId repAs rep (Just a)) (TCStep taskId (Left ncxta))) Just rewrite = Right rewrite TaskException e str = case searchContException e str conts of Nothing = Left (TaskException e str) Just rewrite = Right rewrite = case mbCont of Left res = (res,iworld) Right (sel,taskb,enca) # (taskIdb,iworld) = getNextTaskId iworld # (cxtb,iworld) = taskb.initFun taskIdb iworld # (resb,iworld) = taskb.evalFun Nothing Nothing (matchTarget (subRepAs repAs taskb) taskId) cxtb iworld = case resb of TaskUnstable mbb rep ncxtb = (TaskUnstable mbb rep (TCStep taskId (Right (enca,sel,ncxtb))),iworld) TaskStable b rep ncxtb = (TaskStable b rep (TCStep taskId (Right (enca,sel,ncxtb))), iworld) TaskException e str = (TaskException e str, iworld) //Eval right-hand side eval eEvent cEvent repAs (TCStep taskId (Right (enca,sel,cxtb))) iworld # mbTaskb = case conts !! sel of (AnyTime _ taskbf) = fmap taskbf (fromJSON enca) (WithResult _ _ taskbf) = fmap taskbf (fromJSON enca) (WithoutResult _ taskb) = Just taskb (WhenStable taskbf) = fmap taskbf (fromJSON enca) (Catch taskbf) = fmap taskbf (fromJSON enca) (CatchAll taskbf) = fmap taskbf (fromJSON enca) = case mbTaskb of Just taskb # (resb, iworld) = taskb.evalFun eEvent cEvent (matchTarget (subRepAs repAs taskb) taskId) cxtb iworld = case resb of TaskUnstable mbb rep ncxtb = (TaskUnstable mbb rep (TCStep taskId (Right (enca,sel,ncxtb))),iworld) TaskStable b rep ncxtb = (TaskStable b rep (TCStep taskId (Right (enca,sel,ncxtb))), iworld) TaskException e str = (TaskException e str, iworld) Nothing = (taskException "Corrupt task value in step", iworld) //Incorred state eval eEvent cEvent _ context iworld = (taskException "Corrupt task context in step", iworld) searchContInstable mba mbcommit conts = search mba mbcommit 0 Nothing conts where search _ _ _ mbmatch [] = mbmatch //First matching trigger wins search (Just a) mbcommit i mbmatch [WhenValid pred f:cs] | pred a = Just (i, f a, toJSON a) = search (Just a) mbcommit (i + 1) mbmatch cs search mba (Just commit) i Nothing [AnyTime action f:cs] | commit == actionName action = search mba (Just commit) (i + 1) (Just (i, f mba, toJSON mba)) cs = search mba (Just commit) (i + 1) Nothing cs search Nothing (Just commit) i Nothing [WithoutResult action taskb:cs] | commit == actionName action = search Nothing (Just commit) (i + 1) (Just (i, taskb, JSONNull)) cs = search Nothing (Just commit) (i + 1) Nothing cs search (Just a) (Just commit) i Nothing [WithResult action pred taskb:cs] | commit == actionName action && pred a = search (Just a) (Just commit) (i + 1) (Just (i, taskb a, toJSON a)) cs = search (Just a) (Just commit) (i + 1) Nothing cs search mba mbcommit i mbmatch [_:cs] = search mba mbcommit (i + 1) mbmatch cs searchContStable a mbcommit conts = search a mbcommit 0 Nothing conts where search _ _ _ mbmatch [] = mbmatch search a mbcommit i mbmatch [WhenStable f:_] = Just (i,f a, toJSON a) search a (Just commit) i Nothing [AnyTime action f:cs] | commit == actionName action = search a (Just commit) (i + 1) (Just (i, f (Just a), toJSON (Just a))) cs = search a (Just commit) (i + 1) Nothing cs search a (Just commit) i Nothing [WithResult action pred f:cs] | commit == actionName action && pred a = search a (Just commit) (i + 1) (Just (i, f a, toJSON a)) cs = search a (Just commit) (i + 1) Nothing cs search a mbcommit i mbmatch [_:cs] = search a mbcommit (i + 1) mbmatch cs searchContException dyn str conts = search dyn str 0 Nothing conts where search _ _ _ catchall [] = catchall //Return the maybe catchall search dyn str i catchall [Catch f:cs] = case (match f dyn) of Just (taskb,enca) = Just (i, taskb, enca) //We have a match _ = search dyn str (i + 1) catchall cs //Keep searching search dyn str i Nothing [CatchAll f:cs] = search dyn str (i + 1) (Just (i, f str, toJSON str)) cs //Keep searching (at least we have a catchall) search dyn str i mbcatchall [_:cs] = search dyn str (i + 1) mbcatchall cs //Keep searching match :: (e -> Task b) Dynamic -> Maybe (Task b, JSONNode) | iTask e match f (e :: e^) = Just (f e, toJSON e) match _ _ = Nothing addStepActions taskId (RepAsService _) rep mba = case rep of (ServiceRep (parts,actions,attributes)) = ServiceRep (parts,actions ++ stepActions taskId mba,attributes) _ = rep addStepActions taskId (RepAsTUI Nothing layout) rep mba = case rep of (TUIRep gui) # layoutfun = fromMaybe DEFAULT_LAYOUT layout # fixme = [] = TUIRep (layoutfun SequentialComposition [gui] (stepActions taskId mba) [(TASK_ATTRIBUTE, toString taskId):fixme]) //TODO: Add attributes from task _ # layoutfun = fromMaybe DEFAULT_LAYOUT layout = TUIRep (layoutfun SequentialComposition [] (stepActions taskId mba) [(TASK_ATTRIBUTE, toString taskId)]) addStepActions taskId (RepAsTUI (Just _) layout) rep mba = rep stepActions taskId mba = stepActions` conts where stepActions` [] = [] stepActions` [AnyTime action _:cs] = [(toString taskId,action,True):stepActions` cs] stepActions` [WithResult action pred _:cs] = [(toString taskId,action,maybe False pred mba):stepActions` cs] stepActions` [WithoutResult action _:cs] = [(toString taskId,action,isNothing mba):stepActions` cs] stepActions` [_:cs] = stepActions` cs subRepAs (RepAsService target) _ = RepAsService target subRepAs (RepAsTUI target _) {Task|layout} = RepAsTUI target layout // Parallel composition :: ResultSet a = RSException !Dynamic !String | RSResults ![(!ParallelItem,!TaskResult a)] //Phantom type wrapper for task id's used to solve overloading :: ListId a = ListId TaskId parallel :: !d ![(!ParallelTaskType,!ParallelTask a)] -> Task [Maybe a] | descr d & iTask a parallel desc initTasks = mkTask init eval where //Create initial set of tasks and initial state init taskId iworld=:{IWorld|timestamp} //Create the list of initial parallel items # (items,iworld) = mkParallelItems listId initTasks (length initTasks - 1) iworld //Initialize all initial items # (items,iworld) = initParallelItems listId 0 items 0 iworld = (TCParallel taskId listMeta items, iworld) where listId = ListId taskId //Passed to subfunctions to solve overloading listMeta = {nextIdx = length initTasks, listVersion = 0} eval eEvent cEvent repAs context=:(TCParallel taskId meta items) iworld //If a reorder edit event is given, reorder the stack # items = case eEvent of Just (TaskEvent t ("top",JSONString top)) = reorder (fromString top) items _ = items //Eval all subtasks # (results,nextIdx,iworld) = evalParallelItems (listId taskId initTasks) eEvent cEvent repAs 0 (zip (items,repeat Nothing)) meta.nextIdx iworld = case results of RSException e str = (TaskException e str, iworld) RSResults itemsAndResults # rep = mergeTaskReps taskId desc repAs itemsAndResults # (items,results) = unzip itemsAndResults # (val,stable) = mergeValues results | stable = (TaskStable val rep (TCParallel taskId meta items), iworld) | otherwise = (TaskUnstable (Just val) rep (TCParallel taskId meta items), iworld) where listKey = toString (ParallelTaskList taskId) //Fallback eval _ _ _ _ iworld = (taskException "Corrupt task context in parallel", iworld) //Helper function to unify ListId type parameter with type parameter of initial task set listId :: !TaskId [(!ParallelTaskType,!ParallelTask a)] -> ListId a listId taskId _ = ListId taskId //Change the order of the subtask such that the indicated sub becomes top and the others //maintain their relative ordering reorder :: !TaskId ![ParallelItem] -> [ParallelItem] reorder top items = let (titems,ritems) = splitWith isTop (sortByStack items) in (sortByTaskId [{ParallelItem|i & stack = o} \\ i <- (ritems ++ titems) & o <- [0..]]) where isTop {ParallelItem|taskId} = taskId == top sortByTaskId items = sortBy ( \{ParallelItem|taskId=a} {ParallelItem|taskId=b} -> a < b) items sortByStack items = sortBy ( \{ParallelItem|stack=a} {ParallelItem|stack=b} -> a < b) items evalParallelItems :: !(ListId a) !(Maybe EditEvent) !(Maybe CommitEvent) !TaskRepTarget !Int ![(ParallelItem, Maybe (TaskResult a))] !Int !*IWorld -> (!ResultSet a, !Int, !*IWorld) | iTask a evalParallelItems listId=:(ListId listTaskId) eEvent cEvent repAs index items nextIdx iworld | index >= length items //All done, return result set and remove list from scope # iworld = unshareParallelList listId iworld # iworld = disableControl listId iworld = (RSResults [(item,result) \\ (item,Just result) <- items], nextIdx, iworld) | otherwise //Update scope # iworld = shareParallelList listId (map fst items) version iworld //Enable control # iworld = enableControl listId nextIdx iworld //Evaluate item at index # (result,item,iworld) = evalParallelItem listId eEvent cEvent repAs (fst (items !! index)) iworld //Process additions and removals from the list # (controls,nextIdx,iworld) = takeControl listId iworld # (items,iworld) = processControls listId controls (updateAt index (item,Just result) items) iworld # index = if (isEmpty controls) index (resetIndex items) //If items have been removed, the index may not be correct anymore = case result of TaskException e str //Clean scope and return exeption # iworld = unshareParallelList listId iworld = (RSException e str, nextIdx, iworld) _ //Evaluate other items = evalParallelItems listId eEvent cEvent repAs (index + 1) items nextIdx iworld where version = fixme where fixme = 0 evalParallelItem :: !(ListId a) !(Maybe EditEvent) !(Maybe CommitEvent) !TaskRepTarget !ParallelItem !*IWorld -> (!TaskResult a,!ParallelItem,!*IWorld) | iTask a evalParallelItem listId=:(ListId listTaskId) eEvent cEvent repAs item=:{ParallelItem|task=(parTask :: ParallelTask a^),state} iworld # (result, iworld) = task.evalFun eEvent cEvent (subRepAs repAs listTaskId task) state iworld # item = case result of TaskUnstable mbr rep state = {ParallelItem|item & state = state, lastValue = toJSON mbr} //TODO: set lastAttributes TaskStable r rep state = {ParallelItem|item & state = state, lastValue = toJSON (Just r)} //TODO: set lastAttributes TaskException e str = item = (result,item,iworld) where task = parTask listShare listShare = taskListShare (ParallelTaskList listTaskId) processControls :: !(ListId a) ![ParallelControl] ![(ParallelItem,Maybe (TaskResult a))] !*IWorld -> (![(ParallelItem,Maybe (TaskResult a))],!*IWorld) | iTask a processControls listId [] items iworld = (items,iworld) processControls listId [AppendTask item:controls] items iworld //Initialize the new item and append for later evaluation //TODO: Maybe initialize should only happen just before evaluation? # (item,iworld) = initParallelItem listId item iworld = processControls listId controls (items ++ [(item,Nothing)]) iworld processControls listId [RemoveTask taskId:controls] items iworld //Filter the item from the set # items = [item \\ item <- items | (fst item).ParallelItem.taskId <> taskId] = processControls listId controls items iworld resetIndex :: [(ParallelItem,Maybe (TaskResult a))] -> Int resetIndex items = reset 0 items where reset idx [(_,Just _):items] = reset (idx + 1) items //Keep searching reset idx _ = idx - 1 //The previous index was apparently the last Just enableControl :: !(ListId a) !Int *IWorld -> *IWorld enableControl (ListId taskId) nextIdx iworld=:{parallelControls} = {iworld & parallelControls = 'Map'.put ("taskList:" +++ listKey) (nextIdx,[]) parallelControls} where listKey = toString (ParallelTaskList taskId) takeControl :: !(ListId a) !*IWorld -> (![ParallelControl],!Int,!*IWorld) takeControl (ListId taskId) iworld=:{parallelControls} = case 'Map'.get ("taskList:" +++ listKey) parallelControls of Just (nextIdx,controls) = (controls,nextIdx,iworld) _ = abort "Could not read parallel controls" where listKey = toString (ParallelTaskList taskId) disableControl :: !(ListId a) *IWorld -> *IWorld disableControl (ListId taskId) iworld=:{parallelControls} = {iworld & parallelControls = 'Map'.del ("taskList:" +++ listKey) parallelControls} where listKey = toString (ParallelTaskList taskId) mergeTaskReps :: !TaskId !d !TaskRepTarget ![(!ParallelItem,!TaskResult a)] -> TaskRep | descr d mergeTaskReps taskId desc (RepAsTUI target layout) results # layout = (fromMaybe DEFAULT_LAYOUT layout) # attributes = [(TASK_ATTRIBUTE,toString taskId) : initAttributes desc] | maybe True (\t -> t == taskId) target //Show if target is Nothing or taskId matches # parts = [(t,g,ac,kvSet STACK_ATTRIBUTE (toString stack) (kvSet TASK_ATTRIBUTE (toString taskId) at)) \\ ({ParallelItem|taskId,stack,detached},TaskUnstable _ (TUIRep (t,g,ac,at)) _) <- results | not detached] = TUIRep (layout ParallelComposition parts [] attributes) | otherwise //If a target is set, only one of the branches should have a TUIRep representation = case [gui \\ (_,TaskUnstable _ (TUIRep gui) _) <- results] of [part] = TUIRep part parts = NoRep mergeTaskReps _ _ (RepAsService target) results # fixme = ([],[],[]) = ServiceRep fixme mergeValues :: ![TaskResult a] -> (![Maybe a],!Bool) mergeValues [] = ([],True) mergeValues [TaskStable v _ _:is] = let (vs,stable) = mergeValues is in ([Just v:vs],stable) mergeValues [TaskUnstable mbv _ _:is] = ([mbv:fst (mergeValues is)], False) subRepAs :: !TaskRepTarget !TaskId !(Task a) -> TaskRepTarget subRepAs (RepAsTUI Nothing _) taskId task=:{layout} = RepAsTUI Nothing layout subRepAs (RepAsTUI (Just target) _) taskId task=:{layout} | target == taskId = RepAsTUI Nothing layout = RepAsTUI (Just target) layout subRepAs (RepAsService Nothing) taskId task = RepAsService Nothing subRepAs (RepAsService (Just target)) taskId task | target == taskId = RepAsService Nothing = RepAsService (Just target) //SHARED HELPER FUNCTIONS //Use decrementing stack order values (o) //To make sure that the first initial subtask has the highest order value //(this will ensure the first tab is active, or the first window will be on top) mkParallelItems :: !(ListId a) ![(!ParallelTaskType,!ParallelTask a)] !Int *IWorld -> (![ParallelItem],!*IWorld) | TC a mkParallelItems listId [] stackOrder iworld = ([],iworld) mkParallelItems listId [(parType,parTask):tasks] stackOrder iworld=:{IWorld|localDateTime,currentUser} # (taskId,iworld) = getNextTaskId iworld # (listItems,iworld) = mkParallelItems listId tasks (stackOrder - 1) iworld = ([mkParallelItem parType taskId stackOrder currentUser localDateTime parTask :listItems], iworld) mkParallelItem :: !ParallelTaskType !TaskId !Int !User !DateTime !(ParallelTask a) -> ParallelItem | TC a mkParallelItem parType taskId stackOrder user now parTask # (progress,management) = case parType of Embedded = (Nothing,Nothing) (Detached management) = (Just {ProgressMeta|status=Unstable,issuedAt=now,issuedBy=user,firstEvent=Nothing,latestEvent=Nothing},Just management) = {taskId = taskId, stack = stackOrder, detached = False, progress = progress, management = management ,task = (dynamic parTask :: ParallelTask a^), state = TCEmpty taskId, lastValue = JSONNull, lastAttributes = []} initParallelItems :: !(ListId a) !Int ![ParallelItem] !Int !*IWorld -> (![ParallelItem],!*IWorld) | iTask a initParallelItems listId=:(ListId taskId) index items version iworld | index >= length items = (items, unshareParallelList listId iworld) //Remove shared data from scope # iworld = shareParallelList listId items version iworld //Update shared data # (item,iworld) = initParallelItem listId (items !! index) iworld //Init item at index = initParallelItems listId (index + 1) (updateAt index item items) version iworld initParallelItem :: !(ListId a) !ParallelItem !*IWorld -> (!ParallelItem,!*IWorld) | iTask a initParallelItem (ListId listTaskId) item=:{ParallelItem|taskId, task = (parTask :: ParallelTask a^)} iworld # (state,iworld) = (parTask listShare).initFun taskId iworld = ({ParallelItem|item & state = state}, iworld) where listShare = taskListShare (ParallelTaskList listTaskId) shareParallelList :: !(ListId a) ![ParallelItem] !Int !*IWorld -> *IWorld shareParallelList (ListId taskId) items version iworld=:{parallelLists} = {iworld & parallelLists = 'Map'.put ("taskList:" +++ listKey) (version,items) parallelLists} where listKey = toString (ParallelTaskList taskId) unshareParallelList :: !(ListId a) !*IWorld -> *IWorld unshareParallelList (ListId taskId) iworld=:{parallelLists} = {iworld & parallelLists = 'Map'.del ("taskList:" +++ listKey) parallelLists} where listKey = toString (ParallelTaskList taskId) //Derived shares taskListState :: !(SharedTaskList a) -> ReadOnlyShared [Maybe a] taskListState tasklist = mapRead (\{TaskList|state} -> state) tasklist taskListMeta :: !(SharedTaskList a) -> ReadOnlyShared [TaskListItem] taskListMeta tasklist = mapRead (\{TaskList|items} -> items) tasklist /** * Appends a task to a task list */ appendTask :: !ParallelTaskType !(ParallelTask a) !(SharedTaskList a) -> Task Int | TC a appendTask parType parTask tasklist = mkInstantTask eval where listId = hd (getIds tasklist) eval taskId iworld=:{parallelControls,currentUser,localDateTime} = case 'Map'.get listId parallelControls of Just (nextIdx,controls) //For the global tasklist we don't use the internal counter, but get the index from the //process database # (newIdx,newTaskId,nextIdx,iworld) = case listId of "taskList:tasklist-top" # (newIdx,iworld) = newTopNo iworld = (newIdx,TaskId newIdx 0,nextIdx, iworld) _ # (newTaskId,iworld) = getNextTaskId iworld = (nextIdx,newTaskId,nextIdx + 1,iworld) # newItem = mkParallelItem parType newTaskId newIdx currentUser localDateTime parTask # parallelControls = 'Map'.put listId (nextIdx, controls ++ [AppendTask newItem]) parallelControls = (TaskStable newIdx NoRep (TCEmpty taskId), {iworld & parallelControls = parallelControls, readShares = Nothing}) _ = (taskException ("Task list " +++ listId +++ " is not in scope"), iworld) /** * Removes (and stops) a task from a task list */ removeTask :: !TaskId !(SharedTaskList s) -> Task Void | TC s removeTask remId tasklist = mkInstantTask (removeTask` remId tasklist) where listId = hd (getIds tasklist) removeTask` :: !TaskId !(SharedTaskList s) TaskId *IWorld -> (!TaskResult Void,!*IWorld) | TC s removeTask` remId _ taskId iworld=:{parallelControls} = case 'Map'.get listId parallelControls of Just (nextIdx,controls) # parallelControls = 'Map'.put listId (nextIdx, controls ++ [RemoveTask remId]) parallelControls = (TaskStable Void NoRep (TCEmpty taskId), {iworld & parallelControls = parallelControls, readShares = Nothing}) _ = (taskException ("Task list " +++ listId +++ " is not in scope"), iworld) /* * Alters the evaluation functions of a task in such a way * that before evaluation the currentUser field in iworld is set to * the given user, and restored afterwards. */ workAs :: !User !(Task a) -> Task a | iTask a workAs user task = {Task|task & initFun = init task.initFun, evalFun = eval task.evalFun} where init f taskId iworld=:{currentUser} # (context,iworld) = f taskId {iworld & currentUser = user} = (context,{iworld & currentUser = currentUser}) eval f eEvent cEvent repAs context iworld=:{currentUser} # (result,iworld) = f eEvent cEvent repAs context {iworld & currentUser = user} = (result,{iworld & currentUser = currentUser}) withShared :: !b !((Shared b) -> Task a) -> Task a | iTask a & iTask b withShared initial stask = mkTask init eval where init taskId iworld # (taskIda,iworld) = getNextTaskId iworld # iworld = shareValue taskId initial initial 0 iworld # (inita,iworld) = (stask (localShare taskId)).initFun taskId iworld # (value,version,iworld) = unshareValue taskId initial iworld = (TCShared taskId (toJSON value) version inita, iworld) eval eEvent cEvent repAs context=:(TCShared taskId encv version cxta) iworld # iworld = shareValue taskId initial (fromJust (fromJSON encv)) version iworld # taska = stask (localShare taskId) # (resa,iworld) = taska.evalFun eEvent cEvent (matchTarget (subRepAs repAs taska) taskId) cxta iworld # (value,version,iworld) = unshareValue taskId initial iworld = case resa of TaskUnstable mba rep ncxta = (TaskUnstable mba rep (TCShared taskId (toJSON value) version ncxta),iworld) TaskStable a rep ncxta = (TaskStable a rep (TCShared taskId (toJSON value) version ncxta),iworld) TaskException e str = (TaskException e str,iworld) eval _ _ _ _ iworld = (taskException "Corrupt task context in withShared", iworld) subRepAs (RepAsService target) _ = (RepAsService target) subRepAs (RepAsTUI target mbLayout) task=:{layout} = case mbLayout of Nothing = RepAsTUI target layout Just overwrite = RepAsTUI target (Just overwrite) shareValue :: !TaskId s !s !Int !*IWorld -> *IWorld | iTask s //With bogus argument to solve overloading shareValue taskId _ value version iworld=:{localShares} = {iworld & localShares = 'Map'.put ("localShare:" +++ toString taskId) (version,dynamic value :: s^) localShares} unshareValue :: !TaskId s !*IWorld -> (!s,!Int,!*IWorld) | iTask s //With bogus argument to solve overloading unshareValue taskId _ iworld=:{localShares} = case 'Map'.get ("localShare:" +++ toString taskId) localShares of Just (version,(value :: s^)) = (value,version,{iworld & localShares = 'Map'.del ("localShare:" +++ toString taskId) localShares}) _ = abort "Shared value not in scope" localShare :: !TaskId -> (Shared s) | iTask s localShare taskId = (makeUnsafeShare "localShare" shareKey read write getVersion) where shareKey = toString taskId read iworld=:{localShares} = case 'Map'.get ("localShare:" +++ shareKey) localShares of Just (_,(value:: s^)) = (Ok value, iworld) _ = (Error ("Could not read local shared stated " +++ shareKey), iworld) write value iworld=:{localShares} = case 'Map'.get ("localShare:" +++ shareKey) localShares of Just (version,_) = (Ok Void, {iworld & localShares = 'Map'.put ("localShare:" +++ shareKey) (version + 1, dynamic value :: s^) localShares}) _ = (Error ("Could not read timestamp for local shared stated " +++ shareKey),iworld) getVersion iworld=:{localShares} = case 'Map'.get ("localShare:" +++ shareKey) localShares of Just (version,_) = (Ok version, iworld) _ = (Error ("Could not read timestamp for local shared stated " +++ shareKey),iworld) /* * Tuning of tasks */ class tune b :: !b !(Task a) -> Task a instance tune SetLayout where tune (SetLayout layout) task = {Task|task & layout = Just layout} instance tune ModifyLayout where tune (ModifyLayout f) task=:{Task|layout} = {Task|task & layout = Just (f (fromMaybe DEFAULT_LAYOUT layout))} /** * Helper function that sets the target task id to Nothing if it matches the given task id. * This ensures that a representation for the full sub-tree is generated when determining the representation target for sub trees. */ matchTarget :: !TaskRepTarget !TaskId -> TaskRepTarget matchTarget repAs=:(RepAsTUI (Just target) layout) taskId = if (target == taskId) (RepAsTUI Nothing layout) repAs matchTarget repAs=:(RepAsService (Just target)) taskId = if (target == taskId) (RepAsService Nothing) repAs matchTarget repAs taskId = repAs