Core.icl 44.2 KB
Newer Older
1 2
implementation module iTasks.WF.Combinators.Core

Mart Lubbers's avatar
Mart Lubbers committed
3
import StdEnv
4
import StdOverloadedList
Mart Lubbers's avatar
Mart Lubbers committed
5

Mart Lubbers's avatar
Mart Lubbers committed
6
import iTasks.SDS.Combinators.Common
7
import iTasks.SDS.Definition
Mart Lubbers's avatar
Mart Lubbers committed
8 9 10 11 12 13 14 15 16 17 18 19 20
import iTasks.SDS.Sources.Store
import iTasks.SDS.Sources.System
import iTasks.UI.Definition
import iTasks.UI.Editor.Common
import iTasks.UI.Layout.Common
import iTasks.UI.Tune
import iTasks.WF.Combinators.SDS
import iTasks.WF.Definition
import iTasks.WF.Derives
import iTasks.WF.Tasks.Core
import iTasks.WF.Tasks.IO
import iTasks.WF.Tasks.SDS
import iTasks.WF.Tasks.System
21

22
import iTasks.Engine
Mart Lubbers's avatar
Mart Lubbers committed
23

24
import iTasks.Internal.EngineTasks
25
import iTasks.Internal.DynamicUtil
26 27
import iTasks.Internal.Task
import iTasks.Internal.TaskState
28
import iTasks.Internal.TaskIO
29 30
import iTasks.Internal.TaskEval
import iTasks.Internal.IWorld
31
import iTasks.Internal.Util
32
import iTasks.Internal.AsyncSDS
Mart Lubbers's avatar
Mart Lubbers committed
33 34
import iTasks.Internal.AsyncTask
import iTasks.Internal.Serialization
35

Mart Lubbers's avatar
Mart Lubbers committed
36 37
import iTasks.Util.DeferredJSON
import Data.Queue
38

Mart Lubbers's avatar
Mart Lubbers committed
39
import iTasks.Extensions.DateTime
40 41

import qualified Data.Map as DM
42
import qualified Data.Set as DS
43 44
import qualified Data.Queue as DQ

45
import Data.Either, Data.Error, Data.Func
Mart Lubbers's avatar
Mart Lubbers committed
46
import Text
47
import Text.GenJSON
48
from Data.Functor import <$>, class Functor(fmap)
49
from Data.Map import qualified instance Functor (Map k)
50

Bas Lijnse's avatar
Bas Lijnse committed
51
derive gEq TaskChange
52
derive gDefault TaskListFilter, TaskId
53

54 55 56 57 58 59
instance toString AttachException
where
	toString InstanceNotFound	= "Cannot find task instance to attach"
	toString InstanceEvalError	= "Error in attached task instance "

derive class iTask AttachException
60

61
transformError :: ((TaskValue a) -> MaybeError TaskException (TaskValue b)) !(Task a) -> Task b
Mart Lubbers's avatar
Mart Lubbers committed
62
transformError f task = Task (eval task)
63
where
Mart Lubbers's avatar
Mart Lubbers committed
64
	eval (Task task) event evalOpts iworld = case task event evalOpts iworld of
Mart Lubbers's avatar
cleanup  
Mart Lubbers committed
65
		(ValueResult val lastEvent rep task, iworld) = case f val of
