threadscope-0.2.0: GUI/Timeline/Render.hs
{-# LANGUAGE NamedFieldPuns #-}
module GUI.Timeline.Render (
renderView,
renderTraces,
updateLabelDrawingArea,
calculateTotalTimelineHeight,
toWholePixels
) where
import GUI.Timeline.Types
import GUI.Timeline.Render.Constants
import GUI.Timeline.Ticks
import GUI.Timeline.HEC
import GUI.Timeline.Sparks
import GUI.Timeline.Activity
import Events.HECs
import GUI.Types
import GUI.ViewerColours
import GUI.Timeline.CairoDrawing
import Graphics.UI.Gtk
import Graphics.Rendering.Cairo
import Graphics.UI.Gtk.Gdk.GC (GC, gcNew) --FIXME: eliminate old style drawing
import Data.IORef
import Control.Monad
-------------------------------------------------------------------------------
-- | This function redraws the currently visible part of the
-- main trace canvas plus related canvases.
--
renderView :: TimelineState
-> ViewParameters
-> HECs -> Timestamp -> [Timestamp]
-> Region -> IO ()
renderView TimelineState{timelineDrawingArea, timelineVAdj, timelinePrevView}
params hecs cursor_t bookmarks exposeRegion = do
-- Get state information from user-interface components
(dAreaWidth, _) <- widgetGetSize timelineDrawingArea
vadj_value <- adjustmentGetValue timelineVAdj
prev_view <- readIORef timelinePrevView
rect <- regionGetClipbox exposeRegion
win <- widgetGetDrawWindow timelineDrawingArea
renderWithDrawable win $ do
let renderToNewSurface = do
new_surface <- withTargetSurface $ \surface ->
liftIO $ createSimilarSurface surface ContentColor
dAreaWidth (height params)
renderWith new_surface $ do
clearWhite
renderTraces params hecs rect
return new_surface
surface <-
case prev_view of
Nothing -> renderToNewSurface
Just (old_params, surface)
| old_params == params
-> return surface
| width old_params == width params &&
height old_params == height params
-> do
if old_params { hadjValue = hadjValue params } == params
-- only the hadjValue changed
&& abs (hadjValue params - hadjValue old_params) <
fromIntegral (width params) * scaleValue params
-- and the views overlap...
then do
scrollView surface old_params params hecs
else do
renderWith surface $ do
clearWhite; renderTraces params hecs rect
return surface
| otherwise
-> do surfaceFinish surface
renderToNewSurface
liftIO $ writeIORef timelinePrevView (Just (params, surface))
region exposeRegion
clip
setSourceSurface surface 0 (-vadj_value)
-- ^^ this is where we adjust for the vertical scrollbar
setOperator OperatorSource
paint
when (scaleValue params > 0) $ do
renderBookmarks bookmarks params
drawCursor cursor_t params
-------------------------------------------------------------------------------
-- Render the bookmarks
renderBookmarks :: [Timestamp] -> ViewParameters -> Render ()
renderBookmarks bookmarks vp@ViewParameters{height} = do
setLineWidth 1
setSourceRGBAhex bookmarkColour 1.0
sequence_
[ do moveTo x 0
lineTo x (fromIntegral height)
stroke
| bookmark <- bookmarks
, let x = timestampToView vp bookmark ]
-------------------------------------------------------------------------------
drawCursor :: Timestamp -> ViewParameters -> Render ()
drawCursor cursor_t vp@ViewParameters{height} = do
setLineWidth 3
setOperator OperatorOver
setSourceRGBAhex blue 1.0
let x = timestampToView vp cursor_t
moveTo x 0
lineTo x (fromIntegral height)
stroke
-------------------------------------------------------------------------------
-- We currently have two different way of converting from logical units
-- (ie timestamps in nanoseconds) to device units (ie pixels):
-- * the first is to set the cairo context to the appropriate scale
-- * the second is to do the conversion ourself
--
-- While in principle the first is superior due to the simplicity: cairo
-- lets us use Double as the logical unit and scaling factor. In practice
-- however cairo does not support the full Double range because internally
-- it makes use of a 32bit fixed point float format. With very large scaling
-- factors we end up with artifacts like lines disappearing.
--
-- So sadly we will probably have to convert to using the second method.
-- | Use cairo to convert from logical units (timestamps) to device units
--
withViewScale :: ViewParameters -> Render () -> Render ()
withViewScale ViewParameters{scaleValue, hadjValue} inner = do
save
scale (1/scaleValue) 1.0
translate (-hadjValue) 0
inner
restore
-- | Manually convert from logical units (timestamps) to device units.
--
timestampToView :: ViewParameters -> Timestamp -> Double
timestampToView ViewParameters{scaleValue, hadjValue} ts =
(fromIntegral ts - hadjValue) / scaleValue
-------------------------------------------------------------------------------
-- This function draws the current view of all the HECs with Cario
renderTraces :: ViewParameters -> HECs -> Rectangle
-> Render ()
renderTraces params@ViewParameters{..} hecs (Rectangle rx _ry rw _rh)
= do
let
scale_rx = fromIntegral rx * scaleValue
scale_rw = fromIntegral rw * scaleValue
scale_width = fromIntegral width * scaleValue
startPos :: Timestamp
startPos = fromIntegral (max 0 (truncate (scale_rx + hadjValue)))
-- hadj_value might be negative, as we leave a
-- small gap before the trace starts at the beginning
endPos :: Timestamp
endPos = minimum [
ceiling (max 0 (hadjValue + scale_width)),
ceiling (max 0 (hadjValue + scale_rx + scale_rw)),
hecLastEventTime hecs
]
-- Now render the timeline drawing if we have a non-empty trace
when (scaleValue > 0) $ do
withViewScale params $ do
save
-- First render the ticks and tick times
renderTicks startPos endPos scaleValue height
restore
-- This function helps to render a single HEC...
let
renderTrace trace y = do
save
translate 0 (fromIntegral y)
case trace of
TraceHEC c ->
let (dtree, etree, _) = hecTrees hecs !! c
in renderHEC params startPos endPos (dtree, etree)
SparkCreationHEC c ->
let (_, _, stree) = hecTrees hecs !! c
maxV = maxSparkValue hecs
in renderSparkCreation params startPos endPos stree maxV
SparkConversionHEC c ->
let (_, _, stree) = hecTrees hecs !! c
maxV = maxSparkValue hecs
in renderSparkConversion params startPos endPos stree maxV
SparkPoolHEC c ->
let (_, _, stree) = hecTrees hecs !! c
maxP = maxSparkPool hecs
in renderSparkPool params startPos endPos stree maxP
TraceActivity ->
renderActivity params hecs startPos endPos
_ ->
return ()
restore
-- Now rennder all the HECs.
zipWithM_ renderTrace viewTraces (traceYPositions labelsMode viewTraces)
-------------------------------------------------------------------------------
-- parameters differ only in the hadjValue, we can scroll ...
scrollView :: Surface
-> ViewParameters -> ViewParameters
-> HECs
-> Render Surface
scrollView surface old new hecs = do
-- scrolling on the same surface seems not to work, I get garbled results.
-- Not sure what the best way to do this is.
-- let new_surface = surface
new_surface <- withTargetSurface $ \surface ->
liftIO $ createSimilarSurface surface ContentColor
(width new) (height new)
renderWith new_surface $ do
let
scale = scaleValue new
old_hadj = hadjValue old
new_hadj = hadjValue new
w = fromIntegral (width new)
h = fromIntegral (height new)
off = (old_hadj - new_hadj) / scale
-- liftIO $ printf "scrollView: old: %f, new %f, dist = %f (%f pixels)\n"
-- old_hadj new_hadj (old_hadj - new_hadj) off
-- copy the content from the old surface to the new surface,
-- shifted by the appropriate amount.
setSourceSurface surface off 0
if old_hadj > new_hadj
then do rectangle off 0 (w - off) h -- scroll right.
else do rectangle 0 0 (w + off) h -- scroll left.
fill
let rect | old_hadj > new_hadj
= Rectangle 0 0 (ceiling off) (height new)
| otherwise
= Rectangle (truncate (w + off)) 0 (ceiling (-off)) (height new)
case rect of
Rectangle x y w h -> rectangle (fromIntegral x) (fromIntegral y)
(fromIntegral w) (fromIntegral h)
setSourceRGBA 0xffff 0xffff 0xffff 0xffff
fill
renderTraces new hecs rect
surfaceFinish surface
return new_surface
------------------------------------------------------------------------------
toWholePixels :: Double -> Double -> Double
toWholePixels 0 _x = 0
toWholePixels scale x = fromIntegral (truncate (x / scale)) * scale
-------------------------------------------------------------------------------
updateLabelDrawingArea :: TimelineState -> Bool -> [Trace] -> IO ()
updateLabelDrawingArea TimelineState{timelineVAdj, timelineLabelDrawingArea} showLabels traces
= do win <- widgetGetDrawWindow timelineLabelDrawingArea
vadj_value <- adjustmentGetValue timelineVAdj
gc <- gcNew win
let ys = map (subtract (round vadj_value)) $
traceYPositions showLabels traces
zipWithM_ (drawLabel timelineLabelDrawingArea gc) traces ys
drawLabel :: DrawingArea -> GC -> Trace -> Int -> IO ()
drawLabel canvas gc trace y
= do win <- widgetGetDrawWindow canvas
txt <- canvas `widgetCreateLayout` (showTrace trace)
--FIXME: eliminate use of GC drawing and use cairo instead.
drawLayoutWithColors win gc 10 y txt (Just black) Nothing
--------------------------------------------------------------------------------
traceYPositions :: Bool -> [Trace] -> [Int]
traceYPositions showLabels traces
= scanl (\a b -> a + (traceHeight b) + extra + tracePad) firstTraceY traces
where
extra = if showLabels then hecLabelExtra else 0
traceHeight (TraceHEC _) = hecTraceHeight
traceHeight (SparkCreationHEC _) = hecSparksHeight
traceHeight (SparkConversionHEC _) = hecSparksHeight
traceHeight (SparkPoolHEC _) = hecSparksHeight
traceHeight TraceActivity = activityGraphHeight
traceHeight _ = 0
--------------------------------------------------------------------------------
showTrace :: Trace -> String
showTrace (TraceHEC n) = "HEC " ++ show n
showTrace (SparkCreationHEC n) = "Spark\ncreation\nrate\n(spark/ms)\nHEC " ++ show n
showTrace (SparkConversionHEC n) = "Spark\nconversion\nrate\n(spark/ms)\nHEC " ++ show n
showTrace (SparkPoolHEC n) = "Spark pool\nsize\nHEC " ++ show n
showTrace TraceActivity = "Activity"
showTrace _ = "?"
--------------------------------------------------------------------------------
calculateTotalTimelineHeight :: Bool -> [Trace] -> Int
calculateTotalTimelineHeight showLabels traces =
last (traceYPositions showLabels traces)
--------------------------------------------------------------------------------