implementation module Trace import StdList, StdTuple import Html, Text import ProcessDB import TaskTree import JSON derive JSONEncode TraceTree derive JSONDecode TraceTree derive bimap Maybe, (,) traceProcesses :: [Process] -> HtmlTag traceProcesses processes = mkTable processes where mkTable processes = TableTag [ClassAttr "debug-table"] [mkHeader: [mkRow process \\ process <- processes]] mkHeader = TrTag [] [ThTag [] [Text "Id"],ThTag [] [Text "Subject"],ThTag [] [Text "Owner"],ThTag [] [Text "Delegator"], ThTag [] [Text "Status"],ThTag [] [Text "Parent"], ThTag [] [Text "Active changes"] ] mkRow process = TrTag [] [ TdTag [] [Text process.Process.processId] , TdTag [] [Text process.Process.properties.managerProps.subject] , TdTag [] [Text (toString (fst process.Process.properties.managerProps.worker) +++ ": " +++ snd process.Process.properties.managerProps.worker)] , TdTag [] [Text (toString (fst process.Process.properties.systemProps.manager) +++ ": " +++ snd process.Process.properties.systemProps.manager)] , TdTag [] [Text (toString process.Process.status)] , TdTag [] (case process.Process.parent of "" = [Text "N/A"] x = [Text (toString x)] ) , TdTag [] [Text (join ", " (map fst process.Process.changes))] ] traceTaskTree :: TaskTree -> TraceTree traceTaskTree tree = mkTree tree where mkTree (TTInteractiveTask info _ _) = { cls = "master-task" , user = "" , uiProvider = "col" , leaf = True , iconCls = "task-int" , taskId = info.TaskInfo.taskId , taskLabel = toString (Text info.TaskInfo.taskLabel) , traceValue = info.TaskInfo.traceValue , taskClass = "INT" , children = [] } mkTree (TTMonitorTask info _ ) = { cls = "master-task" , user = "" , uiProvider = "col" , leaf = True , iconCls = "task-mon" , taskId = info.TaskInfo.taskId , taskLabel = toString (Text info.TaskInfo.taskLabel) , traceValue = info.TaskInfo.traceValue , taskClass = "MON" , children = [] } mkTree (TTRpcTask info _ ) = { cls = "master-task" , user = "" , uiProvider = "col" , leaf = True , iconCls = "task-rpc" , taskId = info.TaskInfo.taskId , taskLabel = toString (Text info.TaskInfo.taskLabel) , traceValue = info.TaskInfo.traceValue , taskClass = "RPC" , children = [] } mkTree (TTSequenceTask info trees) = { cls = "master-task" , user = "" , uiProvider = "col" , leaf = checkIfLeaf trees , iconCls = "task-seq" , taskId = info.TaskInfo.taskId , taskLabel = toString (Text info.TaskInfo.taskLabel) , traceValue = info.TaskInfo.traceValue , taskClass = "SEQ" , children = [traceTaskTree tree \\ tree <- trees] } mkTree (TTParallelTask info trees) = { cls = "master-task" , user = "" , uiProvider = "col" , leaf = checkIfLeaf trees , iconCls = "task-par" , taskId = info.TaskInfo.taskId , taskLabel = toString (Text info.TaskInfo.taskLabel) , traceValue = info.TaskInfo.traceValue , taskClass = "PAR" , children = [traceTaskTree tree \\ tree <- trees] } mkTree (TTMainTask info mti trees) # (userId, userName) = mti.TaskProperties.managerProps.TaskManagerProperties.worker = { cls = "master-task" , uiProvider = "col" , user = userName+++" ("+++toString userId+++")" , leaf = checkIfLeaf trees , iconCls = "task-mnt" , taskId = info.TaskInfo.taskId , taskLabel = toString (Text info.TaskInfo.taskLabel) , traceValue = info.TaskInfo.traceValue , taskClass = "MNT" , children = [traceTaskTree tree \\ tree <- trees] } mkTree (TTFinishedTask info) = { cls = "master-task" , user = "" , uiProvider = "col" , leaf = True , iconCls = "task-fin" , taskId = info.TaskInfo.taskId , taskLabel = toString (Text info.TaskInfo.taskLabel) , traceValue = info.TaskInfo.traceValue , taskClass = "FIN" , children = [] } checkIfLeaf trees | length trees > 0 = False | otherwise = True traceTaskForest :: [TaskTree] -> String traceTaskForest trees = toJSON [traceTaskTree tree \\ tree <- trees]