From 56939ce01a85202e9a5825f0f36cbdb6ca240d61 Mon Sep 17 00:00:00 2001 From: sheaf Date: Tue, 28 May 2024 10:24:47 +0200 Subject: [PATCH] GTK 4.14 compatibility --- MetaBrush.cabal | 19 ++++++++++++++++--- cabal.project | 18 ++++++++++++++++-- src/app/MetaBrush/Action.hs | 29 ++++++++++++++++++----------- src/app/MetaBrush/Application.hs | 22 +++++++++++++--------- src/app/MetaBrush/Asset/Colours.hs | 10 ++++++++-- src/app/MetaBrush/Event.hs | 8 ++++---- src/app/MetaBrush/GTK/Util.hs | 30 ++++++++++++++++++++++++++---- src/app/MetaBrush/UI/InfoBar.hs | 4 ++-- 8 files changed, 103 insertions(+), 37 deletions(-) diff --git a/MetaBrush.cabal b/MetaBrush.cabal index a4fde28..daf9a81 100644 --- 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 diff --git a/cabal.project b/cabal.project index 7b1a31e..5042c09 100644 --- 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 -- -------------- diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 9afb413..dc16f86 100644 --- 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 diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index ad9cb65..bf0dd97 100644 --- 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 diff --git a/src/app/MetaBrush/Asset/Colours.hs b/src/app/MetaBrush/Asset/Colours.hs index 22d6d3a..bf0669f 100644 --- 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 diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index 7c8b2d8..a259f66 100644 --- 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 ) ) -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/GTK/Util.hs b/src/app/MetaBrush/GTK/Util.hs index 41ee886..6a74638 100644 --- 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 -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs index edabd78..2f6646e 100644 --- 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