From 30d52ff65f1c5b49515d9be5da81be6e2fa79b08 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Tue, 25 Mar 2025 16:05:41 +0000 Subject: [PATCH 01/15] Switch to GTK3 --- GUI/BookmarkView.hs | 2 +- GUI/Dialogs.hs | 9 ++--- GUI/EventsView.hs | 13 +++---- GUI/Histogram.hs | 37 ++++++++++--------- GUI/KeyView.hs | 13 +++---- GUI/MainWindow.hs | 1 - GUI/ProgressView.hs | 5 +-- GUI/SaveAs.hs | 4 +-- GUI/Timeline.hs | 38 ++++++++++---------- GUI/Timeline/Motion.hs | 2 +- GUI/Timeline/Render.hs | 36 ++++++++++--------- Graphics/UI/Gtk/ModelView/TreeView/Compat.hs | 4 +-- threadscope.cabal | 5 +-- 13 files changed, 90 insertions(+), 79 deletions(-) diff --git a/GUI/BookmarkView.hs b/GUI/BookmarkView.hs index 6e21e5e7..42d36431 100644 --- a/GUI/BookmarkView.hs +++ b/GUI/BookmarkView.hs @@ -117,7 +117,7 @@ bookmarkViewNew builder BookmarkViewActions{..} = do (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 index 395bc735..7043f7ce 100644 --- a/GUI/Dialogs.hs +++ b/GUI/Dialogs.hs @@ -8,6 +8,7 @@ import Graphics.UI.Gtk import Data.Version (showVersion) import System.FilePath +import Control.Monad.Trans ------------------------------------------------------------------------------- @@ -32,7 +33,7 @@ aboutDialog parent 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 @@ openFileDialog parent open 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 @@ exportFileDialog parent oldfile save = do 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 @@ errorMessageDialog parent headline explanation = do 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 index 74d56d9e..f2a98da2 100644 --- a/GUI/EventsView.hs +++ b/GUI/EventsView.hs @@ -100,9 +100,9 @@ eventsViewNew builder EventsViewActions{..} = do ----------------------------------------------------------------------------- -- Drawing - on drawArea exposeEvent $ liftIO $ do + on drawArea draw $ liftIO $ do drawEvents eventsView =<< readIORef stateRef - return True + return () ----------------------------------------------------------------------------- -- Key navigation @@ -122,7 +122,7 @@ eventsViewNew builder EventsViewActions{..} = do 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 @@ -239,7 +239,7 @@ updateScrollAdjustment :: EventsView -> ViewState -> IO () 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 @@ -276,7 +276,8 @@ drawEvents EventsView{drawArea, adj} begin = lower end = min upper (snd (bounds eventsArr)) - win <- widgetGetDrawWindow drawArea + -- TODO: don't use Just here + Just win <- widgetGetWindow drawArea style <- get drawArea widgetStyle focused <- get drawArea widgetIsFocus let state | focused = StateSelected @@ -286,7 +287,7 @@ drawEvents EventsView{drawArea, adj} layout <- layoutEmpty pangoCtx layoutSetEllipsize layout EllipsizeEnd - (width,clipHeight) <- widgetGetSize drawArea + Rectangle _ _ width clipHeight <- widgetGetAllocation drawArea let clipRect = Rectangle 0 0 width clipHeight let -- With average char width, timeWidth is enough for 24 hours of logs diff --git a/GUI/Histogram.hs b/GUI/Histogram.hs index 6aaaa6c8..5d4bbe97 100644 --- a/GUI/Histogram.hs +++ b/GUI/Histogram.hs @@ -16,6 +16,7 @@ import Graphics.UI.Gtk import qualified GUI.GtkExtras as GtkExt import Data.IORef +import Control.Monad.Trans data HistogramView = HistogramView @@ -51,7 +52,7 @@ histogramViewNew builder = do 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,13 +81,14 @@ histogramViewNew builder = do ++ "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 @@ -96,37 +98,38 @@ histogramViewNew builder = do histogramDrawingArea "" 4 20 layout - return True + 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 index a64063ef..e85f79e5 100644 --- a/GUI/KeyView.hs +++ b/GUI/KeyView.hs @@ -24,7 +24,8 @@ keyViewNew builder = do 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 @@ keyData = ] -createKeyEntries :: DrawableClass dw +createKeyEntries :: DrawWindowClass dw => dw -> [(String, KeyStyle, Color,String)] -> IO [(String, String, Pixbuf)] @@ -165,12 +166,12 @@ renderKEvent keyColour = do 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) + -- TODO: is this right??? + renderWithDrawWindow similar draw + pixbuf <- pixbufNewFromWindow similar 0 0 w h return pixbuf ------------------------------------------------------------------------------- diff --git a/GUI/MainWindow.hs b/GUI/MainWindow.hs index 19122c38..7c9c6983 100644 --- a/GUI/MainWindow.hs +++ b/GUI/MainWindow.hs @@ -32,7 +32,6 @@ instance Glib.GObjectClass MainWindow where 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 index a83a27b0..db9dda8f 100644 --- a/GUI/ProgressView.hs +++ b/GUI/ProgressView.hs @@ -16,6 +16,7 @@ import GUI.GtkExtras 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 @@ new parent cancelAction = do 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 index a576b5d7..112f01f6 100644 --- a/GUI/SaveAs.hs +++ b/GUI/SaveAs.hs @@ -62,14 +62,14 @@ saveAs hecs params'@ViewParameters{xScaleAreaHeight, width, 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 index 24302f73..012f8f78 100644 --- a/GUI/Timeline.hs +++ b/GUI/Timeline.hs @@ -38,6 +38,7 @@ import Graphics.Rendering.Cairo ( liftIO ) import Data.IORef import Control.Monad +import Control.Monad.Trans import qualified Data.Text as T ----------------------------------------------------------------------------- @@ -78,7 +79,7 @@ timelineGetViewParameters :: TimelineView -> IO ViewParameters 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 @@ timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, labelsModeIORef 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 @@ timelineViewNew builder actions = do ------------------------------------------------------------------------ -- 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 @@ timelineViewNew builder actions = do 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 @@ timelineViewNew builder actions = do ------------------------------------------------------------------------ -- Redrawing - on timelineDrawingArea exposeEvent $ do - exposeRegion <- eventRegion + on timelineDrawingArea draw $ do liftIO $ do maybeEventArray <- readIORef hecsIORef @@ -290,14 +290,15 @@ timelineViewNew builder actions = do -- 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 + exposeRect <- widgetGetAllocation timelineDrawingArea + Rectangle _ _ _ 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 exposeRect - return True + return () on timelineDrawingArea configureEvent $ do liftIO $ configureTimelineDrawingArea timelineWin @@ -357,7 +358,7 @@ updateTimelineVScroll TimelineView{tracesIORef, labelsModeIORef, timelineState=T 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 +378,7 @@ updateTimelineVScroll TimelineView{tracesIORef, labelsModeIORef, timelineState=T -- 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 +468,9 @@ mouseRelease view@TimelineView{..} TimelineViewActions{..} state button x = 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 index 4aafb37c..ce90e1ec 100644 --- a/GUI/Timeline/Motion.hs +++ b/GUI/Timeline/Motion.hs @@ -68,7 +68,7 @@ zoomToFit TimelineState{scaleIORef, maxSpkIORef,timelineAdj, 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 index 546b93f3..729e7610 100644 --- a/GUI/Timeline/Render.hs +++ b/GUI/Timeline/Render.hs @@ -61,20 +61,19 @@ import qualified Data.Text as T 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 +112,8 @@ renderView TimelineState{timelineDrawingArea, timelineVAdj, timelinePrevView} liftIO $ writeIORef timelinePrevView (Just (params, surface)) - region exposeRegion + -- TODO: figure out what this did??? + -- region exposeRegion clip setSourceSurface surface 0 (-vadj_value) -- ^^ this is where we adjust for the vertical scrollbar @@ -319,15 +319,16 @@ scrollView surface old new hecs = do -- 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 +342,7 @@ renderYScaleArea ViewParameters{maxSpkValue, labelsMode, viewTraces, 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 +353,12 @@ updateYScaleArea :: TimelineState -> Double -> Double -> Maybe Interval -> 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 +395,7 @@ drawSingleYScale maxSpkValue maxSparkPool maxYHistogram minterval xoffset -- 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 index b697ded7..a24124d5 100644 --- a/Graphics/UI/Gtk/ModelView/TreeView/Compat.hs +++ b/Graphics/UI/Gtk/ModelView/TreeView/Compat.hs @@ -4,7 +4,7 @@ module Graphics.UI.Gtk.ModelView.TreeView.Compat ) 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 @@ treeViewSetModel => 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/threadscope.cabal b/threadscope.cabal index e2471e13..6e9cdcef 100644 --- a/threadscope.cabal +++ b/threadscope.cabal @@ -53,7 +53,7 @@ source-repository head 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, @@ -69,7 +69,8 @@ Executable threadscope bytestring < 0.13, file-embed < 0.1, template-haskell < 2.24, - temporary >= 1.1 && < 1.4 + temporary >= 1.1 && < 1.4, + transformers include-dirs: include default-extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards From 613dd5ff976aab5b79f74a939c3f73c8acccb068 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Tue, 25 Mar 2025 16:35:16 +0000 Subject: [PATCH 02/15] wip --- GUI/KeyView.hs | 2 +- GUI/Timeline.hs | 4 ++++ GUI/Timeline/Render.hs | 4 +++- 3 files changed, 8 insertions(+), 2 deletions(-) diff --git a/GUI/KeyView.hs b/GUI/KeyView.hs index e85f79e5..932bcc1a 100644 --- a/GUI/KeyView.hs +++ b/GUI/KeyView.hs @@ -169,7 +169,7 @@ renderKEvent keyColour = do renderToPixbuf :: DrawWindowClass dw => dw -> (Int, Int) -> C.Render () -> IO Pixbuf renderToPixbuf similar (w, h) draw = do - -- TODO: is this right??? + -- TODO: is this right??? I think so. It seems to work at least :shrug: renderWithDrawWindow similar draw pixbuf <- pixbufNewFromWindow similar 0 0 w h return pixbuf diff --git a/GUI/Timeline.hs b/GUI/Timeline.hs index 012f8f78..7a67ab3f 100644 --- a/GUI/Timeline.hs +++ b/GUI/Timeline.hs @@ -24,6 +24,7 @@ module GUI.Timeline ( timelineCentreOnCursor, ) where +import Debug.Trace import GUI.Types import GUI.Timeline.Types @@ -280,18 +281,21 @@ timelineViewNew builder actions = do on timelineDrawingArea draw $ do liftIO $ do + traceM "timelineDrawingArea" maybeEventArray <- readIORef hecsIORef -- Check to see if an event trace has been loaded case maybeEventArray of Nothing -> return () Just hecs -> do + traceShowM "just hecs" params <- timelineGetViewParameters timelineWin -- 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). exposeRect <- widgetGetAllocation timelineDrawingArea Rectangle _ _ _ h <- widgetGetAllocation timelineDrawingArea + traceShowM exposeRect let params' = params { height = max (height params) h } selection <- readIORef selectionRef bookmarks <- readIORef bookmarkIORef diff --git a/GUI/Timeline/Render.hs b/GUI/Timeline/Render.hs index 729e7610..ec8a8604 100644 --- a/GUI/Timeline/Render.hs +++ b/GUI/Timeline/Render.hs @@ -53,6 +53,8 @@ import Data.IORef 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 @@ -113,7 +115,7 @@ renderView TimelineState{timelineDrawingArea, timelineVAdj, timelinePrevView} liftIO $ writeIORef timelinePrevView (Just (params, surface)) -- TODO: figure out what this did??? - -- region exposeRegion + C.rectangle rect clip setSourceSurface surface 0 (-vadj_value) -- ^^ this is where we adjust for the vertical scrollbar From 73fb2f29cd76fa94dd7602c2996a9700823ec23d Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Tue, 25 Mar 2025 17:10:01 +0000 Subject: [PATCH 03/15] wip --- GUI/DataFiles.hs | 5 +++++ GUI/EventsView.hs | 3 +-- GUI/Timeline.hs | 4 ++-- GUI/Timeline/Render.hs | 5 ++++- threadscope.cabal | 2 ++ 5 files changed, 14 insertions(+), 5 deletions(-) diff --git a/GUI/DataFiles.hs b/GUI/DataFiles.hs index dd82a49a..9d67890b 100644 --- a/GUI/DataFiles.hs +++ b/GUI/DataFiles.hs @@ -21,10 +21,15 @@ uiFile = "threadscope.ui" logoFile :: FilePath logoFile = "threadscope.png" + + -- | Textual representation of the UI file ui :: Q Exp ui = [| TE.decodeUtf8 $(makeRelativeToProject uiFile >>= embedFile) |] + + + renderLogo :: B.ByteString -> IO (Maybe Pixbuf) renderLogo bytes = withSystemTempFile logoFile $ \path h -> do diff --git a/GUI/EventsView.hs b/GUI/EventsView.hs index f2a98da2..825bdae5 100644 --- a/GUI/EventsView.hs +++ b/GUI/EventsView.hs @@ -287,8 +287,7 @@ drawEvents EventsView{drawArea, adj} layout <- layoutEmpty pangoCtx layoutSetEllipsize layout EllipsizeEnd - Rectangle _ _ width clipHeight <- widgetGetAllocation drawArea - let clipRect = Rectangle 0 0 width clipHeight + clipRect@(Rectangle _ _ width _) <- widgetGetAllocation drawArea let -- With average char width, timeWidth is enough for 24 hours of logs -- (way more than TS can handle, currently). Aligns nicely with diff --git a/GUI/Timeline.hs b/GUI/Timeline.hs index 7a67ab3f..6c9cb9ad 100644 --- a/GUI/Timeline.hs +++ b/GUI/Timeline.hs @@ -293,14 +293,14 @@ timelineViewNew builder actions = do -- 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). - exposeRect <- widgetGetAllocation timelineDrawingArea + exposeRect@(Rectangle _ _ w h)<- widgetGetAllocation timelineDrawingArea Rectangle _ _ _ h <- widgetGetAllocation timelineDrawingArea traceShowM exposeRect let params' = params { height = max (height params) h } selection <- readIORef selectionRef bookmarks <- readIORef bookmarkIORef - renderView timelineState params' hecs selection bookmarks exposeRect + renderView timelineState params' hecs selection bookmarks (Rectangle 0 0 w h) return () diff --git a/GUI/Timeline/Render.hs b/GUI/Timeline/Render.hs index ec8a8604..e17faa2d 100644 --- a/GUI/Timeline/Render.hs +++ b/GUI/Timeline/Render.hs @@ -20,6 +20,7 @@ import Events.HECs import GUI.Types import GUI.ViewerColours import GUI.Timeline.CairoDrawing +import Debug.Trace import Graphics.UI.Gtk hiding (rectangle) import Graphics.Rendering.Cairo @@ -321,10 +322,11 @@ scrollView surface old new hecs = do -- and not only the newly exposed area. This is comparatively very cheap. updateXScaleArea :: TimelineState -> Timestamp -> IO () updateXScaleArea TimelineState{..} lastTx = do + traceM "updateXScaleArea" -- TODO: get rid of this Just Just win <- widgetGetWindow timelineXScaleArea Rectangle _ _ width _ <- widgetGetAllocation timelineDrawingArea - Rectangle _ _ xScaleAreaHeight _ <- widgetGetAllocation timelineXScaleArea + Rectangle _ _ _ xScaleAreaHeight <- widgetGetAllocation timelineXScaleArea scaleValue <- readIORef scaleIORef -- Snap the view to whole pixels, to avoid blurring. hadjValue0 <- adjustmentGetValue timelineAdj @@ -342,6 +344,7 @@ renderYScaleArea :: ViewParameters -> HECs -> DrawingArea -> Render () renderYScaleArea ViewParameters{maxSpkValue, labelsMode, viewTraces, histogramHeight, minterval} hecs yScaleArea = do + traceM "updateXScaleArea" let maxP = maxSparkPool hecs maxH = fromIntegral $ maxYHistogram hecs Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea diff --git a/threadscope.cabal b/threadscope.cabal index 6e9cdcef..dfefc95d 100644 --- a/threadscope.cabal +++ b/threadscope.cabal @@ -34,6 +34,7 @@ Bug-reports: https://github.com/haskell/ThreadScope/issues 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 @@ -74,6 +75,7 @@ Executable threadscope include-dirs: include default-extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards + other-extensions: TemplateHaskell Other-Modules: Events.HECs, Events.EventDuration, Events.EventTree, From 5726f52613355ce9d979395d4ab38e34c796ae55 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Tue, 25 Mar 2025 17:38:28 +0000 Subject: [PATCH 04/15] wip --- GUI/EventsView.hs | 16 +++++++++++++--- GUI/Timeline.hs | 4 +--- 2 files changed, 14 insertions(+), 6 deletions(-) diff --git a/GUI/EventsView.hs b/GUI/EventsView.hs index 825bdae5..c55ec619 100644 --- a/GUI/EventsView.hs +++ b/GUI/EventsView.hs @@ -13,6 +13,7 @@ module GUI.EventsView ( ) where import GHC.RTS.Events +import Debug.Trace import Graphics.UI.Gtk import qualified GUI.GtkExtras as GtkExt @@ -278,8 +279,9 @@ drawEvents EventsView{drawArea, adj} -- TODO: don't use Just here Just win <- widgetGetWindow drawArea - style <- get drawArea widgetStyle - focused <- get drawArea widgetIsFocus + style <- widgetGetStyle drawArea + focused <- widgetGetIsFocus drawArea + traceM "got is focus" let state | focused = StateSelected | otherwise = StateActive @@ -287,7 +289,9 @@ drawEvents EventsView{drawArea, adj} layout <- layoutEmpty pangoCtx layoutSetEllipsize layout EllipsizeEnd - clipRect@(Rectangle _ _ width _) <- widgetGetAllocation drawArea + + (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 @@ -299,6 +303,7 @@ drawEvents EventsView{drawArea, adj} columnGap = 20 descrWidth = width - timeWidth - columnGap + traceM "draw each" sequence_ [ do when (inside || selected) $ GtkExt.stylePaintFlatBox @@ -307,11 +312,15 @@ drawEvents EventsView{drawArea, adj} clipRect drawArea "" 0 (round y) width (round lineHeight) + traceM "stylePaint" -- The event time layoutSetText layout (showEventTime event) + traceM "set text" layoutSetAlignment layout AlignRight + traceM "set align" layoutSetWidth layout (Just (fromIntegral timeWidth)) + traceM "set width" GtkExt.stylePaintLayout style win state2 True @@ -319,6 +328,7 @@ drawEvents EventsView{drawArea, adj} drawArea "" 0 (round y) layout + traceM "paint layout" -- The event description text layoutSetText layout (showEventDescr event) diff --git a/GUI/Timeline.hs b/GUI/Timeline.hs index 6c9cb9ad..a041303d 100644 --- a/GUI/Timeline.hs +++ b/GUI/Timeline.hs @@ -293,9 +293,7 @@ timelineViewNew builder actions = do -- 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). - exposeRect@(Rectangle _ _ w h)<- widgetGetAllocation timelineDrawingArea - Rectangle _ _ _ h <- widgetGetAllocation timelineDrawingArea - traceShowM exposeRect + (Rectangle _ _ w h)<- widgetGetAllocation timelineDrawingArea let params' = params { height = max (height params) h } selection <- readIORef selectionRef bookmarks <- readIORef bookmarkIORef From 485f6927eea022b5bf6793e85d7b17b9ce2de988 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Fri, 28 Mar 2025 16:14:59 +0000 Subject: [PATCH 05/15] update ci gtk packge --- .github/workflows/ci.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 5f83404d..2a7fcd6b 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -48,15 +48,15 @@ jobs: zlib-dev zlib-static binutils curl \ gcc g++ gmp-dev libc-dev libffi-dev make \ musl-dev ncurses-dev perl tar xz \ - gtk+2.0-dev + gtk+3.0-dev - name: Install system dependencies (Ubuntu) if: runner.os == 'Linux' && !startsWith(matrix.container, 'alpine') - run: sudo apt-get update && sudo apt-get install libgtk2.0-dev + run: sudo apt-get update && sudo apt-get install libgtk3.0-dev - name: Install system dependencies (macOS) if: runner.os == 'macOS' - run: brew install cairo gtk+ pkg-config + run: brew install cairo gtk+3 pkg-config - name: Set extra cabal build options (macOS) if: runner.os == 'macOS' From 1bbdb706e1297007cf0d151b7cd4aa209bbc514a Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Fri, 28 Mar 2025 16:16:16 +0000 Subject: [PATCH 06/15] update ci gtk packge --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 2a7fcd6b..834687af 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -52,7 +52,7 @@ jobs: - name: Install system dependencies (Ubuntu) if: runner.os == 'Linux' && !startsWith(matrix.container, 'alpine') - run: sudo apt-get update && sudo apt-get install libgtk3.0-dev + run: sudo apt-get update && sudo apt-get install libgtk-3-dev - name: Install system dependencies (macOS) if: runner.os == 'macOS' From 555bfb5d0c09332e34e88ecd7f079ae345dd8d94 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Sun, 13 Apr 2025 18:37:55 +0100 Subject: [PATCH 07/15] wip --- .github/workflows/ci.yml | 4 +-- GUI/EventsView.hs | 40 +++++++++------------------ GUI/GtkExtras.hs | 58 ---------------------------------------- GUI/Histogram.hs | 17 +++++++----- 4 files changed, 25 insertions(+), 94 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 834687af..4ded2635 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -24,8 +24,8 @@ jobs: include: # The windows build is currently broken # See #135 - #- os: windows-latest - # ghc-version: '9.10' + - os: windows-latest + ghc-version: '9.10' - os: macos-latest ghc-version: '9.10' # gtk2hs is broken under apline diff --git a/GUI/EventsView.hs b/GUI/EventsView.hs index c55ec619..39740af3 100644 --- a/GUI/EventsView.hs +++ b/GUI/EventsView.hs @@ -15,7 +15,8 @@ module GUI.EventsView ( 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 @@ -303,44 +304,29 @@ drawEvents EventsView{drawArea, adj} columnGap = 20 descrWidth = width - timeWidth - columnGap - traceM "draw each" sequence_ [ do when (inside || selected) $ - GtkExt.stylePaintFlatBox - style win - state1 ShadowNone - clipRect - drawArea "" - 0 (round y) width (round lineHeight) - traceM "stylePaint" + 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) - traceM "set text" layoutSetAlignment layout AlignRight - traceM "set align" layoutSetWidth layout (Just (fromIntegral timeWidth)) - traceM "set width" - GtkExt.stylePaintLayout - style win - state2 True - clipRect - drawArea "" - 0 (round y) - layout - traceM "paint 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 index 880df46e..a18169f1 100644 --- a/GUI/GtkExtras.hs +++ b/GUI/GtkExtras.hs @@ -30,58 +30,6 @@ waitGUI = do ------------------------------------------------------------------------------- -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 @@ -115,12 +63,6 @@ launchProgramForURI uri = ------------------------------------------------------------------------------- -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 index 5d4bbe97..31d0a142 100644 --- a/GUI/Histogram.hs +++ b/GUI/Histogram.hs @@ -91,13 +91,16 @@ histogramViewNew builder = do Nothing -> return () Just hecs | null (durHistogram hecs) -> do - GtkExt.stylePaintLayout - style win - StateNormal True - (Rectangle 0 0 w windowHeight) - histogramDrawingArea "" - 4 20 - layout + renderWithDrawWindow win $ do + C.moveTo 4 20 + showLayout layout + -- GtkExt.stylePaintLayout + -- style win + -- StateNormal True + -- (Rectangle 0 0 w windowHeight) + -- histogramDrawingArea "" + -- 4 20 + -- layout return () | otherwise -> do minterval <- readIORef mintervalIORef From 412c02923252dcaa0b22dee48d666f061f5fd2e6 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Mon, 14 Apr 2025 09:47:37 +0100 Subject: [PATCH 08/15] windows ci --- .github/workflows/ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 4ded2635..eaa80440 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -113,7 +113,8 @@ jobs: path-type: inherit install: >- mingw-w64-x86_64-pkg-config - mingw-w64-x86_64-gtk2 + mingw-w64-x86_64-gtk3 + mingw-w64-x86_64-pango - name: Build run: cabal build all From 6f18db76b4650a79829480813a9436d84c21e798 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Mon, 14 Apr 2025 11:41:01 +0100 Subject: [PATCH 09/15] windows ci --- .github/workflows/ci.yml | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index eaa80440..6a3d2003 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -54,6 +54,15 @@ jobs: if: runner.os == 'Linux' && !startsWith(matrix.container, 'alpine') run: sudo apt-get update && sudo apt-get install libgtk-3-dev + - name: Install system dependencies (Windows) + if: ${{ startsWith(matrix.os, 'windows') }} + uses: msys2/setup-msys2@v2 + with: + path-type: inherit + install: >- + mingw-w64-x86_64-pkg-config + mingw-w64-x86_64-gtk3 + - name: Install system dependencies (macOS) if: runner.os == 'macOS' run: brew install cairo gtk+3 pkg-config @@ -106,16 +115,6 @@ jobs: path: ${{ steps.setup.outputs.cabal-store }} key: ${{ steps.cache.outputs.cache-primary-key }} - - name: Install system dependencies (Windows) - if: ${{ startsWith(matrix.os, 'windows') }} - uses: msys2/setup-msys2@v2 - with: - path-type: inherit - install: >- - mingw-w64-x86_64-pkg-config - mingw-w64-x86_64-gtk3 - mingw-w64-x86_64-pango - - name: Build run: cabal build all From fd95087347b74e37f2af031325af9952585a2c41 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Mon, 14 Apr 2025 12:00:49 +0100 Subject: [PATCH 10/15] windows ci --- .github/workflows/ci.yml | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 6a3d2003..01289c67 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -54,15 +54,6 @@ jobs: if: runner.os == 'Linux' && !startsWith(matrix.container, 'alpine') run: sudo apt-get update && sudo apt-get install libgtk-3-dev - - name: Install system dependencies (Windows) - if: ${{ startsWith(matrix.os, 'windows') }} - uses: msys2/setup-msys2@v2 - with: - path-type: inherit - install: >- - mingw-w64-x86_64-pkg-config - mingw-w64-x86_64-gtk3 - - name: Install system dependencies (macOS) if: runner.os == 'macOS' run: brew install cairo gtk+3 pkg-config @@ -72,13 +63,26 @@ jobs: run: | printf 'package gtk\n flags: +have-quartz-gtk' >>cabal.project - - name: Set up GHC ${{ matrix.ghc-version }} uses: haskell-actions/setup@v2 id: setup with: ghc-version: ${{ matrix.ghc-version }} + # Taken from https://github.com/agda/agda/blob/8210048a50c35d8d6fd0ae7e5edd1699592fda6f/src/github/workflows/cabal.yml#L113C1-L124C85 + # See: https://github.com/haskell/text-icu/pull/86 + # pacman needs MSYS /usr/bin in PATH, but this breaks the latest cache action. + # - https://github.com/actions/cache/issues/1073 + # MSYS' pkg-config needs MSYS /mingw64/bin which we can safely add to the PATH + # + - name: Install system dependencies (Windows) + if: ${{ startsWith(matrix.os, 'windows') }} + shell: pwsh + run: | + $env:PATH = "C:\msys64\usr\bin;$env:PATH" + pacman --noconfirm -S msys2-keyring mingw-w64-x86_64-pkgconf mingw-w64-x86_64-gtk3 + echo "C:\msys64\mingw64\bin" | Out-File -FilePath "$env:GITHUB_PATH" -Append + - name: Enable static build (only on alpine) if: ${{ startsWith(matrix.container, 'alpine') }} run: | From c738bed24d5d965f4d440debca37d5b812e72a19 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Thu, 29 May 2025 10:56:56 +0100 Subject: [PATCH 11/15] delete traces --- GUI/EventsView.hs | 1 - GUI/Timeline.hs | 1 - GUI/Timeline/Render.hs | 3 --- 3 files changed, 5 deletions(-) diff --git a/GUI/EventsView.hs b/GUI/EventsView.hs index 39740af3..c01236c5 100644 --- a/GUI/EventsView.hs +++ b/GUI/EventsView.hs @@ -282,7 +282,6 @@ drawEvents EventsView{drawArea, adj} Just win <- widgetGetWindow drawArea style <- widgetGetStyle drawArea focused <- widgetGetIsFocus drawArea - traceM "got is focus" let state | focused = StateSelected | otherwise = StateActive diff --git a/GUI/Timeline.hs b/GUI/Timeline.hs index a041303d..fb414a56 100644 --- a/GUI/Timeline.hs +++ b/GUI/Timeline.hs @@ -281,7 +281,6 @@ timelineViewNew builder actions = do on timelineDrawingArea draw $ do liftIO $ do - traceM "timelineDrawingArea" maybeEventArray <- readIORef hecsIORef -- Check to see if an event trace has been loaded diff --git a/GUI/Timeline/Render.hs b/GUI/Timeline/Render.hs index e17faa2d..3ee568fc 100644 --- a/GUI/Timeline/Render.hs +++ b/GUI/Timeline/Render.hs @@ -115,7 +115,6 @@ renderView TimelineState{timelineDrawingArea, timelineVAdj, timelinePrevView} liftIO $ writeIORef timelinePrevView (Just (params, surface)) - -- TODO: figure out what this did??? C.rectangle rect clip setSourceSurface surface 0 (-vadj_value) @@ -322,7 +321,6 @@ scrollView surface old new hecs = do -- and not only the newly exposed area. This is comparatively very cheap. updateXScaleArea :: TimelineState -> Timestamp -> IO () updateXScaleArea TimelineState{..} lastTx = do - traceM "updateXScaleArea" -- TODO: get rid of this Just Just win <- widgetGetWindow timelineXScaleArea Rectangle _ _ width _ <- widgetGetAllocation timelineDrawingArea @@ -344,7 +342,6 @@ renderYScaleArea :: ViewParameters -> HECs -> DrawingArea -> Render () renderYScaleArea ViewParameters{maxSpkValue, labelsMode, viewTraces, histogramHeight, minterval} hecs yScaleArea = do - traceM "updateXScaleArea" let maxP = maxSparkPool hecs maxH = fromIntegral $ maxYHistogram hecs Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea From bad6694d0fca9f7bf551fbb56d8363719506f565 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Thu, 29 May 2025 10:59:31 +0100 Subject: [PATCH 12/15] undo empty lines --- GUI/DataFiles.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/GUI/DataFiles.hs b/GUI/DataFiles.hs index 9d67890b..dd82a49a 100644 --- a/GUI/DataFiles.hs +++ b/GUI/DataFiles.hs @@ -21,15 +21,10 @@ uiFile = "threadscope.ui" logoFile :: FilePath logoFile = "threadscope.png" - - -- | Textual representation of the UI file ui :: Q Exp ui = [| TE.decodeUtf8 $(makeRelativeToProject uiFile >>= embedFile) |] - - - renderLogo :: B.ByteString -> IO (Maybe Pixbuf) renderLogo bytes = withSystemTempFile logoFile $ \path h -> do From 38a395a69d20842451e756c858c24d66a18439a5 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Thu, 29 May 2025 11:04:28 +0100 Subject: [PATCH 13/15] Delete some unecessary comments and traces --- GUI/Histogram.hs | 7 ------- GUI/KeyView.hs | 1 - GUI/Timeline.hs | 1 - GUI/Timeline/Render.hs | 1 - 4 files changed, 10 deletions(-) diff --git a/GUI/Histogram.hs b/GUI/Histogram.hs index 31d0a142..73d983ef 100644 --- a/GUI/Histogram.hs +++ b/GUI/Histogram.hs @@ -94,13 +94,6 @@ histogramViewNew builder = do renderWithDrawWindow win $ do C.moveTo 4 20 showLayout layout - -- GtkExt.stylePaintLayout - -- style win - -- StateNormal True - -- (Rectangle 0 0 w windowHeight) - -- histogramDrawingArea "" - -- 4 20 - -- layout return () | otherwise -> do minterval <- readIORef mintervalIORef diff --git a/GUI/KeyView.hs b/GUI/KeyView.hs index 932bcc1a..1c365630 100644 --- a/GUI/KeyView.hs +++ b/GUI/KeyView.hs @@ -169,7 +169,6 @@ renderKEvent keyColour = do renderToPixbuf :: DrawWindowClass dw => dw -> (Int, Int) -> C.Render () -> IO Pixbuf renderToPixbuf similar (w, h) draw = do - -- TODO: is this right??? I think so. It seems to work at least :shrug: renderWithDrawWindow similar draw pixbuf <- pixbufNewFromWindow similar 0 0 w h return pixbuf diff --git a/GUI/Timeline.hs b/GUI/Timeline.hs index fb414a56..90a8c5ec 100644 --- a/GUI/Timeline.hs +++ b/GUI/Timeline.hs @@ -24,7 +24,6 @@ module GUI.Timeline ( timelineCentreOnCursor, ) where -import Debug.Trace import GUI.Types import GUI.Timeline.Types diff --git a/GUI/Timeline/Render.hs b/GUI/Timeline/Render.hs index 3ee568fc..6edde7aa 100644 --- a/GUI/Timeline/Render.hs +++ b/GUI/Timeline/Render.hs @@ -20,7 +20,6 @@ import Events.HECs import GUI.Types import GUI.ViewerColours import GUI.Timeline.CairoDrawing -import Debug.Trace import Graphics.UI.Gtk hiding (rectangle) import Graphics.Rendering.Cairo From a4f60e41e0b04db546b114fe6da83f647d80901f Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Thu, 29 May 2025 11:10:26 +0100 Subject: [PATCH 14/15] Delete trace --- GUI/Timeline.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/GUI/Timeline.hs b/GUI/Timeline.hs index 90a8c5ec..d449977f 100644 --- a/GUI/Timeline.hs +++ b/GUI/Timeline.hs @@ -286,7 +286,6 @@ timelineViewNew builder actions = do case maybeEventArray of Nothing -> return () Just hecs -> do - traceShowM "just hecs" params <- timelineGetViewParameters timelineWin -- 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 From 292a329a07a09da180c369a6092d3e08aab86df4 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Thu, 29 May 2025 11:14:14 +0100 Subject: [PATCH 15/15] Add uppper bound for transformers --- threadscope.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/threadscope.cabal b/threadscope.cabal index dfefc95d..80da4dec 100644 --- a/threadscope.cabal +++ b/threadscope.cabal @@ -71,7 +71,7 @@ Executable threadscope file-embed < 0.1, template-haskell < 2.24, temporary >= 1.1 && < 1.4, - transformers + transformers <0.6.3 include-dirs: include default-extensions: RecordWildCards, NamedFieldPuns, BangPatterns, PatternGuards