TaskTreeFilters.icl 15.1 KB
Newer Older
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
1 2 3 4 5 6
implementation module TaskTreeFilters

import StdEnv
import iDataFormlib
import InternaliTasksCommon, iTasksHtmlSupport

7 8 9 10 11 12 13 14 15
:: TaskStatus = TaskFinished | TaskActivated | TaskDeleted

instance == TaskStatus
where
	(==) TaskFinished 	TaskFinished 	= True
	(==) TaskActivated 	TaskActivated 	= True
	(==) TaskDeleted 	TaskDeleted 	= True
	(==) _ 				_ 				= False

16 17
determineTaskList :: !UserId !HtmlTree -> [([Bool],Bool,TaskDescription)]
determineTaskList thisuser tree = fst (determineTaskList` thisuser [] tree defaultTaskDescriptor)
18
where
19
	determineSubTaskList thisuser path [] taskDescr
20
		= []
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
	determineSubTaskList thisuser path [(desc,t)] taskDescr
		# collection = fst (determineTaskList` thisuser (path ++ [False]) t taskDescr)
		= [(path ++ [False],True,taskDescr):collection]
	determineSubTaskList thisuser path [(desc,t):ts] taskDescr
		# collection = fst (determineTaskList` thisuser (path ++ [False]) t taskDescr)
		# collections = determineSubTaskList thisuser path ts taskDescr
		= [(path ++ [False],True,taskDescr):collection] ++ collections
			

	determineTaskList` thisuser path (ntaskDescr @@: tree) taskDescr 	
		# (collected, more)						= determineTaskList` thisuser path tree ntaskDescr								
		| ntaskDescr.taskWorkerId == thisuser	= ([(path, not more,ntaskDescr):collected], True)
												= (collected, more)

	determineTaskList` thisuser path (CondAnd label nr ts) taskDescr
		# collections = determineSubTaskList thisuser path ts taskDescr
		= ([(path,True,taskDescr):collections],True)


	/*	
	determineTaskList` thisuser path (CondAnd label nr []) taskDescr
												= ([], False)
												
	determineTaskList` thisuser path (CondAnd label nr [t=:(condAndDescr,htmlTree):ts]) taskDescr
		# collection							= determineTaskList` thisuser path htmlTree taskDescr
		# collections 							= determineTaskList` thisuser path (CondAnd label nr ts) taskDescr
		= [(path,True,{taskDescr & taskNrId = condAndDescr.caTaskNrId, taskLabel = label, curStatus = condAndDescr.caStatus})] ++ collection ++ collections
	*/
	determineTaskList` thisuser path (tree1 +|+ tree2) taskDescr
		# (collection1, more1)					= determineTaskList` thisuser path tree1 taskDescr
		# (collection2, more2)					= determineTaskList` thisuser path tree2 taskDescr
		= (collection1 ++ collection2, more1 || more2) 
	
	determineTaskList` thisuser path (tree1 +-+ tree2) taskDescr
		# (collection1, more1)					= determineTaskList` thisuser path tree1 taskDescr
		# (collection2, more2)					= determineTaskList` thisuser path tree2 taskDescr
		= (collection1 ++ collection2, more1 || more2)
	
	determineTaskList` thisuser path (BT html inputs) taskDescr
		= ([], False)
	determineTaskList` thisuser path (DivCode id tree) taskDescr
		= determineTaskList` thisuser path tree taskDescr
	determineTaskList` thisuser path (TaskTrace traceinfo tree) taskDescr
		= determineTaskList` thisuser path tree taskDescr
65 66 67 68 69 70

defaultTaskDescriptor
	=	{ delegatorId	= 0								
		, taskWorkerId	= 0								
		, taskNrId		= ""								
		, processNr		= 0								
71
		, workflowLabel	= "Non-existing"							
72 73 74 75 76 77 78
		, taskLabel		= "Non-existing"								
		, timeCreated	= Time 0
		, taskPriority	= LowPriority
		, curStatus		= True
		}

determineTaskForTab :: !UserId !TaskNrId !HtmlTree -> (!TaskStatus,![HtmlTag],![InputId])
79
determineTaskForTab thisuser thistaskid tree
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
80
	= case determineMyTaskTree thisuser thistaskid tree of							//Find the subtree by task id
81
		Nothing
82
			= (TaskDeleted, [], [])													//Subtask not found, nothing to do anymore
83 84
		Just tree
			# (html,inputs)	= mkFilteredTaskTree thisuser thisuser tree				//Collect only the parts for the current user
85 86 87 88 89
			= (test tree, html, inputs)
	where
		test (description @@: html) 
		| description.taskNrId == thistaskid && description.curStatus = TaskFinished
		= TaskActivated
90

91 92 93 94 95 96
mkFilteredTaskTree :: !UserId !UserId !HtmlTree -> (![HtmlTag],![InputId])
mkFilteredTaskTree thisuser taskuser (description @@: tree) 						
	# (html,inputs)		= mkFilteredTaskTree thisuser description.taskWorkerId tree
	| thisuser == description.taskWorkerId
							= (html,inputs)
	| otherwise				= ([],[])
97
mkFilteredTaskTree thisuser taskuser (CondAnd label nr [])
98
	= ([],[])
99
mkFilteredTaskTree thisuser taskuser (CondAnd label nr [(index,tree):trees])
100
	# (tag,input)			= mkFilteredTaskTree thisuser taskuser tree
101
	# (tags,inputs)			= mkFilteredTaskTree thisuser taskuser (CondAnd label nr trees)
102
	= (tag ++ tags,input ++ inputs)
103 104 105
mkFilteredTaskTree thisuser taskuser (tree1 +|+ tree2)
	# (lhtml,linputs)	= mkFilteredTaskTree thisuser taskuser tree1
	# (rhtml,rinputs)	= mkFilteredTaskTree thisuser taskuser tree2
106
	= (lhtml <||> rhtml,linputs ++ rinputs)
107 108 109
mkFilteredTaskTree thisuser taskuser (tree1 +-+ tree2)
	# (lhtml,linputs)	= mkFilteredTaskTree thisuser taskuser tree1
	# (rhtml,rinputs)	= mkFilteredTaskTree thisuser taskuser tree2
110
	= (lhtml <=> rhtml,linputs ++ rinputs)
111 112 113 114 115 116 117
mkFilteredTaskTree thisuser taskuser (BT bdtg inputs)
	| thisuser == taskuser	= (bdtg,inputs)
	| otherwise				= ([],[])
mkFilteredTaskTree thisuser taskuser (DivCode id tree)
	# (html,inputs)			= mkFilteredTaskTree thisuser taskuser tree
	| thisuser == taskuser 	= ([DivTag [IdAttr id, ClassAttr "itasks-thread"] html],inputs)
	| otherwise				= ([],[])
118 119 120 121
mkFilteredTaskTree thisuser taskuser (TaskTrace traceinfo tree)
	# (html,inputs)			= mkFilteredTaskTree thisuser taskuser tree
	| thisuser == taskuser 	= (html,inputs)
	| otherwise				= ([],[])
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
122

123
mkUnfilteredTaskTree :: !HtmlTree -> (![HtmlTag],![InputId])
124 125
mkUnfilteredTaskTree (BT body inputs) 			= (body, inputs)
mkUnfilteredTaskTree (_ @@: html) 				= mkUnfilteredTaskTree html
126 127
mkUnfilteredTaskTree (CondAnd label nr []) 		= ([],[])
mkUnfilteredTaskTree (CondAnd label nr [(tn,tree):trees]) 		
128 129 130
												= (htmlL ++ htmlR,inpL ++ inpR)
where
	(htmlL,inpL) = mkUnfilteredTaskTree tree
131
	(htmlR,inpR) = mkUnfilteredTaskTree (CondAnd label nr trees)
132 133
mkUnfilteredTaskTree (DivCode str html) 		= mkUnfilteredTaskTree html
mkUnfilteredTaskTree (TaskTrace traceinfo html) = mkUnfilteredTaskTree html
134
mkUnfilteredTaskTree (nodeL +-+ nodeR) 			= (htmlL <=> htmlR,inpL ++ inpR)
135 136 137
where
	(htmlL,inpL) = mkUnfilteredTaskTree nodeL
	(htmlR,inpR) = mkUnfilteredTaskTree nodeR
138
mkUnfilteredTaskTree (nodeL +|+ nodeR) 			= (htmlL <||> htmlR, inpL ++ inpR)
139 140 141 142
where
	(htmlL,inpL) = mkUnfilteredTaskTree nodeL
	(htmlR,inpR) = mkUnfilteredTaskTree nodeR

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
143 144 145 146 147
// ******************************************************************************************************
// Search for that part of the task tree which is applicable for a given user and a given task
// ******************************************************************************************************

determineMyTaskTree :: !UserId !TaskNrId !HtmlTree -> Maybe HtmlTree
148
determineMyTaskTree thisuser thistaskid tree = determineMyTaskTree` thisuser thistaskid tree defaultTaskDescriptor
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
149
where
150 151
	determineMyTaskTree` thisuser thistaskid  (BT bdtg inputs) taskDescr
		= Nothing
152
	determineMyTaskTree` thisuser thistaskid (CondAnd label nr []) taskDescr
153
		= Nothing
154 155 156 157 158
	determineMyTaskTree` thisuser thistaskid (CondAnd label nr [(condAndDescr,tree):trees]) taskDescr
		| thistaskid == condAndDescr.caTaskNrId				
											= Just ({taskDescr 	& taskNrId 	= thistaskid
																, taskLabel = label <+++ condAndDescr.caIndex
																, curStatus = condAndDescr.caStatus} @@: (pruneTree tree))
159
		# mbTree							= determineMyTaskTree` thisuser thistaskid tree taskDescr
160
		| isNothing mbTree					= determineMyTaskTree` thisuser thistaskid (CondAnd label nr trees) taskDescr
161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
		= mbTree
	determineMyTaskTree` thisuser thistaskid  (tree1 +-+ tree2) taskDescr
		# ntree1							= determineMyTaskTree` thisuser thistaskid tree1 taskDescr
		| isJust ntree1						= ntree1
											= determineMyTaskTree` thisuser thistaskid tree2 taskDescr
	determineMyTaskTree` thisuser thistaskid (tree1 +|+ tree2) taskDescr
		# ntree1							= determineMyTaskTree` thisuser thistaskid tree1 taskDescr
		| isJust ntree1						= ntree1
											= determineMyTaskTree` thisuser thistaskid tree2 taskDescr
	determineMyTaskTree` thisuser thistaskid (DivCode id tree) taskDescr
											= determineMyTaskTree` thisuser thistaskid tree taskDescr
	determineMyTaskTree` thisuser thistaskid (TaskTrace traceinfo tree) taskDescr
											= determineMyTaskTree` thisuser thistaskid tree taskDescr
	determineMyTaskTree` thisuser thistaskid (taskdescr @@: tree) taskDescr	
		| taskdescr.taskNrId 	 == thistaskid	&&
		  taskdescr.taskWorkerId == thisuser= Just (taskdescr @@: (pruneTree tree))
											= determineMyTaskTree` thisuser thistaskid tree taskdescr

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
179
	pruneTree :: !HtmlTree -> HtmlTree		// delete all sub trees not belonging to this task
180
	pruneTree (taskdescr @@: tree)			= BT [] []								// this task will appear in another tab						
181
	pruneTree (CondAnd label nr trees)		= BT [] [] 								// this task will appear in another tab as well
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
182 183 184 185 186 187
	pruneTree (tree1 +|+ tree2)				= pruneTree tree1 +|+ pruneTree tree2
	pruneTree (tree1 +-+ tree2)				= pruneTree tree1 +-+ pruneTree tree2
	pruneTree (BT bdtg inputs)				= BT bdtg inputs
	pruneTree (DivCode id tree)				= DivCode id (pruneTree tree)
	pruneTree (TaskTrace traceinfo tree)	= TaskTrace traceinfo (pruneTree tree)

188

189
// ******************************************************************************************************
190
// Trace Calculation
191 192
// ******************************************************************************************************

193 194
:: Trace		=	Trace !(Maybe !TraceInfo) ![Trace]							// traceinfo with possibly subprocess

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
195 196 197 198 199 200 201 202
getTraceFromTaskTree :: !UserId !TaskNrId !HtmlTree -> HtmlTag				
getTraceFromTaskTree userId taskNrId tree
	# mbtree			= determineMyTaskTree userId taskNrId tree
	| isNothing mbtree	= Text "Error: Cannot find task tree !"
	= getFullTraceFromTaskTree (fromJust mbtree)

getFullTraceFromTaskTree :: !HtmlTree -> HtmlTag
getFullTraceFromTaskTree html
203 204
# traceInfos	= collectTraceInfo html
# traces		= insertTraces traceInfos [] 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
205
= showTaskTreeTrace (Just traces)
Rinus Plasmeijer's avatar
 
Rinus Plasmeijer committed
206
where
207 208 209 210
	collectTraceInfo :: !HtmlTree -> [TraceInfo]
	collectTraceInfo (TaskTrace traceinfo html) = [traceinfo : collectTraceInfo html]
	collectTraceInfo (BT body inputs) 			= []
	collectTraceInfo (_ @@: html) 				= collectTraceInfo html
211
	collectTraceInfo (CondAnd label nr html) 	= flatten (map collectTraceInfo (map snd html))
212 213 214 215 216 217 218 219 220
	collectTraceInfo (DivCode str html) 		= collectTraceInfo html
	collectTraceInfo (nodeL +-+ nodeR) 			= traceLeft ++ traceRight
	where
		traceLeft 	= collectTraceInfo nodeL
		traceRight	= collectTraceInfo nodeR
	collectTraceInfo (nodeL +|+ nodeR) 			= traceLeft ++ traceRight
	where
		traceLeft 	= collectTraceInfo nodeL
		traceRight 	= collectTraceInfo nodeR
Rinus Plasmeijer's avatar
 
Rinus Plasmeijer committed
221

222 223 224
	insertTraces [] traces     = traces
	insertTraces [i:is] traces = insertTraces is (insertTrace i traces)

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
225 226
	insertTrace :: !TraceInfo ![Trace] -> [Trace]
	insertTrace info trace = insertTrace` (reverse (parseTaskNr info.trTaskNr)) trace
227
	where
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243
		insertTrace` :: !TaskNr ![Trace] -> [Trace]
		insertTrace` [i] traces
		| i < 0					= abort ("negative task numbers:" <+++ info.trTaskNr <+++ "," <+++ info.trUserId <+++ "," <+++ info.trTaskName)
		# (Trace _ itraces)		= select i traces
		= updateAt` i (Trace (Just info) itraces)  traces
		insertTrace` [i:is] traces
		| i < 0					= abort ("negative task numbers:" <+++ info.trTaskNr <+++ "," <+++ info.trUserId <+++ "," <+++ info.trTaskName)
		# (Trace ni itraces)	= select i traces
		# nistraces				= insertTrace` is itraces
		= updateAt` i (Trace ni nistraces) traces
	
		select :: !Int ![Trace] -> Trace
		select i list
		| i < length list = list!!i 
		=  Trace Nothing []
	
244
		updateAt`:: !Int !Trace ![Trace] -> [Trace]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
245 246 247 248 249 250 251 252 253 254 255 256 257
		updateAt` n x list
		| n < 0		= abort "negative numbers not allowed"
		= updateAt` n x list
		where
			updateAt`:: !Int !Trace ![Trace] -> [Trace]
			updateAt` 0 x []		= [x]
			updateAt` 0 x [y:ys]	= [x:ys]
			updateAt` n x []		= [Trace Nothing []	: updateAt` (n-1) x []]
			updateAt` n x [y:ys]	= [y      			: updateAt` (n-1) x ys]

// ******************************************************************************************************
// Displaying Task Tree Trace information
// ******************************************************************************************************
258
		
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
259 260 261
showTaskTreeTrace :: !(Maybe [Trace]) -> HtmlTag
showTaskTreeTrace Nothing	= Text "No task tree trace "
showTaskTreeTrace (Just a)	= DivTag [] [showLabel "Task Tree Forest:", BrTag [] , STable emptyBackground (print False a),HrTag []]
262 263 264 265 266
where
	print _ []		= []
	print b trace	= [pr b x ++ [STable emptyBackground (print (isDone x||b) xs)]\\ (Trace x xs) <- trace] 

	pr _ Nothing 			= []
267 268
	pr dprev (Just info=:{trTaskName, trActivated})	
	| dprev && (not trActivated)							= pr False Nothing	// subtask not important anymore (assume no milestone tasks)
269 270 271 272 273
	| not trActivated	&& trTaskName%(0,4) == "Ajax "		= showTask cellattr1b Black Navy Aqua  Silver  info
	| not trActivated	&& trTaskName%(0,6) == "Server "	= showTask cellattr1b Black Navy Aqua  Silver  info
	| not trActivated	&& trTaskName%(0,6) == "Client "	= showTask cellattr1b Black Navy Aqua  Silver  info
	| not trActivated										= showTask cellattr1b Black Navy Maroon Silver info
	= showTask cellattr1a Black Yellow Red Black info
274
	
275
	showTask att c1 c2 c3 c4 info
276
	= [STable doneBackground 	
277
		[ [font c1 (toString info.trUserId),font c2 ("T" <+++ info.trTaskNr)]
278 279
		, [showStorage info.trOptions.tasklife, font c3 info.trTaskName]
		, [EmptyBody, font c4 info.trValue]
280 281 282
		]
		]
	isDone Nothing = False
283
	isDone (Just info) = info.trActivated
284

285 286 287 288 289 290 291 292
	showStorage LSTemp		= font "silver" "Tmp"
	showStorage LSClient	= font "aqua" "Cli"
	showStorage LSPage		= font "navy" "Pag"
	showStorage LSSession	= font "navy" "Ssn"
	showStorage LSTxtFileRO	= font "red"   "TxF0"
	showStorage LSTxtFile	= font "red"   "TxF"
	showStorage LSDataFile	= font "red"   "DaF"
	showStorage LSDatabase	= font "red"   "DaB"
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329

	doneBackground = 	[ CellpaddingAttr "pixels 1", CellspacingAttr "pixels 0", cellwidth
						, RulesAttr "none", FrameAttr "border" 
						]
	doneBackground2 = 	[ CellspacingAttr "pixels 0", CellspacingAttr "pixels 0", cellwidth
						]
	emptyBackground = 	[ CellpaddingAttr "pixels 0", CellspacingAttr "pixels 0"]
	cellattr1a		=	[ BgcolorAttr Green, WidthAttr "pixels 10", ValignAttr "absmiddle"]
	cellattr1b		=	[ BgcolorAttr Silver, WidthAttr "pixels 10", ValignAttr "absmiddle"]
	cellattr2		=	[ ValignAttr "top"]
	cellwidth		= 	WidthAttr "130"

	font color message
	= SpanTag [StyleAttr ("font-size: smaller; font-weight: bold; color: " +++ color)] [Text message]

	STable atts table		= TableTag atts (mktable table)
	where
		mktable table 	= [TrTag [] (mkrow rows)           \\ rows <- table]
		mkrow   rows 	= [TdTag [ValignAttr "top"]  [row] \\ row  <- rows ]

	EmptyBody = Text ""

	Black	= "#000000"
	Silver	= "#C0C0C0"
	Gray 	= "#808080"
	White	= "#FFFFFF"
	Maroon	= "#800000"
	Red		= "#FF0000"
	Purple	= "#800080"
	Fuchsia	= "#FF00FF"
	Green	= "#008000" 
	Lime	= "#00FF00"
	Olive	= "#808000" 
	Yellow	= "#FFFF00"
	Navy 	= "#000080" 
	Blue	= "#0000FF"
	Teal	= "#008080" 
330 331
	Aqua	= "#00FFFF"