threadscope-0.1.1: Timeline/Render.hs
module Timeline.Render (
exposeTraceView,
renderTraces,
updateLabelDrawingArea,
calculateTotalTimelineHeight,
toWholePixels
) where
import Timeline.Render.Constants
import Timeline.Motion
import Timeline.Ticks
import Timeline.HEC
import Timeline.Activity
import Timeline.RenderBookmarks
import Timeline.WithViewScale
import State
import ViewerColours
import Traces
import CairoDrawing
import GHC.RTS.Events hiding (Event)
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.Events as Old
import Graphics.Rendering.Cairo as C
import Data.Maybe
import Data.IORef
import Control.Monad
import Text.Printf
-------------------------------------------------------------------------------
-- |The 'updateProfileDrawingArea' function is called when an expose event
-- occurs. This function redraws the currently visible part of the
-- main trace canvas plus related canvases.
exposeTraceView :: ViewerState -> Region -> IO ()
exposeTraceView state@ViewerState{..} exposeRegion = do
maybeEventArray <- readIORef hecsIORef
-- Check to see if an event trace has been loaded
case maybeEventArray of
Nothing -> return ()
Just hecs -> renderView state exposeRegion hecs
renderView :: ViewerState -> Region -> HECs -> IO ()
renderView state@ViewerState{..} exposeRegion hecs = do
-- Get state information from user-interface components
bw_mode <- checkMenuItemGetActive bwToggle
labels_mode <- toggleToolButtonGetActive showLabelsToggle
(dAreaWidth,dAreaHeight) <- widgetGetSize timelineDrawingArea
when debug $ do
putStrLn ("\n=== updateCanvas")
putStrLn (show exposeRegion)
printf "width %d, height %d\n" dAreaWidth dAreaHeight
scaleValue <- checkScaleValue state
vadj_value <- adjustmentGetValue timelineVAdj
when debug $ liftIO $ printf "vadj_value: %f\n" vadj_value
totalHeight <- calculateTotalTimelineHeight state
let timelineHeight = max totalHeight dAreaHeight
-- render either the whole height of the timeline, or the window, whichever
-- is larger (this just ensure we fill the background if the timeline is
-- smaller than the window).
-- snap the view to whole pixels, to avoid blurring
hadj_value0 <- adjustmentGetValue timelineAdj
let hadj_value = toWholePixels scaleValue hadj_value0
when debug $ do
hadj_pagesize <- adjustmentGetPageSize timelineAdj
hadj_lower <- adjustmentGetLower timelineAdj
hadj_upper <- adjustmentGetUpper timelineAdj
ctx <- statusbarGetContextId statusBar "debug"
statusbarPush statusBar ctx $
printf "scale=%f win=(%d,%d) hadj: (val=%f, page=%f, l=%f u=%f)"
scaleValue dAreaWidth dAreaHeight
hadj_value hadj_pagesize hadj_lower hadj_upper
return ()
traces <- getViewTraces state
let params = ViewParameters {
width = dAreaWidth,
height = timelineHeight,
viewTraces = traces,
hadjValue = hadj_value,
scaleValue = scaleValue,
detail = 3, -- for now
bwMode = bw_mode,
labelsMode = labels_mode
}
prev_view <- readIORef timelinePrevView
cursor_t <- readIORef cursorIORef
rect <- regionGetClipbox exposeRegion
win <- widgetGetDrawWindow timelineDrawingArea
renderWithDrawable win $ do
let renderToNewSurface = do
new_surface <- withTargetSurface $ \surface ->
liftIO $ createSimilarSurface surface ContentColor
dAreaWidth timelineHeight
renderWith new_surface $ do
clearWhite
renderTraces state params traces hecs rect
return new_surface
surface <-
case prev_view of
Nothing -> do
when debug $ liftIO $ putStrLn "no old surface"
renderToNewSurface
Just (old_params, surface)
| old_params == params
-> do when debug $ liftIO $ putStrLn "using previously rendered view"
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
-- and the views overlap...
then do
when debug $ liftIO $ putStrLn "scrolling"
scrollView state surface old_params params traces hecs
else do
when debug $ liftIO $ putStrLn "using old surface"
renderWith surface $ do
clearWhite; renderTraces state params traces hecs rect
return surface
| otherwise
-> do when debug $ liftIO $ putStrLn "old surface no good"
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 > 0) $ do
renderBookmarks state params
drawCursor cursor_t params
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
drawCursor :: Timestamp -> ViewParameters -> Render ()
drawCursor cursor_t param@ViewParameters{..} = do
withViewScale param $ do
(threePixels, _) <- deviceToUserDistance 3 0
setLineWidth threePixels
setOperator OperatorOver
setSourceRGBAhex blue 1.0
moveTo (fromIntegral cursor_t) 0
lineTo (fromIntegral cursor_t) (fromIntegral height)
stroke
-------------------------------------------------------------------------------
-- This function draws the current view of all the HECs with Cario
renderTraces :: ViewerState -> ViewParameters -> [Trace] -> HECs -> Rectangle
-> Render ()
renderTraces state@ViewerState{..} params@ViewParameters{..}
traces 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
]
when debug $ liftIO $ do
printf "rx = %d, scale_rx = %f, scale_rw = %f, hadjValue = %f, startPos = %d, endPos = %d scaleValue = %f\n" rx scale_rx scale_rw hadjValue startPos endPos scaleValue
-- 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 ->
renderHEC c params startPos endPos (hecTrees hecs !! c)
TraceActivity ->
renderActivity params hecs startPos endPos
_ ->
return ()
restore
-- Now rennder all the HECs.
zipWithM_ renderTrace traces (traceYPositions labelsMode traces)
when debug $ liftIO $ putStrLn "renderTraces done\n"
-------------------------------------------------------------------------------
-- parameters differ only in the hadjValue, we can scroll ...
scrollView :: ViewerState -> Surface
-> ViewParameters -> ViewParameters
-> [Trace] -> HECs
-> Render Surface
scrollView state surface old new traces 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.
C.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
C.fill
renderTraces state new traces hecs rect
surfaceFinish surface
return new_surface
------------------------------------------------------------------------------
toWholePixels :: Double -> Double -> Double
toWholePixels 0 x = 0
toWholePixels scale x = fromIntegral (truncate (x / scale)) * scale
-------------------------------------------------------------------------------
-- This function returns a value which can be used to scale
-- Timestamp event log values to pixels.
-- If the scale has previous been computed then it is resued.
-- An "uncomputed" scale value is represetned as -1.0 (defaultScaleValue)
-- We estimate the width of the vertical scrollbar at 20 pixels
checkScaleValue :: ViewerState -> IO Double
checkScaleValue state@ViewerState{..}
= do scaleValue <- readIORef scaleIORef
if scaleValue < 0.0
then do zoomToFit state
readIORef scaleIORef
else return scaleValue
-------------------------------------------------------------------------------
updateLabelDrawingArea :: ViewerState -> Event -> IO Bool
updateLabelDrawingArea state@ViewerState{..} (Expose { Old.eventArea=rect })
= do traces <- getViewTraces state
labels_mode <- toggleToolButtonGetActive showLabelsToggle
win <- widgetGetDrawWindow timelineLabelDrawingArea
vadj_value <- adjustmentGetValue timelineVAdj
gc <- gcNew win
let ys = map (subtract (round vadj_value)) $
traceYPositions labels_mode traces
zipWithM_ (drawLabel timelineLabelDrawingArea gc) traces ys
return True
updateLabelDrawingArea _ _ = error "updateLabelDrawingArea"
drawLabel :: DrawingArea -> GC -> Trace -> Int -> IO ()
drawLabel canvas gc trace y
= do win <- widgetGetDrawWindow canvas
txt <- canvas `widgetCreateLayout` (showTrace trace)
drawLayoutWithColors win gc 10 y txt (Just black) Nothing
--------------------------------------------------------------------------------
traceYPositions :: Bool -> [Trace] -> [Int]
traceYPositions labels_mode traces
= scanl (\a b -> a + (traceHeight b) + extra + tracePad) firstTraceY traces
where
extra = if labels_mode then hecLabelExtra else 0
traceHeight (TraceHEC _) = hecTraceHeight
traceHeight TraceActivity = activityGraphHeight
traceHeight _ = 0
--------------------------------------------------------------------------------
showTrace :: Trace -> String
showTrace (TraceHEC n) = "HEC " ++ show n
showTrace TraceActivity = "Activity"
showTrace _ = "?"
--------------------------------------------------------------------------------
calculateTotalTimelineHeight :: ViewerState -> IO Int
calculateTotalTimelineHeight state@ViewerState{..} = do
traces <- getViewTraces state
labels_mode <- toggleToolButtonGetActive showLabelsToggle
return $ last (traceYPositions labels_mode traces)
--------------------------------------------------------------------------------