threadscope-0.2.14.1: GUI/KeyView.hs
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
-------------------------------------------------------------------------------