66
			Error e = (ExceptionResult e, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
67
			Ok v = (ValueResult v lastEvent rep (Task (eval task)), iworld)
Mart Lubbers's avatar
cleanup  
Mart Lubbers committed
68 69
		(ExceptionResult e, iworld)                  = (ExceptionResult e, iworld)
		(DestroyedResult, iworld)                    = (DestroyedResult, iworld)
70

71 72 73 74
removeDupBy :: (a a -> Bool) [a] -> [a]
removeDupBy eq [x:xs] = [x:removeDupBy eq (filter (not o eq x) xs)]
removeDupBy _ [] = []

75
step :: !(Task a) ((?a) -> ?b) [TaskCont a (Task b)] -> Task b | TC, JSONEncode{|*|} a
Mart Lubbers's avatar
Mart Lubbers committed
76
step lhs lhsValFun conts = Task evalinit
77
where
Mart Lubbers's avatar
Mart Lubbers committed
78 79 80
	//Initial setup:
	//Destroyed before first evaluation
	//evalinit :: !Event !TaskEvalOpts !*IWorld -> *(TaskResult a, !*IWorld)
Mart Lubbers's avatar
Mart Lubbers committed
81 82
	evalinit event evalOpts iworld
		| isDestroyOrInterrupt event = (DestroyedResult,iworld)
Mart Lubbers's avatar
Mart Lubbers committed
83 84
	//Check for duplicates
	evalinit event evalOpts iworld
Mart Lubbers's avatar
Mart Lubbers committed
85
		# iworld = if (length (removeDupBy actionEq conts) == length conts)
86
			iworld
87
			(iShowErr ["Duplicate actions in step"] iworld)
Mart Lubbers's avatar
Mart Lubbers committed
88 89
		# (taskIda, iworld) = getNextTaskId iworld
		= evalleft lhs [] taskIda event evalOpts iworld
90 91 92
	where
		actionEq (OnAction (Action a) _) (OnAction (Action b) _) = a == b
		actionEq _ _ = False
93

Mart Lubbers's avatar
Mart Lubbers committed
94 95 96
	//Evaluating the lhs
	//Destroyed when executing the lhs
	//evalleft :: (Task a) [String] TaskId Event TaskEvalOpts !*IWorld -> *(TaskResult a, IWorld)
Mart Lubbers's avatar
Mart Lubbers committed
97 98 99 100 101 102
	evalleft (Task lhs) prevEnabledActions leftTaskId event evalOpts iworld
		| isDestroyOrInterrupt event
			= case lhs event {TaskEvalOpts|evalOpts&taskId=leftTaskId} iworld of
				(DestroyedResult, iworld)    = (DestroyedResult, iworld)
				(ExceptionResult e, iworld)  = (ExceptionResult e, iworld)
				(ValueResult _ _ _ _,iworld) = (ExceptionResult (exception "Failed destroying lhs in step"), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
103
	//Execute lhs
Mart Lubbers's avatar
Mart Lubbers committed
104 105 106 107 108 109
	evalleft (Task lhs) prevEnabledActions leftTaskId event evalOpts=:{lastEval,taskId} iworld
		# mbAction = matchAction taskId event
		# (res, iworld) = lhs event {TaskEvalOpts|evalOpts&taskId=leftTaskId} iworld
		// Right  is a step
		# (mbCont, iworld) = case res of
			ValueResult val info rep lhs
Mart Lubbers's avatar
Mart Lubbers committed
110 111
				= case searchContValue val mbAction conts of
					//No match
112
					?None
Mart Lubbers's avatar
Mart Lubbers committed
113
						# info = {TaskEvalInfo|info & lastEvent = max lastEval info.TaskEvalInfo.lastEvent}
114
						# value = maybe NoValue (\v -> Value v False) (lhsValFun (case val of Value v _ = ?Just v; _ = ?None))
Mart Lubbers's avatar
Mart Lubbers committed
115 116
						# actions = contActions taskId val conts
						# curEnabledActions = [actionId action \\ action <- actions | isEnabled action]
117
						# sl = wrapStepUI taskId evalOpts event actions prevEnabledActions val rep
Mart Lubbers's avatar
Mart Lubbers committed
118 119 120 121 122 123 124
						= (Left (ValueResult
							value
							info
							sl
							(Task (evalleft lhs curEnabledActions leftTaskId))
							)
						, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
125
					//A match
126
					?Just rewrite
Mart Lubbers's avatar
Mart Lubbers committed
127 128
						//Send a destroyevent to the lhs
						# (_, iworld) = (unTask lhs) DestroyEvent {TaskEvalOpts|evalOpts&taskId=leftTaskId} iworld
Mart Lubbers's avatar
Mart Lubbers committed
129 130
						= (Right (rewrite, info.TaskEvalInfo.lastEvent, info.TaskEvalInfo.removedTasks), iworld)
			ExceptionResult e
Mart Lubbers's avatar
Mart Lubbers committed
131
				= case searchContException e conts of
Mart Lubbers's avatar
Mart Lubbers committed
132
					//No match
133
					?None         = (Left (ExceptionResult e), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
134
					//A match
135
					?Just rewrite = (Right (rewrite, lastEval, [|]), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
136 137 138 139 140 141 142 143 144
		= case mbCont of
			//No match, just pass through
			Left res = (res, iworld)
			//A match, continue with the matched rhs
			Right ((_, (Task rhs), _), lastEvent, removedTasks)
				//Execute the rhs with a reset event
				# (resb, iworld)        = rhs ResetEvent evalOpts iworld
				= case resb of
					ValueResult val info change=:(ReplaceUI _) (Task rhs)
145
						# info = {TaskEvalInfo|info & lastEvent = max lastEvent info.TaskEvalInfo.lastEvent, removedTasks = removedTasks ++| info.TaskEvalInfo.removedTasks}
Mart Lubbers's avatar
Mart Lubbers committed
146 147 148 149 150 151 152 153 154 155
						= (ValueResult
							val
							info
							change
							//Actually rewrite to the rhs
							(Task rhs)
						,iworld)
					ValueResult _ _ change _
						= (ExceptionResult (exception ("Reset event of task in step failed to produce replacement UI: ("+++ toString (toJSON change)+++")")), iworld)
					ExceptionResult e = (ExceptionResult e, iworld)
156

157
	wrapStepUI taskId evalOpts event actions prevEnabled val change
158 159 160 161 162 163
		| actionUIs =: []
			= case (event,change) of
				(ResetEvent,ReplaceUI (UI type attributes items)) //Mark the ui as a step
					= ReplaceUI (UI type (addClassAttr "step" attributes) items)
				_
					= change
Mart Lubbers's avatar
Mart Lubbers committed
164
		| otherwise	//Wrap in a container
165 166 167 168 169
			= case (event,change) of
				(ResetEvent,ReplaceUI ui) //On reset generate a new step UI
					= ReplaceUI (uiac UIContainer (classAttr ["step-actions"]) [ui:actionUIs])
				_  //Otherwise create a compound change definition
					= ChangeUI [] [(0,ChangeChild change):actionChanges]
170
	where
171
		actionUIs = contActions taskId val conts
172 173 174 175 176
		actionChanges = [(i,ChangeChild (switch (isEnabled ui) (actionId ui))) \\ ui <- actions & i <- [1..]]
		where
			switch True name = if (isMember name prevEnabled) NoChange (ChangeUI [SetAttribute "enabled" (JSONBool True)] [])
			switch False name = if (isMember name prevEnabled) (ChangeUI [SetAttribute "enabled" (JSONBool False)] []) NoChange

177
matchAction :: TaskId Event -> ?String
178
matchAction taskId (ActionEvent matchId action)
179 180
	| matchId == taskId = ?Just action
matchAction taskId _ = ?None
181 182 183 184 185 186 187 188 189 190

isEnabled (UI _ attr _) = maybe False (\(JSONBool b) -> b) ('DM'.get "enabled" attr)
actionId (UI _ attr _) = maybe "" (\(JSONString s) -> s) ('DM'.get "actionId" attr)

contActions :: TaskId (TaskValue a) [TaskCont a b]-> [UI]
contActions taskId val conts = [actionUI (isJust (taskbf val)) action\\ OnAction action taskbf <- conts]
where
	actionUI enabled action=:(Action actionId)
		= uia UIAction ('DM'.unions [enabledAttr enabled, taskIdAttr (toString taskId), actionIdAttr actionId])

191 192
searchContValue :: (TaskValue a) (?String) [TaskCont a b] -> ?(!Int, !b, !DeferredJSON) | TC a & JSONEncode{|*|} a
searchContValue val mbAction conts = search val mbAction 0 ?None conts
193
where
Mart Lubbers's avatar
Mart Lubbers committed
194
	search _ _ _ mbMatch []							= mbMatch		//No matching OnValue steps were found, return the potential match
195
	search val mbAction i mbMatch [OnValue f:cs]
196
		= case f val of
197 198 199 200 201 202 203 204 205 206 207
			?Just cont = ?Just (i, cont, DeferredJSON val) //Don't look any further, first matching trigger wins
			?None      = search val mbAction (i + 1) mbMatch cs //Keep search
	search val mbAction=:(?Just actionEvent) i ?None [OnAction (Action actionName) f:cs]
		| actionEvent == actionName = 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)
			?None      = search val mbAction (i + 1) ?None cs                               //Keep searching
		| otherwise = search val mbAction (i + 1) ?None cs                                  //Keep searching
	search val mbAction i mbMatch [_:cs] = search val mbAction (i + 1) mbMatch cs           //Keep searching

searchContException :: (Dynamic,String) [TaskCont a b] -> ?(Int, !b, !DeferredJSON)
searchContException (dyn,str) conts = search dyn str 0 ?None conts
208
where
Mart Lubbers's avatar
Mart Lubbers committed
209 210
	search _ _ _ catchall []                        = catchall                                                        //Return the maybe catchall
	search dyn str i catchall [OnException f:cs]    = case (match f dyn) of
211 212 213 214
		?Just (taskb,enca) = ?Just (i, taskb, enca)                                            //We have a match
		_                  = search dyn str (i + 1) catchall cs                            //Keep searching
	search dyn str i ?None [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
Haye Böhm's avatar
Haye Böhm committed
215

216 217 218
	match :: (e -> b) Dynamic -> ?(b, DeferredJSON) | iTask e
	match f (e :: e^)    = ?Just (f e, DeferredJSON e)
	match _ _            = ?None
219 220

// Parallel composition
221
parallel :: ![(ParallelTaskType,ParallelTask a)] [TaskCont [(Int,TaskValue a)] (ParallelTaskType,ParallelTask a)] -> Task [(Int,TaskValue a)] | iTask a
Mart Lubbers's avatar
Mart Lubbers committed
222
parallel initTasks conts = Task evalinit
223
where
Mart Lubbers's avatar
Mart Lubbers committed
224
	//Destroyed before initial execution
Mart Lubbers's avatar
Mart Lubbers committed
225 226 227
	evalinit event _ iworld
		| isDestroyOrInterrupt event
			= (DestroyedResult, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
228 229 230
	//Initialize the task list
	evalinit event evalOpts=:{TaskEvalOpts|taskId} iworld
	//Create the states for the initial tasks
231
		= case initParallelTasks evalOpts taskId initTasks iworld of
Mart Lubbers's avatar
Mart Lubbers committed
232
			(Ok (taskList,embeddedTasks),iworld)
233
				//Write the initial local task list (no need to set relevant columns, because no one is registered yet)
234
				# (e,iworld) = write taskList (sdsFocus (taskId, taskId, fullTaskListFilter) taskInstanceParallelTaskList) EmptyContext iworld
Mart Lubbers's avatar
Mart Lubbers committed
235 236
				| isError e = (ExceptionResult (fromError e),iworld)
				//Write the local embedded tasks
237
				# (e,iworld) = write ('DM'.fromList embeddedTasks) (sdsFocus (taskId, taskId, fullTaskListFilter) taskInstanceParallelTaskListTasks) EmptyContext iworld
Mart Lubbers's avatar
Mart Lubbers committed
238 239
				| isError e = (ExceptionResult (fromError e),iworld)
				//Evaluate the parallel
Mart Lubbers's avatar
Mart Lubbers committed
240
				= eval (length embeddedTasks) [] event evalOpts iworld
Mart Lubbers's avatar
Mart Lubbers committed
241 242 243
			(Error err,iworld)
				= (ExceptionResult err, iworld)
	where
244 245 246
		initParallelTasks _ _ [] iworld = (Ok ([],[]),iworld)
		initParallelTasks evalOpts listId [(parType,parTask):parTasks] iworld
			# (mbStateMbTask, iworld) = initParallelTask evalOpts listId parType parTask iworld
Mart Lubbers's avatar
Mart Lubbers committed
247 248
			= case mbStateMbTask of
					Ok (state,mbTask)
249
						# (mbStateTasks, iworld) = initParallelTasks evalOpts listId parTasks iworld
Mart Lubbers's avatar
Mart Lubbers committed
250
						= case mbStateTasks of
251 252 253
							Ok (states,tasks)
								= (Ok ([state:states], maybe tasks (\task -> [(state.TaskMeta.taskId,task):tasks]) mbTask), iworld)
							err = (err, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
254 255
					err = (liftError err, iworld)

Mart Lubbers's avatar
Mart Lubbers committed
256 257
	eval _ _ ServerInterruptedEvent _ iworld
		= (DestroyedResult, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
258 259 260
	eval _ _ DestroyEvent {TaskEvalOpts|taskId} iworld
		= destroyParallelTasks taskId iworld

Mart Lubbers's avatar
Mart Lubbers committed
261
	//Evaluate the task list
Mart Lubbers's avatar
Mart Lubbers committed
262
	eval prevNumBranches prevEnabledActions event evalOpts=:{TaskEvalOpts|taskId} iworld
Mart Lubbers's avatar
Mart Lubbers committed
263
		//Evaluate all branches of the parallel set
264
		= case evalParallelTasks event evalOpts conts [] [] 'DM'.newMap iworld of
Mart Lubbers's avatar
Mart Lubbers committed
265
			(Ok results, iworld)
266 267 268 269
				//Clean up the stored task list (remove entries marked as removed etc.)
				# (mbRes,iworld) = cleanupParallelTaskList taskId iworld
				//| mbRes =:(Error _) = (Error (fromError mbRes),iworld)
				//Construct the combined task result
Mart Lubbers's avatar
Mart Lubbers committed
270 271 272 273
				# value     = genParallelValue results
				# evalInfo  = genParallelEvalInfo results
				# actions   = contActions taskId value conts
				# rep       = genParallelRep evalOpts event actions prevEnabledActions results prevNumBranches
Mart Lubbers's avatar
Mart Lubbers committed
274
				# curEnabledActions = [actionId action \\ action <- actions | isEnabled action]
275 276
				# curNumBranches = length [()\\(ValueResult _ _ _ _)<-results]
				= (ValueResult value evalInfo rep (Task (eval curNumBranches curEnabledActions)), iworld)
277
			//Stopped because of an unhandled exception
Mart Lubbers's avatar
Mart Lubbers committed
278
			(Error e, iworld)
279
				//Clean up before returning the exception
Mart Lubbers's avatar
Mart Lubbers committed
280
				# (res,iworld) = destroyParallelTasks taskId iworld
281
				= (exceptionResult res e,iworld)
282
	where
283
		exceptionResult :: (TaskResult [(Int,TaskValue a)]) TaskException -> (TaskResult [(Int,TaskValue a)])
284 285
		exceptionResult DestroyedResult e = ExceptionResult e
		exceptionResult (ExceptionResult _) e = ExceptionResult e
286

Mart Lubbers's avatar
Mart Lubbers committed
287
		genParallelEvalInfo :: [TaskResult a] -> TaskEvalInfo
288
		genParallelEvalInfo results = foldr addResult {TaskEvalInfo|lastEvent=0,removedTasks=[|]} results
Mart Lubbers's avatar
Mart Lubbers committed
289 290 291
		where
			addResult (ValueResult _ i1 _ _) i2
				# lastEvent = max i1.TaskEvalInfo.lastEvent i2.TaskEvalInfo.lastEvent
292
				# removedTasks = i1.TaskEvalInfo.removedTasks ++| i2.TaskEvalInfo.removedTasks
293
				= {TaskEvalInfo|lastEvent=lastEvent,removedTasks=removedTasks}
Mart Lubbers's avatar
Mart Lubbers committed
294
			addResult _ i = i
295 296 297 298 299 300 301 302

initParallelTask ::
	!TaskEvalOpts
	!TaskId
	!ParallelTaskType
	!(ParallelTask a)
	!*IWorld
	->
303
	(!MaybeError TaskException (TaskMeta, ?(Task a)), !*IWorld)
304
	| iTask a
305 306 307 308 309 310 311 312 313
initParallelTask evalOpts listId Embedded parTask iworld=:{options,clock,current={taskTime}}
	# (taskId,iworld) = getNextTaskId iworld
	# task            = parTask (sdsTranslate "setTaskAndList" (\listFilter -> (listId,taskId,listFilter)) parallelTaskList)
	# meta =
		{ TaskMeta
		| taskId               = taskId
		, instanceType         = PersistentInstance
		, build                = options.EngineOptions.appVersion
		, createdAt            = clock
314
		, detachedFrom         = ?Just listId
315 316 317 318
		, nextTaskNo           = 0
		, nextTaskTime         = 0
		, status               = Right False
		, attachedTo           = []
319 320 321 322 323
		, connectedTo          = ?None
		, instanceKey          = ?None
		, firstEvent           = ?Just clock
		, lastEvent            = ?Just clock
		, lastIO               = ?None
324
		, cookies              = 'DM'.newMap
325 326 327
		, taskAttributes       = 'DM'.newMap
		, managementAttributes = 'DM'.newMap
		, unsyncedAttributes   = 'DS'.newSet
328
		, unsyncedCookies      = []
329
		, change               = ?None
330 331
		, initialized          = False
		}
332
	= (Ok (meta, ?Just task),iworld)
333 334 335 336 337 338 339 340
initParallelTask evalOpts listId (Detached evalDirect initManagementAttr) parTask iworld=:{options,clock,current={taskTime}}
	//We need to know the instance number in advance, so we can pass the correctly focused task list share
	//to the detached parallel task
	# (mbInstanceNo,iworld) = newInstanceNo iworld
	= case mbInstanceNo of
		Ok instanceNo
			# listShare = sdsTranslate "setTaskAndList" (\listFilter -> (listId, TaskId instanceNo 0, listFilter)) parallelTaskList
			= case createDetachedTaskInstance (parTask listShare) evalOpts instanceNo initManagementAttr listId evalDirect iworld of
341
				(Ok meta,iworld) = (Ok (meta, ?None), iworld)
342 343
				(err,iworld)     = (liftError err, iworld)
		Error e = (Error e, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
344

Mart Lubbers's avatar
Mart Lubbers committed
345
evalParallelTasks :: !Event !TaskEvalOpts
346
	[TaskCont [(TaskTime,TaskValue a)] (ParallelTaskType,ParallelTask a)]
347
	[(TaskId, TaskResult a)] [TaskMeta] (Map TaskId (TaskValue a)) !*IWorld
348
	->
349
	(MaybeError TaskException [TaskResult a],!*IWorld) | iTask a
350
evalParallelTasks event evalOpts=:{TaskEvalOpts|taskId=listId} conts completed [] values iworld
Mart Lubbers's avatar
Mart Lubbers committed
351
	//(re-)read the tasklist to check if it contains items we have not yet evaluated
352
	# filter = {TaskListFilter|fullTaskListFilter & notTaskId = ?Just (map fst completed)} //Explicitly exclude the tasks we already evaluated
353
	# (mbList,iworld)       = read (sdsFocus (listId,listId,filter) (taskInstanceParallelTaskList |*| taskInstanceParallelTaskListValues)) EmptyContext iworld
Mart Lubbers's avatar
Mart Lubbers committed
354
	| mbList =:(Error _)    = (Error (fromError mbList),iworld)
355 356
	# ((_,states),values)   = directResult (fromOk mbList)
	= case states of
Mart Lubbers's avatar
Mart Lubbers committed
357
		//We are done, unless we have continuations that extend the set
358
		[] = case searchContValue (genParallelValue (reverse (map snd completed))) (matchAction listId event) conts of
359
			?None //We have evaluated all branches and nothing is added anymore
360
                = (Ok $ reverse $ map snd completed, iworld)
361
			?Just (_,(type,task),_) //One of the rules for extending the list triggered
362 363
				= case initParallelTask evalOpts listId type task iworld of
					(Ok (state,mbTask),iworld)
364
					  # taskId                    = state.TaskMeta.taskId
365
					  # (mbError,iworld)          = modify (\(_,states) -> states ++ [state])
366
							(sdsFocus (listId,taskId,fullTaskListFilter) taskInstanceParallelTaskList) EmptyContext iworld
Mart Lubbers's avatar
Mart Lubbers committed
367 368
					  | mbError =:(Error _)       = (liftError mbError,iworld)
					  //Store the task function
369
					  # (mbError,iworld)          = (write (fromJust mbTask @? encodeTaskValue) (sdsFocus (listId,taskId) taskInstanceParallelTaskListTask) EmptyContext iworld)
Mart Lubbers's avatar
Mart Lubbers committed
370
					  | mbError =:(Error _)       = (liftError mbError,iworld)
371
					  = evalParallelTasks ResetEvent evalOpts conts completed [state] values iworld //Continue
372
					(err,iworld) = (liftError err, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
373
		//There is more work to do:
374
		todo = evalParallelTasks event evalOpts conts completed todo values iworld
375

376
evalParallelTasks event evalOpts=:{TaskEvalOpts|taskId=listId} conts completed [t=:{TaskMeta|taskId=taskId=:(TaskId _ taskNo)}:todo] values iworld
377 378
	# lastValue = fromMaybe NoValue $ 'DM'.get taskId values
	= case evalParallelTask listId event evalOpts t lastValue iworld of
379
		(Error e, iworld) = (Error e,iworld)
380
		(Ok (ExceptionResult e), iworld) = (Error e,iworld) //Stop on exceptions
381
		(Ok result=:(ValueResult val {TaskEvalInfo|lastEvent,removedTasks} rep task), iworld)
382
			//Add the current result before checking for removals
Mart Lubbers's avatar
Mart Lubbers committed
383
			# completed = [(taskId, result):completed]
384
			//Check if in the branch tasks from this list were removed but that were already evaluated
385
			# removed = [t \\ {removedTaskListId=l,removedTaskId=t=:(TaskId _ n)} <|- removedTasks | l == listId && n <= taskNo]
386
			# (completed,iworld) = destroyRemoved listId removed completed iworld
387
			= evalParallelTasks event evalOpts conts completed todo values iworld
388
		(Ok result=:DestroyedResult, iworld)
389
			= evalParallelTasks event evalOpts conts [(taskId, result):completed] todo values iworld
390 391 392 393 394 395

evalParallelTask :: TaskId !Event !TaskEvalOpts TaskMeta (TaskValue a) !*IWorld
	-> *(MaybeError TaskException (TaskResult a), !*IWorld) | iTask a
evalParallelTask listId=:(TaskId listInstanceNo _) event evalOpts taskState=:{TaskMeta|taskId=TaskId instanceNo _} value iworld
	| instanceNo <> listInstanceNo = evalDetachedParallelTask listId event evalOpts taskState iworld
                                   = evalEmbeddedParallelTask listId event evalOpts taskState value iworld
Mart Lubbers's avatar
Mart Lubbers committed
396
where
397 398 399 400 401 402 403 404 405 406 407 408
	//Retrieve result of detached parallel task
	evalDetachedParallelTask :: !TaskId !Event !TaskEvalOpts !TaskMeta !*IWorld -> *(MaybeError TaskException (TaskResult a), *IWorld) | iTask a
	evalDetachedParallelTask listId event evalOpts localMeta=:{TaskMeta|taskId=taskId=:(TaskId instanceNo _),managementAttributes,unsyncedAttributes} iworld
		//If we have local management updates, first synchronize them to the detached task list entry
		# (mbError,iworld) = modify (syncManagementAttributes managementAttributes unsyncedAttributes)
			(sdsFocus (instanceNo,False,False) taskInstance) EmptyContext iworld
		| mbError =:(Error _) = (Error (fromError mbError),iworld)
		//Synchronize the meta-data and value
		= case readRegister listId (sdsFocus (instanceNo,False,False) taskInstance |*| sdsFocus instanceNo taskInstanceValue) iworld of
			(Error e,iworld) = (Error e,iworld)
			(Ok (ReadingDone (detachedMeta,encoded)),iworld)
				# value = decode encoded
409
				# evalInfo = {TaskEvalInfo|lastEvent=0,removedTasks=[|]}
410 411 412 413 414
				# result = ValueResult value evalInfo NoChange nopTask
				//Synchronize the record in the local list with the entry in the global list
                # (mbError,iworld) = write detachedMeta (sdsFocus (listId,taskId,False) taskInstanceParallelTaskListItem) EmptyContext iworld
				| mbError =:(Error _) = (Error (fromError mbError),iworld)
				= (Ok (ValueResult value evalInfo NoChange nopTask), iworld)
415
	where
416 417
		decode (Value enc stable) = maybe NoValue (\dec -> Value dec stable) (fromDeferredJSON enc)
		decode NoValue = NoValue 
Mart Lubbers's avatar
Mart Lubbers committed
418

419 420 421 422 423 424 425
		syncManagementAttributes localAttr syncKeys meta=:{TaskMeta|managementAttributes}
			 = {TaskMeta|meta & managementAttributes = 'DM'.union syncAttr managementAttributes}
		where
			syncAttr = 'DM'.filterWithKey (\k v -> 'DS'.member k syncKeys) localAttr

	evalEmbeddedParallelTask :: !TaskId !Event !TaskEvalOpts !TaskMeta (TaskValue a) !*IWorld -> *(MaybeError TaskException (TaskResult a), *IWorld) | iTask a
	evalEmbeddedParallelTask listId event evalOpts meta=:{TaskMeta|taskId,createdAt,change,initialized} value iworld=:{current={taskTime}}
426
		//Check if we need to destroy the branch
427
		| change === ?Just RemoveTask
Mart Lubbers's avatar
Mart Lubbers committed
428 429 430 431
			# (result, iworld) = destroyEmbeddedParallelTask listId taskId iworld
			= case result of
				(Ok res) = (Ok res,iworld)
				(Error e) = (Error (exception (ExceptionList e)), iworld)
432
		//Lookup task evaluation function, and task evaluation state
433 434
		# thisTask = sdsFocus (listId,taskId) taskInstanceParallelTaskListTask
		# (mbTask,iworld) = read thisTask EmptyContext iworld
435 436
		| mbTask =:(Error _) = (Error (fromError mbTask),iworld)
		# (Task evala) = directResult (fromOk mbTask)
Mart Lubbers's avatar
Mart Lubbers committed
437 438
		//Evaluate new branches with a reset event, other with the event
		= case evala (if initialized event ResetEvent) {TaskEvalOpts|evalOpts&taskId=taskId} iworld of
Mart Lubbers's avatar
Mart Lubbers committed
439 440
			(DestroyedResult, iworld)
				= (Ok DestroyedResult, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
441 442 443 444 445
			//If an exception occured, check if we can handle it at this level
			(ExceptionResult e, iworld)
				//TODO Check exception
				//If the exception can not be handled, don't continue evaluating just stop
				= (Ok (ExceptionResult e),iworld)
446
			(ValueResult val evalInfo=:{TaskEvalInfo|lastEvent,removedTasks} change task, iworld)
447
				# val = decodeTaskValue val
448 449
				//Isolate changes to implicit task attributes
				# taskAttributeUpdate = case change of
450 451 452
					ReplaceUI (UI _ attributes _) = const attributes
					ChangeUI changes _ = \a -> foldl (flip applyUIAttributeChange) a changes
					_ = id
453 454 455 456 457 458
				//Add unsynced changes to management attributes. We need to re-read the tasklist item because they may have
				//been modified by the other branches
				# (mbManagementMeta,iworld) = read (sdsFocus (listId,taskId,False) taskInstanceParallelTaskListItem) EmptyContext iworld
				| mbManagementMeta=:(Error _) = (Error (fromError mbManagementMeta),iworld)
				# change = addManagementAttributeChanges (directResult $ fromOk mbManagementMeta) change
				//Construct task result
459
				# result = ValueResult val evalInfo change (task @? decodeTaskValue)
Mart Lubbers's avatar
Mart Lubbers committed
460
				//Check if the value changed
461
				# valueChanged = val =!= value
Mart Lubbers's avatar
Mart Lubbers committed
462
				//Write the new reduct
463
				# (mbError, iworld) = write task thisTask EmptyContext iworld
Mart Lubbers's avatar
Mart Lubbers committed
464
				| mbError =:(Error _) = (Error (fromError mbError), iworld)
465 466
				//Write meta data
                # (mbError,iworld) = modify
467
						(\meta -> {TaskMeta|meta & status = valueStatus val,
468
							taskAttributes = taskAttributeUpdate meta.TaskMeta.taskAttributes, unsyncedAttributes = 'DS'.newSet, initialized = True})
469
                        (sdsFocus (listId,taskId,valueChanged) taskInstanceParallelTaskListItem)
470
						EmptyContext iworld
Mart Lubbers's avatar
Mart Lubbers committed
471
				| mbError =:(Error _) = (Error (fromError mbError),iworld)
472
				| not valueChanged 
473
					= (Ok result, iworld)
474
                //Write updated value
475
				# (mbError,iworld) = write val (sdsFocus (listId,taskId) taskInstanceParallelTaskListValue) EmptyContext iworld
476
				| mbError =:(Error _) = (Error (fromError mbError),iworld)
477
				= (Ok result, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
478 479
	where
		(TaskId instanceNo taskNo)   = taskId
480

481 482
		valueStatus (Value _ True) = Right True
		valueStatus _ = Right False
483 484 485 486 487 488 489

		addManagementAttributeChanges {TaskMeta|unsyncedAttributes,managementAttributes} change 
			= mergeUIChanges change (ChangeUI [SetAttribute k v \\ (k,v) <- 'DM'.toList managementAttributes | 'DS'.member k unsyncedAttributes] [])

cleanupParallelTaskList :: !TaskId !*IWorld -> *(MaybeError TaskException (), *IWorld)
cleanupParallelTaskList listId iworld
	//Remove all entries that are marked as removed from the list, they have been cleaned up by now
490
	# (res,iworld) = modify (filter (not o isRemoved) o snd)
491
		(sdsFocus (listId,listId,fullTaskListFilter) taskInstanceParallelTaskList) EmptyContext iworld
492 493
	= (const () <$> res, iworld)
where
494
	isRemoved {TaskMeta|change= ?Just RemoveTask} = True
495 496
	isRemoved _ = False

Mart Lubbers's avatar
Mart Lubbers committed
497 498 499
destroyParallelTasks :: !TaskId !*IWorld -> *(TaskResult [(Int,TaskValue a)], *IWorld) | iTask a
destroyParallelTasks listId=:(TaskId instanceNo _) iworld
	// Unlink registrations for all detached tasks
500
	# iworld = clearTaskSDSRegistrations ('DS'.singleton listId) iworld
501
	= case read (sdsFocus (listId, listId, fullTaskListFilter) taskInstanceParallelTaskList) EmptyContext iworld of
Mart Lubbers's avatar
Mart Lubbers committed
502
		(Error e,iworld) = (ExceptionResult e, iworld)
503
		(Ok (ReadingDone (_,taskStates)),iworld)
Mart Lubbers's avatar
Mart Lubbers committed
504 505
			// Destroy all child tasks (`result` is always `DestroyedResult` but passed to solve overloading
			# (result,exceptions,iworld) = foldl (destroyParallelTask listId) (DestroyedResult, [], iworld) taskStates
506

507
			// Remove the (shared) tasklist/value/reduct
508
			# (exceptions,iworld) = case write [] (sdsFocus (listId,listId,fullTaskListFilter,fullExtendedTaskListFilter) taskListMetaData) EmptyContext iworld of
509
				(Ok (WritingDone ),iworld) = (exceptions,iworld)
510
				(Error e,iworld) = ([e:exceptions],iworld)
511 512 513 514 515 516 517 518 519 520
			| not $ exceptions =: [] = (ExceptionResult (exception (ExceptionList exceptions)), iworld)
			# (exceptions,iworld) = case write 'DM'.newMap (sdsFocus (listId,listId,fullTaskListFilter,fullExtendedTaskListFilter) taskListDynamicValueData) EmptyContext iworld of
				(Ok (WritingDone ),iworld) = (exceptions,iworld)
				(Error e,iworld) = ([e:exceptions],iworld)
			| not $ exceptions =: [] = (ExceptionResult (exception (ExceptionList exceptions)), iworld)
			# (exceptions,iworld) = case write 'DM'.newMap (sdsFocus (listId,listId,fullTaskListFilter,fullExtendedTaskListFilter) taskListDynamicTaskData) EmptyContext iworld of
				(Ok (WritingDone ),iworld) = (exceptions,iworld)
				(Error e,iworld) = ([e:exceptions],iworld)
			| not $ exceptions =: [] = (ExceptionResult (exception (ExceptionList exceptions)), iworld)
			= (destroyResult result, iworld)
521
where
522
	destroyParallelTask listId=:(TaskId listInstance _) (_,exceptions,iworld) {TaskMeta|taskId=taskId=:(TaskId taskInstance _)}
Mart Lubbers's avatar
Mart Lubbers committed
523 524 525
		= case (if detached destroyDetachedParallelTask destroyEmbeddedParallelTask) listId taskId iworld of
			(Error e, iworld) = (DestroyedResult, e ++ exceptions,iworld)
			(Ok res, iworld) = (res, exceptions,iworld)
526 527
	where
		detached = taskInstance <> listInstance
528

529
	destroyResult :: (TaskResult a) -> (TaskResult [(Int,TaskValue a)])
530 531
	destroyResult DestroyedResult = DestroyedResult
	destroyResult (ExceptionResult e) = ExceptionResult e
Mart Lubbers's avatar
Mart Lubbers committed
532
	destroyResult (ValueResult _ _ _ _) = ExceptionResult (exception "Valueresult in a destroy?")
533

Mart Lubbers's avatar
Mart Lubbers committed
534 535
destroyEmbeddedParallelTask :: TaskId TaskId *IWorld -> *(MaybeError [TaskException] (TaskResult a), *IWorld) | iTask a
destroyEmbeddedParallelTask listId=:(TaskId instanceNo _) taskId iworld=:{current={taskTime}}
536
	# (errs,destroyResult,iworld) = case read (sdsFocus (listId,taskId) taskInstanceParallelTaskListTask) EmptyContext iworld of
Mart Lubbers's avatar
Mart Lubbers committed
537
		(Error e,iworld) = ([e], DestroyedResult,iworld)
Haye Böhm's avatar
Haye Böhm committed
538
		(Ok (ReadingDone (Task eval)),iworld)
Mart Lubbers's avatar
Mart Lubbers committed
539
			= case eval DestroyEvent {mkEvalOpts & noUI = True, taskId=taskId} iworld of
540 541 542 543
				(DestroyedResult,   iworld) = ([],  DestroyedResult, iworld)
				(ExceptionResult e, iworld) = ([e], DestroyedResult, iworld)
				(_,                 iworld) =
					([exception "destroyEmbeddedParallelTask: unexpected result"],DestroyedResult,iworld)
Mart Lubbers's avatar
Mart Lubbers committed
544
	// 2. Remove the task evaluation function
545 546
	# (errs,iworld) = case modify (\tasks -> 'DM'.del taskId tasks)
	                              (sdsFocus (listId,listId,defaultValue,defaultValue) taskListDynamicTaskData) EmptyContext iworld of
547
		(Error e,iworld) = ([e:errs],iworld)
Haye Böhm's avatar
Haye Böhm committed
548
		(Ok (ModifyingDone _),iworld) = (errs,iworld)
Mart Lubbers's avatar
Mart Lubbers committed
549
	= (Ok destroyResult, iworld)
550

Mart Lubbers's avatar
Mart Lubbers committed
551 552
destroyDetachedParallelTask :: TaskId TaskId *IWorld -> *(MaybeError [TaskException] (TaskResult a), *IWorld) | iTask a
destroyDetachedParallelTask listId=:(TaskId instanceNo _) taskId iworld
553 554
	//TODO: Detached parallel tasks should be marked that their parent no longer needs their result
	//      That way attach combinators can be programmed to notify the user or simply stop the task
Mart Lubbers's avatar
Mart Lubbers committed
555
	= (Ok DestroyedResult, iworld)
556

Mart Lubbers's avatar
Mart Lubbers committed
557
destroyRemoved :: TaskId [TaskId] [(TaskId, TaskResult a)] *IWorld -> ([(TaskId, TaskResult a)], *IWorld) | iTask a
558
destroyRemoved listId removed [] iworld = ([],iworld)
Mart Lubbers's avatar
Mart Lubbers committed
559 560 561 562 563
destroyRemoved listId removed [r=:(taskId, _):rs] iworld
	| isMember taskId removed
		= case destroyEmbeddedParallelTask listId taskId iworld of
			(Error e, iworld) = ([(taskId, ExceptionResult (exception (ExceptionList e))):rs], iworld)
			(Ok tr, iworld)
564
				# (rs,iworld) = destroyRemoved listId removed rs iworld
Mart Lubbers's avatar
Mart Lubbers committed
565
				= ([(taskId, tr):rs],iworld)
566 567 568
	# (rs,iworld) = destroyRemoved listId removed rs iworld
	= ([r:rs],iworld)

569
genParallelValue :: [TaskResult a] -> TaskValue [(TaskTime,TaskValue a)]
570 571 572 573 574 575
genParallelValue results = Value [(lastEvent,val) \\ ValueResult val {TaskEvalInfo|lastEvent} _ _ <- results] False

genParallelRep :: !TaskEvalOpts !Event [UI] [String] [TaskResult a] Int -> UIChange
genParallelRep evalOpts event actions prevEnabledActions results prevNumBranches
	= case event of
		ResetEvent
576
			= ReplaceUI (uiac UIContainer (classAttr [className]) ([def \\ ValueResult _ _ (ReplaceUI def) _ <- results] ++ actions))
Haye Böhm's avatar
Haye Böhm committed
577
		_
578 579 580 581
			# (idx,iChanges) = itemChanges 0 prevNumBranches results
			# aChanges       = actionChanges idx
			= ChangeUI [] (iChanges ++ aChanges)
where
582 583
	className = if (actions =: []) "parallel" "parallel-actions"

584 585 586 587 588 589 590 591 592 593 594
	itemChanges i numExisting [] = (i,[])
	itemChanges i numExisting [ValueResult _ _ change _:rs]
		| i < numExisting
			# (i`,changes) = itemChanges (i + 1) numExisting rs
			= (i`,[(i,ChangeChild change):changes]) 	//Update an existing branch
		| otherwise			= case change of
			(ReplaceUI def)
				# (i`,changes) = itemChanges (i + 1) (numExisting + 1) rs
				= (i`,[(i,InsertChild def):changes]) 	//Add a new branch
			_
				= itemChanges (i + 1) (numExisting + 1) rs //Skip if we don't get a blank UI
Haye Böhm's avatar
Haye Böhm committed
595

596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615
	itemChanges i numExisting [DestroyedResult:rs]
		| i < numExisting
			# (i`,changes) = itemChanges i (numExisting - 1) rs
			= (i`,[(i,RemoveChild):changes])
		| otherwise
			= itemChanges i numExisting rs //No need to destroy a branch that was not yet in the UI

	itemChanges i numExisting [ExceptionResult e:rs]
		| i < numExisting
			# (i`,changes) = itemChanges i (numExisting - 1) rs
			= (i`,[(i,RemoveChild):changes])
		| otherwise
			= itemChanges i numExisting rs

	actionChanges startIdx = [(i,ChangeChild (switch (isEnabled ui) (actionId ui))) \\ ui <- actions & i <- [startIdx..]]
	where
		switch True name = if (isMember name prevEnabledActions) NoChange (ChangeUI [SetAttribute "enabled" (JSONBool True)] [])
		switch False name = if (isMember name prevEnabledActions) (ChangeUI [SetAttribute "enabled" (JSONBool False)] []) NoChange

genParallelEvalInfo :: [TaskResult a] -> TaskEvalInfo
616
genParallelEvalInfo results = foldr addResult {TaskEvalInfo|lastEvent=0,removedTasks=[|]} results
617 618 619
where
    addResult (ValueResult _ i1 _ _) i2
        # lastEvent = max i1.TaskEvalInfo.lastEvent i2.TaskEvalInfo.lastEvent
620
        # removedTasks = i1.TaskEvalInfo.removedTasks ++| i2.TaskEvalInfo.removedTasks
621
        = {TaskEvalInfo|lastEvent=lastEvent,removedTasks=removedTasks}
622 623
    addResult _ i = i

Bas Lijnse's avatar
Bas Lijnse committed
624
readListId :: (SharedTaskList a) *IWorld -> (MaybeError TaskException TaskId,*IWorld) | TC a
625
readListId slist iworld = case read (sdsFocus fullTaskListFilter slist) EmptyContext iworld of
626
	(Ok e,iworld)	= (Ok (fst (directResult e)), iworld)
627 628 629 630 631 632
	(Error e, iworld)	    = (Error e, iworld)

appendTask :: !ParallelTaskType !(ParallelTask a) !(SharedTaskList a) -> Task TaskId | iTask a
appendTask parType parTask slist = mkInstantTask eval
where
	eval _ iworld=:{current={taskTime}}
Mart Lubbers's avatar
Mart Lubbers committed
633 634 635 636
		# (mbListId,iworld) = readListId slist iworld
		| mbListId =:(Error _) = (mbListId,iworld)
		# listId = fromOk mbListId
		//Check if someone is trying to add an embedded task to the topLevel list
Bas Lijnse's avatar
Bas Lijnse committed
637
		| listId == TaskId 0 0 && parType =:(Embedded)
Mart Lubbers's avatar
Mart Lubbers committed
638
			= (Error (exception "Embedded tasks can not be added to the top-level task list"),iworld)
639
		# (mbStateMbTask, iworld) = initParallelTask mkEvalOpts listId parType parTask iworld
Mart Lubbers's avatar
Mart Lubbers committed
640 641
		= case mbStateMbTask of
			Ok (state,mbTask)
642
				# taskId = state.TaskMeta.taskId
Mart Lubbers's avatar
Mart Lubbers committed
643 644 645
				| listId == TaskId 0 0 //For the top-level list, we don't need to do anything else
					= (Ok taskId, iworld)
			  	//Update the task list
646
				# (mbError,iworld)    =  modify (\(_,states) -> states ++ [state]) (sdsFocus (listId,taskId,fullTaskListFilter) taskInstanceParallelTaskList) EmptyContext iworld
Mart Lubbers's avatar
Mart Lubbers committed
647 648
				| mbError =:(Error _) = (liftError mbError,iworld)
				//If the task is an embedded one, we also need to store the task function
649
				| mbTask =:(?Just _)
650
					# (mbError,iworld) = (write (fromJust mbTask @? encodeTaskValue) (sdsFocus (listId,taskId) taskInstanceParallelTaskListTask) EmptyContext iworld)
Mart Lubbers's avatar
Mart Lubbers committed
651 652 653 654
					| mbError =:(Error _) = (liftError mbError,iworld)
					= (Ok taskId, iworld)
				= (Ok taskId, iworld)
			err = (liftError err, iworld)
655 656 657
/**
* Removes (and stops) a task from a task list
*/
Bas Lijnse's avatar
Bas Lijnse committed
658
removeTask :: !TaskId !(SharedTaskList a) -> Task () | TC a
659 660
removeTask removeId=:(TaskId instanceNo taskNo) slist = Task eval
where
Mart Lubbers's avatar
Mart Lubbers committed
661
	eval DestroyEvent _ iworld = (DestroyedResult, iworld)