threadscope-0.2.15.1: GUI/Timeline.hs

{-# LANGUAGE CPP #-}
module GUI.Timeline (
    TimelineView,
    timelineViewNew,
    TimelineViewActions(..),

    timelineSetBWMode,
    timelineSetLabelsMode,
    timelineGetViewParameters,
    timelineGetYScaleArea,
    timelineWindowSetHECs,
    timelineWindowSetTraces,
    timelineWindowSetBookmarks,
    timelineSetSelection,
    TimeSelection(..),

    timelineZoomIn,
    timelineZoomOut,
    timelineZoomToFit,
    timelineScrollLeft,
    timelineScrollRight,
    timelineScrollToBeginning,
    timelineScrollToEnd,
    timelineCentreOnCursor,
 ) where

import GUI.Types
import GUI.Timeline.Types

import GUI.Timeline.Motion
import GUI.Timeline.Render
import GUI.Timeline.Render.Constants

import Events.HECs

import Graphics.UI.Gtk

import Data.IORef
import Data.Ord
import Control.Monad
import Control.Monad.Trans
import qualified Data.Text as T

-----------------------------------------------------------------------------
-- The CPUs view

data TimelineView = TimelineView {

       timelineState   :: TimelineState,

       hecsIORef       :: IORef (Maybe HECs),
       tracesIORef     :: IORef [Trace],
       bookmarkIORef   :: IORef [Timestamp],

       selectionRef    :: IORef TimeSelection,
       labelsModeIORef :: IORef Bool,
       bwmodeIORef     :: IORef Bool,

       cursorIBeam     :: Cursor,
       cursorMove      :: Cursor
     }

data TimelineViewActions = TimelineViewActions {
       timelineViewSelectionChanged :: TimeSelection -> IO ()
     }

-- | Draw some parts of the timeline in black and white rather than colour.
timelineSetBWMode :: TimelineView -> Bool -> IO ()
timelineSetBWMode timelineWin bwmode = do
  writeIORef (bwmodeIORef timelineWin) bwmode
  widgetQueueDraw (timelineDrawingArea (timelineState timelineWin))

timelineSetLabelsMode :: TimelineView -> Bool -> IO ()
timelineSetLabelsMode timelineWin labelsMode = do
  writeIORef (labelsModeIORef timelineWin) labelsMode
  widgetQueueDraw (timelineDrawingArea (timelineState timelineWin))
  updateTimelineVScroll timelineWin

timelineGetViewParameters :: TimelineView -> IO ViewParameters
timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, labelsModeIORef,
                                       timelineState=TimelineState{..}} = do

  Rectangle _ _ w _ <- widgetGetAllocation timelineDrawingArea
  scaleValue  <- readIORef scaleIORef
  maxSpkValue <- readIORef maxSpkIORef

  -- snap the view to whole pixels, to avoid blurring
  hadj_value0 <- adjustmentGetValue timelineAdj
  let hadj_value = toWholePixels scaleValue hadj_value0

  traces <- readIORef tracesIORef
  bwmode <- readIORef bwmodeIORef
  labelsMode <- readIORef labelsModeIORef

  Rectangle _ _ _ xScaleAreaHeight <- widgetGetAllocation timelineXScaleArea
  let histTotalHeight = stdHistogramHeight + histXScaleHeight
      timelineHeight =
        calculateTotalTimelineHeight labelsMode histTotalHeight traces

  return ViewParameters
           { width      = w
           , height     = timelineHeight
           , viewTraces = traces
           , hadjValue  = hadj_value
           , scaleValue = scaleValue
           , maxSpkValue = maxSpkValue
           , detail     = 3 --for now
           , bwMode     = bwmode
           , labelsMode = labelsMode
           , histogramHeight = stdHistogramHeight
           , minterval = Nothing
           , xScaleAreaHeight = xScaleAreaHeight
           }

timelineGetYScaleArea :: TimelineView -> DrawingArea
timelineGetYScaleArea timelineWin =
  timelineYScaleArea $ timelineState timelineWin

timelineWindowSetHECs :: TimelineView -> Maybe HECs -> IO ()
timelineWindowSetHECs timelineWin@TimelineView{..} mhecs = do
  writeIORef hecsIORef mhecs
  zoomToFit timelineState mhecs
  timelineParamsChanged timelineWin

