diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for threadscope +## 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. + ## 2022-05-10 - v0.2.14.1 * Spelling fixes ([#121](https://github.com/haskell/ThreadScope/pull/121), [#123](https://github.com/haskell/ThreadScope/pull/123)) diff --git a/GUI/BookmarkView.hs b/GUI/BookmarkView.hs --- a/GUI/BookmarkView.hs +++ b/GUI/BookmarkView.hs @@ -117,7 +117,7 @@ (ts,_) <- listStoreGetValue bookmarkStore pos bookmarkViewGotoBookmark ts - onRowActivated bookmarkTreeView $ \[pos] _ -> do + bookmarkTreeView `on` rowActivated $ \[pos] _ -> do (ts, _) <- listStoreGetValue bookmarkStore pos bookmarkViewGotoBookmark ts diff --git a/GUI/Dialogs.hs b/GUI/Dialogs.hs --- a/GUI/Dialogs.hs +++ b/GUI/Dialogs.hs @@ -8,6 +8,7 @@ import Data.Version (showVersion) import System.FilePath +import Control.Monad.Trans ------------------------------------------------------------------------------- @@ -32,7 +33,7 @@ aboutDialogWebsite := "http://www.haskell.org/haskellwiki/ThreadScope", windowTransientFor := toWindow parent ] - onResponse dialog $ \_ -> widgetDestroy dialog + dialog `on` response $ \_ -> widgetDestroy dialog widgetShow dialog ------------------------------------------------------------------------------- @@ -59,7 +60,7 @@ fileFilterAddPattern allfiles "*" fileChooserAddFilter dialog allfiles - onResponse dialog $ \response -> do + dialog `on` response $ \response -> do case response of ResponseAccept -> do mfile <- fileChooserGetFilename dialog @@ -105,7 +106,7 @@ fileFilterAddPattern pdfFiles "*.pdf" fileChooserAddFilter dialog pdfFiles - onResponse dialog $ \response -> + dialog `on` response $ \response -> case response of ResponseAccept -> do mfile <- fileChooserGetFilename dialog @@ -158,5 +159,5 @@ dialogAddButton dialog "Close" ResponseClose dialogSetDefaultResponse dialog ResponseClose - onResponse dialog $ \_-> widgetDestroy dialog + dialog `on` response $ \_-> widgetDestroy dialog widgetShowAll dialog diff --git a/GUI/EventsView.hs b/GUI/EventsView.hs --- a/GUI/EventsView.hs +++ b/GUI/EventsView.hs @@ -13,10 +13,13 @@ ) where import GHC.RTS.Events +import Debug.Trace -import Graphics.UI.Gtk +import Graphics.UI.Gtk hiding (rectangle) +import Graphics.Rendering.Cairo import qualified GUI.GtkExtras as GtkExt +import Control.Monad import Control.Monad.Reader import Data.Array import Data.Monoid @@ -99,9 +102,9 @@ ----------------------------------------------------------------------------- -- Drawing - on drawArea exposeEvent $ liftIO $ do + on drawArea draw $ liftIO $ do drawEvents eventsView =<< readIORef stateRef - return True + return () ----------------------------------------------------------------------------- -- Key navigation @@ -121,7 +124,7 @@ return True key <- eventKeyName -#if MIN_VERSION_gtk(0,13,0) +#if MIN_VERSION_gtk3(0,13,0) case T.unpack key of #else case key of @@ -238,7 +241,7 @@ updateScrollAdjustment EventsView{drawArea, adj} ViewState{lineHeight, eventsState} = do - (_,windowHeight) <- widgetGetSize drawArea + Rectangle _ _ _ windowHeight <- widgetGetAllocation drawArea let numLines = case eventsState of EventsEmpty -> 0 EventsLoaded{eventsArr} -> snd (bounds eventsArr) + 1 @@ -275,9 +278,10 @@ begin = lower end = min upper (snd (bounds eventsArr)) - win <- widgetGetDrawWindow drawArea - style <- get drawArea widgetStyle - focused <- get drawArea widgetIsFocus + -- TODO: don't use Just here + Just win <- widgetGetWindow drawArea + style <- widgetGetStyle drawArea + focused <- widgetGetIsFocus drawArea let state | focused = StateSelected | otherwise = StateActive @@ -285,9 +289,10 @@ layout <- layoutEmpty pangoCtx layoutSetEllipsize layout EllipsizeEnd - (width,clipHeight) <- widgetGetSize drawArea - let clipRect = Rectangle 0 0 width clipHeight + (Rectangle _ _ width _) <- widgetGetAllocation drawArea + let clipRect = Rectangle 0 0 0 0 + let -- With average char width, timeWidth is enough for 24 hours of logs -- (way more than TS can handle, currently). Aligns nicely with -- current timeline_yscale_area width, too. @@ -300,36 +305,27 @@ sequence_ [ do when (inside || selected) $ - GtkExt.stylePaintFlatBox - style win - state1 ShadowNone - clipRect - drawArea "" - 0 (round y) width (round lineHeight) + renderWithDrawWindow win $ do + -- TODO: figure out how I can grab the correct color from GTK's style + setSourceRGBA 0.2 1 1 0.2 + rectangle 0 y (fromIntegral width) lineHeight + fill -- The event time layoutSetText layout (showEventTime event) layoutSetAlignment layout AlignRight layoutSetWidth layout (Just (fromIntegral timeWidth)) - GtkExt.stylePaintLayout - style win - state2 True - clipRect - drawArea "" - 0 (round y) - layout + renderWithDrawWindow win $ do + moveTo 0 y + showLayout layout -- The event description text layoutSetText layout (showEventDescr event) layoutSetAlignment layout AlignLeft layoutSetWidth layout (Just (fromIntegral descrWidth)) - GtkExt.stylePaintLayout - style win - state2 True - clipRect - drawArea "" - (timeWidth + columnGap) (round y) - layout + renderWithDrawWindow win $ do + moveTo (fromIntegral $ timeWidth + columnGap) y + showLayout layout | n <- [begin..end] , let y = fromIntegral n * lineHeight - yOffset diff --git a/GUI/GtkExtras.hs b/GUI/GtkExtras.hs --- a/GUI/GtkExtras.hs +++ b/GUI/GtkExtras.hs @@ -30,58 +30,6 @@ ------------------------------------------------------------------------------- -stylePaintFlatBox :: WidgetClass widget - => Style - -> DrawWindow - -> StateType - -> ShadowType - -> Rectangle - -> widget - -> String - -> Int -> Int -> Int -> Int - -> IO () -stylePaintFlatBox style window stateType shadowType - clipRect widget detail x y width height = - with clipRect $ \rectPtr -> - withCString detail $ \detailPtr -> - (\(Style arg1) (DrawWindow arg2) arg3 arg4 arg5 (Widget arg6) arg7 arg8 arg9 arg10 arg11 -> withForeignPtr arg1 $ \argPtr1 ->withForeignPtr arg2 $ \argPtr2 ->withForeignPtr arg6 $ \argPtr6 -> gtk_paint_flat_box argPtr1 argPtr2 arg3 arg4 arg5 argPtr6 arg7 arg8 arg9 arg10 arg11) - style - window - ((fromIntegral.fromEnum) stateType) - ((fromIntegral.fromEnum) shadowType) - (castPtr rectPtr) - (toWidget widget) - detailPtr - (fromIntegral x) (fromIntegral y) - (fromIntegral width) (fromIntegral height) - -stylePaintLayout :: WidgetClass widget - => Style - -> DrawWindow - -> StateType - -> Bool - -> Rectangle - -> widget - -> String - -> Int -> Int - -> PangoLayout - -> IO () -stylePaintLayout style window stateType useText - clipRect widget detail x y (PangoLayout _ layout) = - with clipRect $ \rectPtr -> - withCString detail $ \detailPtr -> - (\(Style arg1) (DrawWindow arg2) arg3 arg4 arg5 (Widget arg6) arg7 arg8 arg9 (PangoLayoutRaw arg10) -> withForeignPtr arg1 $ \argPtr1 ->withForeignPtr arg2 $ \argPtr2 ->withForeignPtr arg6 $ \argPtr6 ->withForeignPtr arg10 $ \argPtr10 -> gtk_paint_layout argPtr1 argPtr2 arg3 arg4 arg5 argPtr6 arg7 arg8 arg9 argPtr10) - style - window - ((fromIntegral.fromEnum) stateType) - (fromBool useText) - (castPtr rectPtr) - (toWidget widget) - detailPtr - (fromIntegral x) (fromIntegral y) - layout - - launchProgramForURI :: String -> IO Bool #if mingw32_HOST_OS || mingw32_TARGET_OS launchProgramForURI uri = do @@ -114,12 +62,6 @@ #endif ------------------------------------------------------------------------------- - -foreign import ccall safe "gtk_paint_flat_box" - gtk_paint_flat_box :: Ptr Style -> Ptr DrawWindow -> CInt -> CInt -> Ptr () -> Ptr Widget -> Ptr CChar -> CInt -> CInt -> CInt -> CInt -> IO () - -foreign import ccall safe "gtk_paint_layout" - gtk_paint_layout :: Ptr Style -> Ptr DrawWindow -> CInt -> CInt -> Ptr () -> Ptr Widget -> Ptr CChar -> CInt -> CInt -> Ptr PangoLayoutRaw -> IO () foreign import ccall safe "gtk_show_uri" gtk_show_uri :: Ptr Screen -> Ptr CChar -> CUInt -> Ptr (Ptr ()) -> IO CInt diff --git a/GUI/Histogram.hs b/GUI/Histogram.hs --- a/GUI/Histogram.hs +++ b/GUI/Histogram.hs @@ -16,6 +16,7 @@ import qualified GUI.GtkExtras as GtkExt import Data.IORef +import Control.Monad.Trans data HistogramView = HistogramView @@ -51,7 +52,7 @@ fontDescriptionSetFamily fd "sans serif" widgetModifyFont histogramYScaleArea (Just fd) - (_, xh) <- widgetGetSize timelineXScaleArea + Rectangle _ _ _ xh <- widgetGetAllocation timelineXScaleArea let xScaleAreaHeight = fromIntegral xh traces = [TraceHistogram] paramsHist (w, h) minterval = ViewParameters @@ -80,53 +81,51 @@ ++ "Re-run with +RTS -lf to generate them." -- Program the callback for the capability drawingArea - on histogramDrawingArea exposeEvent $ + on histogramDrawingArea draw $ C.liftIO $ do maybeEventArray <- readIORef hecsIORef - win <- widgetGetDrawWindow histogramDrawingArea - (w, windowHeight) <- widgetGetSize histogramDrawingArea + -- TODO: get rid of Just + Just win <- widgetGetWindow histogramDrawingArea + Rectangle _ _ w windowHeight <- widgetGetAllocation histogramDrawingArea case maybeEventArray of - Nothing -> return False + Nothing -> return () Just hecs | null (durHistogram hecs) -> do - GtkExt.stylePaintLayout - style win - StateNormal True - (Rectangle 0 0 w windowHeight) - histogramDrawingArea "" - 4 20 - layout - return True + renderWithDrawWindow win $ do + C.moveTo 4 20 + showLayout layout + return () | otherwise -> do minterval <- readIORef mintervalIORef if windowHeight < 80 - then return False + then return () else do let size = (w, windowHeight - firstTraceY) params = paramsHist size minterval rect = Rectangle 0 0 w (snd size) - renderWithDrawable win $ + renderWithDrawWindow win $ renderTraces params hecs rect - return True + return () -- Redrawing histogramYScaleArea - histogramYScaleArea `onExpose` \_ -> do + histogramYScaleArea `on` draw $ liftIO $ do maybeEventArray <- readIORef hecsIORef case maybeEventArray of - Nothing -> return False + Nothing -> return () Just hecs - | null (durHistogram hecs) -> return False + | null (durHistogram hecs) -> return () | otherwise -> do - win <- widgetGetDrawWindow histogramYScaleArea + -- TODO: get rid of Just + Just win <- widgetGetWindow histogramYScaleArea minterval <- readIORef mintervalIORef - (_, windowHeight) <- widgetGetSize histogramYScaleArea + Rectangle _ _ _ windowHeight <- widgetGetAllocation histogramYScaleArea if windowHeight < 80 - then return False + then return () else do let size = (undefined, windowHeight - firstTraceY) params = paramsHist size minterval - renderWithDrawable win $ + renderWithDrawWindow win $ renderYScaleArea params hecs histogramYScaleArea - return True + return () return HistogramView{..} diff --git a/GUI/KeyView.hs b/GUI/KeyView.hs --- a/GUI/KeyView.hs +++ b/GUI/KeyView.hs @@ -24,7 +24,8 @@ keyTreeView <- builderGetObject builder castToTreeView "key_list" - dw <- widgetGetDrawWindow keyTreeView + -- TODO: get rid of this Just + Just dw <- widgetGetWindow keyTreeView keyEntries <- createKeyEntries dw keyData keyStore <- listStoreNew keyEntries @@ -113,7 +114,7 @@ ] -createKeyEntries :: DrawableClass dw +createKeyEntries :: DrawWindowClass dw => dw -> [(String, KeyStyle, Color,String)] -> IO [(String, String, Pixbuf)] @@ -165,12 +166,11 @@ C.relLineTo 0 25 C.stroke -renderToPixbuf :: DrawableClass dw => dw -> (Int, Int) -> C.Render () +renderToPixbuf :: DrawWindowClass dw => dw -> (Int, Int) -> C.Render () -> IO Pixbuf renderToPixbuf similar (w, h) draw = do - pixmap <- pixmapNew (Just similar) w h Nothing - renderWithDrawable pixmap draw - Just pixbuf <- pixbufGetFromDrawable pixmap (Rectangle 0 0 w h) + renderWithDrawWindow similar draw + pixbuf <- pixbufNewFromWindow similar 0 0 w h return pixbuf ------------------------------------------------------------------------------- diff --git a/GUI/MainWindow.hs b/GUI/MainWindow.hs --- a/GUI/MainWindow.hs +++ b/GUI/MainWindow.hs @@ -32,7 +32,6 @@ toGObject = toGObject . mainWindow unsafeCastGObject = error "cannot downcast to MainView type" -instance Gtk.ObjectClass MainWindow instance Gtk.WidgetClass MainWindow instance Gtk.ContainerClass MainWindow instance Gtk.BinClass MainWindow diff --git a/GUI/ProgressView.hs b/GUI/ProgressView.hs --- a/GUI/ProgressView.hs +++ b/GUI/ProgressView.hs @@ -16,6 +16,7 @@ import qualified Control.Concurrent as Concurrent import Control.Exception import Data.Typeable +import Control.Monad.Trans data ProgressView = ProgressView { progressWindow :: Gtk.Window, @@ -95,8 +96,8 @@ progress <- progressBarNew cancel <- buttonNewFromStock stockCancel - onClicked cancel (widgetDestroy win >> cancelAction) - onDelete win (\_ -> cancelAction >> return True) + cancel `on` buttonActivated $ (widgetDestroy win >> cancelAction) + win `on` destroyEvent $ lift cancelAction >> return True on win keyPressEvent $ do keyVal <- eventKeyVal case keyVal of diff --git a/GUI/SaveAs.hs b/GUI/SaveAs.hs --- a/GUI/SaveAs.hs +++ b/GUI/SaveAs.hs @@ -62,14 +62,14 @@ saveAsPDF :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO () saveAsPDF filename hecs params yScaleArea = do - (xoffset, _) <- liftIO $ widgetGetSize yScaleArea + Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea withPDFSurface filename (fromIntegral w') (fromIntegral h') $ \surface -> renderWith surface drawAll saveAsPNG :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO () saveAsPNG filename hecs params yScaleArea = do - (xoffset, _) <- liftIO $ widgetGetSize yScaleArea + Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea withImageSurface FormatARGB32 w' h' $ \surface -> do renderWith surface drawAll diff --git a/GUI/Timeline.hs b/GUI/Timeline.hs --- a/GUI/Timeline.hs +++ b/GUI/Timeline.hs @@ -38,6 +38,7 @@ import Data.IORef import Control.Monad +import Control.Monad.Trans import qualified Data.Text as T ----------------------------------------------------------------------------- @@ -78,7 +79,7 @@ timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, labelsModeIORef, timelineState=TimelineState{..}} = do - (w, _) <- widgetGetSize timelineDrawingArea + Rectangle _ _ w _ <- widgetGetAllocation timelineDrawingArea scaleValue <- readIORef scaleIORef maxSpkValue <- readIORef maxSpkIORef @@ -90,7 +91,7 @@ bwmode <- readIORef bwmodeIORef labelsMode <- readIORef labelsModeIORef - (_, xScaleAreaHeight) <- widgetGetSize timelineXScaleArea + Rectangle _ _ _ xScaleAreaHeight <- widgetGetAllocation timelineXScaleArea let histTotalHeight = stdHistogramHeight + histXScaleHeight timelineHeight = calculateTotalTimelineHeight labelsMode histTotalHeight traces @@ -169,32 +170,32 @@ ------------------------------------------------------------------------ -- Redrawing labelDrawingArea - timelineYScaleArea `onExpose` \_ -> do + timelineYScaleArea `on` draw $ liftIO $ do maybeEventArray <- readIORef hecsIORef -- Check to see if an event trace has been loaded case maybeEventArray of - Nothing -> return False + 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 True + return () ------------------------------------------------------------------------ -- Redrawing XScaleArea - timelineXScaleArea `onExpose` \_ -> do + timelineXScaleArea `on` draw $ liftIO $ do maybeEventArray <- readIORef hecsIORef -- Check to see if an event trace has been loaded case maybeEventArray of - Nothing -> return False + Nothing -> return () Just hecs -> do let lastTx = hecLastEventTime hecs updateXScaleArea timelineState lastTx - return True + return () ------------------------------------------------------------------------ -- Allow mouse wheel to be used for zoom in/out @@ -253,7 +254,7 @@ in withMouseState whenNoMouse >> return True keyName <- eventKeyName keyVal <- eventKeyVal -#if MIN_VERSION_gtk(0,13,0) +#if MIN_VERSION_gtk3(0,13,0) case (T.unpack keyName, keyToChar keyVal, keyVal) of #else case (keyName, keyToChar keyVal, keyVal) of @@ -277,8 +278,7 @@ ------------------------------------------------------------------------ -- Redrawing - on timelineDrawingArea exposeEvent $ do - exposeRegion <- eventRegion + on timelineDrawingArea draw $ do liftIO $ do maybeEventArray <- readIORef hecsIORef @@ -290,14 +290,14 @@ -- 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). - (_, h) <- widgetGetSize timelineDrawingArea + (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 exposeRegion + renderView timelineState params' hecs selection bookmarks (Rectangle 0 0 w h) - return True + return () on timelineDrawingArea configureEvent $ do liftIO $ configureTimelineDrawingArea timelineWin @@ -357,7 +357,7 @@ labelsMode <- readIORef labelsModeIORef let histTotalHeight = stdHistogramHeight + histXScaleHeight h = calculateTotalTimelineHeight labelsMode histTotalHeight traces - (_,winh) <- widgetGetSize timelineDrawingArea + Rectangle _ _ _ winh <- widgetGetAllocation timelineDrawingArea let winh' = fromIntegral winh; h' = fromIntegral h adjustmentSetLower timelineVAdj 0 @@ -377,7 +377,7 @@ -- the view at all. updateTimelineHPageSize :: TimelineState -> IO () updateTimelineHPageSize TimelineState{..} = do - (winw,_) <- widgetGetSize timelineDrawingArea + Rectangle _ _ winw _ <- widgetGetAllocation timelineDrawingArea scaleValue <- readIORef scaleIORef adjustmentSetPageSize timelineAdj (fromIntegral winw * scaleValue) @@ -467,8 +467,9 @@ widgetSetCursor :: WidgetClass widget => widget -> Maybe Cursor -> IO () widgetSetCursor widget cursor = do -#if MIN_VERSION_gtk(0,12,1) - dw <- widgetGetDrawWindow widget +#if MIN_VERSION_gtk3(0,12,1) + -- TODO: get rid of this Just + Just dw <- widgetGetWindow widget drawWindowSetCursor dw cursor #endif return () diff --git a/GUI/Timeline/Motion.hs b/GUI/Timeline/Motion.hs --- a/GUI/Timeline/Motion.hs +++ b/GUI/Timeline/Motion.hs @@ -68,7 +68,7 @@ let lastTx = hecLastEventTime hecs upper = fromIntegral lastTx lower = 0 - (w, _) <- widgetGetSize timelineDrawingArea + Rectangle _ _ w _ <- widgetGetAllocation timelineDrawingArea let newScaleValue = upper / fromIntegral w (sliceAll, profAll) = treesProfile newScaleValue 0 lastTx hecs -- TODO: verify that no empty lists possible below diff --git a/GUI/Timeline/Render.hs b/GUI/Timeline/Render.hs --- a/GUI/Timeline/Render.hs +++ b/GUI/Timeline/Render.hs @@ -53,6 +53,8 @@ import Control.Monad import qualified Data.Text as T +import qualified Graphics.UI.Gtk.Cairo as C + ------------------------------------------------------------------------------- -- | This function redraws the currently visible part of the @@ -61,20 +63,19 @@ renderView :: TimelineState -> ViewParameters -> HECs -> TimeSelection -> [Timestamp] - -> Region -> IO () + -> Rectangle -> IO () renderView TimelineState{timelineDrawingArea, timelineVAdj, timelinePrevView} - params hecs selection bookmarks exposeRegion = do + params hecs selection bookmarks rect = do -- Get state information from user-interface components - (w, _) <- widgetGetSize timelineDrawingArea + Rectangle _ _ w _ <- widgetGetAllocation timelineDrawingArea vadj_value <- adjustmentGetValue timelineVAdj prev_view <- readIORef timelinePrevView - rect <- regionGetClipbox exposeRegion - - win <- widgetGetDrawWindow timelineDrawingArea - renderWithDrawable win $ do + -- TODO: get rid of this Just + Just win <- widgetGetWindow timelineDrawingArea + renderWithDrawWindow win $ do let renderToNewSurface = do new_surface <- withTargetSurface $ \surface -> @@ -113,7 +114,7 @@ liftIO $ writeIORef timelinePrevView (Just (params, surface)) - region exposeRegion + C.rectangle rect clip setSourceSurface surface 0 (-vadj_value) -- ^^ this is where we adjust for the vertical scrollbar @@ -319,15 +320,16 @@ -- and not only the newly exposed area. This is comparatively very cheap. updateXScaleArea :: TimelineState -> Timestamp -> IO () updateXScaleArea TimelineState{..} lastTx = do - win <- widgetGetDrawWindow timelineXScaleArea - (width, _) <- widgetGetSize timelineDrawingArea - (_, xScaleAreaHeight) <- widgetGetSize timelineXScaleArea + -- TODO: get rid of this Just + Just win <- widgetGetWindow timelineXScaleArea + Rectangle _ _ width _ <- widgetGetAllocation timelineDrawingArea + Rectangle _ _ _ xScaleAreaHeight <- widgetGetAllocation timelineXScaleArea scaleValue <- readIORef scaleIORef -- Snap the view to whole pixels, to avoid blurring. hadjValue0 <- adjustmentGetValue timelineAdj let hadjValue = toWholePixels scaleValue hadjValue0 off y = y + xScaleAreaHeight - 17 - renderWithDrawable win $ + renderWithDrawWindow win $ renderXScale scaleValue hadjValue lastTx width off XScaleTime return () @@ -341,7 +343,7 @@ hecs yScaleArea = do let maxP = maxSparkPool hecs maxH = fromIntegral $ maxYHistogram hecs - (xoffset, _) <- liftIO $ widgetGetSize yScaleArea + Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea drawYScaleArea maxSpkValue maxP maxH minterval (fromIntegral xoffset) 0 labelsMode histogramHeight viewTraces yScaleArea @@ -352,11 +354,12 @@ -> Bool -> [Trace] -> IO () updateYScaleArea TimelineState{..} maxSparkPool maxYHistogram minterval labelsMode traces = do - win <- widgetGetDrawWindow timelineYScaleArea + -- TODO: get rid of this Just + Just win <- widgetGetWindow timelineYScaleArea maxSpkValue <- readIORef maxSpkIORef vadj_value <- adjustmentGetValue timelineVAdj - (xoffset, _) <- widgetGetSize timelineYScaleArea - renderWithDrawable win $ + Rectangle _ _ xoffset _ <- widgetGetAllocation timelineYScaleArea + renderWithDrawWindow win $ drawYScaleArea maxSpkValue maxSparkPool maxYHistogram minterval (fromIntegral xoffset) vadj_value labelsMode stdHistogramHeight traces timelineYScaleArea @@ -393,7 +396,7 @@ -- Note: the following does not always work, see the HACK in Timeline.hs layoutSetAttributes layout [AttrSize minBound maxBound 8, AttrFamily minBound maxBound -#if MIN_VERSION_gtk(0,13,0) +#if MIN_VERSION_gtk3(0,13,0) (T.pack "sans serif")] #else "sans serif"] diff --git a/Graphics/UI/Gtk/ModelView/TreeView/Compat.hs b/Graphics/UI/Gtk/ModelView/TreeView/Compat.hs --- a/Graphics/UI/Gtk/ModelView/TreeView/Compat.hs +++ b/Graphics/UI/Gtk/ModelView/TreeView/Compat.hs @@ -4,7 +4,7 @@ ) where import Graphics.UI.Gtk hiding (treeViewSetModel) import qualified Graphics.UI.Gtk.ModelView.TreeView as Gtk -#if !MIN_VERSION_gtk(0, 14, 9) +#if !MIN_VERSION_gtk3(0, 14, 9) import qualified System.Glib.FFI as Glib import qualified Graphics.UI.GtkInternals as Gtk #endif @@ -14,7 +14,7 @@ => self -> Maybe model -> IO () -#if MIN_VERSION_gtk(0, 14, 9) +#if MIN_VERSION_gtk3(0, 14, 9) treeViewSetModel = Gtk.treeViewSetModel #else treeViewSetModel self model = Gtk.treeViewSetModel self diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,16 +8,16 @@ Currently [pre-built binaries](https://github.com/haskell/ThreadScope/releases) for the following platforms are provided: -* Ubuntu 18.04 (64-bit) -* macOS 10.15 -* Windows Server 2019 (x64) +* Ubuntu 24.04 (64-bit) +* macOS 14.7 +* Windows Server 2022 (x64) -GTK+2 needs to be installed for these binaries to work. +GTK+3 needs to be installed for these binaries to work. -On Windows, the [MSYS2](http://www.msys2.org) is the recommended way to install GTK+2. In MSYS2 MINGW64 shell: +On Windows, the [MSYS2](http://www.msys2.org) is the recommended way to install GTK+3. In MSYS2 MINGW64 shell: ```sh -pacman -S $MINGW_PACKAGE_PREFIX-gtk2 +pacman -S $MINGW_PACKAGE_PREFIX-gtk3 ``` then you can run the threadscope binary from the shell. @@ -26,12 +26,14 @@ Use `git clone` or `cabal get threadscope` to get the source and move into the threadscope directory. +The code for the Github Actions is a good guide for building from source. + ### Linux -GTK+2 is required to be installed. On Ubuntu-like systems: +GTK+3 is required to be installed. On Ubuntu-like systems: ```sh -sudo apt install libgtk2.0-dev +sudo apt install libgtk-3-dev ``` Then you can build threadscope using cabal: @@ -53,7 +55,7 @@ GTK+ is required: ```sh -brew install gtk+ +brew install cairo gtk+3 pkg-config ``` Then you can build threadscope using cabal: @@ -72,13 +74,16 @@ ### Windows +> [!CAUTION] +> The Windows instructions may be out of date. Contributions to update them would be welcome. + [Chocolatey](https://chocolatey.org/) can be used to install GHC and [MSYS2](https://www.msys2.org/) is the recommended way to install GTK+. ```sh choco install ghc refreshenv set PATH=C:\\msys64\\mingw64\\bin;C:\\msys64\\usr\\bin;%PATH% -pacman -Sy mingw-w64-x86_64-gtk2 +pacman -Sy mingw-w64-x86_64-gtk3 ``` then you can build threadscope using cabal: @@ -89,7 +94,7 @@ Or you can use stack instead. -CAVEAT: gtk2 needs to be installed twice: one for stack's MSYS2 environment and another for local MSYS2 environment. +CAVEAT: gtk3 needs to be installed twice: one for stack's MSYS2 environment and another for local MSYS2 environment. In command prompt: @@ -98,14 +103,14 @@ stack exec -- pacman --needed -Sy bash pacman pacman-mirrors msys2-runtime msys2-runtime-devel stack exec -- pacman -Syu stack exec -- pacman -Syuu -stack exec -- pacman -S base-devel mingw-w64-x86_64-pkg-config mingw-w64-x86_64-toolchain mingw-w64-x86_64-gtk2 +stack exec -- pacman -S base-devel mingw-w64-x86_64-pkg-config mingw-w64-x86_64-toolchain mingw-w64-x86_64-gtk3 stack install ``` Then in MSYS2 MINGW64 shell: ```sh -pacman -S $MINGW_PACKAGE_PREFIX-gtk2 +pacman -S $MINGW_PACKAGE_PREFIX-gtk3 echo 'export PATH=$APPDATA/local/bin:$PATH' >> .profile source .profile threadscope 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.14.1 +Version: 0.2.15.0 Category: Development, Profiling, Trace Synopsis: A graphical tool for profiling parallel Haskell programs. Description: ThreadScope is a graphical viewer for thread profile @@ -34,12 +34,18 @@ Build-Type: Simple Data-files: threadscope.ui, threadscope.png Extra-source-files: include/windows_cconv.h + threadscope.ui README.md CHANGELOG.md Tested-with: GHC == 8.8.4 GHC == 8.10.7 GHC == 9.0.2 - GHC == 9.2.2 + GHC == 9.2.8 + GHC == 9.4.8 + GHC == 9.6.6 + GHC == 9.8.4 + GHC == 9.10.1 + GHC == 9.12.1 source-repository head type: git @@ -48,26 +54,28 @@ Executable threadscope Main-is: Main.hs Build-Depends: base >= 4.10 && < 5, - gtk >= 0.12 && < 0.16, + gtk3 >= 0.12 && < 0.16, cairo < 0.14, glib < 0.14, pango < 0.14, binary < 0.11, array < 0.6, - mtl < 2.3, - filepath < 1.5, - ghc-events >= 0.13 && < 0.18, - containers >= 0.2 && < 0.7, - deepseq >= 1.1, - text < 2.1, - time >= 1.1 && < 1.13, - bytestring < 0.12, + mtl < 2.4, + filepath < 1.6, + ghc-events >= 0.13 && < 0.21, + containers >= 0.2 && < 0.8, + deepseq >= 1.1 && <1.7.0, + text < 2.2, + time >= 1.1 && < 1.15, + bytestring < 0.13, file-embed < 0.1, - template-haskell < 2.19, - temporary >= 1.1 && < 1.4 + template-haskell < 2.24, + temporary >= 1.1 && < 1.4, + transformers <0.6.3 include-dirs: include default-extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards + other-extensions: TemplateHaskell Other-Modules: Events.HECs, Events.EventDuration, Events.EventTree, @@ -116,6 +124,6 @@ ghc-options: -fno-warn-unused-matches if !os(windows) - build-depends: unix >= 2.3 && < 2.8 + build-depends: unix >= 2.3 && < 2.9 default-language: Haskell2010