CoreCombinators.icl 20.3 KB
Newer Older
1
implementation module CoreCombinators
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
2

Steffen Michels's avatar
Steffen Michels committed
3
import StdList, StdTuple, StdMisc, StdBool, StdOrdList
4
import Task, TaskState, TaskStore, TaskEval, Util, HTTP, GenUpdate, GenEq_NG, Store, SystemTypes, Time, Text, Shared, Func, Tuple, List_NG
5
import iTaskClass, InteractionTasks, LayoutCombinators, TUIDefinition
6

7
from Map				import qualified get, put, del
8
from StdFunc			import id, const, o, seq
9
from IWorld				import :: IWorld(..)
10
from iTasks				import JSONEncode, JSONDecode, dynamicJSONEncode, dynamicJSONDecode
11
from TaskEval			import localShare, parListShare, topListShare
12
from CoreTasks			import return
Steffen Michels's avatar
Steffen Michels committed
13
from SharedDataSource	import write, read//, getIds, :: ShareId
14

15
derive class iTask ParallelTaskType, WorkOnStatus
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
16

17
getNextTaskId :: *IWorld -> (!TaskId,!*IWorld)
18
getNextTaskId iworld=:{currentInstance,nextTaskNo} = (TaskId currentInstance nextTaskNo, {IWorld|iworld & nextTaskNo = nextTaskNo + 1})
19

Bas Lijnse's avatar
Bas Lijnse committed
20
transform :: ((TaskValue a) -> TaskValue b) !(Task a) -> Task b | iTask a & iTask b 
21
transform f (Task evala) = Task eval
22
where
23 24
	eval eEvent cEvent refresh repAs tree iworld = case evala eEvent cEvent refresh repAs tree iworld of
		(ValueResult val lastEvent rep tree,iworld)	= (ValueResult (f val) lastEvent rep tree, iworld)	//TODO: guarantee stability
25
		(ExceptionResult e str, iworld)				= (ExceptionResult e str, iworld)
26

Steffen Michels's avatar
Steffen Michels committed
27
project	:: ((TaskValue a) r -> Maybe w) (ReadWriteShared r w) !(Task a) -> Task a | iTask a
28
project projection share (Task evala) = Task eval
Bas Lijnse's avatar
Bas Lijnse committed
29
where
30
	eval eEvent cEvent refresh repAs state iworld
31 32 33 34
		# (taskId,prev,statea) = case state of
			(TCInit taskId _)					= (taskId,NoValue,state) 
			(TCProject taskId encprev statea)	= (taskId,fromJust (fromJSON encprev),statea)
			
35
		# (resa, iworld) 	= evala eEvent cEvent refresh repAs statea iworld
Bas Lijnse's avatar
Bas Lijnse committed
36
		= case resa of
37 38 39 40
			ValueResult val ts rep ncxta
				# result = ValueResult val ts rep (TCProject taskId (toJSON val) ncxta)
				| val =!= prev
					= projectOnShare val result iworld
Bas Lijnse's avatar
Bas Lijnse committed
41
				| otherwise
42
					= (result,iworld)
Bas Lijnse's avatar
Bas Lijnse committed
43 44
			ExceptionResult e str
				= (ExceptionResult e str,iworld)
Bas Lijnse's avatar
Bas Lijnse committed
45
	
Bas Lijnse's avatar
Bas Lijnse committed
46
	projectOnShare val result iworld
Steffen Michels's avatar
Steffen Michels committed
47 48 49 50 51 52 53 54 55 56
		# (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)
Bas Lijnse's avatar
Bas Lijnse committed
57

Steffen Michels's avatar
Steffen Michels committed
58
step :: !(Task a) [TaskStep a b] -> Task b | iTask a & iTask b
59
step (Task evala) conts = Task eval
60
where
61
	eval eEvent cEvent refresh repAs (TCInit taskId ts) iworld
62
		# (taskIda,iworld)	= getNextTaskId iworld
63
		= eval eEvent cEvent refresh repAs (TCStep taskId (Left (TCInit taskIda ts))) iworld
