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
|
module GUI.KeyView (
KeyView,
keyViewNew,
) where
import GUI.ViewerColours
import GUI.Timeline.Render.Constants
import Graphics.UI.Gtk
import qualified Graphics.UI.Gtk.ModelView.TreeView.Compat as Compat
import qualified Graphics.Rendering.Cairo as C
---------------------------------------------------------------------------
-- | Abstract key view object.
--
data KeyView = KeyView
---------------------------------------------------------------------------
keyViewNew :: Builder -> IO KeyView
keyViewNew builder = do
keyTreeView <- builderGetObject builder castToTreeView "key_list"
dw <- widgetGetDrawWindow keyTreeView
keyEntries <- createKeyEntries dw keyData
keyStore <- listStoreNew keyEntries
keyColumn <- treeViewColumnNew
imageCell <- cellRendererPixbufNew
labelCell <- cellRendererTextNew
treeViewColumnPackStart keyColumn imageCell False
treeViewColumnPackStart keyColumn labelCell True
treeViewAppendColumn keyTreeView keyColumn
selection <- treeViewGetSelection keyTreeView
treeSelectionSetMode selection SelectionNone
let tooltipColumn = makeColumnIdString 0
customStoreSetColumn keyStore tooltipColumn (\(_,tooltip,_) -> tooltip)
Compat.treeViewSetModel keyTreeView (Just keyStore)
set keyTreeView [ treeViewTooltipColumn := tooltipColumn ]
cellLayoutSetAttributes keyColumn imageCell keyStore $ \(_,_,img) ->
[ cellPixbuf := img ]
cellLayoutSetAttributes keyColumn labelCell keyStore $ \(label,_,_) ->
[ cellText := label ]
---------------------------------------------------------------------------
return KeyView
-------------------------------------------------------------------------------
data KeyStyle = KDuration | KEvent | KEventAndGraph
keyData :: [(String, KeyStyle, Color, String)]
keyData =
[ ("running", KDuration, runningColour,
"Indicates a period of time spent running Haskell code (not GC, not blocked/idle)")
, ("GC", KDuration, gcColour,
"Indicates a period of time spent by the RTS performing garbage collection (GC)")
, ("GC waiting", KDuration, gcWaitColour,
"Indicates a period of time spent by the RTS waiting to initiate or finish garbage collection (GC)")
, ("create thread", KEvent, createThreadColour,
"Indicates a new Haskell thread has been created")
, ("seq GC req", KEvent, seqGCReqColour,
"Indicates a HEC has requested to start a sequential GC")
, ("par GC req", KEvent, parGCReqColour,
"Indicates a HEC has requested to start a parallel GC")
, ("migrate thread", KEvent, migrateThreadColour,
"Indicates a Haskell thread has been moved from one HEC to another")
, ("thread wakeup", KEvent, threadWakeupColour,
"Indicates that a thread that was previously blocked (e.g. I/O, MVar etc) is now ready to run")
, ("shutdown", KEvent, shutdownColour,
"Indicates a HEC is terminating")
, ("user message", KEvent, userMessageColour,
"Indicates a message generated from Haskell code (via traceEvent)")
, ("perf counter", KEvent, createdConvertedColour,
"Indicates an update of a perf counter")
, ("perf tracepoint", KEvent, shutdownColour,
"Indicates that a perf tracepoint was reached")
, ("create spark", KEventAndGraph, createdConvertedColour,
"As an event it indicates a use of `par` resulted in a spark being " ++
"created (and added to the spark pool). In the spark creation " ++
"graph the coloured area represents the number of sparks created.")
, ("dud spark", KEventAndGraph, fizzledDudsColour,
"As an event it indicates a use of `par` resulted in the spark being " ++
"discarded because it was a 'dud' (already evaluated). In the spark " ++
"creation graph the coloured area represents the number of dud sparks.")
, ("overflowed spark",KEventAndGraph, overflowedColour,
"As an event it indicates a use of `par` resulted in the spark being " ++
"discarded because the spark pool was full. In the spark creation " ++
"graph the coloured area represents the number of overflowed sparks.")
, ("run spark", KEventAndGraph, createdConvertedColour,
"As an event it indicates a spark has started to be run/evaluated. " ++
"In the spark conversion graph the coloured area represents the number " ++
"of sparks run.")
, ("fizzled spark", KEventAndGraph, fizzledDudsColour,
"As an event it indicates a spark has 'fizzled', meaning it has been " ++
"discovered that the spark's thunk was evaluated by some other thread. " ++
"In the spark conversion graph the coloured area represents the number " ++
"of sparks that have fizzled.")
, ("GCed spark", KEventAndGraph, gcColour,
"As an event it indicates a spark has been GCed, meaning it has been " ++
"discovered that the spark's thunk was no longer needed anywhere. " ++
"In the spark conversion graph the coloured area represents the number " ++
"of sparks that were GCed.")
]
createKeyEntries :: DrawableClass dw
=> dw
-> [(String, KeyStyle, Color,String)]
-> IO [(String, String, Pixbuf)]
createKeyEntries similar entries =
sequence
[ do pixbuf <- renderToPixbuf similar (50, hecBarHeight) $ do
C.setSourceRGB 1 1 1
C.paint
renderKeyIcon style colour
return (label, tooltip, pixbuf)
| (label, style, colour, tooltip) <- entries ]
renderKeyIcon :: KeyStyle -> Color -> C.Render ()
renderKeyIcon KDuration keyColour = do
setSourceRGBAhex keyColour 1.0
let x = fromIntegral ox
C.rectangle (x - 2) 5 38 (fromIntegral (hecBarHeight `div` 2))
C.fill
renderKeyIcon KEvent keyColour = renderKEvent keyColour
renderKeyIcon KEventAndGraph keyColour = do
renderKEvent keyColour
-- An icon roughly representing a jaggedy graph.
let x = fromIntegral ox
y = fromIntegral hecBarHeight
C.moveTo (2*x) (y - 2)
C.relLineTo 3 (-6)
C.relLineTo 3 0
C.relLineTo 3 3
C.relLineTo 5 1
C.relLineTo 1 (-(y - 4))
C.relLineTo 2 (y - 4)
C.relLineTo 1 (-(y - 4))
C.relLineTo 2 (y - 4)
C.lineTo (2*x+20) (y - 2)
C.fill
setSourceRGBAhex black 1.0
C.setLineWidth 1.0
C.moveTo (2*x-4) (y - 2.5)
C.lineTo (2*x+24) (y - 2.5)
C.stroke
renderKEvent :: Color -> C.Render ()
renderKEvent keyColour = do
setSourceRGBAhex keyColour 1.0
C.setLineWidth 3.0
let x = fromIntegral ox
C.moveTo x 0
C.relLineTo 0 25
C.stroke
renderToPixbuf :: DrawableClass dw => dw -> (Int, Int) -> C.Render ()
-> IO Pixbuf
renderToPixbuf similar (w, h) draw = do
pixmap <- pixmapNew (Just similar) w h Nothing
renderWithDrawable pixmap draw
Just pixbuf <- pixbufGetFromDrawable pixmap (Rectangle 0 0 w h)
return pixbuf
-------------------------------------------------------------------------------
|
