GTK 4.14 compatibility

2024-11-23 15:34:06 +00:00 · 2024-05-28 10:24:47 +02:00 · 2024-05-28 10:24:47 +02:00 · 56939ce01a
parent 300fbf92c0
commit 56939ce01a
8 changed files with 103 additions and 37 deletions
--- a/MetaBrush.cabal
+++ b/MetaBrush.cabal
@ -29,6 +29,13 @@ flag asserts
  default: False
  manual:  True

+-- Workaround for https://github.com/haskell/cabal/issues/4237
+-- See https://github.com/commercialhaskell/stack/issues/2197
+flag gtk-410
+  description: GTK is 4.10 or later
+  default: True
+  manual:  False
+
 common common

    build-depends:
@ -120,7 +127,7 @@ common extras
      , hashable
           >= 1.3.0.0    && < 1.5
      , lens
-           >= 4.19.2     && < 5.3
+           >= 4.19.2     && < 6.0
      , mtl
           >= 2.2.2      && < 2.4
      , scientific
@ -156,6 +163,12 @@ common gtk
      , haskell-gi-base
           >= 0.26       && < 0.27

+    -- Workaround for https://github.com/haskell/cabal/issues/4237
+    -- See https://github.com/commercialhaskell/stack/issues/2197
+    if flag(gtk-410)
+      pkgconfig-depends: gtk4 >= 4.10
+      cpp-options: -DMIN_VERSION_GTK_4_10
+
 library metabrushes

    import:
@ -186,7 +199,7 @@ library metabrushes
        atomic-file-ops
          ^>= 0.3.0.0
      , bytestring
-           >= 0.10.10.0  && < 0.12
+           >= 0.10.10.0  && < 0.13

 executable MetaBrush

@ -237,4 +250,4 @@ executable MetaBrush
    build-depends:
        metabrushes
      , tardis
-           >= 0.4.2.0    && < 0.5
+           >= 0.4.2.0    && < 0.6
--- a/cabal.project
+++ b/cabal.project
@ -9,10 +9,11 @@ constraints:
 -- text +simdutf causes the "digit" package to fail to build with undefined symbol linker errors

 -- Fix a severe bug in Waargonaut (no corresponding Hackage release???)
+-- + GHC 9.10 compatibility
 source-repository-package
  type: git
-  location: https://github.com/haskell-waargonaut/waargonaut
-  tag: 5f838582a8c5aae1a198ecd4958729e53a6b03cf
+  location: https://github.com/sheaf/waargonaut
+  tag: ec171cd5d185309692b745e2e2f291eab4038fb9

 allow-newer:
  *:base, *:template-haskell, *:ghc-prim,
@ -21,18 +22,31 @@ allow-newer:
  eigen:primitive,
  eigen:transformers,
  gi-cairo-connector:mtl,
+  hedgehog:containers,
  hedgehog:resourcet,
  JuicyPixels:zlib,
  natural:lens,
+  natural:semigroupoids,
  records-sop:deepseq,
  waargonaut:bifunctors,
+  waargonaut:bytestring,
+  waargonaut:containers,
+  waargonaut:hoist-error,
  waargonaut:lens,
+  waargonaut:mtl,
  waargonaut:records-sop,
  waargonaut:semigroups,
+  waargonaut:semigroupoids,
  waargonaut:text,
  waargonaut:vector,
  waargonaut:witherable,

+-- Fix "ERROR: couldn't find API description for GLib.time_t"
+source-repository-package
+  type: git
+  location: https://github.com/sheaf/haskell-gi
+  tag: ec11dd69ab6a3a9f7f7e967f5f7ffa7d9206cd2a
+
 --------------
 -- GHC 9.10 --
 --------------
--- a/src/app/MetaBrush/Action.hs
+++ b/src/app/MetaBrush/Action.hs
@ -143,6 +143,8 @@ import MetaBrush.Document.Update
  , modifyingCurrentDocument
  , updateUIAction, updateHistoryState
  )
+import MetaBrush.GTK.Util
+  ( widgetShow )
 import MetaBrush.UI.Coordinates
  ( toViewportCoordinates )
 import MetaBrush.UI.InfoBar