64

65
	//Eval left-hand side
66
	eval eEvent cEvent refresh repAs (TCStep taskId (Left statea)) iworld=:{taskTime}
67
		# (resa, iworld) 	= evala eEvent cEvent refresh repAs statea iworld
68
		# mbcommit			= case cEvent of
69
			(Just (TaskEvent t action))
70 71
				| t == taskId && not refresh	= Just action
			_									= Nothing
72
		# mbCont			= case resa of
73 74
			ValueResult val lastEvent rep nstatea = case searchContValue val mbcommit conts of
				Nothing			= Left (ValueResult NoValue lastEvent (addStepActions taskId repAs rep val) (TCStep taskId (Left nstatea)) )
75
				Just rewrite	= Right rewrite
Bas Lijnse's avatar
Bas Lijnse committed
76 77
			ExceptionResult e str = case searchContException e str conts of
				Nothing			= Left (ExceptionResult e str)
78 79
				Just rewrite	= Right rewrite
		= case mbCont of
80
			Left res = (res,iworld)
81
			Right (sel,Task evalb,enca)
82
				# (taskIdb,iworld)	= getNextTaskId iworld
83
				# (resb,iworld)		= evalb Nothing Nothing refresh repAs (TCInit taskIdb taskTime) iworld 
84
				= case resb of
85
					ValueResult val lastEvent rep nstateb	= (ValueResult val lastEvent rep (TCStep taskId (Right (enca,sel,nstateb))),iworld)
Bas Lijnse's avatar
Bas Lijnse committed
86
					ExceptionResult e str					= (ExceptionResult e str, iworld)
87
	//Eval right-hand side
88
	eval eEvent cEvent refresh repAs (TCStep taskId (Right (enca,sel,stateb))) iworld
89
		# mbTaskb = case conts !! sel of
Bas Lijnse's avatar
Bas Lijnse committed
90 91 92 93
			(OnValue _ taskbf)			= fmap taskbf (fromJSON enca)
			(OnAction _ _ taskbf)		= fmap taskbf (fromJSON enca)
			(OnException taskbf)		= fmap taskbf (fromJSON enca)
			(OnAllExceptions taskbf)	= fmap taskbf (fromJSON enca)
94
		= case mbTaskb of
95
			Just (Task evalb)
96
				# (resb, iworld)	= evalb eEvent cEvent refresh repAs stateb iworld 
97
				= case resb of
98 99
					ValueResult val lastEvent rep nstateb	= (ValueResult val lastEvent rep (TCStep taskId (Right (enca,sel,nstateb))), iworld)
					ExceptionResult e str					= (ExceptionResult e str, iworld)
100
			Nothing
Bas Lijnse's avatar
Bas Lijnse committed
101
				= (exception "Corrupt task value in step", iworld) 	
102
	//Incorred state
103
	eval eEvent cEvent refresh _ state iworld
104
		= (exception ("Corrupt task state in step:" +++ (toString (toJSON state))), iworld)
105

Bas Lijnse's avatar
Bas Lijnse committed
106
	searchContValue val mbcommit conts = search val mbcommit 0 Nothing conts
107
	where
Bas Lijnse's avatar
Bas Lijnse committed
108 109 110 111 112 113 114 115
		search _ _ _ mbmatch []							= mbmatch									//No matching OnValue steps were found, return the potential match
		search val mbcommit i mbmatch [OnValue pred f:cs]
			| pred val									= Just (i, f val, toJSON val)				//Don't look any further, first matching trigger wins
														= search val mbcommit (i + 1) mbmatch cs	//Keep search
		search val (Just commit) i Nothing [OnAction action pred f:cs]
			| pred val && commit == actionName action	= search val (Just commit) (i + 1) (Just (i, f val, toJSON val)) cs //We found a potential winner (if no OnValue values are in cs)
														= search val (Just commit) (i + 1) Nothing cs						//Keep searching
		search val mbcommit i mbmatch [_:cs]			= search val mbcommit (i + 1) mbmatch cs							//Keep searching
