TaskEval.icl 14.8 KB
Newer Older
1
implementation module TaskEval
2

3
import StdList, StdBool, StdTuple
4
import Error
5
import SystemTypes, IWorld, Shared, Task, TaskState, TaskStore, Util, Func
6
import LayoutCombinators
7

8
from CoreCombinators	import :: ParallelTaskType(..), :: ParallelTask(..)
9
from Map				import qualified newMap, fromList, toList, get, put
10 11
from SharedDataSource	import qualified read, write, writeFilterMsg
from IWorld				import dequeueWorkFilter
12 13
import iTaskClass

14 15 16 17 18 19 20
createSessionTaskInstance :: !(Task a) !Event !*IWorld -> (!MaybeErrorString (!TaskResult JSONNode, !InstanceNo, !SessionId), !*IWorld) |  iTask a
createSessionTaskInstance task event iworld=:{currentDateTime,taskTime}
	# (sessionId,iworld)	= newSessionId iworld
	# (instanceNo,iworld)	= newInstanceNo iworld
	# worker				= AnonymousUser sessionId
	//Create the initial instance data in the store
	# mmeta					= defaultValue
21
	# pmeta					= {issuedAt=currentDateTime,issuedBy=worker,stable=False,firstEvent=Nothing,latestEvent=Nothing,latestAttributes='Map'.newMap}
22 23 24
	# meta					= createMeta instanceNo (Just sessionId) 0 (Just worker) mmeta pmeta
	# (_,iworld)			= 'SharedDataSource'.write meta (taskInstanceMeta instanceNo) iworld
	# (_,iworld)			= 'SharedDataSource'.write (createReduct instanceNo task taskTime) (taskInstanceReduct instanceNo) iworld
25
	# (_,iworld)			= 'SharedDataSource'.write (createResult instanceNo taskTime) (taskInstanceResult instanceNo) iworld
26 27 28 29 30 31 32 33 34 35 36 37 38 39
	//Register the sessionId -> instanceNo relation
	# iworld				= registerSession sessionId instanceNo iworld
	//Evaluate once
	# (mbResult,iworld)		= evalTaskInstance RefreshEvent instanceNo iworld
	= case mbResult of
		Ok result	= (Ok (result,instanceNo,sessionId),iworld)
		Error e		= (Error e, iworld)
where
	registerSession sessionId instanceNo iworld=:{IWorld|sessions}
		= {IWorld|iworld & sessions = 'Map'.put sessionId instanceNo sessions}

createTopTaskInstance  :: !(Task a) !ManagementMeta !User !InstanceNo !*IWorld -> (!TaskId, !*IWorld) | iTask a
createTopTaskInstance  task mmeta issuer parent iworld=:{currentDateTime,taskTime}
	# (instanceNo,iworld)	= newInstanceNo iworld
40
	# pmeta					= {issuedAt=currentDateTime,issuedBy=issuer,stable=False,firstEvent=Nothing,latestEvent=Nothing,latestAttributes='Map'.newMap}
41 42 43
	# meta					= createMeta instanceNo Nothing parent Nothing mmeta pmeta
	# (_,iworld)			= 'SharedDataSource'.write meta (taskInstanceMeta instanceNo) iworld
	# (_,iworld)			= 'SharedDataSource'.write (createReduct instanceNo task taskTime) (taskInstanceReduct instanceNo) iworld
44
	# (_,iworld)			= 'SharedDataSource'.write (createResult instanceNo taskTime) (taskInstanceResult instanceNo) iworld
45 46 47 48 49 50 51 52
	= (TaskId instanceNo 0, iworld)

createMeta :: !InstanceNo (Maybe SessionId) InstanceNo !(Maybe User) !ManagementMeta !ProgressMeta  -> TIMeta
createMeta instanceNo sessionId parent worker mmeta pmeta
	= {TIMeta|instanceNo=instanceNo,sessionId=sessionId,parent=parent,worker=worker,observes=[],observedBy=[],management=mmeta,progress=pmeta}

createReduct :: !InstanceNo !(Task a) !TaskTime -> TIReduct | iTask a
createReduct instanceNo task taskTime
53
	= {TIReduct|task=toJSONTask task,nextTaskNo=2,nextTaskTime=1,shares = 'Map'.newMap, lists = 'Map'.newMap, tasks= 'Map'.newMap}
54 55 56
where
	toJSONTask (Task eval) = Task eval`
	where
Bas Lijnse's avatar
Bas Lijnse committed
57
		eval` event repOpts tree iworld = case eval event repOpts tree iworld of
58 59
			(ValueResult val ts rep tree,iworld)	= (ValueResult (fmap toJSON val) ts rep tree, iworld)
			(ExceptionResult e str,iworld)			= (ExceptionResult e str,iworld)
60

61 62
createResult :: !InstanceNo !TaskTime -> TaskResult JSONNode
createResult instanceNo taskTime = ValueResult NoValue {TaskInfo|lastEvent=taskTime,refreshSensitive=True} (TaskRep (UIControlGroup {UIControlGroup|attributes='Map'.newMap, controls=[],direction = Vertical,actions = []}) []) (TCInit (TaskId instanceNo 0) 1)
63 64 65 66

//Evaluate a session task instance when a new event is received from a client
evalSessionTaskInstance :: !SessionId !Event !*IWorld -> (!MaybeErrorString (!TaskResult JSONNode, !InstanceNo, !SessionId), !*IWorld)
evalSessionTaskInstance sessionId event iworld 
67 68
	//Set session user
	# iworld				= {iworld & currentUser = AnonymousUser sessionId}
69 70
	//Update current datetime in iworld
	# iworld				= updateCurrentDateTime iworld
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
	//Determine which task instance to evaluate
	# (sessionNo, iworld)	= determineSessionInstanceNo sessionId iworld
	| sessionNo == 0		= (Error ("Could not load session " +++ sessionId), iworld)
	//Evaluate the task instance at which the event is targeted
	# (mbResult,iworld)		= evalTaskInstance event (eventTarget event sessionNo) iworld
	//Evaluate urgent task instances (just started workOn's for example)
	# iworld				= refreshUrgentTaskInstances iworld
	//If the session task is outdated compute it a second time
	# (outdated,iworld)		= isSessionOutdated sessionNo iworld
	| outdated
		# (mbResult,iworld)		= evalTaskInstance RefreshEvent sessionNo iworld
		= case mbResult of
			Ok result	= (Ok (result,sessionNo,sessionId),iworld)
			Error e		= (Error e, iworld)
	| otherwise
		= case mbResult of
			Ok result	= (Ok (result,sessionNo,sessionId),iworld)
			Error e		= (Error e, iworld)
89
where
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
	determineSessionInstanceNo sessionId iworld=:{IWorld|sessions}
		= case 'Map'.get sessionId sessions of
			Just no	= (no,iworld)
			_		= (0, iworld)

	isSessionOutdated sessionNo iworld //TODO: This function should not really be here
		# (work,iworld) = dequeueWorkFilter (\w -> case w of (Evaluate no) = (no == sessionNo); _ = False) iworld
		= (not (isEmpty work),iworld)

	eventTarget (EditEvent (TaskId no _) _ _)	_	= no
	eventTarget (ActionEvent (TaskId no _) _) _ 	= no
	eventTarget (FocusEvent (TaskId no _)) _		= no
	eventTarget RefreshEvent no						= no

//Evaluate a task instance, just to refresh its state
refreshTaskInstance :: !InstanceNo !*IWorld -> *IWorld
refreshTaskInstance instanceNo iworld
	= snd (evalTaskInstance RefreshEvent instanceNo iworld)

refreshUrgentTaskInstances :: !*IWorld -> *IWorld
refreshUrgentTaskInstances iworld
	# (work,iworld) = dequeueWorkFilter isUrgent iworld
	= seqSt refreshTaskInstance [instanceNo \\EvaluateUrgent instanceNo <- work] iworld
where
	isUrgent (EvaluateUrgent _)	= True
	isUrgent _					= False
116 117

//Evaluate a single task instance
118 119 120 121 122 123 124 125
evalTaskInstance :: !Event !InstanceNo !*IWorld -> (!MaybeErrorString (TaskResult JSONNode),!*IWorld)
evalTaskInstance event instanceNo iworld=:{currentDateTime,currentUser,currentInstance,nextTaskNo,taskTime,localShares,localLists}
	//Read the task instance data
	# (meta, iworld)			= 'SharedDataSource'.read (taskInstanceMeta instanceNo) iworld
	| isError meta				= (liftError meta, iworld)
	# meta=:{TIMeta|sessionId,parent,worker=Just worker,progress} = fromOk meta
	# (reduct, iworld)			= 'SharedDataSource'.read (taskInstanceReduct instanceNo) iworld
	| isError reduct			= (liftError reduct, iworld)
126
	# reduct=:{TIReduct|task=Task eval,nextTaskNo=curNextTaskNo,nextTaskTime,shares,lists,tasks} = fromOk reduct
127 128 129
	# (result, iworld)			= 'SharedDataSource'.read (taskInstanceResult instanceNo) iworld
	| isError result			= (liftError result, iworld)
	= case fromOk result of
130 131
		(ExceptionResult e msg)		= (Ok (ExceptionResult e msg), iworld)
		(ValueResult val _ _ tree)
132 133 134 135
			//Eval instance
			# repAs						= {TaskRepOpts|useLayout=Nothing,afterLayout=Nothing,modLayout=Nothing,appFinalLayout=isJust sessionId}
			//Update current process id & eval stack in iworld
			# taskId					= TaskId instanceNo 0
136
			# eventRoute				= determineEventRoute event lists
137 138 139 140 141
			# iworld					= {iworld & currentInstance = instanceNo
												  , currentUser = worker
												  , nextTaskNo = reduct.TIReduct.nextTaskNo
												  , taskTime = reduct.TIReduct.nextTaskTime
												  , localShares = shares
142 143 144 145
												  , localLists = lists
												  , localTasks = tasks
												  , eventRoute = eventRoute
												  } 
146 147 148 149 150 151 152 153
			//Clear the instance's registrations for share changes
			# iworld					= clearShareRegistrations instanceNo iworld
			//Apply task's eval function and take updated nextTaskId from iworld
			# (result,iworld)			= eval event repAs tree iworld
			//Update meta data
			# (meta, iworld) = case 'SharedDataSource'.read (taskInstanceMeta instanceNo) iworld of
				(Ok meta, iworld)		= (meta, iworld)
				(_, iworld)				= (meta, iworld)
154
			# meta						= {TIMeta|meta & progress = updateProgress currentDateTime result progress}
155 156 157 158 159
			# (_,iworld)				= 'SharedDataSource'.writeFilterMsg meta ((<>) instanceNo) (taskInstanceMeta instanceNo) iworld //TODO Check error
			//Store updated reduct
			# (nextTaskNo,iworld)		= getNextTaskNo iworld
			# (shares,iworld)			= getLocalShares iworld
			# (lists,iworld)			= getLocalLists iworld
160 161
			# (tasks,iworld)			= getLocalTasks iworld
			# reduct					= {TIReduct|reduct & nextTaskNo = nextTaskNo, nextTaskTime = nextTaskTime + 1, shares = shares, lists = lists, tasks = tasks}
162 163
			# (_,iworld)				= 'SharedDataSource'.writeFilterMsg reduct ((<>) instanceNo) (taskInstanceReduct instanceNo) iworld //TODO Check error
			//Store the result
164
			# (_,iworld)				= 'SharedDataSource'.writeFilterMsg result ((<>) instanceNo) (taskInstanceResult instanceNo) iworld //TODO Check error
165 166
			//Return the result
			= (Ok result, iworld)
167
where
168 169 170
	getNextTaskNo iworld=:{IWorld|nextTaskNo}	= (nextTaskNo,iworld)
	getLocalShares iworld=:{IWorld|localShares}	= (localShares,iworld)
	getLocalLists iworld=:{IWorld|localLists}	= (localLists,iworld)
171
	getLocalTasks iworld=:{IWorld|localTasks}	= (localTasks,iworld)
172

173 174 175 176 177 178 179
	updateProgress now result progress
		# progress = {progress & firstEvent = Just (fromMaybe now progress.firstEvent), latestEvent = Just now}
		= case result of
			(ExceptionResult _ _)				= {progress & stable = True}
			(ValueResult (Value _ True) _ _ _)	= {progress & stable = True}
			(ValueResult _ _ (TaskRep ui _) _)	= {progress & stable = False, latestAttributes = uiDefAttributes ui}
			_									= {progress & stable = False}
180

181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215
determineEventRoute :: Event (Map TaskId [TaskListEntry]) -> Map TaskId Int
determineEventRoute RefreshEvent _ = 'Map'.newMap 
determineEventRoute (EditEvent id _ _) lists	= determineEventRoute` id ('Map'.toList lists)
determineEventRoute (ActionEvent id _) lists	= determineEventRoute` id ('Map'.toList lists)
determineEventRoute (FocusEvent id) lists		= determineEventRoute` id ('Map'.toList lists)

//TODO: Optimize this search function
determineEventRoute` :: TaskId [(TaskId,[TaskListEntry])] -> Map TaskId Int 
determineEventRoute` eventId lists = 'Map'.fromList (search eventId)
where
	search searchId = case searchInLists searchId lists of	
		Just (parId, index)	= [(parId,index):search parId]
		Nothing				= []

	searchInLists searchId [] = Nothing
	searchInLists searchId [(parId,entries):xs] = case [i \\ e <- entries & i <- [0..] | inEntry searchId e] of
		[index] = Just (parId,index)
		_		= searchInLists searchId xs

	inEntry searchId {TaskListEntry|lastEval=ValueResult _ _ _ tree} = inTree searchId tree
	inEntry _ _ = False

	inTree searchId (TCInit taskId _) = searchId == taskId
	inTree searchId (TCBasic taskId _ _ _) = searchId == taskId
	inTree searchId (TCInteract taskId _ _ _ _ _) = searchId == taskId
	inTree searchId (TCInteract1 taskId _ _ _) = searchId == taskId
	inTree searchId (TCInteract2 taskId _ _ _ _) = searchId == taskId
	inTree searchId (TCProject taskId _ tree) = searchId == taskId || inTree searchId tree
	inTree searchId (TCStep taskId _ (Left tree)) = searchId == taskId || inTree searchId tree
	inTree searchId (TCStep taskId _ (Right (_,_,tree))) = searchId == taskId || inTree searchId tree
	inTree searchId (TCParallel taskId _) = searchId == taskId
	inTree searchId (TCShared taskId _ tree) = searchId == taskId || inTree searchId tree
	inTree searchId (TCStable taskId _ _) = searchId == taskId
	inTree searchId _ = False

216
localShare :: !TaskId -> Shared a | iTask a
Steffen Michels's avatar
Steffen Michels committed
217
localShare taskId=:(TaskId instanceNo taskNo) = createChangeOnWriteSDS "localShare" shareKey read write
218 219 220
where
	shareKey = toString taskId

221 222 223 224 225 226 227 228 229 230 231
	read iworld=:{currentInstance,localShares}
		//Local share
		| instanceNo == currentInstance
			= case 'Map'.get taskId localShares of
				Just encs	
					= case fromJSON encs of
						Just s	= (Ok s, iworld)
						_		= (Error ("Could not decode local shared state " +++ shareKey), iworld)
				_			= (Error ("Could not read local shared state " +++ shareKey), iworld)
		//Share of ancestor
		| otherwise
232
			= case 'SharedDataSource'.read (taskInstanceReduct instanceNo) iworld of
233 234
				(Ok reduct,iworld)
					=  case 'Map'.get taskId reduct.TIReduct.shares of
235 236 237 238 239 240 241 242 243 244 245 246 247
						Just encs
							= case fromJSON encs of	
								Just s	= (Ok s, iworld)
								_		= (Error ("Could not decode remote shared state " +++ shareKey), iworld)
						_
							= (Error ("Could not read remote shared state " +++ shareKey), iworld)
				(Error _,iworld)
					= (Error ("Could not read remote shared state " +++ shareKey), iworld)
				
	write value iworld=:{currentInstance,localShares}
		| instanceNo == currentInstance
			= (Ok Void, {iworld & localShares = 'Map'.put taskId (toJSON value) localShares})
		| otherwise
248
			= case 'SharedDataSource'.read (taskInstanceReduct instanceNo) iworld of
249
				(Ok reduct,iworld)
250 251
					# reduct		= {TIReduct|reduct & shares = 'Map'.put taskId (toJSON value) reduct.TIReduct.shares}
					# (_,iworld)	= 'SharedDataSource'.write reduct (taskInstanceReduct instanceNo) iworld
252 253 254 255
					= (Ok Void, iworld)
				(Error _,iworld)
					= (Error ("Could not write to remote shared state " +++ shareKey), iworld)
		
256 257
//Top list share has no items, and is therefore completely polymorphic
topListShare :: SharedTaskList a
258
topListShare = createReadOnlySDS read
259 260
where
	read iworld
261
		= ({TaskList|listId = TopLevelTaskList, items = []}, iworld)
262
		
263
parListShare :: !TaskId -> SharedTaskList a | iTask a
Steffen Michels's avatar
Steffen Michels committed
264
parListShare taskId=:(TaskId instanceNo taskNo) = createReadOnlySDSError read
265 266
where
	shareKey = toString taskId
267 268 269 270
	read iworld=:{currentInstance,localLists}
		| instanceNo == currentInstance		
			= case 'Map'.get taskId localLists of
				Just entries
Bas Lijnse's avatar
Bas Lijnse committed
271
					= (Ok {TaskList|listId = ParallelTaskList taskId, items = [toItem e\\ e <- entries | not e.TaskListEntry.removed]},iworld)
272 273
				_	= (Error ("Could not read local task list " +++ shareKey), iworld)
		| otherwise
274
			= case 'SharedDataSource'.read (taskInstanceReduct instanceNo) iworld of
275 276
				(Ok reduct, iworld)
					= case 'Map'.get taskId reduct.TIReduct.lists of					
277
						Just entries
Bas Lijnse's avatar
Bas Lijnse committed
278
							= (Ok {TaskList|listId = ParallelTaskList taskId, items = [toItem e\\ e <- entries | not e.TaskListEntry.removed]},iworld)
279 280 281 282
						_	= (Error ("Could not read remote task list " +++ shareKey), iworld)
				(Error _,iworld)
					= (Error ("Could not load remote task list " +++ shareKey), iworld)
					
283
	toItem {TaskListEntry|entryId,state,lastEval=ValueResult val _ _ _,attributes}
284 285 286 287 288 289 290 291 292 293 294 295
		= 	{taskId			= entryId
			,value			= deserialize val
			,managementMeta = management
			,progressMeta	= progress
			}
	where
		(progress,management) = case state of
			DetachedState _ p m = (Just p,Just m)
			_					= (Nothing,Nothing)
	
	deserialize NoValue	= NoValue
	deserialize (Value json stable) = maybe NoValue (\v -> Value v stable) (fromJSON json)