GTK 4.14 compatibility

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

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
+  location: https://github.com/sheaf/waargonaut
-  tag: 5f838582a8c5aae1a198ecd4958729e53a6b03cf
+  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 --
 --------------

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
+      viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
-      viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight 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
+        viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
-        viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight 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
+        viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
-        viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight 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
+      --viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
-      --viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+      --viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
 
       unless ( dx == 0 && dy == 0 ) do
         modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do

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
+    viewportWidth  <- GTK.widgetGetWidth  viewportDrawingArea
-    viewportHeight <- GTK.widgetGetAllocatedHeight 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
+        viewportWidth  <- GTK.widgetGetWidth  viewportDrawingArea
-        viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
+        viewportHeight <- GTK.widgetGetHeight viewportDrawingArea
-        width  <- GTK.widgetGetAllocatedWidth  rulerDrawingArea
+        width          <- GTK.widgetGetWidth  rulerDrawingArea
-        height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
+        height         <- GTK.widgetGetHeight rulerDrawingArea
-        mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do
+        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

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

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
+      dx <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  rulerCornerDrawingArea
-      dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight 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 ) )
 
 --------------------------------------------------------------------------------

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
+widgetAddClasses widget classNames =
-  styleContext <- GTK.widgetGetStyleContext widget
+#if MIN_VERSION_GTK_4_10
-  for_ classNames ( GTK.styleContextAddClass styleContext )
+  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
 
 --------------------------------------------------------------------------------
 

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
+    viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetWidth  viewportDrawingArea
-    viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+    viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetHeight viewportDrawingArea
     case mbDoc of
       Nothing -> do
         GTK.labelSetText        zoomText $ na