116
		
117 118
	searchContException dyn str conts = search dyn str 0 Nothing conts
	where
119
		search _ _ _ catchall []					= catchall														//Return the maybe catchall
Bas Lijnse's avatar
Bas Lijnse committed
120
		search dyn str i catchall [OnException f:cs] = case (match f dyn) of
121 122
			Just (taskb,enca)						= Just (i, taskb, enca)											//We have a match
			_										= search dyn str (i + 1) catchall cs							//Keep searching
Bas Lijnse's avatar
Bas Lijnse committed
123
		search dyn str i Nothing [OnAllExceptions f:cs]	= search dyn str (i + 1) (Just (i, f str, toJSON str)) cs 	//Keep searching (at least we have a catchall)
124
		search dyn str i mbcatchall [_:cs]			= search dyn str (i + 1) mbcatchall cs							//Keep searching
125
				
126 127 128
		match :: (e -> Task b) Dynamic -> Maybe (Task b, JSONNode) | iTask e
		match f (e :: e^)	= Just (f e, toJSON e)
		match _ _			= Nothing 
129
	
130
	addStepActions taskId repAs (TaskRep gui parts) val 
Bas Lijnse's avatar
Bas Lijnse committed
131 132
		# fixme = []
		= TaskRep ((repLayout repAs) SequentialComposition [gui] (stepActions taskId val) [(TASK_ATTRIBUTE, toString taskId):fixme]) parts	//TODO: Add attributes from task
133
	
Bas Lijnse's avatar
Bas Lijnse committed
134 135
	stepActions taskId val = [(toString taskId,action,pred val)\\ OnAction action pred _ <- conts]

136
// Parallel composition
137

Bas Lijnse's avatar
Bas Lijnse committed
138
parallel :: !d ![(!ParallelTaskType,!ParallelTask a)] -> Task [(!TaskTime,!TaskValue a)] | descr d & iTask a
139
parallel desc initTasks = Task eval 
140
where
141 142 143 144 145 146
	//Create initial task list
	eval eEvent cEvent refresh repAs (TCInit taskId ts) iworld=:{IWorld|localLists}
		//Append the initial tasks to the list 
		# iworld	= foldl append {iworld & localLists = 'Map'.put taskId [] localLists} initTasks
		//Evaluate the parallel
		= eval eEvent cEvent refresh repAs (TCParallel taskId) iworld
147
	where
148 149 150 151 152 153 154 155 156 157
		append iworld t = snd (appendTaskToList taskId t iworld)

	//Evaluate the task list
	eval eEvent cEvent refresh repAs (TCParallel taskId) iworld=:{taskTime}
		//Update the tasktime if an explicit reorder event of tabs/windows is targeted at the parallel 
		# iworld = case eEvent of
			Just (TaskEvent t ("top",JSONString top))	
				| t == taskId && not refresh	= updateListEntryTime taskId (fromString top) taskTime iworld
												= iworld
			_	= iworld
158

159 160 161 162 163 164 165 166 167
		//Evaluate all parallel tasks in the list
		= case evalParTasks taskId eEvent cEvent refresh repAs iworld of
			(Just res=:(ExceptionResult e str),iworld)	= (res,iworld)
			(Just res=:(ValueResult _ _ _ _),iworld)	= (exception "parallel evaluation yielded unexpected result",iworld)
			(Nothing,iworld=:{localLists})
				//Create the task value
				# entries			= fromMaybe [] ('Map'.get taskId localLists) 
				# rep				= parallelRep desc taskId repAs entries
				# values			= map toValueAndTime entries 
Bas Lijnse's avatar
Bas Lijnse committed
168
				# stable			= if (all (isStable o snd) values) Stable Unstable
169 170
				# ts				= foldr max 0 (map fst values)
				= (ValueResult (Value values stable) ts rep (TCParallel taskId),iworld)
171
	//Fallback
172
	eval _ _ _ _ _ iworld
173
		= (exception "Corrupt task state in parallel", iworld)
174
	
