1{-# LANGUAGE CPP #-}
2module GUI.Timeline (
3    TimelineView,
4    timelineViewNew,
5    TimelineViewActions(..),
6
7    timelineSetBWMode,
8    timelineSetLabelsMode,
9    timelineGetViewParameters,
10    timelineGetYScaleArea,
11    timelineWindowSetHECs,
12    timelineWindowSetTraces,
13    timelineWindowSetBookmarks,
14    timelineSetSelection,
15    TimeSelection(..),
16
17    timelineZoomIn,
18    timelineZoomOut,
19    timelineZoomToFit,
20    timelineScrollLeft,
21    timelineScrollRight,
22    timelineScrollToBeginning,
23    timelineScrollToEnd,
24    timelineCentreOnCursor,
25 ) where
26
27import GUI.Types
28import GUI.Timeline.Types
29
30import GUI.Timeline.Motion
31import GUI.Timeline.Render
32import GUI.Timeline.Render.Constants
33
34import Events.HECs
35
36import Graphics.UI.Gtk
37import Graphics.Rendering.Cairo ( liftIO )
38
39import Data.IORef
40import Control.Monad
41import qualified Data.Text as T
42
43-----------------------------------------------------------------------------
44-- The CPUs view
45
46data TimelineView = TimelineView {
47
48       timelineState   :: TimelineState,
49
50       hecsIORef       :: IORef (Maybe HECs),
51       tracesIORef     :: IORef [Trace],
52       bookmarkIORef   :: IORef [Timestamp],
53
54       selectionRef    :: IORef TimeSelection,
55       labelsModeIORef :: IORef Bool,
56       bwmodeIORef     :: IORef Bool,
57
58       cursorIBeam     :: Cursor,
59       cursorMove      :: Cursor
60     }
61
62data TimelineViewActions = TimelineViewActions {
63       timelineViewSelectionChanged :: TimeSelection -> IO ()
64     }
65
66-- | Draw some parts of the timeline in black and white rather than colour.
67timelineSetBWMode :: TimelineView -> Bool -> IO ()
68timelineSetBWMode timelineWin bwmode = do
69  writeIORef (bwmodeIORef timelineWin) bwmode
70  widgetQueueDraw (timelineDrawingArea (timelineState timelineWin))
71
72timelineSetLabelsMode :: TimelineView -> Bool -> IO ()
73timelineSetLabelsMode timelineWin labelsMode = do
74  writeIORef (labelsModeIORef timelineWin) labelsMode
75  widgetQueueDraw (timelineDrawingArea (timelineState timelineWin))
76
77timelineGetViewParameters :: TimelineView -> IO ViewParameters
78timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, labelsModeIORef,
79                                       timelineState=TimelineState{..}} = do
80
81  (w, _) <- widgetGetSize timelineDrawingArea
82  scaleValue  <- readIORef scaleIORef
83  maxSpkValue <- readIORef maxSpkIORef
84
85  -- snap the view to whole pixels, to avoid blurring
86  hadj_value0 <- adjustmentGetValue timelineAdj
87  let hadj_value = toWholePixels scaleValue hadj_value0
88
89  traces <- readIORef tracesIORef
90  bwmode <- readIORef bwmodeIORef
91  labelsMode <- readIORef labelsModeIORef
92
93  (_, xScaleAreaHeight) <- widgetGetSize timelineXScaleArea
94  let histTotalHeight = stdHistogramHeight + histXScaleHeight
95      timelineHeight =
96        calculateTotalTimelineHeight labelsMode histTotalHeight traces
97
98  return ViewParameters
99           { width      = w
100           , height     = timelineHeight
101           , viewTraces = traces
102           , hadjValue  = hadj_value
103           , scaleValue = scaleValue
104           , maxSpkValue = maxSpkValue
105           , detail     = 3 --for now
106           , bwMode     = bwmode
107           , labelsMode = labelsMode
108           , histogramHeight = stdHistogramHeight
109           , minterval = Nothing
110           , xScaleAreaHeight = xScaleAreaHeight
111           }
112
113timelineGetYScaleArea :: TimelineView -> DrawingArea
114timelineGetYScaleArea timelineWin =
115  timelineYScaleArea $ timelineState timelineWin
116
117timelineWindowSetHECs :: TimelineView -> Maybe HECs -> IO ()
118timelineWindowSetHECs timelineWin@TimelineView{..} mhecs = do
119  writeIORef hecsIORef mhecs
120  zoomToFit timelineState mhecs
121  timelineParamsChanged timelineWin
122
123timelineWindowSetTraces :: TimelineView -> [Trace] -> IO ()
124timelineWindowSetTraces timelineWin@TimelineView{tracesIORef} traces = do
125  writeIORef tracesIORef traces
126  timelineParamsChanged timelineWin
127
128timelineWindowSetBookmarks :: TimelineView -> [Timestamp] -> IO ()
129timelineWindowSetBookmarks timelineWin@TimelineView{bookmarkIORef} bookmarks = do
130  writeIORef bookmarkIORef bookmarks
131  timelineParamsChanged timelineWin
132
133-----------------------------------------------------------------------------
134
135timelineViewNew :: Builder -> TimelineViewActions -> IO TimelineView
136timelineViewNew builder actions = do
137
138  let getWidget cast = builderGetObject builder cast
139  timelineViewport    <- getWidget castToWidget "timeline_viewport"
140  timelineDrawingArea <- getWidget castToDrawingArea "timeline_drawingarea"
141  timelineYScaleArea  <- getWidget castToDrawingArea "timeline_yscale_area"
142  timelineXScaleArea  <- getWidget castToDrawingArea "timeline_xscale_area"
143  timelineHScrollbar  <- getWidget castToHScrollbar "timeline_hscroll"
144  timelineVScrollbar  <- getWidget castToVScrollbar "timeline_vscroll"
145  timelineAdj         <- rangeGetAdjustment timelineHScrollbar
146  timelineVAdj        <- rangeGetAdjustment timelineVScrollbar
147
148  -- HACK: layoutSetAttributes does not work for \mu, so let's work around
149  fd <- fontDescriptionNew
150  fontDescriptionSetSize fd 8
151  fontDescriptionSetFamily fd "sans serif"
152  widgetModifyFont timelineYScaleArea (Just fd)
153
154  cursorIBeam <- cursorNew Xterm
155  cursorMove  <- cursorNew Fleur
156
157  hecsIORef   <- newIORef Nothing
158  tracesIORef <- newIORef []
159  bookmarkIORef <- newIORef []
160  scaleIORef  <- newIORef 0
161  maxSpkIORef <- newIORef 0
162  selectionRef <- newIORef (PointSelection 0)
163  bwmodeIORef <- newIORef False
164  labelsModeIORef <- newIORef False
165  timelinePrevView <- newIORef Nothing
166
167  let timelineState = TimelineState{..}
168      timelineWin   = TimelineView{..}
169
170  ------------------------------------------------------------------------
171  -- Redrawing labelDrawingArea
172  timelineYScaleArea `onExpose` \_ -> do
173    maybeEventArray <- readIORef hecsIORef
174
175    -- Check to see if an event trace has been loaded
176    case maybeEventArray of
177      Nothing   -> return False
178      Just hecs -> do
179        traces <- readIORef tracesIORef
180        labelsMode <- readIORef labelsModeIORef
181        let maxP = maxSparkPool hecs
182            maxH = fromIntegral (maxYHistogram hecs)
183        updateYScaleArea timelineState maxP maxH Nothing labelsMode traces
184        return True
185
186  ------------------------------------------------------------------------
187  -- Redrawing XScaleArea
188  timelineXScaleArea `onExpose` \_ -> do
189    maybeEventArray <- readIORef hecsIORef
190
191    -- Check to see if an event trace has been loaded
192    case maybeEventArray of
193      Nothing   -> return False
194      Just hecs -> do
195        let lastTx = hecLastEventTime hecs
196        updateXScaleArea timelineState lastTx
197        return True
198
199  ------------------------------------------------------------------------
200  -- Allow mouse wheel to be used for zoom in/out
201  on timelineViewport scrollEvent $ tryEvent $ do
202    dir <- eventScrollDirection
203    mods <- eventModifier
204    (x, _y) <- eventCoordinates
205    x_ts    <- liftIO $ viewPointToTime timelineWin x
206    liftIO $ case (dir,mods) of
207      (ScrollUp,   [Control]) -> zoomIn  timelineState x_ts
208      (ScrollDown, [Control]) -> zoomOut timelineState x_ts
209      (ScrollUp,   [])        -> vscrollUp timelineState
210      (ScrollDown, [])        -> vscrollDown timelineState
211      _ -> return ()
212
213  ------------------------------------------------------------------------
214  -- Mouse button and selection
215
216  widgetSetCursor timelineDrawingArea (Just cursorIBeam)
217
218  mouseStateVar <- newIORef None
219
220  let withMouseState action = liftIO $ do
221        st  <- readIORef mouseStateVar
222        st' <- action st
223        writeIORef mouseStateVar st'
224
225  on timelineDrawingArea buttonPressEvent $ do
226    (x,_y) <- eventCoordinates
227    button <- eventButton
228    liftIO $ widgetGrabFocus timelineViewport
229    withMouseState (\st -> mousePress timelineWin st button x)
230    return False
231
232  on timelineDrawingArea buttonReleaseEvent $ do
233    (x,_y) <- eventCoordinates
234    button <- eventButton
235    withMouseState (\st -> mouseRelease timelineWin actions st button x)
236    return False
237
238  widgetAddEvents timelineDrawingArea [Button1MotionMask, Button2MotionMask]
239  on timelineDrawingArea motionNotifyEvent $ do
240    (x, _y) <- eventCoordinates
241    withMouseState (\st -> mouseMove timelineWin st x)
242    return False
243
244  on timelineDrawingArea grabBrokenEvent $ do
245    withMouseState (mouseMoveCancel timelineWin actions)
246    return False
247
248  -- Escape key to cancel selection or drag
249  on timelineViewport keyPressEvent $ do
250    let liftNoMouse a =
251          let whenNoMouse None = a >> return None
252              whenNoMouse st   = return st
253          in withMouseState whenNoMouse >> return True
254    keyName <- eventKeyName
255    keyVal <- eventKeyVal
256#if MIN_VERSION_gtk(0,13,0)
257    case (T.unpack keyName, keyToChar keyVal, keyVal) of
258#else
259    case (keyName, keyToChar keyVal, keyVal) of
260#endif
261      ("Right", _, _)   -> liftNoMouse $ scrollRight timelineState
262      ("Left",  _, _)   -> liftNoMouse $ scrollLeft  timelineState
263      (_ , Just '+', _) -> liftNoMouse $ timelineZoomIn  timelineWin
264      (_ , Just '-', _) -> liftNoMouse $ timelineZoomOut timelineWin
265      (_, _, 0xff1b)    -> withMouseState (mouseMoveCancel timelineWin actions)
266                           >> return True
267      _                 -> return False
268
269  ------------------------------------------------------------------------
270  -- Scroll bars
271
272  onValueChanged timelineAdj  $ queueRedrawTimelines timelineState
273  onValueChanged timelineVAdj $ queueRedrawTimelines timelineState
274  onAdjChanged   timelineAdj  $ queueRedrawTimelines timelineState
275  onAdjChanged   timelineVAdj $ queueRedrawTimelines timelineState
276
277  ------------------------------------------------------------------------
278  -- Redrawing
279
280  on timelineDrawingArea exposeEvent $ do
281     exposeRegion <- eventRegion
282     liftIO $ do
283       maybeEventArray <- readIORef hecsIORef
284
285       -- Check to see if an event trace has been loaded
286       case maybeEventArray of
287         Nothing   -> return ()
288         Just hecs -> do
289           params <- timelineGetViewParameters timelineWin
290           -- render either the whole height of the timeline, or the window, whichever
291           -- is larger (this just ensure we fill the background if the timeline is
292           -- smaller than the window).
293           (_, h) <- widgetGetSize timelineDrawingArea
294           let params' = params { height = max (height params) h }
295           selection  <- readIORef selectionRef
296           bookmarks <- readIORef bookmarkIORef
297
298           renderView timelineState params' hecs selection bookmarks exposeRegion
299
300     return True
301
302  on timelineDrawingArea configureEvent $ do
303     liftIO $ configureTimelineDrawingArea timelineWin
304     return True
305
306  return timelineWin
307
308-------------------------------------------------------------------------------
309
310viewPointToTime :: TimelineView -> Double -> IO Timestamp
311viewPointToTime TimelineView{timelineState=TimelineState{..}} x = do
312    hadjValue  <- adjustmentGetValue timelineAdj
313    scaleValue <- readIORef scaleIORef
314    let ts = round (max 0 (hadjValue + x * scaleValue))
315    return $! ts
316
317viewPointToTimeNoClamp :: TimelineView -> Double -> IO Double
318viewPointToTimeNoClamp TimelineView{timelineState=TimelineState{..}} x = do
319    hadjValue  <- adjustmentGetValue timelineAdj
320    scaleValue <- readIORef scaleIORef
321    let ts = hadjValue + x * scaleValue
322    return $! ts
323
324viewRangeToTimeRange :: TimelineView
325                     -> (Double, Double) -> IO (Timestamp, Timestamp)
326viewRangeToTimeRange view (x, x') = do
327    let xMin = min x x'
328        xMax = max x x'
329    xv  <- viewPointToTime view xMin
330    xv' <- viewPointToTime view xMax
331    return (xv, xv')
332
333-------------------------------------------------------------------------------
334-- Update the internal state and the timemline view after changing which
335-- traces are displayed, or the order of traces.
336
337queueRedrawTimelines :: TimelineState -> IO ()
338queueRedrawTimelines TimelineState{..} = do
339  widgetQueueDraw timelineDrawingArea
340  widgetQueueDraw timelineYScaleArea
341  widgetQueueDraw timelineXScaleArea
342
343--FIXME: we are still unclear about which state changes involve which updates
344timelineParamsChanged :: TimelineView -> IO ()
345timelineParamsChanged timelineWin@TimelineView{timelineState} = do
346  queueRedrawTimelines timelineState
347  updateTimelineVScroll timelineWin
348
349configureTimelineDrawingArea :: TimelineView -> IO ()
350configureTimelineDrawingArea timelineWin@TimelineView{timelineState} = do
351  updateTimelineVScroll timelineWin
352  updateTimelineHPageSize timelineState
353
354updateTimelineVScroll :: TimelineView -> IO ()
355updateTimelineVScroll TimelineView{tracesIORef, labelsModeIORef, timelineState=TimelineState{..}} = do
356  traces <- readIORef tracesIORef
357  labelsMode <- readIORef labelsModeIORef
358  let histTotalHeight = stdHistogramHeight + histXScaleHeight
359      h = calculateTotalTimelineHeight labelsMode histTotalHeight traces
360  (_,winh) <- widgetGetSize timelineDrawingArea
361  let winh' = fromIntegral winh;
362      h' = fromIntegral h
363  adjustmentSetLower    timelineVAdj 0
364  adjustmentSetUpper    timelineVAdj h'
365
366  val <- adjustmentGetValue timelineVAdj
367  when (val > h') $ adjustmentSetValue timelineVAdj h'
368
369  set timelineVAdj [
370      adjustmentPageSize      := winh',
371      adjustmentStepIncrement := winh' * 0.1,
372      adjustmentPageIncrement := winh' * 0.9
373    ]
374
375-- when the drawing area is resized, we update the page size of the
376-- adjustment.  Everything else stays the same: we don't scale or move
377-- the view at all.
378updateTimelineHPageSize :: TimelineState -> IO ()
379updateTimelineHPageSize TimelineState{..} = do
380  (winw,_) <- widgetGetSize timelineDrawingArea
381  scaleValue <- readIORef scaleIORef
382  adjustmentSetPageSize timelineAdj (fromIntegral winw * scaleValue)
383
384-------------------------------------------------------------------------------
385-- Cursor / selection and mouse interaction
386
387timelineSetSelection :: TimelineView -> TimeSelection -> IO ()
388timelineSetSelection TimelineView{..} selection = do
389  writeIORef selectionRef selection
390  queueRedrawTimelines timelineState
391
392-- little state machine
393data MouseState = None
394                | PressLeft  !Double   -- left mouse button is currently pressed
395                                       -- but not over threshold for dragging
396                | DragLeft   !Double   -- dragging with left mouse button
397                | DragMiddle !Double !Double  -- dragging with middle mouse button
398
399mousePress :: TimelineView
400           -> MouseState -> MouseButton -> Double -> IO MouseState
401mousePress view@TimelineView{..} state button x =
402  case (state, button) of
403    (None, LeftButton)   -> do xv <- viewPointToTime view x
404                               -- update the view without notifying the client
405                               timelineSetSelection view (PointSelection xv)
406                               return (PressLeft x)
407    (None, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorMove)
408                               v <- adjustmentGetValue timelineAdj
409                               return (DragMiddle x v)
410    _                    -> return state
411  where
412    TimelineState{timelineAdj, timelineDrawingArea} = timelineState
413
414
415mouseMove :: TimelineView -> MouseState
416          -> Double -> IO MouseState
417mouseMove view@TimelineView{..} state x =
418  case state of
419    None              -> return None
420    PressLeft x0
421      | dragThreshold -> mouseMove view (DragLeft x0) x
422      | otherwise     -> return (PressLeft x0)
423      where
424        dragThreshold = abs (x - x0) > 5
425    DragLeft  x0      -> do (xv, xv') <- viewRangeToTimeRange view (x0, x)
426                            -- update the view without notifying the client
427                            timelineSetSelection view (RangeSelection xv xv')
428                            return (DragLeft x0)
429    DragMiddle x0 v   -> do xv  <- viewPointToTimeNoClamp view x
430                            xv' <- viewPointToTimeNoClamp view x0
431                            scrollTo timelineState (v + (xv' - xv))
432                            return (DragMiddle x0 v)
433
434
435mouseMoveCancel :: TimelineView -> TimelineViewActions
436                -> MouseState -> IO MouseState
437mouseMoveCancel view@TimelineView{..} TimelineViewActions{..} state =
438  case state of
439    PressLeft x0   -> do xv <- viewPointToTime view x0
440                         timelineViewSelectionChanged (PointSelection xv)
441                         return None
442    DragLeft  x0   -> do xv <- viewPointToTime view x0
443                         timelineViewSelectionChanged (PointSelection xv)
444                         return None
445    DragMiddle _ _ -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam)
446                         return None
447    None           -> return None
448  where
449    TimelineState{timelineDrawingArea} = timelineState
450
451mouseRelease :: TimelineView -> TimelineViewActions
452             -> MouseState -> MouseButton -> Double -> IO MouseState
453mouseRelease view@TimelineView{..} TimelineViewActions{..} state button x =
454  case (state, button) of
455    (PressLeft x0,  LeftButton)  -> do xv <- viewPointToTime view x0
456                                       timelineViewSelectionChanged (PointSelection xv)
457                                       return None
458    (DragLeft x0,   LeftButton)  -> do (xv, xv') <- viewRangeToTimeRange view (x0, x)
459                                       timelineViewSelectionChanged (RangeSelection xv xv')
460                                       return None
461    (DragMiddle{}, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam)
462                                       return None
463    _                            -> return state
464  where
465    TimelineState{timelineDrawingArea} = timelineState
466
467
468widgetSetCursor :: WidgetClass widget => widget -> Maybe Cursor -> IO ()
469widgetSetCursor widget cursor = do
470#if MIN_VERSION_gtk(0,12,1)
471    dw <- widgetGetDrawWindow widget
472    drawWindowSetCursor dw cursor
473#endif
474    return ()
475
476-------------------------------------------------------------------------------
477
478timelineZoomIn :: TimelineView -> IO ()
479timelineZoomIn TimelineView{..} = do
480  selection <- readIORef selectionRef
481  zoomIn timelineState (selectionPoint selection)
482
483timelineZoomOut :: TimelineView -> IO ()
484timelineZoomOut TimelineView{..} = do
485  selection <- readIORef selectionRef
486  zoomOut timelineState (selectionPoint selection)
487
488timelineZoomToFit :: TimelineView -> IO ()
489timelineZoomToFit TimelineView{..} = do
490  mhecs <- readIORef hecsIORef
491  zoomToFit timelineState mhecs
492
493timelineScrollLeft :: TimelineView -> IO ()
494timelineScrollLeft TimelineView{timelineState} = scrollLeft timelineState
495
496timelineScrollRight :: TimelineView -> IO ()
497timelineScrollRight TimelineView{timelineState} = scrollRight timelineState
498
499timelineScrollToBeginning :: TimelineView -> IO ()
500timelineScrollToBeginning TimelineView{timelineState} =
501  scrollToBeginning timelineState
502
503timelineScrollToEnd :: TimelineView -> IO ()
504timelineScrollToEnd TimelineView{timelineState} =
505  scrollToEnd timelineState
506
507-- This one is especially evil since it relies on a shared cursor IORef
508timelineCentreOnCursor :: TimelineView -> IO ()
509timelineCentreOnCursor TimelineView{..} = do
510  selection <- readIORef selectionRef
511  centreOnCursor timelineState (selectionPoint selection)
512
513selectionPoint :: TimeSelection -> Timestamp
514selectionPoint (PointSelection x)    = x
515selectionPoint (RangeSelection x x') = midpoint x x'
516  where
517    midpoint a b = a + (b - a) `div` 2
518