@ -201,6 +203,7 @@ data OpenFile = OpenFile !TabLocation

 instance HandleAction OpenFile where
  handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) ( OpenFile tabLoc ) = do
+    -- GTK 4 TODO: use FileDialog
    fileChooser <-
      GTK.fileChooserNativeNew ( Just "Open MetaBrush document..." ) ( Just window )
        GTK.FileChooserActionOpen
@ -237,6 +240,7 @@ warningDialog
  :: ( Show errMess, GTK.IsWindow window )
  => window -> FilePath -> errMess -> IO ()
 warningDialog window filePath errMess = do
+  -- GTK 4 TODO: use Window
  dialog <- GTK.new GTK.MessageDialog []
  GTK.setMessageDialogText dialog
    ( "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack ( show errMess ) )
@ -248,7 +252,7 @@ warningDialog window filePath errMess = do
  widgetAddClasses dialog [ "metabrush", "bg", "plain", "text", "dialog" ]
  closeButton <- GTK.dialogAddButton dialog "OK" 1
  widgetAddClass closeButton "dialogButton"
-  GTK.widgetShow dialog
+  widgetShow dialog
  void $ GTK.afterDialogResponse dialog \ _ -> do
    GTK.windowDestroy dialog

@ -261,6 +265,7 @@ data OpenFolder = OpenFolder !TabLocation

 instance HandleAction OpenFolder where
  handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) ( OpenFolder tabLoc ) = do
+    -- GTK 4 TODO: use FileDialog
    fileChooser <-
      GTK.fileChooserNativeNew ( Just "Select folder..." ) ( Just window )
        GTK.FileChooserActionSelectFolder
@ -359,6 +364,7 @@ export uiElts vars@( Variables { .. } ) = do

 withSavePath :: UIElements -> SaveFormat -> ( FilePath -> IO () ) -> IO ()
 withSavePath ( UIElements {..} ) saveFormat action = do
+  -- GTK 4 TODO: use FileDialog
  fileChooser <-
    GTK.fileChooserNativeNew ( Just saveText ) ( Just window )
      GTK.FileChooserActionSave
@ -427,6 +433,7 @@ instance HandleAction Close where
        Just ( Document { displayName, documentUnique, documentContent }, isActiveDoc )
          | unsavedChanges documentContent
          -> do
+            -- GTK 4 TODO: use Window
            dialog <- GTK.new GTK.MessageDialog []
            GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" )
            GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion
@ -441,7 +448,7 @@ instance HandleAction Close where
            GTK.dialogSetDefaultResponse dialog JustClose
            for_ [ closeButton, saveButton, cancelButton ]
              ( `widgetAddClass` "dialogButton" )
-            GTK.widgetShow dialog
+            widgetShow dialog
            void $ GTK.onDialogResponse dialog \ choice -> do
              case choice of
                JustClose    -> closeDocument isActiveDoc documentUnique
@ -755,7 +762,7 @@ instance HandleAction OpenPrefs where
    GTK.windowSetChild prefsWin ( Just prefsNotebook )
 -}

-    GTK.widgetShow prefsWin
+    widgetShow prefsWin

 --------------------------------------------------------------------------------
 -- Input actions
@ -773,8 +780,8 @@ instance HandleAction MouseMove where
    vars@( Variables {..} )
    ( MouseMove ( ℝ2 x y ) )
    = do
-      viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
-      viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+      viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
+      viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
      modifyingCurrentDocument uiElts vars \ doc@( Document {..} ) -> do
        modifiers   <- STM.readTVar modifiersTVar
        let
@ -848,8 +855,8 @@ instance HandleAction MouseClick where

      -- Left mouse button.
      1 -> do
-        viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
-        viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+        viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
+        viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
        modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
          let
            toViewport :: ℝ 2 -> ℝ 2
@ -1000,8 +1007,8 @@ instance HandleAction MouseRelease where

      -- Left mouse button.
      1 -> do
-        viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
-        viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+        viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
+        viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
        modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
          let
            toViewport :: ℝ 2 -> ℝ 2
