threadscope 0.2.14.1 → 0.2.15.0
raw patch · 16 files changed
+152/−193 lines, 16 filesdep +gtk3dep +transformersdep −gtkdep ~deepseqnew-uploader
Dependencies added: gtk3, transformers
Dependencies removed: gtk
Dependency ranges changed: deepseq
Files
- CHANGELOG.md +4/−0
- GUI/BookmarkView.hs +1/−1
- GUI/Dialogs.hs +5/−4
- GUI/EventsView.hs +26/−30
- GUI/GtkExtras.hs +0/−58
- GUI/Histogram.hs +23/−24
- GUI/KeyView.hs +6/−6
- GUI/MainWindow.hs +0/−1
- GUI/ProgressView.hs +3/−2
- GUI/SaveAs.hs +2/−2
- GUI/Timeline.hs +19/−18
- GUI/Timeline/Motion.hs +1/−1
- GUI/Timeline/Render.hs +20/−17
- Graphics/UI/Gtk/ModelView/TreeView/Compat.hs +2/−2
- README.md +18/−13
- threadscope.cabal +22/−14
CHANGELOG.md view
@@ -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))
GUI/BookmarkView.hs view
@@ -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
GUI/Dialogs.hs view
@@ -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
GUI/EventsView.hs view
@@ -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
GUI/GtkExtras.hs view
@@ -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
GUI/Histogram.hs view
@@ -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 <tt>+RTS -lf</tt> 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{..}
GUI/KeyView.hs view
@@ -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 -------------------------------------------------------------------------------
GUI/MainWindow.hs view
@@ -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
GUI/ProgressView.hs view
@@ -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
GUI/SaveAs.hs view
@@ -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
GUI/Timeline.hs view
@@ -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 ()
GUI/Timeline/Motion.hs view
@@ -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
GUI/Timeline/Render.hs view
@@ -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"]
Graphics/UI/Gtk/ModelView/TreeView/Compat.hs view
@@ -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
README.md view
@@ -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
threadscope.cabal view
@@ -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