Merge pull request #147 from TuongNM/selections-out-of-bounds

Prevent Timeline selections that are out of bounds

Author: TeofilC

GUI/EventsView.hs

@@ -331,7 +331,7 @@ drawEvents EventsView{drawArea, adj}
           selected = cursorPos == n
           (state1, state2)
             | inside    = (StateSelected, StateSelected)
-            | selected  = (state, state)
+            | selected  = (StateSelected, state)
             | otherwise = (state, StateNormal)
     ]
 

GUI/Main.hs

@@ -350,37 +350,21 @@ eventLoop uienv@UIEnv{..} eventlogState = do
     dispatch (EventCursorChangedIndex cursorPos') EventlogLoaded{hecs} = do
       let cursorTs'  = eventIndexToTimestamp hecs cursorPos'
           selection' = PointSelection cursorTs'
-      timelineSetSelection timelineWin selection'
-      eventsViewSetCursor eventsView  cursorPos' Nothing
-      continueWith eventlogState {
-        selection = selection',
-        cursorPos = cursorPos'
-      }
+      mselection <- timelineSetSelection timelineWin selection'
+      setSelection cursorPos' Nothing mselection
 
     dispatch (EventCursorChangedSelection selection'@(PointSelection cursorTs'))
              EventlogLoaded{hecs} = do
       let cursorPos' = timestampToEventIndex hecs cursorTs'
-      timelineSetSelection timelineWin selection'
-      eventsViewSetCursor eventsView cursorPos' Nothing
-      histogramViewSetInterval histogramView Nothing
-      summaryViewSetInterval summaryView Nothing
-      continueWith eventlogState {
-        selection = selection',
-        cursorPos = cursorPos'
-      }
+      mselection <- timelineSetSelection timelineWin selection'
+      setSelection cursorPos' Nothing mselection
 
     dispatch (EventCursorChangedSelection selection'@(RangeSelection start end))
              EventlogLoaded{hecs} = do
       let cursorPos' = timestampToEventIndex hecs start
           mrange = Just (cursorPos', timestampToEventIndex hecs end)
-      timelineSetSelection timelineWin selection'
-      eventsViewSetCursor eventsView cursorPos' mrange
-      histogramViewSetInterval histogramView (Just (start, end))
-      summaryViewSetInterval summaryView (Just (start, end))
-      continueWith eventlogState {
-        selection = selection',
-        cursorPos = cursorPos'
-      }
+      mselection <- timelineSetSelection timelineWin selection'
+      setSelection cursorPos' mrange mselection
 
     dispatch (EventTracesChanged traces) _ = do
       timelineWindowSetTraces timelineWin traces
@@ -435,6 +419,24 @@ eventLoop uienv@UIEnv{..} eventlogState = do
     async doing action =
       forkIO (action `catch` \e -> post (EventUserError doing e))
 
+    setSelection cursorPos' _ (Just selection'@(PointSelection _)) = do
+      eventsViewSetCursor eventsView cursorPos' Nothing
+      histogramViewSetInterval histogramView Nothing
+      summaryViewSetInterval summaryView Nothing
+      continueWith eventlogState {
+        selection = selection',
+        cursorPos = cursorPos'
+      }
+    setSelection cursorPos' mrange (Just selection'@(RangeSelection start end)) = do
+      eventsViewSetCursor eventsView cursorPos' mrange
+      histogramViewSetInterval histogramView (Just (start, end))
+      summaryViewSetInterval summaryView (Just (start, end))
+      continueWith eventlogState {
+        selection = selection',
+        cursorPos = cursorPos'
+      }
+    setSelection _ _ Nothing = continue
+
     post = postEvent eventQueue
     continue = continueWith eventlogState
     continueWith = return . Right

GUI/Timeline.hs

@@ -36,6 +36,7 @@ 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
@@ -384,10 +385,25 @@ updateTimelineHPageSize TimelineState{..} = do
 -------------------------------------------------------------------------------
 -- Cursor / selection and mouse interaction
 
-timelineSetSelection :: TimelineView -> TimeSelection -> IO ()
+timelineSetSelection :: TimelineView -> TimeSelection -> IO (Maybe TimeSelection)
 timelineSetSelection TimelineView{..} selection = do
-  writeIORef selectionRef selection
-  queueRedrawTimelines timelineState
+  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
@@ -402,8 +418,10 @@ mousePress view@TimelineView{..} state button x =
   case (state, button) of
     (None, LeftButton)   -> do xv <- viewPointToTime view x
                                -- update the view without notifying the client
-                               timelineSetSelection view (PointSelection xv)
-                               return (PressLeft x)
+                               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)
@@ -424,8 +442,10 @@ mouseMove view@TimelineView{..} state x =
         dragThreshold = abs (x - x0) > 5
     DragLeft  x0      -> do (xv, xv') <- viewRangeToTimeRange view (x0, x)
                             -- update the view without notifying the client
-                            timelineSetSelection view (RangeSelection xv xv')
-                            return (DragLeft x0)
+                            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))