Commit 19206a2d authored by Rinus Plasmeijer's avatar Rinus Plasmeijer

polished filtering code;

removed a bug for displaying task trees

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/branches/fancyTasks@313 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 5604f0d9
......@@ -18,15 +18,15 @@ Start :: *World -> *World
Start world = startTaskEngine (orderPlacement user) world
orderPlacement user
= (user @: ("Shopping", selectFromShop))
= (user @:> ("Shopping", selectFromShop))
-&&-
(user @: ("Credit Card Information", fillInAndCheckCreditCard createDefault))
=>> \(basket,cardInfo) -> user @: ("Order Confirmation", confirmOrder basket cardInfo)
=>> \_ -> bank @: ("Cash Request", cashRequest bank cardInfo (amountFrom basket))
(user @:> ("Credit Card Information", fillInAndCheckCreditCard createDefault))
=>> \(basket,cardInfo) -> user @:> ("Order Confirmation", confirmOrder basket cardInfo)
=>> \_ -> bank @:> ("Cash Request", cashRequest bank cardInfo (amountFrom basket))
=>> \granted -> if granted
(storage @: ("Order Delivery Request", deliverOrder user basket (deliveryAddress cardInfo)) #>>
user @: ("Delivery Notice", deliverOKNotice user basket (deliveryAddress cardInfo)))
(user @: ("Delivery Failure", deliverFailureNotice user basket (amountFrom basket)))
(storage @:> ("Order Delivery Request", deliverOrder user basket (deliveryAddress cardInfo)) #>>
user @:> ("Delivery Notice", deliverOKNotice user basket (deliveryAddress cardInfo)))
(user @:> ("Delivery Failure", deliverFailureNotice user basket (amountFrom basket)))
fillInAndCheckCreditCard :: CardInfo -> Task CardInfo
fillInAndCheckCreditCard cardInfo
......@@ -45,20 +45,24 @@ bank :== 0
storage :== 0
webSystem :== 0
items = [("Appels", 1.0,3.50),("Peren", 1.0,2.50)]
items = [(DisplayMode "Appels", 1.0,DisplayMode 3.50),(DisplayMode "Peren", 1.0,DisplayMode 2.50)]
instance toString (DisplayMode a) | toString a
where
toString (DisplayMode a) = toString a
instance toString (a,b,c) | toString a & toString b & toString c
where
toString (a,b,c) = "(" <+++ a <+++ "," <+++ b <+++ "," <+++ c <+++ ")"
amountFrom (item,amount,price) = amount * price
amountFrom (item,amount,DisplayMode price) = amount * price
deliveryAddress cardInfo = "delivery address " +++ cardInfo
selectFromShop
= [Text "Please select an item from our shop"]
?>> editTask "OK" ("Appels", 1.0,3.50)
?>> editTask "OK" (DisplayMode "Appels", 1.0,DisplayMode 3.50)
fillInCreditCard cardInfo
= [Text "Please fill in your credit card number"]
......
......@@ -15,7 +15,7 @@ handleTaskTreeForestRequest mainTask request session hst
# 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
# taskTreeTrace = getFullTraceFromTaskTree htmlTree // calculate Task Tree
# content = toString (DivTag [IdAttr "itasks-tasktreeforest",ClassAttr "trace"] [taskTreeTrace])
= ({http_emptyResponse & rsp_data = content}, hst) // create the http response
......
......@@ -27,8 +27,8 @@ 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, maybeProcessTable, maybeThreadTable, hst)
= calculateTaskTree thisUserId True True True mainTask hst // calculate the TaskTree given the id of the current user
# (toServer, htmlTree, maybeError, _, _, hst)
= calculateTaskTree thisUserId traceOn False False mainTask hst // calculate the TaskTree given the id of the current user
# (taskStatus,html,inputs) = determineTaskForTab thisUserId taskId htmlTree // filter out the code and inputs to display in this tab
# (htmlstates,hst) = getPageStates hst // Collect states that must be temporarily stored in the browser
# hst =: {states} = storeStates hst // Write states that are stored on the server
......@@ -63,22 +63,28 @@ handleWorkTabRequest mainTask request session hst
= ({http_emptyResponse & rsp_data = toJSON content}, {hst & states = states}) // create the http response
where
traceOn = http_getValue "traceStates" request.arg_post "" == "1"
traceUpdatesOn = http_getValue "traceUpdates" request.arg_post "" == "1"
traceSubTreesOn = http_getValue "traceSubTrees" request.arg_post "" == "1"
mbStateTrace req states
| http_getValue "traceStates" req.arg_post "" == "1"
| traceOn
# (trace1,states) = traceInStates states
# (trace2,states) = traceStates states
= (Just (toString (DivTag [] [trace1,trace2])), states)
| otherwise
= (Nothing, states)
mbUpdateTrace req states
| http_getValue "traceUpdates" req.arg_post "" == "1"
| traceUpdatesOn
# (trace,states) = traceUpdates states
= (Just (toString trace), states)
| otherwise
= (Nothing, states)
mbSubTreeTrace req thisUserId taskId htmlTree
| http_getValue "traceSubTrees" req.arg_post "" == "1"
= Just (toString (filterTaskTreeOfTask thisUserId taskId htmlTree))
| traceSubTreesOn
= Just (toString (getTraceFromTaskTree thisUserId taskId htmlTree))
| otherwise
= Nothing
......@@ -109,9 +109,9 @@ where
assignTaskTo :: !UserId !(LabeledTask a) -> Task a | iData a
assignTaskTo nuserId (taskname,taska) = Task assignTaskTo`
where
assignTaskTo` tst=:{html=ohtml,tasknr,activated,userId,workflowLink=(_,(_,processNr,workflowLabel))}
assignTaskTo` tst=:{tasknr,activated,userId,workflowLink=(_,(_,processNr,workflowLabel))}
| not activated = (createDefault,tst)
# (currtime,tst) = appTaskTSt (appWorldOnce ("Task: " +++ taskname +++ " For: " +++ toString nuserId) time) tst
# (currtime,tst=:{html=ohtml}) = 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 NEWTRACE
| activated = (a,{tst & activated = True // work is done
......
......@@ -12,7 +12,9 @@ determineTaskForTab :: !UserId !TaskNrId !HtmlTree -> (!TaskStatus,![HtmlTag],
mkFilteredTaskTree :: !UserId !UserId !HtmlTree -> (![HtmlTag],![InputId])
mkUnfilteredTaskTree :: !HtmlTree -> (![HtmlTag],![InputId])
filterTaskTree :: !HtmlTree -> HtmlTag
filterTaskTreeOfTask :: !UserId !TaskNrId !HtmlTree -> HtmlTag
// Showing Trace from Task Tree
getFullTraceFromTaskTree:: !HtmlTree -> HtmlTag
getTraceFromTaskTree :: !UserId !TaskNrId !HtmlTree -> HtmlTag
......@@ -6,7 +6,6 @@ import InternaliTasksCommon, iTasksHtmlSupport
:: TaskStatus = TaskFinished | TaskActivated | TaskDeleted
instance == TaskStatus
where
(==) TaskFinished TaskFinished = True
......@@ -38,7 +37,7 @@ determineTaskList thisuser (TaskTrace traceinfo tree)
determineTaskForTab :: !UserId !TaskNrId !HtmlTree -> (!TaskStatus,![HtmlTag],![InputId])
determineTaskForTab thisuser thistaskid tree
= case determineTaskTree thisuser thistaskid tree of //Find the subtree by task id
= case determineMyTaskTree thisuser thistaskid tree of //Find the subtree by task id
Nothing
= (TaskDeleted, [], []) //Subtask not found, nothing to do anymore
Just tree
......@@ -49,38 +48,6 @@ determineTaskForTab thisuser thistaskid tree
| description.taskNrId == thistaskid && description.curStatus = TaskFinished
= TaskActivated
determineTaskTree :: !UserId !TaskNrId !HtmlTree -> Maybe HtmlTree
determineTaskTree thisuser thistaskid (taskdescr @@: tree)
| taskdescr.taskNrId == thistaskid = Just (taskdescr @@: (pruneTree tree))
= determineTaskTree thisuser thistaskid tree
determineTaskTree thisuser thistaskid (ntaskuser -@: tree)
| thisuser == ntaskuser = Nothing
= determineTaskTree thisuser thistaskid tree
determineTaskTree thisuser thistaskid (tree1 +|+ tree2)
# ntree1 = determineTaskTree thisuser thistaskid tree1
| isJust ntree1 = ntree1
= determineTaskTree thisuser thistaskid tree2
determineTaskTree thisuser thistaskid (tree1 +-+ tree2)
# ntree1 = determineTaskTree thisuser thistaskid tree1
| isJust ntree1 = ntree1
= determineTaskTree thisuser thistaskid tree2
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
pruneTree :: !HtmlTree -> HtmlTree // delete all sub trees not belonging to this task
pruneTree (taskdescr @@: tree) = BT [] []
pruneTree (ntaskuser -@: tree) = ntaskuser -@: pruneTree tree
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))
mkFilteredTaskTree :: !UserId !UserId !HtmlTree -> (![HtmlTag],![InputId])
mkFilteredTaskTree thisuser taskuser (description @@: tree)
# (html,inputs) = mkFilteredTaskTree thisuser description.taskWorkerId tree
......@@ -125,6 +92,41 @@ where
(htmlL,inpL) = mkUnfilteredTaskTree nodeL
(htmlR,inpR) = mkUnfilteredTaskTree nodeR
// ******************************************************************************************************
// 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
determineMyTaskTree thisuser thistaskid (BT bdtg inputs)
= Nothing
determineMyTaskTree thisuser thistaskid (ntaskuser -@: tree)
= determineMyTaskTree thisuser thistaskid tree
determineMyTaskTree thisuser thistaskid (tree1 +-+ tree2)
# ntree1 = determineMyTaskTree thisuser thistaskid tree1
| isJust ntree1 = ntree1
= determineMyTaskTree thisuser thistaskid tree2
determineMyTaskTree thisuser thistaskid (tree1 +|+ tree2)
# ntree1 = determineMyTaskTree thisuser thistaskid tree1
| isJust ntree1 = ntree1
= determineMyTaskTree thisuser thistaskid tree2
determineMyTaskTree thisuser thistaskid (DivCode id tree)
= determineMyTaskTree thisuser thistaskid tree
determineMyTaskTree thisuser thistaskid (TaskTrace traceinfo tree)
= determineMyTaskTree thisuser thistaskid tree
determineMyTaskTree thisuser thistaskid (taskdescr @@: tree)
| taskdescr.taskNrId == thistaskid &&
taskdescr.taskWorkerId == thisuser= Just (taskdescr @@: (pruneTree tree))
= determineMyTaskTree thisuser thistaskid tree
where
pruneTree :: !HtmlTree -> HtmlTree // delete all sub trees not belonging to this task
pruneTree (taskdescr @@: tree) = BT [] []
pruneTree (ntaskuser -@: tree) = ntaskuser -@: pruneTree tree
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)
// ******************************************************************************************************
// Trace Calculation
......@@ -132,11 +134,17 @@ where
:: Trace = Trace !(Maybe !TraceInfo) ![Trace] // traceinfo with possibly subprocess
filterTaskTree :: !HtmlTree -> HtmlTag
filterTaskTree html
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
# traceInfos = collectTraceInfo html
# traces = insertTraces traceInfos []
= showTaskTree (Just traces)
= showTaskTreeTrace (Just traces)
where
collectTraceInfo :: !HtmlTree -> [TraceInfo]
collectTraceInfo (TaskTrace traceinfo html) = [traceinfo : collectTraceInfo html]
......@@ -156,46 +164,43 @@ where
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 (parseTaskNr info.trTaskNr)) trace
where
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 []
updateAt`:: !Int !Trace ![Trace] -> [Trace]
updateAt` n x list
| n < 0 = abort "negative numbers not allowed"
= updateAt` n x list
insertTrace :: !TraceInfo ![Trace] -> [Trace]
insertTrace info trace = insertTrace` (reverse (parseTaskNr info.trTaskNr)) trace
where
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 []
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]
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
// ******************************************************************************************************
showTaskTree :: !(Maybe [Trace]) -> HtmlTag
showTaskTree Nothing = Text "No task tree trace "
showTaskTree (Just a) = DivTag [] [showLabel "Task Tree Forest:", BrTag [] , STable emptyBackground (print False a),HrTag []]
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 []]
where
print _ [] = []
print b trace = [pr b x ++ [STable emptyBackground (print (isDone x||b) xs)]\\ (Trace x xs) <- trace]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment