File: KeyView.hs

package info (click to toggle)
threadscope 0.2.14.1-1
  • links: PTS, VCS
  • area: main
  • in suites: bookworm
  • size: 580 kB
  • sloc: haskell: 5,457; ansic: 10; makefile: 7
file content (176 lines) | stat: -rw-r--r-- 7,039 bytes parent folder | download
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

-------------------------------------------------------------------------------