1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
|
module GUI.TraceView (
TraceView,
traceViewNew,
TraceViewActions(..),
traceViewSetHECs,
traceViewGetTraces,
) where
import Events.HECs
import GUI.Types
import Graphics.UI.Gtk
import qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat
import Data.Tree
-- | Abstract trace view object.
--
data TraceView = TraceView {
tracesStore :: TreeStore (Trace, Visibility)
}
data Visibility = Visible | Hidden | MixedVisibility
deriving Eq
-- | The actions to take in response to TraceView events.
--
data TraceViewActions = TraceViewActions {
traceViewTracesChanged :: [Trace] -> IO ()
}
traceViewNew :: Builder -> TraceViewActions -> IO TraceView
traceViewNew builder actions = do
tracesTreeView <- builderGetObject builder castToTreeView "traces_tree"
tracesStore <- treeStoreNew []
traceColumn <- treeViewColumnNew
textcell <- cellRendererTextNew
togglecell <- cellRendererToggleNew
let traceview = TraceView {..}
treeViewColumnPackStart traceColumn textcell True
treeViewColumnPackStart traceColumn togglecell False
treeViewAppendColumn tracesTreeView traceColumn
Compat.treeViewSetModel tracesTreeView (Just tracesStore)
cellLayoutSetAttributes traceColumn textcell tracesStore $ \(tr, _) ->
[ cellText := renderTrace tr ]
cellLayoutSetAttributes traceColumn togglecell tracesStore $ \(_, vis) ->
[ cellToggleActive := vis == Visible
, cellToggleInconsistent := vis == MixedVisibility ]
on togglecell cellToggled $ \str -> do
let path = stringToTreePath str
Node (trace, visibility) subtrees <- treeStoreGetTree tracesStore path
let visibility' = invertVisibility visibility
treeStoreSetValue tracesStore path (trace, visibility')
updateChildren tracesStore path subtrees visibility'
updateParents tracesStore (init path)
traceViewTracesChanged actions =<< traceViewGetTraces traceview
return traceview
where
renderTrace (TraceHEC hec) = "HEC " ++ show hec
renderTrace (TraceInstantHEC hec) = "HEC " ++ show hec
renderTrace (TraceCreationHEC hec) = "HEC " ++ show hec
renderTrace (TraceConversionHEC hec) = "HEC " ++ show hec
renderTrace (TracePoolHEC hec) = "HEC " ++ show hec
renderTrace (TraceHistogram) = "Spark Histogram"
renderTrace (TraceGroup label) = label
renderTrace (TraceActivity) = "Activity Profile"
updateChildren tracesStore path subtrees visibility' =
sequence_
[ do treeStoreSetValue tracesStore path' (trace, visibility')
updateChildren tracesStore path' subtrees' visibility'
| (Node (trace, _) subtrees', n) <- zip subtrees [0..]
, let path' = path ++ [n] ]
updateParents :: TreeStore (Trace, Visibility) -> TreePath -> IO ()
updateParents _ [] = return ()
updateParents tracesStore path = do
Node (trace, _) subtrees <- treeStoreGetTree tracesStore path
let visibility = accumVisibility [ vis | subtree <- subtrees
, (_, vis) <- flatten subtree ]
treeStoreSetValue tracesStore path (trace, visibility)
updateParents tracesStore (init path)
invertVisibility Hidden = Visible
invertVisibility _ = Hidden
accumVisibility = foldr1 (\a b -> if a == b then a else MixedVisibility)
-- Find the HEC traces in the treeStore and replace them
traceViewSetHECs :: TraceView -> HECs -> IO ()
traceViewSetHECs TraceView{tracesStore} hecs = do
treeStoreClear tracesStore
-- for testing only (e.g., to compare with histogram of data from interval
-- or to compare visually with other traces):
-- treeStoreInsert tracesStore [] 0 (TraceHistogram, Visible)
go 0
treeStoreInsert tracesStore [] 0 (TraceActivity, Visible)
where
newT = Node { rootLabel = (TraceGroup "HEC Traces", Visible),
subForest = [ Node { rootLabel = (TraceHEC k, Visible),
subForest = [] }
| k <- [ 0 .. hecCount hecs - 1 ] ] }
newI = Node { rootLabel = (TraceGroup "Instant Events", Hidden),
subForest = [ Node { rootLabel = (TraceInstantHEC k, Hidden),
subForest = [] }
| k <- [ 0 .. hecCount hecs - 1 ] ] }
nCre = Node { rootLabel = (TraceGroup "Spark Creation", Hidden),
subForest = [ Node { rootLabel = (TraceCreationHEC k, Hidden),
subForest = [] }
| k <- [ 0 .. hecCount hecs - 1 ] ] }
nCon = Node { rootLabel = (TraceGroup "Spark Conversion", Hidden),
subForest = [ Node { rootLabel = (TraceConversionHEC k, Hidden),
subForest = [] }
| k <- [ 0 .. hecCount hecs - 1 ] ] }
nPoo = Node { rootLabel = (TraceGroup "Spark Pool", Hidden),
subForest = [ Node { rootLabel = (TracePoolHEC k, Hidden),
subForest = [] }
| k <- [ 0 .. hecCount hecs - 1 ] ] }
go n = do
m <- treeStoreLookup tracesStore [n]
case m of
Nothing -> do
treeStoreInsertTree tracesStore [] 0 nPoo
treeStoreInsertTree tracesStore [] 0 nCon
treeStoreInsertTree tracesStore [] 0 nCre
treeStoreInsertTree tracesStore [] 0 newI
treeStoreInsertTree tracesStore [] 0 newT
Just t ->
case t of
Node { rootLabel = (TraceGroup "HEC Traces", _) } -> do
treeStoreRemove tracesStore [n]
treeStoreInsertTree tracesStore [] n newT
go (n+1)
Node { rootLabel = (TraceGroup "HEC Instant Events", _) } -> do
treeStoreRemove tracesStore [n]
treeStoreInsertTree tracesStore [] n newI
go (n+1)
Node { rootLabel = (TraceGroup "Spark Creation", _) } -> do
treeStoreRemove tracesStore [n]
treeStoreInsertTree tracesStore [] n nCre
go (n+1)
Node { rootLabel = (TraceGroup "Spark Conversion", _) } -> do
treeStoreRemove tracesStore [n]
treeStoreInsertTree tracesStore [] n nCon
go (n+1)
Node { rootLabel = (TraceGroup "Spark Pool", _) } -> do
treeStoreRemove tracesStore [n]
treeStoreInsertTree tracesStore [] n nPoo
go (n+1)
Node { rootLabel = (TraceActivity, _) } -> do
treeStoreRemove tracesStore [n]
go (n+1)
_ ->
go (n+1)
traceViewGetTraces :: TraceView -> IO [Trace]
traceViewGetTraces TraceView{tracesStore} = do
f <- getTracesStoreContents tracesStore
return [ t | (t, Visible) <- concatMap flatten f, notGroup t ]
where
notGroup (TraceGroup _) = False
notGroup _ = True
getTracesStoreContents :: TreeStore a -> IO (Forest a)
getTracesStoreContents tracesStore = go 0
where
go !n = do
m <- treeStoreLookup tracesStore [n]
case m of
Nothing -> return []
Just t -> do
ts <- go (n+1)
return (t:ts)
|