175 176 177
	evalParTasks :: !TaskId !(Maybe EditEvent) !(Maybe CommitEvent) !RefreshFlag !TaskRepOpts !*IWorld -> (!Maybe (TaskResult [(TaskTime,TaskValue a)]),!*IWorld) | iTask a
	evalParTasks taskId eEvent cEvent refresh repAs iworld=:{localLists}
		= evalFrom 0 (fromMaybe [] ('Map'.get taskId localLists)) iworld
178
	where
179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199
		evalFrom n list iworld = case foldl (evalParTask taskId eEvent cEvent refresh repAs) (Nothing,iworld) (drop n list) of
			(Just (ExceptionResult e str),iworld)	= (Just (ExceptionResult e str),iworld)
			(Nothing,iworld=:{localLists})			
				# nlist = fromMaybe [] ('Map'.get taskId localLists)
				| length nlist > length list	= evalFrom (length list) nlist iworld	//Extra branches were added -> evaluate these as well 
												= (Nothing,iworld)						//Done
			//IMPORTANT: This last rule should never match, but it helps to solve overloading solves overloading
			(Just (ValueResult val ts rep tree),iworld) = (Just (ValueResult (Value [(ts,val)] Unstable) ts rep tree),iworld)
	
	evalParTask :: !TaskId !(Maybe EditEvent) !(Maybe CommitEvent) !RefreshFlag !TaskRepOpts !(!Maybe (TaskResult a),!*IWorld) !TaskListEntry -> (!Maybe (TaskResult a),!*IWorld) | iTask a
	//Evaluate embedded tasks
	evalParTask taskId eEvent cEvent refresh repAs (Nothing,iworld) {TaskListEntry|entryId,state=EmbeddedState (Task evala :: Task a^),result=ValueResult _ _ _ tree, removed=False}
		# (result,iworld) = evala eEvent cEvent refresh (TaskRepOpts Nothing Nothing) tree iworld
		= case result of
			ExceptionResult _ _	= (Just result,iworld)	
			_					= (Nothing,updateListEntryEmbeddedResult taskId entryId result iworld)				
	//Copy the last stored result of detached tasks
	evalParTask taskId eEvent cEvent refresh repAs (Nothing,iworld) {TaskListEntry|entryId,state=DetachedState instanceNo _ _,removed=False}
		= case loadTaskInstance instanceNo iworld of
			(Error _, iworld)	= (Nothing,iworld)	//TODO: remove from parallel if it can't be loaded (now it simply keeps the last known result)
			(Ok inst, iworld)	= (Nothing,updateListEntryDetachedResult taskId entryId inst.TaskInstance.result inst.TaskInstance.progress inst.TaskInstance.management iworld)
200

201 202 203 204 205
	//Do nothing if an exeption occurred or marked as removed
	evalParTask taskId eEvent cEvent refresh repAs (result,iworld) entry = (result,iworld) 

	toValueAndTime :: !TaskListEntry -> (!TaskTime,TaskValue a) | iTask a
	toValueAndTime {TaskListEntry|result=ValueResult val _ _ _,time}	= (time,deserialize val)	
206
	where
207 208 209 210 211
		deserialize (Value json stable) = case fromJSON json of
			Nothing = NoValue
			Just a	= Value a stable
		deserialize NoValue	= NoValue
	toValueAndTime {TaskListEntry|time}									= (time,NoValue)
212
	
213 214
	parallelRep :: !d !TaskId !TaskRepOpts ![TaskListEntry] -> TaskRep | descr d
	parallelRep desc taskId repAs entries
215
		# layout		= repLayout repAs
216
		# attributes	= [(TASK_ATTRIBUTE,toString taskId) : initAttributes desc]
217
		# parts = [(t,g,ac,kvSet TIME_ATTRIBUTE (toString time) (kvSet TASK_ATTRIBUTE (toString entryId) at))
Bas Lijnse's avatar
Bas Lijnse committed
218
					 \\ {TaskListEntry|entryId,state=EmbeddedState _,result=ValueResult val _ (TaskRep (t,g,ac,at) _) _,time,removed=False} <- entries | not (isStable val)]	
219 220
		= TaskRep (layout ParallelComposition parts [] attributes) []
	
Bas Lijnse's avatar
Bas Lijnse committed
221 222
	isStable (Value _ Stable) 	= True
	isStable _					= False
223
																
224
//SHARED HELPER FUNCTIONS
225 226
//TODO: Also add to lists which are not in scope!
appendTaskToList :: !TaskId !(!ParallelTaskType,!ParallelTask a) !*IWorld -> (!TaskId,!*IWorld) | iTask a
227
appendTaskToList taskId=:(TaskId parent _) (parType,parTask) iworld=:{localLists,taskTime,currentUser,currentDateTime}
228 229 230 231 232 233 234 235 236
	# list = fromMaybe [] ('Map'.get taskId localLists)
	# (taskIda,state,iworld) = case parType of
		Embedded
			# (taskIda,iworld)	= getNextTaskId iworld
			# task		= parTask (parListShare taskId)
			= (taskIda,EmbeddedState (dynamic task :: Task a^),iworld)
		Detached management
			# task									= parTask (parListShare taskId)
			# progress								= {issuedAt=currentDateTime,issuedBy=currentUser,status=Unstable,firstEvent=Nothing,latestEvent=Nothing}
237
			# (taskIda=:TaskId instanceNo _,iworld)	= createPersistentInstance task management currentUser parent iworld
238 239 240 241
			= (taskIda,DetachedState instanceNo progress management, iworld)
	# result	= ValueResult NoValue taskTime (TaskRep (SingleTask,Just (stringDisplay "Task not evaluated yet"),[],[]) []) (TCInit taskIda taskTime)
	# entry		= {entryId = taskIda, state = state, result = result, time = taskTime, removed = False}
	= (taskIda, {iworld & localLists = 'Map'.put taskId (list ++ [entry]) localLists})		
242

243 244 245
updateListEntryEmbeddedResult :: !TaskId !TaskId (TaskResult a) !*IWorld -> *IWorld | iTask a
updateListEntryEmbeddedResult listId entryId result iworld
	= updateListEntry listId entryId (\e=:{TaskListEntry|time} -> {TaskListEntry|e & result = serialize result, time = maxTime time result}) iworld
246
where
247 248
	serialize (ValueResult val ts rep tree) = ValueResult (fmap toJSON val) ts rep tree
	serialize (ExceptionResult e str)		= ExceptionResult e str
249

Bas Lijnse's avatar
Bas Lijnse committed
250 251 252
	maxTime cur (ValueResult _ ts _ _)		= max cur ts
	maxTime cur _							= cur

253 254 255
updateListEntryDetachedResult :: !TaskId !TaskId (TaskResult JSONNode) !ProgressMeta !ManagementMeta !*IWorld -> *IWorld
updateListEntryDetachedResult listId entryId result progress management iworld
	= updateListEntry listId entryId update iworld
256
where
Bas Lijnse's avatar
Bas Lijnse committed
257 258
	update e=:{TaskListEntry|state=DetachedState no _ _}
		= {TaskListEntry| e & state = DetachedState no progress management,result = result}
259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278
	update e = e

updateListEntryTime :: !TaskId !TaskId !TaskTime !*IWorld -> *IWorld
updateListEntryTime listId entryId ts iworld
	= updateListEntry listId entryId (\e -> {TaskListEntry|e & time = ts}) iworld

markListEntryRemoved :: !TaskId !TaskId !*IWorld -> *IWorld
markListEntryRemoved listId entryId iworld
	= updateListEntry listId entryId (\e -> {TaskListEntry|e & removed = True}) iworld
	
//TODO Also update list entries of lists that are not in scope
updateListEntry :: !TaskId !TaskId !(TaskListEntry -> TaskListEntry) !*IWorld -> *IWorld
updateListEntry listId entryId f iworld=:{localLists}
	= case 'Map'.get listId localLists of
		Nothing 	= iworld
		Just list	= {iworld & localLists = 'Map'.put listId
							[if (e.TaskListEntry.entryId == entryId) (f e) e \\ e <- list] localLists}