@ -1210,8 +1217,8 @@ instance HandleAction Scroll where
    vars@( Variables {..} )
    ( Scroll mbMousePos ( V2 dx dy ) ) = do

-      --viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
-      --viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+      --viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
+      --viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea

      unless ( dx == 0 && dy == 0 ) do
        modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
--- a/src/app/MetaBrush/Application.hs
+++ b/src/app/MetaBrush/Application.hs
@ -72,7 +72,7 @@ import qualified Control.Concurrent.STM.TVar as STM
 import Control.Monad.Trans.Reader
  ( runReaderT )

-- MetaBrush
+-- brush-strokes
 import Math.Root.Isolation
  ( RootIsolationOptions(..), defaultRootIsolationOptions )
 import Math.Bezier.Cubic.Fit
@ -85,6 +85,8 @@ import Math.Bezier.Stroke
  )
 import Math.Linear
  ( ℝ(..) )
+
+-- MetaBrush
 import MetaBrush.Action
  ( ActionOrigin(..) )
 import qualified MetaBrush.Asset.Brushes as Asset.Brushes
@ -108,6 +110,8 @@ import MetaBrush.Document.Update
  ( activeDocument, withActiveDocument )
 import MetaBrush.Event
  ( handleEvents )
+import MetaBrush.GTK.Util
+  ( widgetShow )
 import MetaBrush.Records
 import MetaBrush.Render.Document
  ( blankRender, getDocumentRender )
@ -378,8 +382,8 @@ runApplication application = do

  -- Render the document using the latest available draw data.
  GTK.drawingAreaSetDrawFunc viewportDrawingArea $ Just \ _ cairoContext _ _ -> void $ do
-    viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
-    viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
+    viewportWidth  <- GTK.widgetGetWidth  viewportDrawingArea
+    viewportHeight <- GTK.widgetGetHeight viewportDrawingArea
    -- Get the Cairo instructions for rendering the current document
    mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
    render <- case mbDoc of
