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
-------------------------------------------------------------------------------
|