timelineWindowSetTraces :: TimelineView -> [Trace] -> IO ()
timelineWindowSetTraces timelineWin@TimelineView{tracesIORef} traces = do
  writeIORef tracesIORef traces
  timelineParamsChanged timelineWin

timelineWindowSetBookmarks :: TimelineView -> [Timestamp] -> IO ()
timelineWindowSetBookmarks timelineWin@TimelineView{bookmarkIORef} bookmarks = do
  writeIORef bookmarkIORef bookmarks
  timelineParamsChanged timelineWin

-----------------------------------------------------------------------------

timelineViewNew :: Builder -> TimelineViewActions -> IO TimelineView
timelineViewNew builder actions = do

  let getWidget cast = builderGetObject builder cast
  timelineViewport    <- getWidget castToWidget "timeline_viewport"
  timelineDrawingArea <- getWidget castToDrawingArea "timeline_drawingarea"
  timelineYScaleArea  <- getWidget castToDrawingArea "timeline_yscale_area"
  timelineXScaleArea  <- getWidget castToDrawingArea "timeline_xscale_area"
  timelineHScrollbar  <- getWidget castToHScrollbar "timeline_hscroll"
  timelineVScrollbar  <- getWidget castToVScrollbar "timeline_vscroll"
  timelineAdj         <- rangeGetAdjustment timelineHScrollbar
  timelineVAdj        <- rangeGetAdjustment timelineVScrollbar

  -- HACK: layoutSetAttributes does not work for \mu, so let's work around
  fd <- fontDescriptionNew
  fontDescriptionSetSize fd 8
  fontDescriptionSetFamily fd "sans serif"
  widgetModifyFont timelineYScaleArea (Just fd)

  cursorIBeam <- cursorNew Xterm
  cursorMove  <- cursorNew Fleur

  hecsIORef   <- newIORef Nothing
  tracesIORef <- newIORef []
  bookmarkIORef <- newIORef []
  scaleIORef  <- newIORef 0
  maxSpkIORef <- newIORef 0
  selectionRef <- newIORef (PointSelection 0)
  bwmodeIORef <- newIORef False
  labelsModeIORef <- newIORef False
  timelinePrevView <- newIORef Nothing

  let timelineState = TimelineState{..}
      timelineWin   = TimelineView{..}

  ------------------------------------------------------------------------
  -- Redrawing labelDrawingArea
  timelineYScaleArea `on` draw $ liftIO $ do
    maybeEventArray <- readIORef hecsIORef

    -- Check to see if an event trace has been loaded
    case maybeEventArray of
      Nothing   -> return ()
      Just hecs -> do
        traces <- readIORef tracesIORef
        labelsMode <- readIORef labelsModeIORef
        let maxP = maxSparkPool hecs
            maxH = fromIntegral (maxYHistogram hecs)
        updateYScaleArea timelineState maxP maxH Nothing labelsMode traces
        return ()

  ------------------------------------------------------------------------
  -- Redrawing XScaleArea
  timelineXScaleArea `on` draw $ liftIO $ do
    maybeEventArray <- readIORef hecsIORef

    -- Check to see if an event trace has been loaded
    case maybeEventArray of
      Nothing   -> return ()
      Just hecs -> do
        let lastTx = hecLastEventTime hecs
        updateXScaleArea timelineState lastTx
        return ()

  ------------------------------------------------------------------------
  -- Allow mouse wheel to be used for zoom in/out
  on timelineViewport scrollEvent $ tryEvent $ do
    dir <- eventScrollDirection
    mods <- eventModifier
    (x, _y) <- eventCoordinates
    x_ts    <- liftIO $ viewPointToTime timelineWin x
    liftIO $ case (dir,mods) of
      (ScrollUp,   [Control]) -> zoomIn  timelineState x_ts
      (ScrollDown, [Control]) -> zoomOut timelineState x_ts
      (ScrollUp,   [])        -> vscrollUp timelineState
      (ScrollDown, [])        -> vscrollDown timelineState
      _ -> return ()

  ------------------------------------------------------------------------
  -- Mouse button and selection

  widgetSetCursor timelineDrawingArea (Just cursorIBeam)

  mouseStateVar <- newIORef None

  let withMouseState action = liftIO $ do
        st  <- readIORef mouseStateVar
        st' <- action st
        writeIORef mouseStateVar st'

  on timelineDrawingArea buttonPressEvent $ do
    (x,_y) <- eventCoordinates
    button <- eventButton
    liftIO $ widgetGrabFocus timelineViewport
    withMouseState (\st -> mousePress timelineWin st button x)
    return False

  on timelineDrawingArea buttonReleaseEvent $ do
    (x,_y) <- eventCoordinates
    button <- eventButton
    withMouseState (\st -> mouseRelease timelineWin actions st button x)
    return False

  widgetAddEvents timelineDrawingArea [Button1MotionMask, Button2MotionMask]
  on timelineDrawingArea motionNotifyEvent $ do
    (x, _y) <- eventCoordinates
    withMouseState (\st -> mouseMove timelineWin st x)
    return False

  on timelineDrawingArea grabBrokenEvent $ do
    withMouseState (mouseMoveCancel timelineWin actions)
    return False

  -- Escape key to cancel selection or drag
  on timelineViewport keyPressEvent $ do
    let liftNoMouse a =
          let whenNoMouse None = a >> return None
              whenNoMouse st   = return st
          in withMouseState whenNoMouse >> return True
    keyName <- eventKeyName
    keyVal <- eventKeyVal
