Commit 7ec5249f authored by Bas Lijnse's avatar Bas Lijnse

Removed attributes from task evaluation info record

parent 9b0c9029
......@@ -66,7 +66,7 @@ where
:[t \\ StartupTask t <- toStartable startable]]
startTask t = {StartupTask|attributes=defaultValue,task=TaskWrapper t}
systemTask t = {StartupTask|t&attributes='DM'.put "system" "yes" t.StartupTask.attributes}
systemTask t = {StartupTask|t&attributes='DM'.put "system" (JSONBool True) t.StartupTask.attributes}
initSymbolsShare False _ iworld = (Ok (), iworld)
initSymbolsShare True appName iworld = case storeSymbols (IF_WINDOWS (appName +++ ".exe") appName) iworld of
......
......@@ -58,11 +58,11 @@ where
mkRow {TaskInstance|instanceNo,attributes,listId} =
{WorklistRow
|taskNr = Just (toString instanceNo)
,title = fmap toString ('DM'.get "title" attributes)
,priority = fmap toString ('DM'.get "priority" attributes)
,title = fmap (\(JSONString x) -> x) ('DM'.get "title" attributes)
,priority = fmap (\(JSONInt x) -> toString x) ('DM'.get "priority" attributes)
,createdBy = fmap toString ('DM'.get "createdBy" attributes)
,date = fmap toString ('DM'.get "createdAt" attributes)
,deadline = fmap toString ('DM'.get "completeBefore" attributes)
,date = fmap toString ('DM'.get "createdAt" attributes)
,deadline = fmap toString ('DM'.get "completeBefore" attributes)
,createdFor = fmap toString ('DM'.get "createdFor" attributes)
,parentTask = if (listId == TaskId 0 0) Nothing (Just (toString listId))
}
......@@ -270,17 +270,17 @@ startWorkflow :: !(SharedTaskList ()) !Workflow -> Task Workflow
startWorkflow list wf
= get currentUser -&&- get currentDateTime
>>= \(user,now) ->
appendTopLevelTask ('DM'.fromList [ ("title", workflowTitle wf)
, ("catalogId", wf.Workflow.path)
, ("createdBy", toString (toUserConstraint user))
, ("createdAt", toString now)
, ("createdFor", toString (toUserConstraint user))
, ("priority", toString 5):userAttr user]) False (unwrapWorkflowTask wf.Workflow.task)
appendTopLevelTask ('DM'.fromList [ ("title", toJSON (workflowTitle wf))
, ("catalogId", toJSON wf.Workflow.path)
, ("createdBy", toJSON (toUserConstraint user))
, ("createdAt", toJSON now)
, ("createdFor", toJSON (toUserConstraint user))
, ("priority", toJSON 5):userAttr user]) False (unwrapWorkflowTask wf.Workflow.task)
>>= \procId ->
openTask list procId
@ const wf
where
userAttr (AuthenticatedUser uid _ _) = [("user", uid)]
userAttr (AuthenticatedUser uid _ _) = [("user", JSONString uid)]
userAttr _ = []
unwrapWorkflowTask (WorkflowTask t) = t @! ()
......@@ -322,7 +322,7 @@ where
= get ((sdsFocus taskId (taskListEntryMeta topLevelTasks)) |*| workflows)
@ \(taskListEntry,catalog) -> maybe Nothing (lookup catalog) ('DM'.get "catalogId" taskListEntry.TaskListItem.attributes)
where
lookup [wf=:{Workflow|path}:wfs] cid = if (path == cid) (Just wf) (lookup wfs cid)
lookup [wf=:{Workflow|path}:wfs] (JSONString cid) = if (path == cid) (Just wf) (lookup wfs (JSONString cid))
lookup [] _ = Nothing
appendOnce :: TaskId (Task a) (SharedTaskList a) -> Task () | iTask a
......@@ -335,7 +335,7 @@ where
name = toString identity
checkItems name [] = False
checkItems name [{TaskListItem|attributes}:is]
| maybe False ((==) name) ('DM'.get "name" attributes) = True //Item with name exists!
| maybe False ((==) (JSONString name)) ('DM'.get "name" attributes) = True //Item with name exists!
= checkItems name is
removeWhenStable :: (Task a) (SharedTaskList a) -> Task a | iTask a
......
......@@ -117,7 +117,7 @@ assign :: !TaskAttributes !(Task a) -> Task a | iTask a
*/
(@:) infix 3 :: !worker !(Task a) -> Task a | iTask a & toUserConstraint worker
workerAttributes :: worker [(String, String)] -> TaskAttributes | toUserConstraint worker
workerAttributes :: worker [(String, JSONNode)] -> TaskAttributes | toUserConstraint worker
appendTopLevelTaskFor :: !worker !Bool !(Task a) -> Task TaskId | iTask a & toUserConstraint worker
appendTopLevelTaskPrioFor :: !worker !String !String !Bool !(Task a) -> Task TaskId | iTask a & toUserConstraint worker
......
......@@ -136,17 +136,18 @@ where
userFromAttr :: a TaskAttributes -> MaybeError TaskException User
userFromAttr _ attr = case 'DM'.get "auth-user" attr of
Just userId = Ok (AuthenticatedUser userId (maybe [] (split ",") ('DM'.get "auth-roles" attr)) ('DM'.get "auth-title" attr))
Just (JSONString userId)
= Ok (AuthenticatedUser userId (maybe [] (\(JSONString s) -> split "," s) ('DM'.get "auth-roles" attr)) (fmap toString ('DM'.get "auth-title" attr)))
_ = case 'DM'.get "session" attr of
Just session = Ok (AnonymousUser session)
_ = Ok SystemUser
Just (JSONString session) = Ok (AnonymousUser session)
_ = Ok SystemUser
userToAttr :: a TaskAttributes User -> MaybeError TaskException (Maybe TaskAttributes)
userToAttr _ attr (AuthenticatedUser userId userRoles userTitle)
//Update user properties
# attr = 'DM'.put "auth-user" userId attr
# attr = if (isEmpty userRoles) ('DM'.del "auth-roles" attr) ('DM'.put "auth-roles" (join "," userRoles) attr)
# attr = maybe ('DM'.del "auth-title" attr) (\title -> 'DM'.put "auth-title" title attr) userTitle
# attr = 'DM'.put "auth-user" (JSONString userId) attr
# attr = if (isEmpty userRoles) ('DM'.del "auth-roles" attr) ('DM'.put "auth-roles" (JSONString (join "," userRoles)) attr)
# attr = maybe ('DM'.del "auth-title" attr) (\title -> 'DM'.put "auth-title" (JSONString title) attr) userTitle
= Ok (Just attr)
userToAttr _ attr _
//Remove user properties
......@@ -164,11 +165,11 @@ where
readPrj (items,user) = filter (forWorker user) items
forWorker user {TaskListItem|attributes} = case 'DM'.get "user" attributes of
Just uid1 = case user of
Just (JSONString uid1) = case user of
(AuthenticatedUser uid2 _ _) = uid1 == uid2
_ = False
Nothing = case 'DM'.get "role" attributes of
Just role = case user of
Just (JSONString role) = case user of
(AuthenticatedUser _ roles _) = isMember role roles
_ = False
Nothing = True
......@@ -181,12 +182,12 @@ where
notify _ _ _ = const (const False)
forUser user {TaskInstance|attributes} = case 'DM'.get "user" attributes of
Just uid1 = case user of
Just (JSONString uid1) = case user of
(AuthenticatedUser uid2 _ _) = uid1 == uid2
_ = False
Nothing = case 'DM'.get "role" attributes of
Just role = case user of
Just (JSONString role) = case user of
(AuthenticatedUser _ roles _) = isMember role roles
_ = False
Nothing = True
......@@ -208,7 +209,7 @@ workOn t
= get currentUser -&&- get (sdsFocus no taskInstanceAttributesByNo)
>>- \(user,attr) -> set user (sdsFocus no taskInstanceUser)
//Attach the instance
>>| attach no True <<@ Title (fromMaybe "Untitled" ('DM'.get "title" attr))
>>| attach no True <<@ Title (maybe "Untitled" (\(JSONString t) -> t) ('DM'.get "title" attr))
where
no = toInstanceNo t
/*
......@@ -271,33 +272,32 @@ where
}
derive class iTask ProcessControlView
workerAttributes :: worker [(String, String)] -> TaskAttributes | toUserConstraint worker
workerAttributes :: worker [(String, JSONNode)] -> TaskAttributes | toUserConstraint worker
workerAttributes worker attr = case toUserConstraint worker of
AnyUser = 'DM'.newMap
UserWithId uid = 'DM'.fromList [("user", uid):attr]
UserWithRole role = 'DM'.fromList [("role", role):attr]
UserWithId uid = 'DM'.fromList [("user", JSONString uid):attr]
UserWithRole role = 'DM'.fromList [("role", JSONString role):attr]
(@:) infix 3 :: !worker !(Task a) -> Task a | iTask a & toUserConstraint worker
(@:) worker task
= get currentUser -&&- get currentDateTime
>>- \(me,now) -> assign (workerAttributes worker
[ ("title", toTitle worker)
, ("createdBy", toString (toUserConstraint me))
, ("createdAt", toString now)
, ("priority", toString 5)
, ("createdFor", toString (toUserConstraint worker))
[ ("title", toJSON (toTitle worker))
, ("createdBy", toJSON (toUserConstraint me))
, ("createdAt", toJSON now)
, ("priority", toJSON 5)
, ("createdFor", toJSON (toUserConstraint worker))
])
task
appendTopLevelTaskPrioFor :: !worker !String !String !Bool !(Task a) -> Task TaskId | iTask a & toUserConstraint worker
appendTopLevelTaskPrioFor worker title priority evalDirect task
= get currentUser -&&- get currentDateTime
>>- \(me,now) -> appendTopLevelTask (workerAttributes worker
[ ("title", title)
, ("createdBy", toString (toUserConstraint me))
, ("createdAt", toString now)
, ("priority", priority)
, ("createdFor", toString (toUserConstraint worker))
[ ("title", toJSON title)
, ("createdBy", toJSON (toUserConstraint me))
, ("createdAt", toJSON now)
, ("priority", toJSON priority)
, ("createdFor", toJSON (toUserConstraint worker))
]) evalDirect task
appendTopLevelTaskFor :: !worker !Bool !(Task a) -> Task TaskId | iTask a & toUserConstraint worker
......
......@@ -28,7 +28,7 @@ where
| isError merr = (ExceptionResult (fromError merr), iworld)
= (ValueResult
NoValue
{TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes=newMap}
{TaskEvalInfo|lastEvent=ts,removedTasks=[]}
NoChange
(TCInit taskId ts)
, iworld)
......
......@@ -42,10 +42,10 @@ where
# (mbError, iworld) = addListener taskId port True (wrapIWorldConnectionTask (handlers symbols taskId) share) iworld
| mbError=:(Error _) = showException "initialization" (fromError mbError) iworld
# iworld = iShow ["SDS server listening on " +++ toString port] iworld
= (ValueResult (Value () False) {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='Map'.newMap} (ReplaceUI (ui UIEmpty)) (TCBasic taskId ts (DeferredJSONNode JSONNull) False), iworld)
= (ValueResult (Value () False) {TaskEvalInfo|lastEvent=ts,removedTasks=[]} (ReplaceUI (ui UIEmpty)) (TCBasic taskId ts (DeferredJSONNode JSONNull) False), iworld)
eval (RefreshEvent taskIds cause) evalOpts tree=:(TCBasic taskId ts data bla) iworld
| not ('Set'.member taskId taskIds) = (ValueResult (Value () False) {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='Map'.newMap} NoChange (TCBasic taskId ts data bla), iworld)
| not ('Set'.member taskId taskIds) = (ValueResult (Value () False) {TaskEvalInfo|lastEvent=ts,removedTasks=[]} NoChange (TCBasic taskId ts data bla), iworld)
# (symbols, iworld) = case read symbolsShare EmptyContext iworld of
(Ok (ReadingDone symbols), iworld) = (readSymbols symbols, iworld)
# (readResult, iworld) = read share EmptyContext iworld
......@@ -55,7 +55,7 @@ where
| results=:(Error _) = showException "re-evaluating share values" (exception (fromError results)) iworld
# (writeResult, iworld) = write ('Map'.fromList (fromOk results)) share EmptyContext iworld
| writeResult=:(Error _) = showException "writing result share values" (fromError writeResult) iworld
= (ValueResult (Value () False) {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='Map'.newMap} NoChange tree, iworld)
= (ValueResult (Value () False) {TaskEvalInfo|lastEvent=ts,removedTasks=[]} NoChange tree, iworld)
showException base taskException=:(_, str) iworld
# iworld = iShow ["SDSService exception during " +++ base +++ ": " +++ str] iworld
......
......@@ -116,11 +116,11 @@ mkInstantTask iworldfun = Task (evalOnce iworldfun)
where
evalOnce f DestroyEvent _ _ iworld = (DestroyedResult,iworld)
evalOnce f event repOpts (TCInit taskId ts) iworld = case f taskId iworld of
(Ok a,iworld) = (ValueResult (Value a True) {lastEvent=ts,removedTasks=[],attributes='DM'.newMap} (rep event) (TCStable taskId ts (DeferredJSON a)), iworld)
(Ok a,iworld) = (ValueResult (Value a True) {lastEvent=ts,removedTasks=[]} (rep event) (TCStable taskId ts (DeferredJSON a)), iworld)
(Error e, iworld) = (ExceptionResult e, iworld)
evalOnce f event repOpts state=:(TCStable taskId ts enc) iworld = case fromJSONOfDeferredJSON enc of
Just a = (ValueResult (Value a True) {lastEvent=ts,attributes='DM'.newMap,removedTasks=[]} (rep event) state, iworld)
Just a = (ValueResult (Value a True) {lastEvent=ts,removedTasks=[]} (rep event) state, iworld)
Nothing = (ExceptionResult (exception "Corrupt task result"), iworld)
rep ResetEvent = ReplaceUI (ui UIEmpty)
......
......@@ -40,7 +40,6 @@ defaultTonicOpts :: TonicOpts
//Additional information passed up from the tree when evaluating a task
:: TaskEvalInfo =
{ lastEvent :: !TaskTime //When was the last event in this task
, attributes :: !TaskAttributes //Meta-data annotations on the task
, removedTasks :: ![(TaskId,TaskId)] //Which embedded parallel tasks were removed (listId,taskId)
}
......
......@@ -23,7 +23,7 @@ from System.Time import :: Timestamp
, includeSessions :: !Bool
, includeDetached :: !Bool
, includeStartup :: !Bool
, matchAttribute :: !Maybe (!String,!String)
, matchAttribute :: !Maybe (!String,!JSONNode)
//'Horizontal' filters
, includeConstants :: !Bool
, includeProgress :: !Bool
......
......@@ -58,7 +58,7 @@ allTaskInstances :: SDSLens () [TaskInstance] ()
detachedTaskInstances :: SDSLens () [TaskInstance] () //Exclude sessions
taskInstanceByNo :: SDSLens InstanceNo TaskInstance TaskAttributes
taskInstanceAttributesByNo :: SDSLens InstanceNo TaskAttributes TaskAttributes
taskInstancesByAttribute :: SDSLens (!String,!String) [TaskInstance] () //Parameter is (key,value)
taskInstancesByAttribute :: SDSLens (!String,!JSONNode) [TaskInstance] () //Parameter is (key,value)
// Application
applicationName :: SDSSource () String () // Application name
......
......@@ -130,7 +130,7 @@ where
writeItem [(n,c,p,_)] a = Ok (Just [(n,c,p,Just a)])
writeItem _ _ = Error (exception "Task instance not found")
taskInstancesByAttribute :: SDSLens (!String,!String) [TaskInstance] ()
taskInstancesByAttribute :: SDSLens (!String,!JSONNode) [TaskInstance] ()
taskInstancesByAttribute
=
(sdsProject (SDSLensRead readInstances) (SDSBlindWrite \_. Ok Nothing) Nothing
......
......@@ -12,8 +12,6 @@ import qualified Data.Set as DS
import qualified Data.Map as DM
import qualified iTasks.Internal.SDS as SDS
//TODO: Remove attributes from TaskEvalInfo
class tune b f :: !b !(f a) -> f a
class tunev b a f | iTask a :: !(b a) !(f a) -> f a
......
......@@ -21,7 +21,7 @@ from iTasks.Internal.SDS import write, read, readRegister, modify
import iTasks.WF.Tasks.System
import StdList, StdBool, StdTuple, StdString, Data.Maybe, Data.Tuple, StdMisc
from StdFunc import o
from StdFunc import o, const, id, flip
import qualified Data.Map as DM
import qualified Data.Set as DS
import qualified Data.Queue as DQ
......@@ -363,9 +363,9 @@ initParallelTask ::
initParallelTask evalOpts=:{tonicOpts = {callTrace}} listId index parType parTask iworld=:{current={taskTime}}
# (mbTaskStuff,iworld) = case parType of
Embedded = mkEmbedded 'DM'.newMap iworld
NamedEmbedded name = mkEmbedded ('DM'.singleton "name" name) iworld
NamedEmbedded name = mkEmbedded ('DM'.singleton "name" (JSONString name)) iworld
Detached attributes evalDirect = mkDetached attributes evalDirect iworld
NamedDetached name attributes evalDirect = mkDetached ('DM'.put "name" name attributes) evalDirect iworld
NamedDetached name attributes evalDirect = mkDetached ('DM'.put "name" (JSONString name) attributes) evalDirect iworld
= case mbTaskStuff of
Ok (taskId,attributes,mbTask)
# state = { ParallelTaskState
......@@ -496,23 +496,27 @@ evalEmbeddedParallelTask listId taskTrees event evalOpts
//TODO Check exception
//If the exception can not be handled, don't continue evaluating just stop
= (Ok (ExceptionResult e),iworld)
ValueResult val evalInfo=:{TaskEvalInfo|lastEvent,attributes,removedTasks} rep tree
ValueResult val evalInfo=:{TaskEvalInfo|lastEvent,removedTasks} rep tree
//Check for a focus event targeted at this branc
# mbNewFocus= case event of
(FocusEvent focusId) = if (focusId == taskId) (Just taskTime) Nothing
_ = Nothing
# lastFocus = maybe lastFocus Just mbNewFocus
# result = ValueResult val evalInfo rep tree
# attributeUpdate = case rep of
ReplaceUI (UI _ attributes _) = const attributes
ChangeUI changes _ = \a -> foldl (flip applyUIAttributeChange) a changes
_ = id
//Check if the value changed
# valueChanged = val =!= decode value
//Write updated value, and optionally the new lastFocus time to the tasklist
# (mbError,iworld) = if valueChanged
(modify
(\pts -> {ParallelTaskState|pts & value = encode val, lastFocus = maybe pts.ParallelTaskState.lastFocus Just mbNewFocus, attributes = attributes})
(\pts -> {ParallelTaskState|pts & value = encode val, lastFocus = maybe pts.ParallelTaskState.lastFocus Just mbNewFocus, attributes = attributeUpdate pts.ParallelTaskState.attributes})
(sdsFocus (listId,taskId,True) taskInstanceParallelTaskListItem)
EmptyContext iworld)
(modify
(\pts -> {ParallelTaskState|pts & lastFocus = maybe pts.ParallelTaskState.lastFocus Just mbNewFocus, attributes = attributes})
(\pts -> {ParallelTaskState|pts & lastFocus = maybe pts.ParallelTaskState.lastFocus Just mbNewFocus, attributes = attributeUpdate pts.ParallelTaskState.attributes})
(sdsFocus (listId,taskId,False) taskInstanceParallelTaskListItem)
EmptyContext
iworld)
......@@ -540,7 +544,7 @@ evalDetachedParallelTask listId taskTrees event evalOpts {ParallelTaskState|task
NoValue = Just NoValue
Value json stable = (\dec -> Value dec stable) <$> fromDeferredJSON json
//TODO: use global tasktime to be able to compare event times between instances
# evalInfo = {TaskEvalInfo|lastEvent=0,attributes='DM'.newMap,removedTasks=[]}
# evalInfo = {TaskEvalInfo|lastEvent=0,removedTasks=[]}
# result = maybe (ExceptionResult (exception "Could not decode task value of detached task"))
(\val -> ValueResult val evalInfo NoChange TCNop) mbValue
= (Ok result,iworld)
......@@ -672,12 +676,12 @@ where
genParallelEvalInfo :: [TaskResult a] -> TaskEvalInfo
genParallelEvalInfo results = foldr addResult {TaskEvalInfo|lastEvent=0,attributes='DM'.newMap,removedTasks=[]} results
genParallelEvalInfo results = foldr addResult {TaskEvalInfo|lastEvent=0,removedTasks=[]} results
where
addResult (ValueResult _ i1 _ _) i2
# lastEvent = max i1.TaskEvalInfo.lastEvent i2.TaskEvalInfo.lastEvent
# removedTasks = i1.TaskEvalInfo.removedTasks ++ i2.TaskEvalInfo.removedTasks
= {TaskEvalInfo|lastEvent=lastEvent,attributes='DM'.newMap,removedTasks=removedTasks}
= {TaskEvalInfo|lastEvent=lastEvent,removedTasks=removedTasks}
addResult _ i = i
readListId :: (SharedTaskList a) *IWorld -> (MaybeError TaskException TaskId,*IWorld) | TC a
......@@ -736,7 +740,7 @@ where
| listId == TaskId 0 0
# (mbe,iworld) = deleteTaskInstance instanceNo iworld
| mbe =: (Error _) = (ExceptionResult (fromError mbe),iworld)
= (ValueResult (Value () True) {lastEvent=ts,attributes='DM'.newMap,removedTasks=[]} (rep event) (TCStable taskId ts (DeferredJSONNode JSONNull)), iworld)
= (ValueResult (Value () True) {lastEvent=ts,removedTasks=[]} (rep event) (TCStable taskId ts (DeferredJSONNode JSONNull)), iworld)
//Mark the task as removed, and update the indices of the tasks afterwards
# taskListFilter = {onlyIndex=Nothing,onlyTaskId=Nothing,onlySelf=False,includeValue=True,includeAttributes=True,includeProgress=True}
# (mbError,iworld) = modify (markAsRemoved removeId) (sdsFocus (listId,taskListFilter) taskInstanceParallelTaskList) EmptyContext iworld
......@@ -745,12 +749,12 @@ where
| taskNo == 0 //(if the taskNo equals zero the instance is embedded)
# (mbe,iworld) = deleteTaskInstance instanceNo iworld
| mbe =: (Error _) = (ExceptionResult (fromError mbe),iworld)
= (ValueResult (Value () True) {lastEvent=ts,attributes='DM'.newMap,removedTasks=[]} (rep event) (TCStable taskId ts (DeferredJSONNode JSONNull)), iworld)
= (ValueResult (Value () True) {lastEvent=ts,removedTasks=[]} (rep event) (TCStable taskId ts (DeferredJSONNode JSONNull)), iworld)
| otherwise
//Pass removal information up
= (ValueResult (Value () True) {lastEvent=ts,attributes='DM'.newMap,removedTasks=[(listId,removeId)]} (rep event) (TCStable taskId ts (DeferredJSONNode JSONNull)), iworld)
= (ValueResult (Value () True) {lastEvent=ts,removedTasks=[(listId,removeId)]} (rep event) (TCStable taskId ts (DeferredJSONNode JSONNull)), iworld)
eval event evalOpts state=:(TCStable taskId ts _) iworld
= (ValueResult (Value () True) {lastEvent=ts,attributes='DM'.newMap,removedTasks=[]} (rep event) state, iworld)
= (ValueResult (Value () True) {lastEvent=ts,removedTasks=[]} (rep event) state, iworld)
rep ResetEvent = ReplaceUI (ui UIEmpty)
rep _ = NoChange
......@@ -775,14 +779,14 @@ where
| listId == TaskId 0 0
= case replaceTaskInstance instanceNo (parTask topLevelTaskList) iworld of
(Ok (), iworld)
= (ValueResult (Value () True) {lastEvent=ts,attributes='DM'.newMap,removedTasks=[]} (rep event) (TCStable taskId ts (DeferredJSONNode JSONNull)), iworld)
= (ValueResult (Value () True) {lastEvent=ts,removedTasks=[]} (rep event) (TCStable taskId ts (DeferredJSONNode JSONNull)), iworld)
(Error e, iworld)
= (ExceptionResult e,iworld)
//If it is a detached task, replacee the detached instance, if it is embedded schedule the change in the parallel task state
| taskNo == 0 //(if the taskNo equals zero the instance is embedded)
= case replaceTaskInstance instanceNo (parTask topLevelTaskList) iworld of
(Ok (), iworld)
= (ValueResult (Value () True) {lastEvent=ts,attributes='DM'.newMap,removedTasks=[]} (rep event) (TCStable taskId ts (DeferredJSONNode JSONNull)), iworld)
= (ValueResult (Value () True) {lastEvent=ts,removedTasks=[]} (rep event) (TCStable taskId ts (DeferredJSONNode JSONNull)), iworld)
(Error e, iworld)
= (ExceptionResult e,iworld)
//Schedule the change in the parallel task state
......@@ -791,9 +795,9 @@ where
# taskListFilter = {onlyIndex=Nothing,onlyTaskId=Nothing,onlySelf=False,includeValue=True,includeAttributes=True,includeProgress=True}
# (mbError,iworld) = modify (scheduleReplacement replaceId task) (sdsFocus (listId,taskListFilter) taskInstanceParallelTaskList) EmptyContext iworld
| mbError =:(Error _) = (ExceptionResult (fromError mbError),iworld)
= (ValueResult (Value () True) {lastEvent=ts,attributes='DM'.newMap,removedTasks=[]} (rep event) (TCStable taskId ts (DeferredJSONNode JSONNull)), iworld)
= (ValueResult (Value () True) {lastEvent=ts,removedTasks=[]} (rep event) (TCStable taskId ts (DeferredJSONNode JSONNull)), iworld)
eval event evalOpts state=:(TCStable taskId ts _) iworld
= (ValueResult (Value () True) {lastEvent=ts,attributes='DM'.newMap,removedTasks=[]} (rep event) state, iworld)
= (ValueResult (Value () True) {lastEvent=ts,removedTasks=[]} (rep event) state, iworld)
rep ResetEvent = ReplaceUI (ui UIEmpty)
rep _ = NoChange
......@@ -864,7 +868,7 @@ where
//Determine UI change
# change = determineUIChange event curStatus prevStatus instanceNo instanceKey
# stable = (curStatus =: ASDeleted) || (curStatus =: ASExcepted _)
= (ValueResult (Value curStatus stable) {TaskEvalInfo|lastEvent=ts,attributes='DM'.newMap,removedTasks=[]} change (TCAttach taskId ts curStatus build instanceKey), iworld)
= (ValueResult (Value curStatus stable) {TaskEvalInfo|lastEvent=ts,removedTasks=[]} change (TCAttach taskId ts curStatus build instanceKey), iworld)
determineUIChange event curStatus prevStatus instanceNo instanceKey
| curStatus === prevStatus && not (event =: ResetEvent) = NoChange
......
......@@ -69,7 +69,7 @@ exception :: !e -> TaskException | TC, toString e
:: InstanceNo :== Int
:: TaskNo :== Int
:: TaskAttributes :== Map String String
:: TaskAttributes :== Map String JSONNode
:: InstanceKey :== String
instance toString TaskId
......
......@@ -104,7 +104,7 @@ interactAwaitReadRefresh :: (sds () r w) (InteractionHandlers l r w v) (Editor v
-> *(TaskResult (l,v), *IWorld) | iTask l & iTask r & iTask v & TC r & TC w & Registrable sds
interactAwaitReadRefresh shared handlers editor (RefreshEvent taskIds reason) evalOpts t=:(TCAwait Read taskId ts tree)
iworld=:{sdsEvalStates, current={taskTime}}
| not ('DS'.member taskId taskIds) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='DM'.newMap} NoChange t, iworld)
| not ('DS'.member taskId taskIds) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[]} NoChange t, iworld)
= case 'DM'.get taskId sdsEvalStates of
Nothing = (ExceptionResult (exception ("No SDS state found for task " +++ toString taskId)), iworld)
(Just val)
......@@ -121,18 +121,18 @@ interactAwaitReadRefresh shared handlers editor (RefreshEvent taskIds reason) ev
(Error e, vst) = (ExceptionResult (exception e), vst)
(Ok (UI type attr items, st), vst)
# change = ReplaceUI (UI type ('DM'.unions [taskTypeAttr "interact", attr]) items)
# info = {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='DM'.newMap}
# info = {TaskEvalInfo|lastEvent=ts,removedTasks=[]}
# value = maybe NoValue (\v -> Value (l, v) False) mbV
= (ValueResult value info change (TCInteract taskId ts (DeferredJSON l) (DeferredJSON mbV) st (mode =: View _)), vst)) iworld
Reading sds = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='DM'.newMap} NoChange t, {iworld & sdsEvalStates = 'DM'.put taskId (dynamicResult ('SDS'.readRegister taskId sds)) sdsEvalStates})
Reading sds = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[]} NoChange t, {iworld & sdsEvalStates = 'DM'.put taskId (dynamicResult ('SDS'.readRegister taskId sds)) sdsEvalStates})
(_, iworld) = (ExceptionResult (exception "Dynamic type mismatch"), iworld)
interactAwaitModifyRefresh :: (sds () r w) (InteractionHandlers l r w v) (Editor v) Event TaskEvalOpts TaskTree *IWorld
-> *(TaskResult (l,v), *IWorld) | iTask l & iTask r & iTask v & TC r & TC w & RWShared sds
interactAwaitModifyRefresh shared handlers editor (RefreshEvent taskIds reason) evalOpts
t=:(TCAwait Modify _ _ (TCInteract taskId ts encl encv st viewmode)) iworld=:{sdsEvalStates, current={taskTime}}
| not ('DS'.member taskId taskIds) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='DM'.newMap} NoChange t, iworld)
# evalInfo = {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='DM'.newMap}
| not ('DS'.member taskId taskIds) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[]} NoChange t, iworld)
# evalInfo = {TaskEvalInfo|lastEvent=ts,removedTasks=[]}
= case 'DM'.get taskId sdsEvalStates of
Nothing = (ExceptionResult (exception ("No SDS state found for task " +++ toString taskId)), iworld)
(Just val) = case val iworld of
......@@ -147,7 +147,7 @@ interactAwaitModifyRefresh shared handlers editor (RefreshEvent taskIds reason)
(Ok (dyn), iworld) = (ExceptionResult (exception ("Dynamic type mismatch, type was " +++ toString (typeCodeOfDynamic dyn))), iworld)
interactAwait t=:(TCAwait _ taskId ts tree) iworld // Ignore all other events when waiting on an async operation.
= (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='DM'.newMap} NoChange t, iworld)
= (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[]} NoChange t, iworld)
interactEvents :: (sds () r w) (InteractionHandlers l r w v) (Editor v) Event TaskEvalOpts TaskTree
(TaskId (r -> w) *IWorld -> (MaybeError TaskException (Maybe (!AsyncAction, !*IWorld -> *(MaybeError TaskException Dynamic, !*IWorld))), !*IWorld))
......@@ -176,7 +176,7 @@ interactEvents shared handlers editor event evalOpts tree modifyFun iworld=:{cur
_ = (Error (exception ("Failed to decode stored model and view in interact: '" +++ toString encl +++ "', '"+++toString encv+++"'")),iworld)
| mbd =:(Error _) = (ExceptionResult (fromError mbd), iworld)
| mbd =:(Ok (Right _)) = case mbd of
(Ok (Right (taskId, ts, sds))) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='DM'.newMap} (ReplaceUI (uia UIProgressBar (textAttr "Getting data"))) (TCAwait Read taskId taskTime tree), iworld)
(Ok (Right (taskId, ts, sds))) = (ValueResult NoValue {TaskEvalInfo|lastEvent=ts,removedTasks=[]} (ReplaceUI (uia UIProgressBar (textAttr "Getting data"))) (TCAwait Read taskId taskTime tree), iworld)
# (Left (taskId,ts,l,v,st,viewMode)) = fromOk mbd
# (mbRes, iworld) = case event of
EditEvent eTaskId name edit | eTaskId == taskId =
......@@ -206,14 +206,14 @@ interactEvents shared handlers editor event evalOpts tree modifyFun iworld=:{cur
// want to wait for the result of the modify (otherwise we send multiple requests which may interfere),
// so we transition to the TCAwait state
Ok (Right (type, sdsf, l, v, st, change))
# evalInfo = {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='DM'.newMap}
# evalInfo = {TaskEvalInfo|lastEvent=ts,removedTasks=[]}
# tree = TCAwait type taskId taskTime (TCInteract taskId taskTime (DeferredJSON l) (DeferredJSON v) st viewMode)
= (ValueResult NoValue evalInfo NoChange tree, {iworld & sdsEvalStates = 'DM'.put taskId sdsf iworld.sdsEvalStates})
Ok (Left (l,mbV,change,st,ts))
//Construct the result
# v = maybe v Just mbV // use previous view state of editor is in invalid state
# value = maybe NoValue (\v -> Value (l, v) False) mbV
# info = {TaskEvalInfo|lastEvent=ts,attributes='DM'.newMap,removedTasks=[]}
# info = {TaskEvalInfo|lastEvent=ts,removedTasks=[]}
= (ValueResult value info change (TCInteract taskId ts (DeferredJSON l) (DeferredJSON v) st viewMode), iworld)
interactModifyShareAsync :: (sds () r w) TaskId (r -> w) !*IWorld ->
......
......@@ -88,7 +88,7 @@ where
eval event evalOpts tree=:(TCStable tid ts (DeferredJSONNode (JSONInt i))) iworld
= (ValueResult (Value i True) (info ts) (rep event) tree, iworld)
info ts = {TaskEvalInfo|lastEvent=ts,attributes='DM'.newMap,removedTasks=[]}
info ts = {TaskEvalInfo|lastEvent=ts,removedTasks=[]}
rep ResetEvent = ReplaceUI (stringDisplay ("External process: " <+++ cmd))
rep _ = NoChange
......@@ -113,7 +113,7 @@ where
(Error e,iworld)
= (ExceptionResult e, iworld)
(Ok _,iworld)
= (ValueResult (Value [] False) {TaskEvalInfo|lastEvent=ts,attributes='DM'.newMap,removedTasks=[]} (rep port)
= (ValueResult (Value [] False) {TaskEvalInfo|lastEvent=ts,removedTasks=[]} (rep port)
(TCBasic taskId ts (DeferredJSONNode JSONNull) False),iworld)
eval event evalOpts tree=:(TCBasic taskId ts _ _) iworld=:{ioStates}
......@@ -122,9 +122,9 @@ where
= (ExceptionResult (exception e), iworld)
Just (IOActive values)
# value = Value [l \\ (_,(l :: l^,_)) <- 'DM'.toList values] False
= (ValueResult value {TaskEvalInfo|lastEvent=ts,attributes='DM'.newMap,removedTasks=[]} (rep port) (TCBasic taskId ts (DeferredJSONNode JSONNull) False),iworld)
= (ValueResult value {TaskEvalInfo|lastEvent=ts,removedTasks=[]} (rep port) (TCBasic taskId ts (DeferredJSONNode JSONNull) False),iworld)
Nothing
= (ValueResult (Value [] False) {TaskEvalInfo|lastEvent=ts,attributes='DM'.newMap,removedTasks=[]} (rep port) (TCBasic taskId ts (DeferredJSONNode JSONNull) False), iworld)
= (ValueResult (Value [] False) {TaskEvalInfo|lastEvent=ts,removedTasks=[]} (rep port) (TCBasic taskId ts (DeferredJSONNode JSONNull) False), iworld)
rep port = ReplaceUI (stringDisplay ("Listening for connections on port "<+++ port))
......@@ -148,16 +148,16 @@ where