readListId :: (SharedTaskList a) *IWorld -> (MaybeErrorString (TaskListId a),*IWorld)	| iTask a
readListId slist iworld = case read slist iworld of
Steffen Michels's avatar
Steffen Michels committed
279 280
	(Ok l,iworld)		= (Ok l.TaskList.listId, iworld)
	(Error e, iworld)	= (Error e, iworld)
281

282
//Derived shares
Bas Lijnse's avatar
Bas Lijnse committed
283
taskListState :: !(SharedTaskList a) -> ReadOnlyShared [TaskValue a]
284
taskListState tasklist = mapRead (\{TaskList|items} -> [value \\ {TaskListItem|value} <- items]) tasklist
285

286
taskListMeta :: !(SharedTaskList a) -> ReadOnlyShared [TaskListItem a]
287
taskListMeta tasklist = mapRead (\{TaskList|items} -> items) tasklist
288 289 290

appendTask :: !ParallelTaskType !(ParallelTask a) !(SharedTaskList a) -> Task TaskId | iTask a
appendTask parType parTask slist = mkInstantTask eval
291
where
292 293 294 295 296 297 298 299 300 301 302 303
	eval taskId iworld=:{taskTime}
		= case readListId slist iworld of
			(Ok listId,iworld)
				# (taskIda,iworld) = append listId parType parTask iworld
				= (ValueResult (Value taskIda Stable) taskTime (TaskRep (SingleTask,Nothing,[],[]) []) (TCEmpty taskIda taskTime), iworld)
			(Error e,iworld)
				= (exception e, iworld)
								
	append :: !(TaskListId a) !ParallelTaskType !(ParallelTask a) !*IWorld -> (!TaskId,!*IWorld) | iTask a
	append TopLevelTaskList parType parTask iworld=:{currentUser}
		# meta						= case parType of Embedded = noMeta; Detached meta = meta;
		# task						= parTask topListShare
304
		= createPersistentInstance task meta currentUser 0 iworld
305 306 307
	append (ParallelTaskList parId) parType parTask iworld
		= appendTaskToList parId (parType,parTask) iworld

308 309 310
/**
* Removes (and stops) a task from a task list
*/
311 312
removeTask :: !TaskId !(SharedTaskList a) -> Task Void | iTask a
removeTask entryId slist = mkInstantTask eval
313
where
314 315 316 317 318 319 320 321 322 323 324 325 326 327
	eval taskId iworld=:{taskTime}
		= case readListId slist iworld of
			(Ok listId,iworld)
				# iworld = remove listId entryId iworld
				= (ValueResult (Value Void Stable) taskTime (TaskRep (SingleTask,Nothing,[],[]) []) (TCEmpty taskId taskTime), iworld)
			(Error e,iworld)
				= (exception e, iworld)

	remove :: !(TaskListId a) !TaskId !*IWorld -> *IWorld
	remove TopLevelTaskList (TaskId instanceNo 0) iworld
		= deleteTaskInstance instanceNo iworld
	remove (ParallelTaskList parId) entryId iworld
		= markListEntryRemoved parId entryId iworld
	remove _ _ iworld = iworld
328