@ -396,11 +400,11 @@ runApplication application = do
    ]
    ( \ ( rulerDrawingArea, ruler ) ->
      GTK.drawingAreaSetDrawFunc rulerDrawingArea $ Just \ _ cairoContext _ _ -> void do
-        viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
-        viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
-        width  <- GTK.widgetGetAllocatedWidth  rulerDrawingArea
-        height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
-        mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do
+        viewportWidth  <- GTK.widgetGetWidth  viewportDrawingArea
+        viewportHeight <- GTK.widgetGetHeight viewportDrawingArea
+        width          <- GTK.widgetGetWidth  rulerDrawingArea
+        height         <- GTK.widgetGetHeight rulerDrawingArea
+        mbRender       <- STM.atomically $ withActiveDocument variables \ doc -> do
          mbMousePos   <- STM.readTVar mousePosTVar
          mbHoldAction <- STM.readTVar mouseHoldTVar
          showGuides   <- STM.readTVar showGuidesTVar
@ -465,7 +469,7 @@ runApplication application = do
  mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
  updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized

-  GTK.widgetShow window
+  widgetShow window

  GTK.widgetSetCanFocus     viewportDrawingArea True
  GTK.widgetSetFocusOnClick viewportDrawingArea True
--- a/src/app/MetaBrush/Asset/Colours.hs
+++ b/src/app/MetaBrush/Asset/Colours.hs
@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}

 {-# OPTIONS_GHC -fno-warn-deprecations #-}
@ -90,10 +91,15 @@ type Colours = ColourRecord GDK.RGBA
 getColours
  :: ( GTK.IsStyleProvider styleProvider )
  => styleProvider -> IO Colours
-getColours provider =
+getColours _provider =
  for colourNames \ ( ColourName { colourName } ) -> do
    widget <- GTK.fixedNew
+#if MIN_VERSION_GTK_4_10
+    GTK.widgetAddCssClass widget colourName
+    GTK.widgetGetColor widget
+#else
    style <- GTK.widgetGetStyleContext widget
-    GTK.styleContextAddProvider style provider ( fromIntegral GTK.STYLE_PROVIDER_PRIORITY_USER )
+    GTK.styleContextAddProvider style _provider ( fromIntegral GTK.STYLE_PROVIDER_PRIORITY_USER )
    GTK.styleContextAddClass style colourName
    GTK.styleContextGetColor style
+#endif
--- a/src/app/MetaBrush/Event.hs
+++ b/src/app/MetaBrush/Event.hs
@ -120,14 +120,14 @@ adjustMousePosition   _                   ViewportOrigin        pt            =
 adjustMousePosition ( Viewport {..} ) ( RulerOrigin ruler ) ( ℝ2 x y ) =
  case ruler of
    RulerCorner -> do
-      dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  rulerCornerDrawingArea
-      dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight rulerCornerDrawingArea
+      dx <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  rulerCornerDrawingArea
+      dy <- fromIntegral @_ @Double <$> GTK.widgetGetHeight rulerCornerDrawingArea
      pure ( ℝ2 ( x - dx ) ( y - dy ) )
    LeftRuler -> do
-      dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth    leftRulerDrawingArea
+      dx <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  leftRulerDrawingArea
      pure ( ℝ2 ( x - dx ) y )
    TopRuler -> do
-      dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight    topRulerDrawingArea
+      dy <- fromIntegral @_ @Double <$> GTK.widgetGetHeight topRulerDrawingArea
      pure ( ℝ2 x ( y - dy ) )

 --------------------------------------------------------------------------------
--- a/src/app/MetaBrush/GTK/Util.hs
+++ b/src/app/MetaBrush/GTK/Util.hs
@ -1,8 +1,10 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ScopedTypeVariables #-}

 module MetaBrush.GTK.Util
  ( withRGBA, showRGBA
  , widgetAddClasses, widgetAddClass
+  , widgetShow
  , (>=?=>), (>>?=)
  )
  where
@ -48,12 +50,32 @@ showRGBA rgba = withRGBA rgba \ r g b a ->
  pure $ "rgba(" ++ show r ++ "," ++ show g ++ "," ++ show b ++ "," ++ show a ++ ")"

 widgetAddClasses :: ( HasCallStack, GTK.IsWidget widget, MonadIO m ) => widget -> [Text] -> m ()
-widgetAddClasses widget classNames = do
-  styleContext <- GTK.widgetGetStyleContext widget
-  for_ classNames ( GTK.styleContextAddClass styleContext )
+widgetAddClasses widget classNames =
+#if MIN_VERSION_GTK_4_10
+  for_ classNames ( GTK.widgetAddCssClass widget )
+#else
+  do
+    styleContext <- GTK.widgetGetStyleContext widget
+    for_ classNames ( GTK.styleContextAddClass styleContext )
+#endif

 widgetAddClass :: ( HasCallStack, GTK.IsWidget widget, MonadIO m ) => widget -> Text -> m ()
-widgetAddClass widget className = GTK.widgetGetStyleContext widget >>= ( `GTK.styleContextAddClass` className )
+widgetAddClass widget className =
+#if MIN_VERSION_GTK_4_10
+  GTK.widgetAddCssClass widget className
+#else
+  GTK.widgetGetStyleContext widget >>= ( `GTK.styleContextAddClass` className )
+#endif
+
+--------------------------------------------------------------------------------
+
+widgetShow :: ( HasCallStack, GTK.IsWidget widget, MonadIO m ) => widget -> m ()
+widgetShow widget =
+#if MIN_VERSION_GTK_4_10
+  GTK.widgetSetVisible widget True
+#else
+  GTK.widgetShow widget
+#endif

 --------------------------------------------------------------------------------

--- a/src/app/MetaBrush/UI/InfoBar.hs
+++ b/src/app/MetaBrush/UI/InfoBar.hs
@ -154,8 +154,8 @@ createInfoBar colours = do
 updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO ()
 updateInfoBar viewportDrawingArea ( InfoBar {..} ) ( Variables { mousePosTVar } ) mbDoc
  = do
-    viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
-    viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+    viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
+    viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
    case mbDoc of
      Nothing -> do
        GTK.labelSetText        zoomText $ na