Switch to GTK3 (#137)

We upgrade from the deprecated GTK2 to the still supported GTK3.

Most of the changes we had to make were described in the migration guide:
https://docs.gtk.org/gtk3/migrating-2to3.html#changes-that-need-to-be-done-at-the-time-of-the-switch

Many of the functions we depended on for low-level rendering were removed, so I've substituted mostly equivalent ones.

The way events are subscribed to has slightly changed and that has lead to a bunch of changes.

With the new version of GTK3, windows CI works again. Resolves #135, #97

We've also updated the Cabal file to be made aware of stuff included through TH.

Author: TeofilC

.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
@@ -48,28 +48,41 @@ 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 libgtk-3-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'
         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: |
@@ -106,15 +119,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-gtk2
-
       - name: Build
         run: cabal build all
 

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
 

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

GUI/EventsView.hs

@@ -13,8 +13,10 @@ module GUI.EventsView (
   ) 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
@@ -100,9 +102,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 +124,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 +241,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,18 +278,20 @@ drawEvents EventsView{drawArea, adj}
       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
 
   pangoCtx <- widgetGetPangoContext drawArea
   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
@@ -301,36 +305,27 @@ drawEvents EventsView{drawArea, adj}
 
   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

@@ -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