Switch to GTK3

.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