#if MIN_VERSION_gtk3(0,13,0)
    case (T.unpack keyName, keyToChar keyVal, keyVal) of
#else
    case (keyName, keyToChar keyVal, keyVal) of
#endif
      ("Right", _, _)   -> liftNoMouse $ scrollRight timelineState
      ("Left",  _, _)   -> liftNoMouse $ scrollLeft  timelineState
      (_ , Just '+', _) -> liftNoMouse $ timelineZoomIn  timelineWin
      (_ , Just '-', _) -> liftNoMouse $ timelineZoomOut timelineWin
      (_, _, 0xff1b)    -> withMouseState (mouseMoveCancel timelineWin actions)
                           >> return True
      _                 -> return False

  ------------------------------------------------------------------------
  -- Scroll bars

  onValueChanged timelineAdj  $ queueRedrawTimelines timelineState
  onValueChanged timelineVAdj $ queueRedrawTimelines timelineState
  onAdjChanged   timelineAdj  $ queueRedrawTimelines timelineState
  onAdjChanged   timelineVAdj $ queueRedrawTimelines timelineState

  ------------------------------------------------------------------------
  -- Redrawing

  on timelineDrawingArea draw $ do
     liftIO $ do
       maybeEventArray <- readIORef hecsIORef

       -- Check to see if an event trace has been loaded
       case maybeEventArray of
         Nothing   -> return ()
         Just hecs -> do
           params <- timelineGetViewParameters timelineWin
           -- 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).
           (Rectangle _ _ w h)<- widgetGetAllocation timelineDrawingArea
           let params' = params { height = max (height params) h }
           selection  <- readIORef selectionRef
           bookmarks <- readIORef bookmarkIORef

           renderView timelineState params' hecs selection bookmarks (Rectangle 0 0 w h)

     return ()

  on timelineDrawingArea configureEvent $ do
     liftIO $ configureTimelineDrawingArea timelineWin
     return True

  return timelineWin

-------------------------------------------------------------------------------

viewPointToTime :: TimelineView -> Double -> IO Timestamp
viewPointToTime TimelineView{timelineState=TimelineState{..}} x = do
    hadjValue  <- adjustmentGetValue timelineAdj
    scaleValue <- readIORef scaleIORef
    let ts = round (max 0 (hadjValue + x * scaleValue))
    return $! ts

viewPointToTimeNoClamp :: TimelineView -> Double -> IO Double
viewPointToTimeNoClamp TimelineView{timelineState=TimelineState{..}} x = do
    hadjValue  <- adjustmentGetValue timelineAdj
    scaleValue <- readIORef scaleIORef
    let ts = hadjValue + x * scaleValue
    return $! ts

viewRangeToTimeRange :: TimelineView
                     -> (Double, Double) -> IO (Timestamp, Timestamp)
