mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-27 09:24:08 +00:00
GTK 4.14 compatibility
This commit is contained in:
parent
300fbf92c0
commit
56939ce01a
|
@ -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
|
||||
|
|
|
@ -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 --
|
||||
--------------
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,10 +400,10 @@ 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
|
||||
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
|
||||
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -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 =
|
||||
#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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue