Commit eb5b6fba authored by Rinus Plasmeijer's avatar Rinus Plasmeijer

trace information is now part of the html task tree

some operators do not store the information as they should


git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/branches/fancyTasks@296 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 99741333
......@@ -11,11 +11,11 @@ import iDataForms, iDataState
*/
handleProcessTableRequest :: !(Task a) !HTTPRequest !Session *HSt -> (!HTTPResponse, !*HSt) | iData a
handleProcessTableRequest mainTask request session hst
# thisUserId = session.Session.userId
# (toServer, htmlTree, maybeError, maybeTrace, maybeProcessTable, maybeThreadTable, hst)
= calculateTaskTree thisUserId True True True mainTask hst // calculate the TaskTree given the id of the current user
# processTable = if (isNothing maybeProcessTable) [] (fromJust maybeProcessTable)
# content = toString (DivTag [IdAttr "itasks-processtable", ClassAttr "trace"] processTable)
= ({http_emptyResponse & rsp_data = content}, hst) // create the http response
# thisUserId = session.Session.userId
# (toServer, htmlTree, maybeError, maybeProcessTable, maybeThreadTable, hst)
= calculateTaskTree thisUserId True True True mainTask hst // calculate the TaskTree given the id of the current user
# processTable = if (isNothing maybeProcessTable) [] (fromJust maybeProcessTable)
# content = toString (DivTag [IdAttr "itasks-processtable", ClassAttr "trace"] processTable)
= ({http_emptyResponse & rsp_data = content}, hst) // create the http response
......@@ -12,11 +12,11 @@ import iDataForms, iDataState
*/
handleTaskTreeForestRequest :: !(Task a) !HTTPRequest !Session *HSt -> (!HTTPResponse, !*HSt) | iData a
handleTaskTreeForestRequest mainTask request session hst
# thisUserId = session.Session.userId
# (toServer, htmlTree, maybeError, maybeTrace, maybeProcessTable, maybeThreadTable, hst)
= calculateTaskTree thisUserId True True True mainTask hst // calculate the TaskTree given the id of the current user
# taskTreeTrace = showTaskTree maybeTrace // TEMP fix to show taskTree
# content = toString (DivTag [IdAttr "itasks-tasktreeforest",ClassAttr "trace"] [taskTreeTrace])
# thisUserId = session.Session.userId
# (toServer, htmlTree, maybeError, maybeProcessTable, maybeThreadTable, hst)
= calculateTaskTree thisUserId True True True mainTask hst // calculate the TaskTree given the id of the current user
# taskTreeTrace = filterTaskTree htmlTree // calculate Task Tree
# content = toString (DivTag [IdAttr "itasks-tasktreeforest",ClassAttr "trace"] [taskTreeTrace])
= ({http_emptyResponse & rsp_data = content}, hst) // create the http response
......@@ -11,9 +11,9 @@ import iDataForms, iDataState
*/
handleThreadTableRequest :: !(Task a) !HTTPRequest !Session *HSt -> (!HTTPResponse, !*HSt) | iData a
handleThreadTableRequest mainTask request session hst
# thisUserId = session.Session.userId
# (toServer, htmlTree, maybeError, maybeTrace, maybeProcessTable, maybeThreadTable, hst)
= calculateTaskTree thisUserId True True True mainTask hst // calculate the TaskTree given the id of the current user
# threadTable = if (isNothing maybeThreadTable) [] (fromJust maybeThreadTable)
# content = toString (DivTag [IdAttr "itasks-threadtable", ClassAttr "trace"] threadTable) // create tab data record
# thisUserId = session.Session.userId
# (toServer, htmlTree, maybeError, maybeProcessTable, maybeThreadTable, hst)
= calculateTaskTree thisUserId True True True mainTask hst // calculate the TaskTree given the id of the current user
# threadTable = if (isNothing maybeThreadTable) [] (fromJust maybeThreadTable)
# content = toString (DivTag [IdAttr "itasks-threadtable", ClassAttr "trace"] threadTable) // create tab data record
= ({http_emptyResponse & rsp_data = content}, hst) // create the http response
......@@ -21,7 +21,7 @@ derive JSONEncode WorkListItem, TaskPriority
handleWorkListRequest :: !(Task a) !HTTPRequest !Session *HSt -> (!HTTPResponse, !*HSt) | iData a
handleWorkListRequest mainTask request session hst
# thisUserId = session.Session.userId
# (toServer, htmlTree, maybeError, maybeTrace, maybeProcessTable, maybeThreadTable,hst)
# (toServer, htmlTree, maybeError, maybeProcessTable, maybeThreadTable,hst)
= calculateTaskTree thisUserId False False False mainTask hst // Calculate the TaskTree given the id of the current user
# worklist = [ { taskid = mytaskdescr.taskNrId
, delegator = toString mytaskdescr.delegatorId
......
......@@ -27,7 +27,7 @@ handleWorkTabRequest :: !(Task a) !HTTPRequest !Session *HSt -> (!HTTPResponse,
handleWorkTabRequest mainTask request session hst
# thisUserId = session.Session.userId // fetch user id from the session
# taskId = http_getValue "taskid" request.arg_get "error" // fetch task id of the tab selecetd
# (toServer, htmlTree, maybeError, maybeTrace, maybeProcessTable, maybeThreadTable, hst =:{states,world})
# (toServer, htmlTree, maybeError, maybeProcessTable, maybeThreadTable, hst =:{states,world})
= calculateTaskTree thisUserId True True True mainTask hst // calculate the TaskTree given the id of the current user
# (taskDone,html,inputs) = determineTaskForTab thisUserId taskId htmlTree // filter out the code and inputs to display in this tab
# (htmlstates,states) = getHtmlStates states // Collect states that must be temporarily stored in the browser
......@@ -36,7 +36,7 @@ handleWorkTabRequest mainTask request session hst
//Tracing
# (stateTrace,states) = mbStateTrace request states
# (updateTrace,states) = mbUpdateTrace request states
# subTreeTrace = mbSubTreeTrace request taskId maybeTrace
# subTreeTrace = mbSubTreeTrace request thisUserId taskId htmlTree
# activeTasks = if taskDone
(Just [ mytaskdescr.taskNrId
......@@ -71,9 +71,9 @@ where
= (Just (toString trace), states)
| otherwise
= (Nothing, states)
mbSubTreeTrace req taskId maybeTrace
mbSubTreeTrace req thisUserId taskId htmlTree
| http_getValue "traceSubTrees" req.arg_get "" == "1"
= Just (toString (showTaskTreeOfTask taskId maybeTrace))
= Just (toString (filterTaskTreeOfTask thisUserId taskId htmlTree))
| otherwise
= Nothing
......@@ -34,8 +34,6 @@ mkParSubTask :: create a subtask with indicated task nr
iTaskId :: generate an id based on the task nr, important for garbage collection and family relation
showTaskNr :: for identifier generation
deleteAllSubTasks :: collects all related tasks
printTrace2 :: show task tree trace
*/
incNr :: !TaskNr -> TaskNr
......
......@@ -62,11 +62,12 @@ mkTaskNoInc :: !String !(Task a) -> (Task a) | iCreateAndPrint a // common sec
mkTaskNoInc taskname mytask = Task mkTaskNoInc`
where
mkTaskNoInc` tst=:{activated,tasknr,userId,options}
| not activated = (createDefault,tst) // not active, don't call task, return default value
# (val,tst=:{activated,trace}) = appTaskTSt mytask tst // active, so perform task and get its result
| not activated = (createDefault,tst) // not active, don't call task, return default value
# (val,tst=:{activated,html}) = appTaskTSt mytask tst // active, so perform task and get its result
# tst = {tst & tasknr = tasknr, options = options, userId = userId}
| isNothing trace || taskname == "" = (val,tst) // no trace, just return value
= (val,{tst & trace = Just (InsertTrace activated tasknr userId options taskname (printToString val%(0,60)) (fromJust trace))}) // adjust trace, don't print to long values
| options.trace || taskname == "" = (val,tst) // no trace, just return value
# tst = {tst & html = TaskTrace {trTaskNr = tasknr, trTaskName = taskname, trActivated = activated, trUserId = userId, trValue = printToString val, trOptions = options} html}
= (val,tst)
mkParSubTask :: !String !Int (Task a) -> (Task a) | iCreateAndPrint a // two shifts are needed
mkParSubTask name i task = Task mkParSubTask`
......@@ -77,46 +78,6 @@ where
where
mysubtask tst=:{tasknr} = appTaskTSt task {tst & tasknr = [-1:tasknr], activated = True} // shift once again!
// ******************************************************************************************************
// Trace Insertion ...
// ******************************************************************************************************
InsertTrace :: !Bool !TaskNr !Int !Options String !String ![Trace] -> [Trace]
InsertTrace finished idx who options taskname val trace = InsertTrace` ridx who val trace
where
InsertTrace` :: !TaskNr !Int !String ![Trace] -> [Trace]
InsertTrace` [i] who str traces
| i < 0 = abort ("negative task numbers:" <+++ showTaskNr idx <+++ "," <+++ who <+++ "," <+++ taskname)
# (Trace _ itraces) = select i traces
= updateAt` i (Trace (Just (finished,(who,show,options,taskname,str))) itraces) traces
InsertTrace` [i:is] who str traces
| i < 0 = abort ("negative task numbers:" <+++ showTaskNr idx <+++ "," <+++ who <+++ "," <+++ taskname)
# (Trace ni itraces) = select i traces
# nistraces = InsertTrace` is who str itraces
= updateAt` i (Trace ni nistraces) traces
select :: !Int ![Trace] -> Trace
select i list
| i < length list = list!!i
= Trace Nothing []
show = idx //showTaskNr idx
ridx = reverse idx
updateAt`:: !Int !Trace ![Trace] -> [Trace]
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]
// ******************************************************************************************************
// iTask Storage Utilities
// ******************************************************************************************************
......
......@@ -133,7 +133,7 @@ where
// Watch it: the Client cannot create new Server threads
startAjaxApplication :: !Int !GlobalInfo !(Task a) !*TSt -> ((!Bool,!Int,TaskNr,!String,![TaskNr]),!*TSt) // determines which threads to execute and calls them..
startAjaxApplication thisUser versioninfo maintask tst=:{tasknr,options,html,trace,userId}
startAjaxApplication thisUser versioninfo maintask tst=:{tasknr,options,html,userId}
# tst = copyThreadTableFromClient versioninfo tst // synchronize thread tables of client and server, if applicable
// first determine whether we should start calculating the task tree from scratch starting at the root
......@@ -377,25 +377,26 @@ where
ServerThreadTableStorage:: !(ThreadTable -> ThreadTable) -> (Task ThreadTable) // used to store Tasknr of callbackfunctions / threads
ServerThreadTableStorage fun = Task handleTable
where
handleTable tst=:{staticInfo} = appTaskTSt (ThreadTableStorageGen serverThreadTableId staticInfo.threadTableLoc fun) tst
handleTable tst=:{staticInfo,options} = appTaskTSt (ThreadTableStorageGen serverThreadTableId staticInfo.threadTableLoc options.trace fun) tst
serverThreadTableId = "Application" +++ "-ThreadTable"
ClientThreadTableStorage:: !(ThreadTable -> ThreadTable) -> (Task ThreadTable) // used to store Tasknr of callbackfunctions / threads
ClientThreadTableStorage fun = Task handleTable
where
handleTable tst=:{staticInfo} = appTaskTSt (ThreadTableStorageGen (clientThreadTableId staticInfo.currentUserId) LSClient fun) tst
handleTable tst=:{staticInfo,options} = appTaskTSt (ThreadTableStorageGen (clientThreadTableId staticInfo.currentUserId) LSClient options.trace fun) tst
clientThreadTableId userid = "User" <+++ userid <+++ "-ThreadTable"
ThreadTableStorageGen :: !String !Lifespan !(ThreadTable -> ThreadTable) -> (Task ThreadTable) // used to store Tasknr of callbackfunctions / threads
ThreadTableStorageGen tableid lifespan fun = Task handleTable // to handle the table on server as well as on client
ThreadTableStorageGen :: !String !Lifespan !Bool !(ThreadTable -> ThreadTable) -> (Task ThreadTable) // used to store Tasknr of callbackfunctions / threads
ThreadTableStorageGen tableid lifespan trace fun = Task handleTable // to handle the table on server as well as on client
where
handleTable tst
# (table,tst) = liftHst (mkStoreForm (Init,storageFormId
{ tasklife = lifespan
, taskstorage = PlainString
, taskmode = NoForm
, trace = trace
, gc = Collect} tableid []) fun) tst
= (table.Form.value,tst)
......
......@@ -27,9 +27,9 @@ derive gParse Time
(=>>) taska taskb = Task mybind
where
mybind tst=:{options}
# (a,tst=:{activated}) = appTaskTSt taska tst
| activated = appTaskTSt (taskb a) {tst & options = options}
= (createDefault,tst)
# (a,tst=:{activated}) = appTaskTSt taska tst
| activated = appTaskTSt (taskb a) {tst & options = options}
= (createDefault,tst)
return_V :: !a -> (Task a) | iCreateAndPrint a
return_V a = mkTask "return_V" (Task dotask)
......@@ -46,11 +46,11 @@ where
newTask` tst=:{tasknr,userId,options}
# taskId = iTaskId userId tasknr taskname
# (taskval,tst) = liftHst (mkStoreForm (Init,storageFormId options taskId (False,createDefault)) id) tst // remember if the task has been done
# (taskdone,taskvalue) = taskval.Form.value // select values
| taskdone = (taskvalue,tst) // if rewritten return stored value
# (taskdone,taskvalue) = taskval.Form.value // select values
| taskdone = (taskvalue,tst) // if rewritten return stored value
# (val,tst=:{activated}) = appTaskTSt mytask {tst & tasknr = [-1:tasknr]} // do task, first shift tasknr
| not activated = (createDefault,{tst & tasknr = tasknr, options = options}) // subtask not ready, return value of subtasks
# tst = deleteSubTasksAndThreads tasknr tst // task ready, garbage collect it
# tst = deleteSubTasksAndThreads tasknr tst // task ready, garbage collect it
# (_,tst) = liftHst (mkStoreForm (Init,storageFormId options taskId (False,createDefault)) (\_ -> (True,val))) tst // remember if the task has been done
= (val,{tst & tasknr = tasknr, options = options})
......@@ -113,7 +113,7 @@ where
| not activated = (createDefault,tst)
# (currtime,tst) = appTaskTSt (appWorldOnce ("Task: " +++ taskname +++ " For: " +++ toString nuserId) time) tst
# tst = IF_Ajax (administrateNewThread userId tst) tst
# (a,tst=:{html=nhtml,activated}) = appTaskTSt (IF_Ajax (UseAjax @>> taska) taska) {tst & html = BT [] [],userId = nuserId} // activate task of indicated user
# (a,tst=:{html=nhtml,activated}) = appTaskTSt (IF_Ajax (UseAjax @>> taska) taska) {tst & /*html = BT [] [],*/userId = nuserId} // activate task of indicated user NEWTRACE
| activated = (a,{tst & activated = True // work is done
, userId = userId // restore previous user id
, html = ohtml }) // plus new one tagged
......
......@@ -28,7 +28,7 @@ where
doTask tst=:{html=ohtml,activated}
| not activated = (createDefault,tst)
# (a,tst=:{activated,html=nhtml}) = appTaskTSt task {tst & html = BT [] []}
| activated = (a,{tst & html = ohtml})
| activated = (a,{tst & html = ohtml +|+ nhtml}) // NEWTRACE
= (a,{tst & html = ohtml +|+ BT prompt [] +|+ nhtml})
(<<?) infixl 5 :: !(Task a) ![HtmlTag] -> Task a | iCreate a
......@@ -37,7 +37,7 @@ where
doTask tst=:{html=ohtml,activated}
| not activated = (createDefault,tst)
# (a,tst=:{activated,html=nhtml}) = appTaskTSt task {tst & html = BT [] []}
| activated = (a,{tst & html = ohtml})
| activated = (a,{tst & html = ohtml +|+ nhtml}) // NEWTRACE
= (a,{tst & html = ohtml +|+ nhtml +|+ BT prompt []})
(!>>) infixr 5 :: ![HtmlTag] !(Task a) -> (Task a) | iCreate a
......
......@@ -15,7 +15,6 @@ import HSt
, staticInfo :: !StaticInfo // info which does not change during a run
, html :: !HtmlTree // accumulator for html code
, options :: !Options // iData lifespan and storage format
, trace :: !Maybe [Trace] // for displaying task trace
, hst :: !HSt // iData state
}
......@@ -33,6 +32,7 @@ import HSt
, taskstorage :: !StorageFormat // default: PlainString
, taskmode :: !Mode // default: Edit
, gc :: !GarbageCollect // default: Collect
, trace :: !Bool // default: False
}
:: GarbageCollect
= Collect // garbage collect iTask administration
......@@ -44,11 +44,15 @@ import HSt
| (+-+) infixl 1 !HtmlTree !HtmlTree // code to be placed next to each other
| (+|+) infixl 1 !HtmlTree !HtmlTree // code to be placed below each other
| DivCode !String !HtmlTree // code that should be labeled with a div, used for Ajax and Client technology
| TaskTrace TraceInfo !HtmlTree // trace information used for displaying the task tree
// Trace information
:: Trace = Trace !TraceInfo ![Trace] // traceinfo with possibly subprocess
:: TraceInfo :== Maybe (!Bool,!(!UserId,!TaskNr,!Options,!String,!String)) // Task finished? who did it, task nr, task name (for tracing) value produced
:: TraceInfo = { trTaskNr :: !TaskNr // tasknr
, trTaskName :: !String // name of the combinator
, trActivated :: !Bool // is the task finshed or not
, trUserId :: !UserId // who is performing the task (can also be determined from the contect)
, trValue :: !String // what is the current value of task (serialized to string)
, trOptions :: !Options // options of this task
}
// Task meta information
:: TaskDescription
......
......@@ -12,7 +12,6 @@ mkTst thisUser itaskstorage threadstorage hst
, userId = if (thisUser >= 0) defaultUser thisUser
, workflowLink = (0,(defaultUser,0,defaultWorkflowName))
, html = BT [] []
, trace = Just []
, hst = hst
, options = initialOptions thisUser itaskstorage
}
......@@ -29,6 +28,7 @@ initialOptions thisUser location
, taskstorage = PlainString
, taskmode = Edit
, gc = Collect
, trace = False
}
......
......@@ -9,4 +9,4 @@ definition module TaskTree
import iTasksTypes
calculateTaskTree :: !UserId !Bool !Bool !Bool !(Task a) !*HSt
-> (!Bool,!HtmlTree,!Maybe String,!Maybe [Trace],!Maybe [HtmlTag],!Maybe [HtmlTag],!*HSt) | iData a
-> (!Bool,!HtmlTree,!Maybe String,!Maybe [HtmlTag],!Maybe [HtmlTag],!*HSt) | iData a
......@@ -14,7 +14,7 @@ import iTasksProcessHandling
import TSt
calculateTaskTree :: !UserId !Bool !Bool !Bool !(Task a) !*HSt
-> (!Bool,!HtmlTree,!Maybe String,!Maybe [Trace],!Maybe [HtmlTag],!Maybe [HtmlTag],!*HSt) | iData a
-> (!Bool,!HtmlTree,!Maybe String,!Maybe [HtmlTag],!Maybe [HtmlTag],!*HSt) | iData a
calculateTaskTree thisUser traceOn showProcessTable showCurrThreadTable mainTask hst
# (pversion,hst) = setPUserNr thisUser id hst // fetch global settings of this user
# ((toServer,thrOwner,event,thrinfo,threads),tst=:{activated})
......@@ -22,7 +22,7 @@ calculateTaskTree thisUser traceOn showProcessTable showCurrThreadTable mainTask
# (processTable,tst)
= if showProcessTable (showWorkflows activated {tst & activated = activated}) ([],{tst & activated = activated})
# (threadTable,tst=:{html,hst,trace,activated})
# (threadTable,tst=:{html,hst,activated})
= if showCurrThreadTable (showThreadTable {tst & activated = activated}) ([],{tst & activated = activated})
# showCompletePage = IF_Ajax (hd threads == [-1]) True
= (toServer,html,Nothing,trace,if showProcessTable (Just processTable) Nothing,if showCurrThreadTable (Just threadTable) Nothing,hst)
\ No newline at end of file
= (toServer,html,Nothing,if showProcessTable (Just processTable) Nothing,if showCurrThreadTable (Just threadTable) Nothing,hst)
\ No newline at end of file
......@@ -2,14 +2,13 @@ definition module TaskTreeFilters
import iTasksTypes
determineTaskList :: !UserId !HtmlTree -> [TaskDescription]
determineTaskForTab :: !UserId !TaskNrId !HtmlTree -> (!Bool,![HtmlTag],![InputId])
determineTaskList :: !UserId !HtmlTree -> [TaskDescription]
determineTaskForTab :: !UserId !TaskNrId !HtmlTree -> (!Bool,![HtmlTag],![InputId])
mkFilteredTaskTree :: !UserId !UserId !HtmlTree -> (![HtmlTag],![InputId])
mkUnfilteredTaskTree :: !HtmlTree -> (![HtmlTag],![InputId])
mkFilteredTaskTree :: !UserId !UserId !HtmlTree -> (![HtmlTag],![InputId])
mkUnfilteredTaskTree :: !HtmlTree -> (![HtmlTag],![InputId])
filterTaskTree :: !HtmlTree -> HtmlTag
filterTaskTreeOfTask :: !UserId !TaskNrId !HtmlTree -> HtmlTag
//TODO: merge trace information into the task tree
showTaskTreeOfTask :: !TaskNrId !(Maybe [Trace]) -> HtmlTag
showTaskTree :: !(Maybe [Trace]) -> HtmlTag
......@@ -23,6 +23,8 @@ determineTaskList thisuser (BT html inputs)
= []
determineTaskList thisuser (DivCode id tree)
= determineTaskList thisuser tree
determineTaskList thisuser (TaskTrace traceinfo tree)
= determineTaskList thisuser tree
determineTaskForTab :: !UserId !TaskNrId !HtmlTree -> (!Bool,![HtmlTag],![InputId])
determineTaskForTab thisuser thistaskid tree
......@@ -52,6 +54,8 @@ determineTaskTree thisuser thistaskid (BT bdtg inputs)
= Nothing
determineTaskTree thisuser thistaskid (DivCode id tree)
= determineTaskTree thisuser thistaskid tree
determineTaskTree thisuser thistaskid (TaskTrace traceinfo tree)
= determineTaskTree thisuser thistaskid tree
mkFilteredTaskTree :: !UserId !UserId !HtmlTree -> (![HtmlTag],![InputId])
mkFilteredTaskTree thisuser taskuser (description @@: tree)
......@@ -77,78 +81,119 @@ mkFilteredTaskTree thisuser taskuser (DivCode id tree)
# (html,inputs) = mkFilteredTaskTree thisuser taskuser tree
| thisuser == taskuser = ([DivTag [IdAttr id, ClassAttr "itasks-thread"] html],inputs)
| otherwise = ([],[])
mkFilteredTaskTree thisuser taskuser (TaskTrace traceinfo tree)
# (html,inputs) = mkFilteredTaskTree thisuser taskuser tree
| thisuser == taskuser = (html,inputs)
| otherwise = ([],[])
mkUnfilteredTaskTree :: !HtmlTree -> (![HtmlTag],![InputId])
mkUnfilteredTaskTree (BT body inputs) = (body, inputs)
mkUnfilteredTaskTree (_ @@: html) = mkUnfilteredTaskTree html
mkUnfilteredTaskTree (_ -@: html) = mkUnfilteredTaskTree html
mkUnfilteredTaskTree (DivCode str html) = mkUnfilteredTaskTree html
mkUnfilteredTaskTree (nodeL +-+ nodeR) = ([htmlL <=> htmlR],inpL ++ inpR)
mkUnfilteredTaskTree (BT body inputs) = (body, inputs)
mkUnfilteredTaskTree (_ @@: html) = mkUnfilteredTaskTree html
mkUnfilteredTaskTree (_ -@: html) = mkUnfilteredTaskTree html
mkUnfilteredTaskTree (DivCode str html) = mkUnfilteredTaskTree html
mkUnfilteredTaskTree (TaskTrace traceinfo html) = mkUnfilteredTaskTree html
mkUnfilteredTaskTree (nodeL +-+ nodeR) = ([htmlL <=> htmlR],inpL ++ inpR)
where
(htmlL,inpL) = mkUnfilteredTaskTree nodeL
(htmlR,inpR) = mkUnfilteredTaskTree nodeR
mkUnfilteredTaskTree (nodeL +|+ nodeR) = (htmlL <|.|> htmlR, inpL ++ inpR)
mkUnfilteredTaskTree (nodeL +|+ nodeR) = (htmlL <|.|> htmlR, inpL ++ inpR)
where
(htmlL,inpL) = mkUnfilteredTaskTree nodeL
(htmlR,inpR) = mkUnfilteredTaskTree nodeR
// ******************************************************************************************************
// Trace Printing ...
// Trace Calculation
// ******************************************************************************************************
showTaskTreeOfTask :: !TaskNrId !(Maybe [Trace]) -> HtmlTag // This can be done much more efficiently, taken the ordening of tasknrs into account
showTaskTreeOfTask tasknr Nothing = Text ("Tracing enabled, cannot determine task tree of task " +++ tasknr)
showTaskTreeOfTask tasknr (Just []) = Text ("Cannot find task tree of task " +++ tasknr)
showTaskTreeOfTask tasknr (Just trace) = showTaskTree (snd (findTaskInTrace tasknr trace))
findTaskInTrace :: !TaskNrId ![Trace] -> (!Bool,!Maybe [Trace])
findTaskInTrace tasknr []
= (False, Just [])
findTaskInTrace tasknr mytrace=:[Trace Nothing traces:mtraces]
# (found,tags) = findTaskInTrace tasknr traces
| found = (found,tags)
= findTaskInTrace tasknr mtraces
findTaskInTrace tasknr mytrace=:[Trace (Just (dtask,(w,i,op,tn,s))) traces:mtraces]
| showTaskNr (repair i) == tasknr = (True, Just mytrace)
# (found,tags) = findTaskInTrace tasknr traces
| found = (found,tags)
= findTaskInTrace tasknr mtraces
:: Trace = Trace !(Maybe !TraceInfo) ![Trace] // traceinfo with possibly subprocess
filterTaskTree :: !HtmlTree -> HtmlTag
filterTaskTree html
# traceInfos = collectTraceInfo html
# traces = insertTraces traceInfos []
= showTaskTree (Just traces)
where
repair [0:tnrs] = [-1:tnrs] // The task numbers obtained from client are one to low: this has to be made global consistent, very ughly
repair other = other
collectTraceInfo :: !HtmlTree -> [TraceInfo]
collectTraceInfo (TaskTrace traceinfo html) = [traceinfo : collectTraceInfo html]
collectTraceInfo (BT body inputs) = []
collectTraceInfo (_ @@: html) = collectTraceInfo html
collectTraceInfo (_ -@: html) = collectTraceInfo html
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
insertTraces [] traces = traces
insertTraces [i:is] traces = insertTraces is (insertTrace i traces)
filterTaskTreeOfTask :: !UserId !TaskNrId !HtmlTree -> HtmlTag
filterTaskTreeOfTask userId taskNrId tree
# mbtree = determineTaskTree userId taskNrId tree
| isNothing mbtree = Text "Error: Cannot find task tree !"
= filterTaskTree (fromJust mbtree)
insertTrace :: !TraceInfo ![Trace] -> [Trace]
insertTrace info trace = insertTrace` (reverse info.trTaskNr) trace
where
insertTrace` :: !TaskNr ![Trace] -> [Trace]
insertTrace` [i] traces
| i < 0 = abort ("negative task numbers:" <+++ showTaskNr 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:" <+++ showTaskNr 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 []
updateAt`:: !Int !Trace ![Trace] -> [Trace]
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]
showTaskTree :: !(Maybe [Trace]) -> HtmlTag
showTaskTree Nothing = Text "No task tree trace " // SpanTag [] []
showTaskTree Nothing = Text "No task tree trace "
showTaskTree (Just a) = DivTag [] [showLabel "Task Tree Forest:", BrTag [] , STable emptyBackground (print False a),HrTag []]
where
print _ [] = []
print b trace = [pr b x ++ [STable emptyBackground (print (isDone x||b) xs)]\\ (Trace x xs) <- trace]
pr _ Nothing = []
pr dprev (Just (dtask,(w,i,op,tn,s)))
| dprev && (not dtask) = pr False Nothing // subtask not important anymore (assume no milestone tasks)
| not dtask && tn%(0,4) == "Ajax " = showTask cellattr1b White Navy Aqua Silver (w,i,op,tn,s)
| not dtask && tn%(0,6) == "Server " = showTask cellattr1b White Navy Aqua Silver (w,i,op,tn,s)
| not dtask && tn%(0,6) == "Client " = showTask cellattr1b White Navy Aqua Silver (w,i,op,tn,s)
| not dtask = showTask cellattr1b White Navy Maroon Silver (w,i,op,tn,s)
= showTask cellattr1a White Yellow Red White (w,i,op,tn,s)
pr dprev (Just info=:{trTaskName, trActivated})
| dprev && (not trActivated) = pr False Nothing // subtask not important anymore (assume no milestone tasks)
| not trActivated && trTaskName%(0,4) == "Ajax " = showTask cellattr1b White Navy Aqua Silver info
| not trActivated && trTaskName%(0,6) == "Server " = showTask cellattr1b White Navy Aqua Silver info
| not trActivated && trTaskName%(0,6) == "Client " = showTask cellattr1b White Navy Aqua Silver info
| not trActivated = showTask cellattr1b White Navy Maroon Silver info
= showTask cellattr1a White Yellow Red White info
showTask2 attr1 c1 c2 c3 c4 (w,i,op,tn,s)
= [TableTag doneBackground [ TrTag [] [TdTag attr1 [font c1 (toString (last (reverse i)))], TdTag cellattr2 [font c2 tn]]
, TrTag [] [TdTag attr1 [font c3 (toString w)], TdTag cellattr2 [font c4 s]]
]
,BrTag []]
showTask att c1 c2 c3 c4 (w,i,op,tn,s)
showTask att c1 c2 c3 c4 info
= [STable doneBackground
[ [font c1 (toString w),font c2 ("T" <+++ showTaskNr i)]
, [showStorage op.tasklife, font c3 tn]
, [EmptyBody, font c4 s]