implementation module iTasks.API.Core.TaskCombinators import StdList, StdTuple, StdMisc, StdBool, StdOrdList import Internet.HTTP, GenEq, System.Time, Text, Data.Func, Data.Tuple, Data.List, Data.Error, Data.Either, Text.JSON import iTasks.Framework.Task, iTasks.Framework.TaskState, iTasks.Framework.TaskStore, iTasks.Framework.TaskEval import iTasks.Framework.Util, iTasks.Framework.Store import iTasks.Framework.Generic, iTasks.Framework.UIDefinition import iTasks.API.Core.Types, iTasks.API.Core.LayoutCombinators import iTasks.Framework.IWorld import iTasks.Framework.Client.Override from Data.Map import qualified get, put, del, newMap, toList, fromList from StdFunc import id, const, o, seq from iTasks import JSONEncode, JSONDecode, dynamicJSONEncode, dynamicJSONDecode from iTasks.Framework.TaskEval import localShare, parListShare, topListShare from iTasks.Framework.SDS import write, writeFilterMsg, read, readRegister from iTasks.API.Core.Tasks import return from iTasks.API.Common.SDSCombinators import toReadOnly, setParam, mapRead, mapReadWriteError derive class iTask ParallelTaskType, WorkOnStatus mkTaskIdent tid = Just (ModuleTaskName "iTasks.API.Core.OptimizedCoreTasks" tid) getNextTaskId :: *IWorld -> (!TaskId,!*IWorld) getNextTaskId iworld=:{current=current=:{TaskEvalState|taskInstance,nextTaskNo}} = (TaskId taskInstance nextTaskNo, {IWorld|iworld & current = {TaskEvalState|current & nextTaskNo = nextTaskNo + 1}}) transform :: ((TaskValue a) -> TaskValue b) !(Task a) -> Task b | iTask a & iTask b transform f (Task tid evala) = Task tid eval where eval event repOpts tree iworld = case evala event repOpts tree iworld of (ValueResult val lastEvent rep tree,iworld) = (ValueResult (f val) lastEvent rep tree, iworld) //TODO: guarantee stability (ExceptionResult e str, iworld) = (ExceptionResult e str, iworld) (DestroyedResult, iworld) = (DestroyedResult, iworld) project :: ((TaskValue a) r -> Maybe w) (ReadWriteShared r w) !(Task a) -> Task a | iTask a project projection share (Task tid evala) = Task tid eval where eval event repOpts (TCDestroy (TCProject taskId _ encprev treea)) iworld //Cleanup duty simply passed to inner task = evala event repOpts (TCDestroy treea) iworld eval event repOpts state iworld # (taskId,mtn,prev,statea) = case state of (TCInit taskId mtn _) = (taskId,mtn,NoValue,state) (TCProject taskId mtn encprev statea) = (taskId,mtn,fromJust (fromJSON encprev),statea) # (resa, iworld) = evala event repOpts statea iworld = case resa of ValueResult val ts rep ncxta # result = ValueResult val ts rep (TCProject taskId mtn (toJSON val) ncxta) | val =!= prev = projectOnShare val result iworld | otherwise = (result,iworld) ExceptionResult e str = (ExceptionResult e str,iworld) projectOnShare val result iworld=:{current={TaskEvalState|taskInstance}} # (er, iworld) = read share iworld = case er of Ok r = case projection val r of Just w # (ew, iworld) = write w share iworld = case ew of Ok _ = (result, iworld) Error e = (exception e, iworld) Nothing = (result, iworld) Error e = (exception e, iworld) step :: !(Task a) ((Maybe a) -> (Maybe b)) [TaskCont a (Task b)] -> Task b | iTask a & iTask b step (Task tid evala) lhsValFun conts = Task Nothing eval where eval event repOpts (TCInit taskId mtn ts) iworld # (taskIda,iworld) = getNextTaskId iworld = eval event repOpts (TCStep taskId tid ts (Left (TCInit taskIda mtn ts))) iworld //Eval left-hand side eval event repOpts (TCStep taskId mtn ts (Left treea)) iworld=:{current={taskTime}} # (resa, iworld) = evala event repOpts treea iworld # ts = case event of (FocusEvent _ focusId) = if (focusId == taskId) taskTime ts _ = ts # mbAction = matchAction taskId event # mbCont = case resa of ValueResult val info rep ntreea = case searchContValue val mbAction conts of Nothing # info = {TaskInfo|info & lastEvent = max ts info.TaskInfo.lastEvent} # value = maybe NoValue (\v -> Value v False) (lhsValFun (case val of Value v _ = Just v; _ = Nothing)) = Left (ValueResult value info (doStepLayout taskId repOpts rep val) (TCStep taskId mtn info.TaskInfo.lastEvent (Left ntreea)) ) Just rewrite = Right (rewrite,Just ntreea, info.TaskInfo.lastEvent) ExceptionResult e str = case searchContException e str conts of Nothing = Left (ExceptionResult e str) Just rewrite = Right (rewrite,Nothing, ts) //TODO: Figure out how to garbage collect after exceptions = case mbCont of Left res = (res,iworld) Right ((sel,Task mtn evalb,d_json_a),mbTreeA, lastEvent) //Cleanup state of left-hand side # iworld = case mbTreeA of Nothing = iworld Just treea = snd (evala (toRefresh event) repOpts (TCDestroy treea) iworld) //TODO: Check for exceptions during cleanup # (taskIdb,iworld) = getNextTaskId iworld # (resb,iworld) = evalb (toRefresh event) repOpts (TCInit taskIdb mtn lastEvent) iworld = case resb of ValueResult val info rep nstateb # info = {TaskInfo|info & lastEvent = max ts info.TaskInfo.lastEvent} = (ValueResult val info (finalizeRep repOpts rep) (TCStep taskId mtn info.TaskInfo.lastEvent (Right (d_json_a,sel,nstateb))),iworld) ExceptionResult e str = (ExceptionResult e str, iworld) //Eval right-hand side eval event repOpts (TCStep taskId mtn ts (Right (enca,sel,treeb))) iworld=:{current={taskTime}} # ts = case event of (FocusEvent _ focusId) = if (focusId == taskId) taskTime ts _ = ts = case restoreTaskB sel enca of Just (Task _ evalb) # (resb, iworld) = evalb event repOpts treeb iworld = case resb of ValueResult val info rep ntreeb # info = {TaskInfo|info & lastEvent = max ts info.TaskInfo.lastEvent} = (ValueResult val info (finalizeRep repOpts rep) (TCStep taskId mtn info.TaskInfo.lastEvent (Right (enca,sel,ntreeb))), iworld) ExceptionResult e str = (ExceptionResult e str, iworld) Nothing = (exception "Corrupt task value in step", iworld) //Cleanup eval event repOpts (TCDestroy (TCStep _ _ _ (Left treea))) iworld = case evala event repOpts (TCDestroy treea) iworld of (DestroyedResult,iworld) = (DestroyedResult,iworld) (ExceptionResult e str,iworld) = (ExceptionResult e str,iworld) (ValueResult _ _ _ _,iworld) = (exception "Destroy failed in step",iworld) eval event repOpts (TCDestroy (TCStep _ _ _ (Right(enca,sel,treeb)))) iworld = case restoreTaskB sel enca of Just (Task _ evalb) = evalb event repOpts (TCDestroy treeb) iworld Nothing = (exception "Corrupt task value in step", iworld) //Incorrect state eval event _ state iworld = (exception ("Corrupt task state in step:" +++ (toString (toJSON state))), iworld) restoreTaskB sel d_json_a = case conts !! sel of (OnValue taskbf) = call_with_DeferredJSON_TaskValue taskbf d_json_a (OnAction _ taskbf) = call_with_DeferredJSON_TaskValue taskbf d_json_a (OnException taskbf) = call_with_DeferredJSON taskbf d_json_a (OnAllExceptions taskbf) = call_with_DeferredJSON taskbf d_json_a doStepLayout taskId repOpts NoRep val = finalizeRep repOpts (TaskRep ((repLayoutRules repOpts).LayoutRules.accuStep {UIDef|content=UIActionSet [],windows=[]} (contActions taskId val conts)) []) doStepLayout taskId repOpts (TaskRep def parts) val = finalizeRep repOpts (TaskRep ((repLayoutRules repOpts).LayoutRules.accuStep def (contActions taskId val conts)) parts) call_with_DeferredJSON_TaskValue :: ((TaskValue a) -> (Maybe (Task .b))) DeferredJSON -> Maybe (Task .b) | TC a & JSONDecode{|*|} a call_with_DeferredJSON_TaskValue f_tva_tb d_json_tva=:(DeferredJSON tva) = f_tva_tb (cast_to_TaskValue tva) call_with_DeferredJSON_TaskValue f_tva_tb (DeferredJSONNode json) = case fromJSON json of Just a -> f_tva_tb a Nothing -> Nothing call_with_DeferredJSON :: (a -> Task .b) DeferredJSON -> Maybe (Task .b) | TC a & JSONDecode{|*|} a call_with_DeferredJSON f_tva_tb d_json_tva=:(DeferredJSON tva) = Just (f_tva_tb (cast tva)) call_with_DeferredJSON f_tva_tb (DeferredJSONNode json) = case fromJSON json of Just a -> Just (f_tva_tb a) Nothing -> Nothing matchAction :: TaskId Event -> Maybe String matchAction taskId (ActionEvent _ matchId action) | matchId == taskId = Just action = Nothing matchAction taskId _ = Nothing contActions :: TaskId (TaskValue a) [TaskCont a b]-> [UIAction] contActions taskId val conts = [{UIAction|taskId=toString taskId,action=action,enabled=isJust (taskbf val)}\\ OnAction action taskbf <- conts] searchContValue :: (TaskValue a) (Maybe String) [TaskCont a b] -> Maybe (!Int, !b, !DeferredJSON) | TC a & JSONEncode{|*|} a searchContValue val mbAction conts = search val mbAction 0 Nothing conts where search _ _ _ mbMatch [] = mbMatch //No matching OnValue steps were found, return the potential match search val mbAction i mbMatch [OnValue f:cs] = case f val of Just cont = Just (i, cont, DeferredJSON val) //Don't look any further, first matching trigger wins Nothing = search val mbAction (i + 1) mbMatch cs //Keep search search val mbAction=:(Just actionEvent) i Nothing [OnAction action f:cs] | actionEvent == actionName action = case f val of Just cont = search val mbAction (i + 1) (Just (i, cont, DeferredJSON val)) cs //We found a potential winner (if no OnValue values are in cs) Nothing = search val mbAction (i + 1) Nothing cs //Keep searching | otherwise = search val mbAction (i + 1) Nothing cs //Keep searching search val mbAction i mbMatch [_:cs] = search val mbAction (i + 1) mbMatch cs //Keep searching searchContException :: Dynamic String [TaskCont a b] -> Maybe (Int, !b, !DeferredJSON) searchContException dyn str conts = search dyn str 0 Nothing conts where search _ _ _ catchall [] = catchall //Return the maybe catchall search dyn str i catchall [OnException 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 [OnAllExceptions f:cs] = search dyn str (i + 1) (Just (i, f str, DeferredJSON 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 -> b) Dynamic -> Maybe (b, DeferredJSON) | iTask e match f (e :: e^) = Just (f e, DeferredJSON e) match _ _ = Nothing // Parallel composition parallel :: !d ![(!ParallelTaskType,!ParallelTask a)] [TaskCont [(!TaskTime,!TaskValue a)] (!ParallelTaskType,!ParallelTask a)] -> Task [(!TaskTime,!TaskValue a)] | descr d & iTask a parallel desc initTasks conts = Task (mkTaskIdent "parallel") eval where //Create initial task list eval event repOpts (TCInit taskId mtn ts) iworld=:{IWorld|current=current=:{localLists}} //Append the initial tasks to the list # iworld = foldl append {iworld & current = {current & localLists = 'Data.Map'.put taskId [] localLists}} initTasks //Evaluate the parallel = eval event repOpts (TCParallel taskId mtn ts) iworld where append iworld t = snd (addTaskToList taskId t Nothing iworld) //Evaluate the task list eval event repOpts (TCParallel taskId mtn ts) iworld=:{current={taskTime}} //Evaluate all parallel tasks in the list = case evalParTasks taskId event repOpts conts iworld of (Left (e,str),iworld) = (ExceptionResult e str,iworld) (Right results,iworld=:{current=current=:{localLists}}) # entries = [(e,r) \\ e <- (fromMaybe [] ('Data.Map'.get taskId localLists)) & (_,r) <- results] # actions = contActions taskId (Value (map fst results) False) conts //Filter out removed entries and destroy their state # (removed,entries) = splitWith (\({TaskListEntry|removed},_) -> removed) entries = case foldl destroyParTask (Nothing,iworld) (map fst removed) of (Just (ExceptionResult e str),iworld) = (ExceptionResult e str,iworld) //An exception occurred (Just result,iworld) = (fixOverloading result initTasks (exception "Destroy failed in parallel"),iworld) (Nothing,iworld=:{current=current=:{localLists}}) //Destruction is ok, build parallel result # rep = parallelRep desc taskId repOpts entries actions # 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] # involvedUsers = foldr (\(e,_) i -> involvedUsers e ++ i) [] entries # ts = case event of (FocusEvent _ focusId) = if (focusId == taskId) taskTime ts _ = ts = (ValueResult (Value values stable) {TaskInfo|lastEvent=ts,involvedUsers=involvedUsers,refreshSensitive=refreshSensitive} (finalizeRep repOpts rep) (TCParallel taskId mtn ts),{iworld & current = {current & localLists = 'Data.Map'.put taskId (map fst entries) localLists}}) //Cleanup eval event repOpts (TCDestroy (TCParallel taskId _ ts)) iworld=:{current={localLists}} # entries = fromMaybe [] ('Data.Map'.get taskId localLists) = case foldl destroyParTask (Nothing,iworld) entries of (Nothing,iworld=:{current=current=:{localLists}}) //All destroyed = (DestroyedResult,{iworld & current = {current & localLists = 'Data.Map'.del taskId localLists}}) (Just (ExceptionResult e str),iworld=:{current=current=:{localLists}}) //An exception occurred = (ExceptionResult e str,{iworld & current = {current & localLists = 'Data.Map'.del taskId localLists}}) (Just result,iworld) = (fixOverloading result initTasks (exception "Destroy failed in step"),iworld) //Fallback eval _ _ _ iworld = (exception "Corrupt task state in parallel", iworld) evalParTasks :: !TaskId !Event !TaskRepOpts [TaskCont [(!TaskTime,!TaskValue a)] (!ParallelTaskType,!ParallelTask a)] !*IWorld -> (!Either (!Dynamic,!String) [((!TaskTime,!TaskValue a), Maybe TaskRep)],!*IWorld) | iTask a evalParTasks taskId event repOpts conts iworld=:{current={localLists,eventRoute}} = evalFrom 0 [] (fromMaybe [] ('Data.Map'.get taskId localLists)) ('Data.Map'.get taskId eventRoute) (matchAction taskId event) repOpts iworld where evalFrom n acc list mbEventIndex mbAction repOpts iworld = case foldl (evalParTask taskId event mbEventIndex repOpts conts) (Right acc,iworld) [(i,e) \\ e <- drop n list & i <- [n..]] of (Left (e,str), iworld) = (Left (e,str), iworld) (Right acc,iworld=:{current={localLists}}) # nlist = fromMaybe [] ('Data.Map'.get taskId localLists) # lenlist = length list //Check if extra branches were added -> evaluate these as well | length nlist > lenlist = evalFrom lenlist acc nlist Nothing mbAction repOpts iworld //Check if for matching continations -> add them and continue evaluation = case searchContValue (Value (map fst acc) False) mbAction conts of Nothing = (Right acc,iworld) //Done Just (_,extension,_) //TODO: Add multiple matches at once, not just one? # (_,iworld) = addTaskToList taskId extension Nothing iworld = evalFrom lenlist acc nlist Nothing Nothing repOpts iworld evalParTask :: !TaskId !Event !(Maybe Int) !TaskRepOpts [TaskCont [(!TaskTime,!TaskValue a)] (!ParallelTaskType,!ParallelTask a)] !(!Either (!Dynamic,!String) [((!TaskTime,!TaskValue a),Maybe TaskRep)],!*IWorld) !(!Int,!TaskListEntry) -> (!Either (!Dynamic,!String) [((!TaskTime,!TaskValue a), Maybe TaskRep)],!*IWorld) | iTask a //Evaluate embedded tasks evalParTask taskId event mbEventIndex repOpts conts (Right acc,iworld=:{current={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 fmap unwrapTask ('Data.Map'.get entryId localTasks) of Just (Task _ evala) # (result,iworld) = evala event {TaskRepOpts|useLayout=Nothing,modLayout=Nothing,noUI=repOpts.noUI} tree iworld = case result of ExceptionResult e str //Check if we have an exception handler the continuations = case searchContException e str conts of Nothing = (Left (e,str),iworld) //No handler, unfortunately Just (_,handler=:(_,parTask),_) //Replace tasklist entry and try again # (entry,iworld) = addTaskToList taskId handler (Just index) iworld = evalParTask taskId event mbEventIndex repOpts conts (Right acc,iworld) (index,entry) ValueResult val info rep tree # (entry,iworld) = updateListEntryEmbeddedResult taskId entryId result iworld = (Right (acc++[((info.TaskInfo.lastEvent,val),Just rep)]),iworld) _ = (Right acc,iworld) | otherwise # (entry,iworld) = updateListEntryEmbeddedResult taskId entryId (ValueResult jsonval info rep tree) iworld = (Right (acc++[((info.TaskInfo.lastEvent,fromJSONTaskValue jsonval),Just rep)]),iworld) //Copy the last stored result of detached tasks evalParTask taskId=:(TaskId curInstanceNo _) event mbEventIndex noUI conts (Right acc,iworld) (index,{TaskListEntry|entryId,state=DetachedState instanceNo _ _,removed=False}) # (mbMeta,iworld) = readRegister curInstanceNo (setParam instanceNo taskInstanceMeta) iworld # (mbValue,iworld) = readRegister curInstanceNo (taskInstanceValue instanceNo) iworld = case (mbMeta,mbValue) of (Ok meta,Ok value=:(TIValue jsonval)) # (entry,iworld) = updateListEntryDetachedResult taskId entryId value meta.TIMeta.progress meta.TIMeta.attributes iworld = (Right (acc++[((entry.TaskListEntry.lastEvent,fromJSONTaskValue jsonval),Nothing)]),iworld) //TODO deal with detached exception case (we now possibly have an exception handler) _ = (Right 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 mbEventIndex noUI conts (result,iworld) (index,entry) = (result,iworld) fromJSONTaskValue NoValue = NoValue fromJSONTaskValue (Value j s) = maybe NoValue (\v -> Value v s) (fromJSON j) destroyParTask :: (!Maybe (TaskResult a),!*IWorld) !TaskListEntry -> (!Maybe (TaskResult a),!*IWorld) | iTask a //Destroy embedded tasks destroyParTask (_,iworld=:{current={localTasks}}) {TaskListEntry|entryId,state=EmbeddedState,lastEval=ValueResult _ _ _ tree} = case 'Data.Map'.get entryId localTasks of Just (Task _ evala :: Task a^) # (result,iworld=:{current=current=:{localTasks}}) = evala (RefreshEvent Nothing) {TaskRepOpts|useLayout=Nothing,modLayout=Nothing,noUI=True} (TCDestroy tree) iworld # iworld = {iworld & current = {current & localTasks = 'Data.Map'.del entryId localTasks}} = 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|lastEval=ValueResult val _ _ _,lastEvent} = (lastEvent,deserialize val) where deserialize (Value json stable) = case fromJSON json of Nothing = NoValue Just a = Value a stable deserialize NoValue = NoValue toValueAndTime {TaskListEntry|lastEvent} = (lastEvent,NoValue) parallelRep :: !d !TaskId !TaskRepOpts ![(!TaskListEntry,!Maybe TaskRep)] [UIAction] -> TaskRep | descr d parallelRep desc taskId repOpts entries actions # layout = repLayoutRules 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,lastEval=ValueResult val _ _ _,createdAt,lastEvent,removed=False},Just (TaskRep def _)) <- entries | not (isStable val)] = TaskRep (layout.LayoutRules.accuParallel (toPrompt desc) parts actions) [] isStable (Value _ stable) = stable isStable _ = False refreshSensitive {TaskListEntry|lastEval=ValueResult _ {TaskInfo|refreshSensitive} _ _} = refreshSensitive refreshSensitive _ = True involvedUsers {TaskListEntry|lastEval=ValueResult _ {TaskInfo|involvedUsers} _ _} = involvedUsers involvedUsers _ = [] //Helper function to help type inferencing a little fixOverloading :: (TaskResult a) [(!ParallelTaskType,!ParallelTask a)] !b -> b fixOverloading _ _ x = x //SHARED HELPER FUNCTIONS addTaskToList :: !TaskId !(!ParallelTaskType,!ParallelTask a) !(Maybe Int) !*IWorld -> (!TaskListEntry,!*IWorld) | iTask a addTaskToList taskId (parType,parTask) mbPos iworld=:{current={taskTime,user,attachmentChain},clocks={localDate,localTime}} # (list,iworld) = loadTaskList taskId iworld # progress = {value=None, issuedAt=DateTime localDate localTime,issuedBy=user,involvedUsers=[],firstEvent=Nothing,latestEvent=Nothing} # (taskIda,name,state,iworld) = case parType of Embedded # (taskIda,iworld=:{current=current=:{localTasks}}) = getNextTaskId iworld # task = parTask (parListShare taskId taskIda) = (taskIda, Nothing, EmbeddedState, {iworld & current = {current & localTasks = 'Data.Map'.put taskIda (dynamic task :: Task a^) localTasks}}) NamedEmbedded name # (taskIda,iworld=:{current=current=:{localTasks}}) = getNextTaskId iworld # task = parTask (parListShare taskId taskIda) = (taskIda, Just name, EmbeddedState, {iworld & current = {current & localTasks = 'Data.Map'.put taskIda (dynamic task :: Task a^) localTasks}}) Detached management evalDirect # (instanceNo,iworld) = newInstanceNo iworld # task = parTask (parListShare taskId (TaskId instanceNo 0)) # (taskIda,iworld) = createDetachedTaskInstance task (Just instanceNo) Nothing management user taskId (if evalDirect (Just attachmentChain) Nothing) iworld = (taskIda,Nothing,DetachedState instanceNo progress management, iworld) NamedDetached name management evalDirect # (instanceNo,iworld) = newInstanceNo iworld # task = parTask (parListShare taskId (TaskId instanceNo 0)) # (taskIda,iworld) = createDetachedTaskInstance task (Just instanceNo) (Just name) management user taskId (if evalDirect (Just attachmentChain) Nothing) iworld = (taskIda,Just name,DetachedState instanceNo progress management, iworld) # lastEval = ValueResult NoValue {TaskInfo|lastEvent=taskTime,involvedUsers=[],refreshSensitive=True} NoRep (TCInit taskIda Nothing taskTime) // TODO TCInit taskIda Nothing -> Nothing here? Or should we parameterize this function with a ModuleTaskName? # entry = {entryId = taskIda, name = name, state = state, lastEval = lastEval, uiAttributes = 'Data.Map'.newMap, createdAt = taskTime, lastEvent = taskTime, removed = False} # list = maybe (list++[entry]) (\pos -> updateAt pos entry list) mbPos # iworld = storeTaskList taskId list iworld = (entry, 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 & lastEval= wrap result, uiAttributes = newAttr result, lastEvent = maxTime lastEvent result}) iworld where wrap (ValueResult val info=:{TaskInfo|refreshSensitive=True} _ tree) //When we know for certain that we'll recompute the task on the next event, = ValueResult (fmap toJSON val) info NoRep tree //don't bother storing the task representation 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 _ = 'Data.Map'.newMap maxTime cur (ValueResult _ {TaskInfo|lastEvent} _ _) = max cur lastEvent maxTime cur _ = cur updateListEntryDetachedResult :: !TaskId !TaskId TIValue !ProgressMeta !TaskAttributes !*IWorld -> (!TaskListEntry,!*IWorld) updateListEntryDetachedResult listId entryId lastValue progress attributes iworld = updateListEntry listId entryId update iworld where update e=:{TaskListEntry|state=DetachedState no _ _} # lastEval = case lastValue of TIValue val = ValueResult val info NoRep TCNop TIException e str = ExceptionResult e str = {TaskListEntry| e & state = DetachedState no progress attributes, lastEval = lastEval} update e = e info = {refreshSensitive=True,involvedUsers=[],lastEvent=0} //FIXME probably a bad idea to construct this nonsense info that may or may not be used markListEntryRemoved :: !TaskId !TaskId !*IWorld -> *IWorld markListEntryRemoved listId entryId iworld = snd (updateListEntry listId entryId (\e -> {TaskListEntry|e & removed = True}) iworld) updateListEntry :: !TaskId !TaskId !(TaskListEntry -> TaskListEntry) !*IWorld -> (!TaskListEntry,!*IWorld) updateListEntry listId entryId f iworld # (list,iworld) = loadTaskList listId iworld # list = [if (e.TaskListEntry.entryId == entryId) (f e) e \\ e <- list] //TODO: MERGE AND OPTIZE WITH ITEM SEARCH # [item:_] = [e \\ e <- list | (e.TaskListEntry.entryId == entryId)] # iworld = storeTaskList listId list iworld = (item,iworld) loadTaskList :: !TaskId !*IWorld -> (![TaskListEntry],!*IWorld) loadTaskList taskId=:(TaskId instanceNo taskNo) iworld=:{current={taskInstance,localLists}} | instanceNo == taskInstance = (fromMaybe [] ('Data.Map'.get taskId localLists),iworld) | otherwise = case read (taskInstanceReduct instanceNo) iworld of (Ok {TIReduct|lists},iworld) = (fromMaybe [] ('Data.Map'.get taskId lists),iworld) (_,iworld) = ([],iworld) storeTaskList :: !TaskId ![TaskListEntry] !*IWorld -> *IWorld storeTaskList taskId=:(TaskId instanceNo taskNo) list iworld=:{current=current=:{taskInstance,localLists}} | instanceNo == taskInstance = {iworld & current = {current & localLists = 'Data.Map'.put taskId list localLists}} | otherwise = case read (taskInstanceReduct instanceNo) iworld of (Ok reduct=:{TIReduct|lists},iworld) # (_,iworld) = write {TIReduct|reduct & lists = 'Data.Map'.put taskId list lists} (taskInstanceReduct instanceNo) iworld = iworld (_,iworld) = iworld readListId :: (SharedTaskList a) *IWorld -> (MaybeErrorString (TaskListId a),*IWorld) | iTask a readListId slist iworld = case read slist iworld of (Ok l,iworld) = (Ok l.TaskList.listId, iworld) (Error e, iworld) = (Error e, iworld) //Derived shares taskListState :: !(SharedTaskList a) -> ReadOnlyShared [TaskValue a] taskListState tasklist = mapRead (\{TaskList|items} -> [value \\ {TaskListItem|value} <- items]) (toReadOnly tasklist) taskListMeta :: !(SharedTaskList a) -> ReadWriteShared [TaskListItem a] [(TaskId,TaskAttributes)] taskListMeta tasklist = mapRead (\{TaskList|items} -> items) tasklist taskListSelfId :: !(SharedTaskList a) -> ReadOnlyShared TaskId taskListSelfId tasklist = mapRead (\{TaskList|selfId} -> selfId) (toReadOnly tasklist) taskListSelfManagement :: !(SharedTaskList a) -> Shared TaskAttributes taskListSelfManagement tasklist = mapReadWriteError (toPrj,fromPrj) tasklist where toPrj {TaskList|selfId,items} = case [m \\ m=:{TaskListItem|taskId} <- items | taskId == selfId] of [] = trace_n (length items) (Error "Task id not found in self management share") [{TaskListItem|attributes}:_] = Ok attributes fromPrj attributes {TaskList|selfId} = Ok (Just [(selfId,attributes)]) appendTask :: !ParallelTaskType !(ParallelTask a) !(SharedTaskList a) -> Task TaskId | iTask a appendTask parType parTask slist = mkInstantTask eval where eval taskId iworld=:{current={taskTime}} = case readListId slist iworld of (Ok listId,iworld) # (taskIda,iworld) = append listId parType parTask iworld = (Ok taskIda, iworld) (Error e,iworld) = (Error (dynamic e,e), iworld) append :: !(TaskListId a) !ParallelTaskType !(ParallelTask a) !*IWorld -> (!TaskId,!*IWorld) | iTask a append TopLevelTaskList parType parTask iworld=:{current={user,attachmentChain}} # (name,meta,evalDirect) = case parType of (Embedded) = (Nothing,defaultValue,False) (NamedEmbedded name) = (Just name,defaultValue,False) (Detached meta evalDirect) = (Nothing,meta,evalDirect) (NamedDetached name meta evalDirect) = (Just name,meta,evalDirect) # task = parTask topListShare = createDetachedTaskInstance task Nothing name meta user (TaskId 0 0) (if evalDirect (Just attachmentChain) Nothing) iworld append (ParallelTaskList parId) parType parTask iworld # ({TaskListEntry|entryId},iworld) = addTaskToList parId (parType,parTask) Nothing iworld = (entryId,iworld) /** * Removes (and stops) a task from a task list */ removeTask :: !TaskId !(SharedTaskList a) -> Task Void | iTask a removeTask entryId slist = mkInstantTask eval where eval taskId iworld = case readListId slist iworld of (Ok listId,iworld) # iworld = remove listId entryId iworld = (Ok Void, iworld) (Error e,iworld) = (Error (dynamic e,e), iworld) remove :: !(TaskListId a) !TaskId !*IWorld -> *IWorld remove TopLevelTaskList (TaskId instanceNo 0) iworld = deleteInstance instanceNo iworld remove (ParallelTaskList parId) entryId iworld = markListEntryRemoved parId entryId iworld remove _ _ iworld = iworld workOn :: !TaskId -> Task WorkOnStatus workOn (TaskId instanceNo taskNo) = Task (mkTaskIdent "workOn") eval where eval event repOpts (TCInit taskId mtn ts) iworld=:{current={attachmentChain,user}} # (meta,iworld) = read (setParam instanceNo taskInstanceMeta) iworld = case meta of Ok meta //Just steal the instance, TODO, make stealing optional # (_,iworld) = write {TIMeta|meta & instanceType=AttachedInstance [taskId:attachmentChain] user} (setParam instanceNo taskInstanceMeta) iworld # iworld = queueUrgentRefresh [instanceNo] iworld = eval event repOpts (TCBasic taskId mtn ts JSONNull False) iworld Error e = (ExceptionResult (dynamic e) e,iworld) eval event repOpts tree=:(TCBasic taskId _ ts _ _) iworld=:{current={taskInstance,user}} //Load instance # layout = repLayoutRules repOpts # (meta,iworld) = readRegister taskInstance (setParam instanceNo taskInstanceMeta) iworld = case meta of (Ok meta=:{TIMeta|progress,instanceType=AttachedInstance _ worker,instanceKey}) | progress.ProgressMeta.value === Exception = (ValueResult (Value WOExcepted True) {TaskInfo|lastEvent=ts,involvedUsers=[],refreshSensitive=False} (finalizeRep repOpts NoRep) tree, iworld) | progress.ProgressMeta.value === Stable = (ValueResult (Value WOFinished True) {TaskInfo|lastEvent=ts,involvedUsers=[],refreshSensitive=False} (finalizeRep repOpts NoRep) tree, iworld) | worker == user # rep = finalizeRep repOpts (TaskRep (layout.LayoutRules.accuWorkOn (embedTaskDef instanceNo instanceKey) meta) []) = (ValueResult (Value WOActive False) {TaskInfo|lastEvent=ts,involvedUsers=[],refreshSensitive=True} rep tree, iworld) | otherwise # rep = finalizeRep repOpts (TaskRep (layout.LayoutRules.accuWorkOn (inUseDef worker) meta) []) = (ValueResult (Value (WOInUse worker) False) {TaskInfo|lastEvent=ts,involvedUsers=[],refreshSensitive=False} rep tree, iworld) _ = (ValueResult (Value WODeleted True) {TaskInfo|lastEvent=ts,involvedUsers=[],refreshSensitive=False} (finalizeRep repOpts NoRep) tree, iworld) eval event repOpts (TCDestroy (TCBasic taskId _ _ _ _)) iworld /* # (meta,iworld) = read fullInstanceMeta iworld //FIXME: Figure out how to get the right share notifications for the released instances = case meta of Ok instances # (_,iworld) = write (map (release taskId) instances) fullInstanceMeta iworld = (DestroyedResult,iworld) _ = (DestroyedResult,iworld) */ = (DestroyedResult,iworld) release taskId meta=:{TIMeta|instanceType=AttachedInstance attachment worker} | isMember taskId attachment = {TIMeta|meta & instanceType = DetachedInstance} = meta release taskId meta = meta embedTaskDef instanceNo instanceKey = {UIDef|content=UIControlStack {UIControlStack|attributes='Data.Map'.newMap,controls=[(UIEmbedding embedSize {UIEmbeddingOpts|instanceNo=instanceNo,instanceKey=instanceKey},'Data.Map'.newMap)],size=embedSize},windows=[]} embedSize = {UISizeOpts|defaultSizeOpts & width= Just FlexSize, height=Just FlexSize} inUseDef worker = {UIDef|content=UIControlStack {UIControlStack|attributes='Data.Map'.newMap,controls=[(stringDisplay (toString worker +++ " is working on this task"),'Data.Map'.newMap)],size=defaultSizeOpts},windows=[]} /* * 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 asUser (Task tid eval) = Task tid eval` where eval` event repOpts state iworld=:{current=current=:{user}} # (result,iworld=:{current}) = eval event repOpts state {iworld & current = {current & user = asUser}} = (addInvolvedUser asUser result,{iworld & current = {current & user = user}}) addInvolvedUser asUser (ValueResult val info=:{TaskInfo|involvedUsers} rep tree) = ValueResult val {TaskInfo|info & involvedUsers= [asUser:involvedUsers]} rep tree addInvolvedUser user res = res withShared :: !b !((Shared b) -> Task a) -> Task a | iTask a & iTask b withShared initial stask = Task (mkTaskIdent "withShared") eval where eval event repOpts (TCInit taskId mtn ts) iworld # (taskIda,iworld=:{current=current=:{localShares}}) = getNextTaskId iworld # localShares = 'Data.Map'.put taskId (toJSON initial) localShares = eval event repOpts (TCShared taskId mtn ts (TCInit taskIda mtn ts)) {iworld & current = {current & localShares = localShares}} eval event repOpts (TCShared taskId mtn ts treea) iworld=:{current={taskTime}} # ts = case event of (FocusEvent _ focusId) = if (focusId == taskId) taskTime ts _ = ts # (Task _ evala) = stask (localShare taskId) # (resa,iworld) = evala event repOpts treea iworld = case resa of ValueResult NoValue info rep ntreea # info = {TaskInfo|info & lastEvent = max ts info.TaskInfo.lastEvent} = (ValueResult NoValue info rep (TCShared taskId mtn info.TaskInfo.lastEvent ntreea),iworld) ValueResult (Value stable val) info rep ntreea # info = {TaskInfo|info & lastEvent = max ts info.TaskInfo.lastEvent} = (ValueResult (Value stable val) info rep (TCShared taskId mtn info.TaskInfo.lastEvent ntreea),iworld) ExceptionResult e str = (ExceptionResult e str,iworld) eval event repOpts (TCDestroy (TCShared taskId _ ts treea)) iworld //First destroy inner task, then remove shared state # (Task _ evala) = stask (localShare taskId) # (resa,iworld=:{current=current=:{localShares}}) = evala event repOpts (TCDestroy treea) iworld = (resa,{iworld & current = {current & localShares = 'Data.Map'.del taskId localShares}}) eval _ _ _ iworld = (exception "Corrupt task state in withShared", iworld) import StdDebug exposeShared :: !(ReadWriteShared r w) !(String (ReadWriteShared r w) -> Task a) -> Task a | iTask a & iTask r & iTask w exposeShared shared stask = Task (mkTaskIdent "exposeShared") eval where eval event repOpts (TCInit taskId mtn ts) iworld=:{exposedShares} # (url, iworld) = newURL iworld // Trick to make it work until John fixes the compiler # exposedShares = 'Data.Map'.put url (dynamic shared :: RWShared Void r^ w^, toJSONShared shared) exposedShares # (taskIda,iworld) = trace_n ("SDS is exposed as "+++url) (getNextTaskId iworld) = eval event repOpts (TCExposedShared taskId mtn ts url (TCInit taskIda mtn ts)) {iworld & exposedShares = exposedShares} eval event repOpts (TCExposedShared taskId mtn ts url treea) iworld=:{current={taskTime}} # ts = case event of (FocusEvent _ focusId) = if (focusId == taskId) taskTime ts _ = ts # (Task _ evala) = stask url (exposedShare url) # (resa,iworld) = evala event repOpts treea iworld = case resa of ValueResult value info rep ntreea # info = {TaskInfo|info & lastEvent = max ts info.TaskInfo.lastEvent} = (ValueResult value info rep (TCExposedShared taskId mtn info.TaskInfo.lastEvent url ntreea),iworld) ExceptionResult e str = (ExceptionResult e str,iworld) eval event repOpts (TCDestroy (TCExposedShared taskId _ ts url treea)) iworld //First destroy inner task, then remove shared state # (Task _ evala) = stask url (exposedShare url) # (resa,iworld) = evala event repOpts (TCDestroy treea) iworld = (resa,{iworld & exposedShares = 'Data.Map'.del url iworld.exposedShares}) eval _ _ _ iworld = (exception "Corrupt task state in exposeShared", iworld) /* * Tuning of tasks */ class tune b :: !b !(Task a) -> Task a class tunev b a | iTask a :: !(b a) !(Task a) -> Task a instance tune SetLayout where tune (SetLayout layout) (Task tid eval) = Task tid eval` where eval` event repOpts=:{useLayout=Nothing,modLayout} state iworld = eval event {TaskRepOpts|repOpts & useLayout = Just ((fromMaybe id modLayout) layout), modLayout = Nothing} state iworld eval` event repOpts=:{useLayout=Just _,modLayout} state iworld = eval event {TaskRepOpts|repOpts & useLayout = Just layout, modLayout = Nothing} state iworld instance tune AfterLayout where tune (AfterLayout f) (Task tid eval) = Task tid eval` where eval` event repOpts state iworld = case eval event repOpts state iworld of (ValueResult value info rep tree,iworld) = (ValueResult value info (updRep rep) tree, iworld) (res,iworld) = (res,iworld) updRep NoRep = TaskRep (f {UIDef|content=UIAttributeSet 'Data.Map'.newMap,windows=[]}) [] updRep (TaskRep def parts) = TaskRep (f def) parts instance tune ModifyLayout where tune (ModifyLayout f) (Task tid eval) = Task tid eval` where eval` event repOpts=:{modLayout=Nothing} state iworld = eval event {TaskRepOpts|repOpts & modLayout = Just f} state iworld eval` event repOpts=:{modLayout=Just g} state iworld = eval event {TaskRepOpts|repOpts & modLayout = Just (g o f)} state iworld instance tunev SetValueAttribute a where tunev (SetValueAttribute attr f) (Task tid eval) = Task tid eval` where eval` event repOpts state iworld = case (eval event repOpts state iworld) of (ValueResult value=:(Value v _) info rep tree,iworld) = (ValueResult value info (updRep v rep) tree, iworld) (res,iworld) = (res,iworld) updRep v NoRep = TaskRep ({UIDef|content=UIAttributeSet ('Data.Map'.put attr (f v) 'Data.Map'.newMap),windows=[]}) [] updRep v (TaskRep def parts) = TaskRep (uiDefSetAttribute attr (f v) def) parts instance tune LazyRefresh where tune _ (Task tid eval) = Task tid 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) instance tune ModuleTaskName where tune mtn=:(ModuleTaskName mn tn) (Task _ eval) = Task (Just mtn) eval` where eval` event repOpts state iworld = eval event repOpts (annotTaskTree state) iworld justMtn = Just mtn annotTaskTree (TCInit tid _ ttime) = TCInit tid justMtn ttime annotTaskTree (TCBasic tid _ ttime json1 b) = TCBasic tid justMtn ttime json1 b annotTaskTree (TCInteract tid _ ttime json1 json2 json3 imask) = TCInteract tid justMtn ttime json1 json2 json3 imask annotTaskTree (TCInteractLocal tid _ ttime json1 json2 imask) = TCInteractLocal tid justMtn ttime json1 json2 imask annotTaskTree (TCInteractViewOnly tid _ ttime json1 json2 imask) = TCInteractViewOnly tid justMtn ttime json1 json2 imask annotTaskTree (TCInteractLocalViewOnly tid _ ttime json1 imask) = TCInteractLocalViewOnly tid justMtn ttime json1 imask annotTaskTree (TCInteract1 tid _ ttime json1 imask) = TCInteract1 tid justMtn ttime json1 imask annotTaskTree (TCInteract2 tid _ ttime json1 json2 imask) = TCInteract2 tid justMtn ttime json1 json2 imask annotTaskTree (TCProject tid _ json1 ttree) = TCProject tid justMtn json1 (annotTaskTree ttree) annotTaskTree (TCStep tid _ ttime (Left tt)) = TCStep tid justMtn ttime (Left (annotTaskTree tt)) annotTaskTree (TCStep tid _ ttime (Right (x, y, tt))) = TCStep tid justMtn ttime (Right (x, y, annotTaskTree tt)) annotTaskTree (TCParallel tid _ ttime) = TCParallel tid justMtn ttime annotTaskTree (TCShared tid _ ttime ttree) = TCShared tid justMtn ttime (annotTaskTree ttree) annotTaskTree (TCExposedShared tid _ ttime str ttree) = TCExposedShared tid justMtn ttime str (annotTaskTree ttree) annotTaskTree (TCStable tid _ ttime djson) = TCStable tid justMtn ttime djson annotTaskTree x = x