diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +* 0.7.0 + - Version bounds compatibility with Stack resolver lts-17.0 + - Replace Travis badge with a Github workflow one. + - Replace .travis.yml with a Github Actions Workflow. + - Improved exception handling and async handling in app-simple + - Fix race condition in app-simple + - Fix patching of grid child properties. * 0.6.3 - Add `Grid` container widget - Fix bugs in patching properties for all types of widgets diff --git a/gi-gtk-declarative.cabal b/gi-gtk-declarative.cabal --- a/gi-gtk-declarative.cabal +++ b/gi-gtk-declarative.cabal @@ -1,5 +1,5 @@ name: gi-gtk-declarative -version: 0.6.3 +version: 0.7.0 synopsis: Declarative GTK+ programming in Haskell description: A declarative programming model for GTK+ user interfaces, implementing support for various widgets @@ -53,18 +53,19 @@ , GI.Gtk.Declarative.Widget , GI.Gtk.Declarative.Widget.Conversions build-depends: base >=4.10 && <5 - , containers >= 0.6 && < 0.7 - , data-default-class >= 0.1 && <0.2 - , gi-gobject >= 2 && <3 - , gi-glib >= 2 && <3 - , gi-gtk >= 3 && <4 - , haskell-gi >= 0.21 && <0.24 - , haskell-gi-base >= 0.21 && <0.24 - , haskell-gi-overloading == 1.0 + , containers >=0.6 && <0.7 + , data-default-class >=0.1 && <0.2 + , gi-gobject >=2 && <3 + , gi-glib >=2 && <3 + , gi-gtk >=3 && <4 + , haskell-gi >=0.24 && <0.25 + , haskell-gi-base >=0.24 && <0.25 + , haskell-gi-overloading >=1.0 && <1.1 , mtl , text - , unordered-containers >= 0.2 && < 0.3 + , unordered-containers >=0.2 && <0.3 , vector + hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -79,7 +80,7 @@ , gi-glib , gi-gdk , gi-gobject - , gi-gtk + , gi-gtk <4 , gi-gtk-declarative , haskell-gi-base , hedgehog >= 1 && < 2 diff --git a/src/GI/Gtk/Declarative/Container/Grid.hs b/src/GI/Gtk/Declarative/Container/Grid.hs --- a/src/GI/Gtk/Declarative/Container/Grid.hs +++ b/src/GI/Gtk/Declarative/Container/Grid.hs @@ -39,6 +39,7 @@ , leftAttach :: Int32 , topAttach :: Int32 } + deriving (Eq, Show) -- | Defaults for 'GridChildProperties'. Use these and override -- specific fields. @@ -51,7 +52,8 @@ instance Patchable GridChild where create = create . child - patch s b1 b2 = patch s (child b1) (child b2) + patch s b1 b2 | properties b1 == properties b2 = patch s (child b1) (child b2) + | otherwise = Replace (create b2) instance EventSource GridChild where subscribe GridChild {..} = subscribe child diff --git a/test/GI/Gtk/Declarative/TestWidget.hs b/test/GI/Gtk/Declarative/TestWidget.hs --- a/test/GI/Gtk/Declarative/TestWidget.hs +++ b/test/GI/Gtk/Declarative/TestWidget.hs @@ -10,17 +10,21 @@ import Control.Applicative import Control.Monad.Except -import Data.Text ( Text ) -import Data.Traversable ( for ) -import Data.Vector ( Vector ) -import qualified Data.Vector as Vector +import Data.Int ( Int32 ) +import Data.Text ( Text ) +import Data.Traversable ( for ) +import Data.List ( sortOn ) +import Data.Vector ( Vector ) +import qualified Data.Vector as Vector import Data.Void -import qualified GI.Gtk as Gtk +import qualified GI.Gtk as Gtk import GI.Gtk.Declarative +import GI.Gtk.Declarative.Container.Grid ( GridChild (..), GridChildProperties (..) ) +import GI.Gtk.Declarative.Container.Grid as Grid import GI.Gtk.Declarative.EventSource -import Hedgehog hiding ( label ) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range +import Hedgehog hiding ( label ) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range import Prelude -- | GTK widgets cannot (in any practical, generic sense) be compared and shown @@ -32,17 +36,22 @@ | TestCustomWidget (Maybe Text) | TestScrolledWindow (Maybe Gtk.PolicyType) TestWidget | TestBox (Maybe Gtk.Orientation) [TestBoxChild] + | TestGrid [TestGridChild] deriving (Eq, Show) data TestBoxChild = TestBoxChild BoxChildProperties TestWidget deriving (Eq, Show) +data TestGridChild = TestGridChild GridChildProperties TestWidget + deriving (Eq, Show) + isNested :: TestWidget -> Bool isNested = \case TestButton{} -> False TestCustomWidget{} -> False TestScrolledWindow _ _ -> True TestBox _ children -> not (null children) + TestGrid children -> not (null children) class HasGtkDefaults a where setDefaults :: a -> a @@ -58,11 +67,17 @@ TestBox orientation children -> TestBox (orientation <|> Just Gtk.OrientationHorizontal) (map setDefaults children) + TestGrid children -> + TestGrid (map setDefaults children) instance HasGtkDefaults TestBoxChild where setDefaults = \case TestBoxChild props child -> TestBoxChild props (setDefaults child) +instance HasGtkDefaults TestGridChild where + setDefaults = \case + TestGridChild props child -> TestGridChild props (setDefaults child) + onlyJusts :: Vector (Maybe a) -> Vector a onlyJusts = Vector.concatMap (maybe Vector.empty Vector.singleton) @@ -98,6 +113,13 @@ (\(TestBoxChild props child) -> BoxChild props (toTestWidget child)) (Vector.fromList children) ) + TestGrid children -> container + Gtk.Grid + [] + (Vector.map + (\(TestGridChild props child) -> GridChild props (toTestWidget child)) + (Vector.fromList children) + ) fromGtkWidget :: (MonadIO m) => Gtk.Widget -> m (Either Text TestWidget) fromGtkWidget = runExceptT . go @@ -138,6 +160,21 @@ pure (TestBox orientation (zipWith TestBoxChild boxChildProps childWidgets) ) + "GtkGrid" -> withCast w Gtk.Grid $ \grid -> do + childGtkWidgets <- #getChildren grid + gridChildren <- for childGtkWidgets $ \childGtkWidget -> do + let prop = getGridChildProp grid childGtkWidget + height <- prop "height" + width <- prop "width" + leftAttach <- prop "left-attach" + topAttach <- prop "top-attach" + child <- go childGtkWidget + pure (TestGridChild GridChildProperties {..} child) + -- the order of the children is not maintained by the Grid, so we + -- need to sort here to allow accurate comparisons of the children + let sortedChildren = + sortOn (\(TestGridChild p _) -> topAttach p) gridChildren + pure (TestGrid sortedChildren) _ -> throwError ("Unsupported TestWidget: " <> name) withCast :: (MonadIO m, Gtk.GObject w, Gtk.GObject w') @@ -149,6 +186,13 @@ Just w' -> f w' Nothing -> throwError "Failed to cast widget" +getGridChildProp + :: (MonadIO m) => Gtk.Grid -> Gtk.Widget -> Text -> ExceptT Text m Int32 +getGridChildProp grid child prop = do + gValue <- liftIO (Gtk.toGValue (0 :: Int32)) + Gtk.containerChildGetProperty grid child prop gValue + liftIO (Gtk.fromGValue gValue) + -- * Generators genTestWidget :: Gen TestWidget @@ -159,6 +203,7 @@ Gen.choice leaves ( subwidgets genTestBoxFrom + <> subwidgets getTestGridFrom <> [ Gen.subtermM genTestWidget (\c -> TestScrolledWindow <$> Gen.maybe genPolicyType <*> pure c) @@ -185,6 +230,11 @@ pure (TestBoxChild props w) o <- Gen.maybe genOrientation pure (TestBox o children) + getTestGridFrom ws = do + children <- for (zip [0 ..] ws) $ \(i, w) -> do + props <- genGridChildProperties i + pure (TestGridChild props w) + pure (TestGrid children) genOrientation :: Gen Gtk.Orientation genOrientation = @@ -205,6 +255,14 @@ genBoxChildProperties = BoxChildProperties <$> Gen.bool <*> Gen.bool <*> Gen.word32 (Range.linear 0 10) + +genGridChildProperties :: Int32 -> Gen GridChildProperties +genGridChildProperties rowN = do + width <- Gen.int32 (Range.linear 1 10) + height <- Gen.int32 (Range.linear 1 5) + leftAttach <- Gen.int32 (Range.linear 0 10) + topAttach <- Gen.int32 (Range.constant (rowN * 5) (rowN * 5 + 5 - height)) + pure GridChildProperties {..} genCustomWidget :: Gen TestWidget genCustomWidget = do