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 GC'd, 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 GC'd.") ] 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 repreenting a jagedy 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 -------------------------------------------------------------------------------