gi-gtk-declarative 0.6.3 → 0.7.0

raw patch · 4 files changed

+88/−20 lines, 4 filesdep ~gi-gtkdep ~haskell-gidep ~haskell-gi-basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: gi-gtk, haskell-gi, haskell-gi-base, haskell-gi-overloading

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• gi-gtk-declarative.cabal +12/−11
• src/GI/Gtk/Declarative/Container/Grid.hs +3/−1
• test/GI/Gtk/Declarative/TestWidget.hs +66/−8

@@ -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

@@ -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

@@ -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

@@ -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