diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for threadscope +## 2025-07-02 - v0.2.15.1 +* Fix a variety of UI bugs (Thanks @TuongNM!) ([#147](https://github.com/haskell/ThreadScope/pull/147))), ([#146](https://github.com/haskell/ThreadScope/pull/146))), ([#145](https://github.com/haskell/ThreadScope/pull/145))) +* Build with GHC-9.14 (modulo an upstream bug with gtk2hs) ([#144](https://github.com/haskell/ThreadScope/pull/144))) + ## 2025-05-29 - v0.2.15.0 * Switch to GTK3 ([#137](https://github.com/haskell/ThreadScope/pull/137))) * Support new versions of GHC up to 9.12 and dependencies. diff --git a/GUI/EventsView.hs b/GUI/EventsView.hs --- a/GUI/EventsView.hs +++ b/GUI/EventsView.hs @@ -13,14 +13,12 @@ ) where import GHC.RTS.Events -import Debug.Trace import Graphics.UI.Gtk hiding (rectangle) import Graphics.Rendering.Cairo -import qualified GUI.GtkExtras as GtkExt +import GUI.ViewerColours import Control.Monad -import Control.Monad.Reader import Data.Array import Data.Monoid import Data.IORef @@ -68,8 +66,6 @@ vScrollbar <- getWidget castToVScrollbar ("eventsVScroll" :: T.Text) adj <- get vScrollbar rangeAdjustment - -- make the background white - widgetModifyBg drawArea StateNormal (Color 0xffff 0xffff 0xffff) widgetSetCanFocus drawArea True --TODO: needs to be reset on each style change ^^ @@ -306,8 +302,7 @@ sequence_ [ do when (inside || selected) $ renderWithDrawWindow win $ do - -- TODO: figure out how I can grab the correct color from GTK's style - setSourceRGBA 0.2 1 1 0.2 + setSourceRGBAForStyle styleGetBackground style state1 rectangle 0 y (fromIntegral width) lineHeight fill @@ -316,6 +311,7 @@ layoutSetAlignment layout AlignRight layoutSetWidth layout (Just (fromIntegral timeWidth)) renderWithDrawWindow win $ do + setForegroundColor style state2 moveTo 0 y showLayout layout @@ -324,6 +320,7 @@ layoutSetAlignment layout AlignLeft layoutSetWidth layout (Just (fromIntegral descrWidth)) renderWithDrawWindow win $ do + setForegroundColor style state2 moveTo (fromIntegral $ timeWidth + columnGap) y showLayout layout @@ -333,8 +330,8 @@ inside = maybe False (\ (s, e) -> s <= n && n <= e) mrange selected = cursorPos == n (state1, state2) - | inside = (StatePrelight, StatePrelight) - | selected = (state, state) + | inside = (StateSelected, StateSelected) + | selected = (StateSelected, state) | otherwise = (state, StateNormal) ] @@ -349,6 +346,7 @@ Message msg -> TB.fromText msg UserMessage msg -> TB.fromText msg _ -> buildEventInfo spec + setForegroundColor = setSourceRGBAForStyle styleGetForeground ------------------------------------------------------------------------------- diff --git a/GUI/Main.hs b/GUI/Main.hs --- a/GUI/Main.hs +++ b/GUI/Main.hs @@ -350,37 +350,21 @@ 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 @@ -434,6 +418,24 @@ 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 diff --git a/GUI/Timeline.hs b/GUI/Timeline.hs --- a/GUI/Timeline.hs +++ b/GUI/Timeline.hs @@ -34,9 +34,9 @@ import Events.HECs import Graphics.UI.Gtk -import Graphics.Rendering.Cairo ( liftIO ) import Data.IORef +import Data.Ord import Control.Monad import Control.Monad.Trans import qualified Data.Text as T @@ -74,6 +74,7 @@ timelineSetLabelsMode timelineWin labelsMode = do writeIORef (labelsModeIORef timelineWin) labelsMode widgetQueueDraw (timelineDrawingArea (timelineState timelineWin)) + updateTimelineVScroll timelineWin timelineGetViewParameters :: TimelineView -> IO ViewParameters timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, labelsModeIORef, @@ -384,11 +385,26 @@ ------------------------------------------------------------------------------- -- 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 | PressLeft !Double -- left mouse button is currently pressed @@ -402,8 +418,10 @@ 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 @@ 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)) diff --git a/GUI/ViewerColours.hs b/GUI/ViewerColours.hs --- a/GUI/ViewerColours.hs +++ b/GUI/ViewerColours.hs @@ -137,3 +137,11 @@ (fromIntegral b/0xFFFF) t ------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +setSourceRGBAForStyle :: (Style -> StateType -> IO Color) -> Style -> StateType -> Render () +setSourceRGBAForStyle getColor style state = do + color <- liftIO $ getColor style state + setSourceRGBAhex color 1 + +------------------------------------------------------------------------------- diff --git a/threadscope.cabal b/threadscope.cabal --- a/threadscope.cabal +++ b/threadscope.cabal @@ -1,6 +1,6 @@ Cabal-version: 1.24 Name: threadscope -Version: 0.2.15.0 +Version: 0.2.15.1 Category: Development, Profiling, Trace Synopsis: A graphical tool for profiling parallel Haskell programs. Description: ThreadScope is a graphical viewer for thread profile @@ -42,10 +42,11 @@ GHC == 9.0.2 GHC == 9.2.8 GHC == 9.4.8 - GHC == 9.6.6 + GHC == 9.6.7 GHC == 9.8.4 - GHC == 9.10.1 - GHC == 9.12.1 + GHC == 9.10.3 + GHC == 9.12.2 + GHC == 9.14.1 source-repository head type: git @@ -62,16 +63,16 @@ array < 0.6, mtl < 2.4, filepath < 1.6, - ghc-events >= 0.13 && < 0.21, - containers >= 0.2 && < 0.8, + ghc-events >= 0.13 && < 0.22, + containers >= 0.2 && < 0.9, deepseq >= 1.1 && <1.7.0, text < 2.2, - time >= 1.1 && < 1.15, + time >= 1.1 && < 1.17, bytestring < 0.13, file-embed < 0.1, - template-haskell < 2.24, + template-haskell < 2.25, temporary >= 1.1 && < 1.4, - transformers <0.6.3 + transformers <0.6.4 include-dirs: include default-extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards