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