threadscope 0.2.15.0 → 0.2.15.1
raw patch · 6 files changed
+81/−48 lines, 6 filesdep ~containersdep ~ghc-eventsdep ~template-haskell
Dependency ranges changed: containers, ghc-events, template-haskell, time, transformers
Files
- CHANGELOG.md +4/−0
- GUI/EventsView.hs +7/−9
- GUI/Main.hs +24/−22
- GUI/Timeline.hs +28/−8
- GUI/ViewerColours.hs +8/−0
- threadscope.cabal +10/−9
CHANGELOG.md view
@@ -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.
GUI/EventsView.hs view
@@ -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 -------------------------------------------------------------------------------
GUI/Main.hs view
@@ -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
GUI/Timeline.hs view
@@ -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))
GUI/ViewerColours.hs view
@@ -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++-------------------------------------------------------------------------------
threadscope.cabal view
@@ -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