viewRangeToTimeRange view (x, x') = do
    let xMin = min x x'
        xMax = max x x'
    xv  <- viewPointToTime view xMin
    xv' <- viewPointToTime view xMax
    return (xv, xv')

-------------------------------------------------------------------------------
-- Update the internal state and the timeline view after changing which
-- traces are displayed, or the order of traces.

queueRedrawTimelines :: TimelineState -> IO ()
queueRedrawTimelines TimelineState{..} = do
  widgetQueueDraw timelineDrawingArea
  widgetQueueDraw timelineYScaleArea
  widgetQueueDraw timelineXScaleArea

--FIXME: we are still unclear about which state changes involve which updates
timelineParamsChanged :: TimelineView -> IO ()
timelineParamsChanged timelineWin@TimelineView{timelineState} = do
  queueRedrawTimelines timelineState
  updateTimelineVScroll timelineWin

configureTimelineDrawingArea :: TimelineView -> IO ()
configureTimelineDrawingArea timelineWin@TimelineView{timelineState} = do
  updateTimelineVScroll timelineWin
  updateTimelineHPageSize timelineState

updateTimelineVScroll :: TimelineView -> IO ()
updateTimelineVScroll TimelineView{tracesIORef, labelsModeIORef, timelineState=TimelineState{..}} = do
  traces <- readIORef tracesIORef
  labelsMode <- readIORef labelsModeIORef
  let histTotalHeight = stdHistogramHeight + histXScaleHeight
      h = calculateTotalTimelineHeight labelsMode histTotalHeight traces
  Rectangle _ _ _ winh <- widgetGetAllocation timelineDrawingArea
  let winh' = fromIntegral winh;
      h' = fromIntegral h
  adjustmentSetLower    timelineVAdj 0
  adjustmentSetUpper    timelineVAdj h'

  val <- adjustmentGetValue timelineVAdj
  when (val > h') $ adjustmentSetValue timelineVAdj h'

  set timelineVAdj [
      adjustmentPageSize      := winh',
      adjustmentStepIncrement := winh' * 0.1,
      adjustmentPageIncrement := winh' * 0.9
    ]

-- when the drawing area is resized, we update the page size of the
-- adjustment.  Everything else stays the same: we don't scale or move
-- the view at all.
updateTimelineHPageSize :: TimelineState -> IO ()
updateTimelineHPageSize TimelineState{..} = do
  Rectangle _ _ winw _ <- widgetGetAllocation timelineDrawingArea
  scaleValue <- readIORef scaleIORef
  adjustmentSetPageSize timelineAdj (fromIntegral winw * scaleValue)

-------------------------------------------------------------------------------
-- Cursor / selection and mouse interaction

timelineSetSelection :: TimelineView -> TimeSelection -> IO (Maybe TimeSelection)
timelineSetSelection TimelineView{..} selection = do
  mhecs <- readIORef hecsIORef
  case mhecs >>= (adjustSelection selection . hecLastEventTime) of
    Nothing -> return Nothing
    Just selection' -> do
      writeIORef selectionRef selection'
      queueRedrawTimelines timelineState
      return $ Just selection'
  where
    -- Prevent selections that are out of bounds.
    adjustSelection (PointSelection timestamp) lastTx
      | timestamp < 0 || timestamp > lastTx = Nothing
      | otherwise = Just $ PointSelection timestamp
    adjustSelection (RangeSelection start end) lastTx
      | start < 0 && end < 0 || start > lastTx && end > lastTx = Nothing
      | otherwise = Just $ RangeSelection (clampSelection lastTx start) (clampSelection lastTx end)

    clampSelection lastTx = clamp (0, lastTx)

-- little state machine
data MouseState = None
                | PressLeft  !Double   -- left mouse button is currently pressed
                                       -- but not over threshold for dragging
                | DragLeft   !Double   -- dragging with left mouse button
                | DragMiddle !Double !Double  -- dragging with middle mouse button

mousePress :: TimelineView
           -> MouseState -> MouseButton -> Double -> IO MouseState
mousePress view@TimelineView{..} state button x =
  case (state, button) of
    (None, LeftButton)   -> do xv <- viewPointToTime view x
                               -- update the view without notifying the client
                               selection <- timelineSetSelection view (PointSelection xv)
                               case selection of
                                 Nothing -> return None
                                 Just _ -> return (PressLeft x)
    (None, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorMove)
                               v <- adjustmentGetValue timelineAdj
                               return (DragMiddle x v)
    _                    -> return state
  where
    TimelineState{timelineAdj, timelineDrawingArea} = timelineState


mouseMove :: TimelineView -> MouseState
          -> Double -> IO MouseState
mouseMove view@TimelineView{..} state x =
  case state of
    None              -> return None
    PressLeft x0
      | dragThreshold -> mouseMove view (DragLeft x0) x
      | otherwise     -> return (PressLeft x0)
      where
        dragThreshold = abs (x - x0) > 5
    DragLeft  x0      -> do (xv, xv') <- viewRangeToTimeRange view (x0, x)
                            -- update the view without notifying the client
                            selection <- timelineSetSelection view (RangeSelection xv xv')
                            case selection of
                              Nothing -> return None
                              Just _ -> return (DragLeft x0)
    DragMiddle x0 v   -> do xv  <- viewPointToTimeNoClamp view x
                            xv' <- viewPointToTimeNoClamp view x0
                            scrollTo timelineState (v + (xv' - xv))
                            return (DragMiddle x0 v)


mouseMoveCancel :: TimelineView -> TimelineViewActions
                -> MouseState -> IO MouseState
mouseMoveCancel view@TimelineView{..} TimelineViewActions{..} state =
  case state of
    PressLeft x0   -> do xv <- viewPointToTime view x0
                         timelineViewSelectionChanged (PointSelection xv)
                         return None
    DragLeft  x0   -> do xv <- viewPointToTime view x0
                         timelineViewSelectionChanged (PointSelection xv)
                         return None
    DragMiddle _ _ -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam)
                         return None
    None           -> return None
  where
    TimelineState{timelineDrawingArea} = timelineState

mouseRelease :: TimelineView -> TimelineViewActions
             -> MouseState -> MouseButton -> Double -> IO MouseState
mouseRelease view@TimelineView{..} TimelineViewActions{..} state button x =
  case (state, button) of
    (PressLeft x0,  LeftButton)  -> do xv <- viewPointToTime view x0
                                       timelineViewSelectionChanged (PointSelection xv)
                                       return None
    (DragLeft x0,   LeftButton)  -> do (xv, xv') <- viewRangeToTimeRange view (x0, x)
                                       timelineViewSelectionChanged (RangeSelection xv xv')
                                       return None
    (DragMiddle{}, MiddleButton) -> do widgetSetCursor timelineDrawingArea (Just cursorIBeam)
                                       return None
    _                            -> return state
  where
    TimelineState{timelineDrawingArea} = timelineState


widgetSetCursor :: WidgetClass widget => widget -> Maybe Cursor -> IO ()
widgetSetCursor widget cursor = do
#if MIN_VERSION_gtk3(0,12,1)
    -- TODO: get rid of this Just
    Just dw <- widgetGetWindow widget
    drawWindowSetCursor dw cursor
#endif
    return ()

-------------------------------------------------------------------------------

timelineZoomIn :: TimelineView -> IO ()
timelineZoomIn TimelineView{..} = do
  selection <- readIORef selectionRef
  zoomIn timelineState (selectionPoint selection)

timelineZoomOut :: TimelineView -> IO ()
timelineZoomOut TimelineView{..} = do
  selection <- readIORef selectionRef
  zoomOut timelineState (selectionPoint selection)

timelineZoomToFit :: TimelineView -> IO ()
timelineZoomToFit TimelineView{..} = do
  mhecs <- readIORef hecsIORef
  zoomToFit timelineState mhecs

timelineScrollLeft :: TimelineView -> IO ()
timelineScrollLeft TimelineView{timelineState} = scrollLeft timelineState

timelineScrollRight :: TimelineView -> IO ()
timelineScrollRight TimelineView{timelineState} = scrollRight timelineState

timelineScrollToBeginning :: TimelineView -> IO ()
timelineScrollToBeginning TimelineView{timelineState} =
  scrollToBeginning timelineState

timelineScrollToEnd :: TimelineView -> IO ()
timelineScrollToEnd TimelineView{timelineState} =
  scrollToEnd timelineState

-- This one is especially evil since it relies on a shared cursor IORef
timelineCentreOnCursor :: TimelineView -> IO ()
timelineCentreOnCursor TimelineView{..} = do
  selection <- readIORef selectionRef
  centreOnCursor timelineState (selectionPoint selection)

selectionPoint :: TimeSelection -> Timestamp
selectionPoint (PointSelection x)    = x
selectionPoint (RangeSelection x x') = midpoint x x'
  where
    midpoint a b = a + (b - a) `div` 2