329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347
workOn :: !TaskId -> Task WorkOnStatus
workOn (TaskId instanceNo taskNo) = Task eval
where
	eval eEvent cEvent refresh repAs (TCInit taskId ts) iworld=:{currentInstance}
		# iworld = addTaskInstanceObserver currentInstance instanceNo iworld
		= eval eEvent cEvent refresh repAs (TCEmpty taskId ts) iworld
		
	eval eEvent cEvent refresh repAs (TCEmpty taskId ts) iworld
		//Load instance
		= case loadTaskInstance instanceNo iworld of
			(Error _, iworld)
				= (ValueResult (Value WODeleted Stable) ts (TaskRep (SingleTask, Nothing, [],[]) []) (TCEmpty taskId ts), iworld)
			(Ok {TaskInstance|result=ValueResult (Value _ Stable) _ _ _}, iworld)
				= (ValueResult (Value WOFinished Stable) ts (TaskRep (SingleTask, Nothing, [],[]) []) (TCEmpty taskId ts), iworld)
			(Ok {TaskInstance|result=ExceptionResult _ err}, iworld)
				= (ValueResult (Value WOExcepted Stable) ts (TaskRep (SingleTask, Nothing, [], []) []) (TCEmpty taskId ts), iworld)
			//Embed the representation of the detached instance
			(Ok {TaskInstance|result=ValueResult _ _ rep _}, iworld)
				= (ValueResult (Value WOActive Unstable) ts rep (TCEmpty taskId ts), iworld)
348 349 350 351 352
/*
* 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.
*/
353
workAs :: !User !(Task a) -> Task a | iTask a
354
workAs user (Task eval) = Task eval`
355
where
356 357
	eval` eEvent cEvent refresh repAs state iworld=:{currentUser}
		# (result,iworld) = eval eEvent cEvent refresh repAs state {iworld & currentUser = user}
358
		= (result,{iworld & currentUser = currentUser})
359

360
withShared :: !b !((Shared b) -> Task a) -> Task a | iTask a & iTask b
361
withShared initial stask = Task eval
362
where	
363 364
	eval eEvent cEvent refresh repAs (TCInit taskId ts) iworld=:{localShares}
		# localShares				= 'Map'.put taskId (toJSON initial) localShares
365
		# (taskIda,iworld)			= getNextTaskId iworld
366
		= eval eEvent cEvent refresh repAs  (TCShared taskId (TCInit taskIda ts)) {iworld & localShares = localShares}
367
		
368
	eval eEvent cEvent refresh repAs (TCShared taskId cxta) iworld
369
		# (Task evala)				= stask (localShare taskId)
370
		# (resa,iworld)				= evala eEvent cEvent refresh repAs cxta iworld
371
		= case resa of
372 373
			ValueResult NoValue lastEvent rep ncxta				= (ValueResult NoValue lastEvent rep (TCShared taskId ncxta),iworld)
			ValueResult (Value stable val) lastEvent rep ncxta	= (ValueResult (Value stable val) lastEvent rep (TCShared taskId ncxta),iworld)
374
			ExceptionResult e str								= (ExceptionResult e str,iworld)
375
	eval _ _ _ _ _ iworld
376
		= (exception "Corrupt task state in withShared", iworld)	
377 378 379 380 381
/*
* Tuning of tasks
*/
class tune b :: !b !(Task a) -> Task a

382
instance tune SetLayout
383 384 385
where
	tune (SetLayout layout) (Task eval)	= Task eval`
	where
386 387 388 389
		eval` eEvent cEvent refresh (TaskRepOpts Nothing mod) state iworld
			= eval eEvent cEvent refresh (TaskRepOpts (Just ((fromMaybe id mod) layout)) Nothing) state iworld 
		eval` eEvent cEvent refresh (TaskRepOpts (Just layout) mod) state iworld
			= eval eEvent cEvent refresh (TaskRepOpts (Just layout) Nothing) state iworld 
390 391
		eval` eEvent cEvent refresh repAs state iworld
			= eval eEvent cEvent refresh repAs state iworld 
392

393
instance tune ModifyLayout
394 395 396
where
	tune (ModifyLayout f) (Task eval)	= Task eval`
	where
397 398 399 400
		eval` eEvent cEvent refresh (TaskRepOpts layout Nothing) state iworld
			= eval eEvent cEvent refresh (TaskRepOpts layout (Just f)) state iworld 
		eval` eEvent cEvent refresh (TaskRepOpts layout (Just g)) state iworld
			= eval eEvent cEvent refresh (TaskRepOpts layout (Just (g o f))) state iworld 	
401 402
		eval` eEvent cEvent refresh repAs state iworld
			= eval eEvent cEvent refresh repAs state iworld 
403