packages feed

gi-gtk-declarative 0.6.2 → 0.6.3

raw patch · 28 files changed

+972/−502 lines, 28 filesdep +containersdep ~haskell-gi-base

Dependencies added: containers

Dependency ranges changed: haskell-gi-base

Files

CHANGELOG.md view
@@ -1,3 +1,8 @@+* 0.6.3+    - Add `Grid` container widget+    - Fix bugs in patching properties for all types of widgets+* 0.6.2+    - Add `Notebook` container widget * 0.6.1     - Fix Nix build issue * 0.6.0
gi-gtk-declarative.cabal view
@@ -1,5 +1,5 @@ name:                 gi-gtk-declarative-version:              0.6.2+version:              0.6.3 synopsis:             Declarative GTK+ programming in Haskell description:          A declarative programming model for GTK+ user                       interfaces, implementing support for various widgets@@ -40,6 +40,7 @@                       , GI.Gtk.Declarative.Container                       , GI.Gtk.Declarative.Container.Box                       , GI.Gtk.Declarative.Container.Class+                      , GI.Gtk.Declarative.Container.Grid                       , GI.Gtk.Declarative.Container.ListBox                       , GI.Gtk.Declarative.Container.MenuItem                       , GI.Gtk.Declarative.Container.Notebook@@ -51,7 +52,8 @@                       , GI.Gtk.Declarative.State                       , GI.Gtk.Declarative.Widget                       , GI.Gtk.Declarative.Widget.Conversions-  build-depends:        base >=4.10 && <5+  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@@ -73,12 +75,15 @@   main-is:           Main.hs   build-depends:     base                 >= 4        && < 5                    , async+                   , containers                    , gi-glib                    , gi-gdk                    , gi-gobject                    , gi-gtk                    , gi-gtk-declarative+                   , haskell-gi-base                    , hedgehog >= 1 && < 2+                   , mtl                    , safe-exceptions                    , stm                    , text@@ -87,3 +92,6 @@   ghc-options:       -Wall -O2 -rtsopts -with-rtsopts=-N -threaded   default-language:  Haskell2010   other-modules:     GI.Gtk.Declarative.CustomWidgetTest+                   , GI.Gtk.Declarative.PatchTest+                   , GI.Gtk.Declarative.TestUtils+                   , GI.Gtk.Declarative.TestWidget
src/GI/Gtk/Declarative.hs view
@@ -7,19 +7,38 @@ -- be a pure function your state to a "Widget". module GI.Gtk.Declarative   ( module Export-  ) where+  )+where -import           GI.Gtk.Declarative.Attributes         as Export-import           GI.Gtk.Declarative.Bin                as Export (Bin, bin)-import           GI.Gtk.Declarative.Container          as Export (Container,-                                                                  container)-import           GI.Gtk.Declarative.Container.Box      as Export-import           GI.Gtk.Declarative.Container.ListBox  as Export ()-import           GI.Gtk.Declarative.Container.MenuItem as Export-import           GI.Gtk.Declarative.Container.Paned    as Export-import           GI.Gtk.Declarative.Container.Notebook as Export-import           GI.Gtk.Declarative.CustomWidget       as Export-import           GI.Gtk.Declarative.Patch              as Export-import           GI.Gtk.Declarative.SingleWidget       as Export-import           GI.Gtk.Declarative.Widget             as Export-import           GI.Gtk.Declarative.Widget.Conversions as Export ()+import           GI.Gtk.Declarative.Attributes as Export+import           GI.Gtk.Declarative.Bin        as Export+                                                ( Bin+                                                , bin+                                                )+import           GI.Gtk.Declarative.Container  as Export+                                                ( Container+                                                , container+                                                )+import           GI.Gtk.Declarative.Container.Box+                                               as Export+import           GI.Gtk.Declarative.Container.Grid+                                               as Export+                                                ( )+import           GI.Gtk.Declarative.Container.ListBox+                                               as Export+                                                ( )+import           GI.Gtk.Declarative.Container.MenuItem+                                               as Export+import           GI.Gtk.Declarative.Container.Paned+                                               as Export+import           GI.Gtk.Declarative.Container.Notebook+                                               as Export+import           GI.Gtk.Declarative.CustomWidget+                                               as Export+import           GI.Gtk.Declarative.Patch      as Export+import           GI.Gtk.Declarative.SingleWidget+                                               as Export+import           GI.Gtk.Declarative.Widget     as Export+import           GI.Gtk.Declarative.Widget.Conversions+                                               as Export+                                                ( )
src/GI/Gtk/Declarative/Attributes.hs view
@@ -16,7 +16,6 @@ module GI.Gtk.Declarative.Attributes   ( Attribute(..)   , classes-  , afterCreated   , ClassSet   -- * Event Handling   , on@@ -26,16 +25,17 @@   ) where -import qualified Data.GI.Base.Attributes                            as GI-import qualified Data.GI.Base.Signals                               as GI-import           Data.HashSet (HashSet)-import qualified Data.HashSet                                       as HashSet-import qualified Data.Text                                          as T-import           Data.Text    (Text)+import qualified Data.GI.Base.Attributes       as GI+import qualified Data.GI.Base.Signals          as GI+import           Data.HashSet                   ( HashSet )+import qualified Data.HashSet                  as HashSet+import qualified Data.Text                     as T+import           Data.Text                      ( Text ) import           Data.Typeable-import           GHC.TypeLits                                       (KnownSymbol,-                                                                     Symbol)-import qualified GI.Gtk                                             as Gtk+import           GHC.TypeLits                   ( KnownSymbol+                                                , Symbol+                                                )+import qualified GI.Gtk                        as Gtk  import           GI.Gtk.Declarative.Attributes.Internal.EventHandler import           GI.Gtk.Declarative.Attributes.Internal.Conversions@@ -51,7 +51,7 @@   -- GTK-defined attribute name. The underlying GI object needs to support   -- the /construct/, /get/, and /set/ operations for the given attribute.   (:=)-    :: (GI.AttrOpAllowed 'GI.AttrConstruct info widget+    ::(GI.AttrOpAllowed 'GI.AttrConstruct info widget       , GI.AttrOpAllowed 'GI.AttrSet info widget       , GI.AttrGetC info widget attr getValue       , GI.AttrSetTypeConstraint info setValue@@ -64,13 +64,13 @@   -- | Defines a set of CSS classes for the underlying widget's style context.   -- Use the 'classes' function instead of this constructor directly.   Classes-    :: Gtk.IsWidget widget+    ::Gtk.IsWidget widget     => ClassSet     -> Attribute widget event   -- | Emit events using a pure event handler. Use the 'on' function, instead of this   -- constructor directly.   OnSignalPure-    :: ( Gtk.GObject widget+    ::( Gtk.GObject widget        , GI.SignalInfo info        , gtkCallback ~ GI.HaskellCallbackType info        , ToGtkCallback gtkCallback Pure@@ -81,7 +81,7 @@   -- | Emit events using a pure event handler. Use the 'on' function, instead of this   -- constructor directly.   OnSignalImpure-    :: ( Gtk.GObject widget+    ::( Gtk.GObject widget        , GI.SignalInfo info        , gtkCallback ~ GI.HaskellCallbackType info        , ToGtkCallback gtkCallback Impure@@ -89,10 +89,6 @@     => Gtk.SignalProxy widget info     -> EventHandler gtkCallback widget Impure event     -> Attribute widget event-  -- | Provide a callback to modify the widget after it's been created.-  AfterCreated-    :: (widget -> IO ())-    -> Attribute widget event  -- | A set of CSS classes. type ClassSet = HashSet Text@@ -101,11 +97,10 @@ -- event handler. instance Functor (Attribute widget) where   fmap f = \case-    attr := value -> attr := value-    Classes cs -> Classes cs-    OnSignalPure signal eh -> OnSignalPure signal (fmap f eh)+    attr := value            -> attr := value+    Classes cs               -> Classes cs+    OnSignalPure   signal eh -> OnSignalPure signal (fmap f eh)     OnSignalImpure signal eh -> OnSignalImpure signal (fmap f eh)-    AfterCreated eh -> AfterCreated eh  -- | Define the CSS classes for the underlying widget's style context. For these -- classes to have any effect, this requires a 'Gtk.CssProvider' with CSS files@@ -143,7 +138,3 @@   -> userEventHandler   -> Attribute widget event onM signal = OnSignalImpure signal . toEventHandler---- | Provide a EventHandler to modify the widget after it's been created.-afterCreated :: (widget -> IO ()) -> Attribute widget event-afterCreated = AfterCreated
src/GI/Gtk/Declarative/Attributes/Collected.hs view
@@ -1,15 +1,16 @@-{-# LANGUAGE DataKinds  #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeApplications  #-}-{-# LANGUAGE RecordWildCards  #-}-{-# LANGUAGE GADTs      #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}  -- | Internal helpers for applying attributes and signal handlers to GTK+ -- widgets. module GI.Gtk.Declarative.Attributes.Collected   ( CollectedProperties   , Collected(..)+  , canBeModifiedTo   , collectAttributes   , constructProperties   , updateProperties@@ -18,52 +19,59 @@ where  import           Data.Foldable-import qualified Data.Text                     as Text-import           Data.Text                                ( Text )-import qualified Data.HashSet                  as HashSet-import qualified Data.HashMap.Strict           as HashMap-import           Data.HashMap.Strict                      ( HashMap ) import qualified Data.GI.Base.Attributes       as GI-import qualified GI.Gtk                        as Gtk+import qualified Data.HashMap.Strict           as HashMap+import           Data.HashMap.Strict            ( HashMap )+import qualified Data.HashSet                  as HashSet+import qualified Data.Set                      as Set+import qualified Data.Text                     as Text+import           Data.Text                      ( Text ) import           Data.Typeable+import           Data.Vector                    ( Vector ) import           GHC.TypeLits-import           Data.Vector                              ( Vector )-+import qualified GI.Gtk                        as Gtk import           GI.Gtk.Declarative.Attributes  -- | A collected property key/value pair, to be used when -- settings properties when patching widgets. data CollectedProperty widget where-  CollectedProperty-    :: (GI.AttrOpAllowed 'GI.AttrConstruct info widget-      , GI.AttrOpAllowed 'GI.AttrSet info widget-      , GI.AttrGetC info widget attr getValue-      , GI.AttrSetTypeConstraint info setValue-      , KnownSymbol attr-      , Typeable attr-      , Eq setValue-      , Typeable setValue-      )-   => GI.AttrLabelProxy attr -> setValue -> CollectedProperty widget+  CollectedProperty ::( GI.AttrOpAllowed 'GI.AttrConstruct info widget,+      GI.AttrOpAllowed 'GI.AttrSet info widget,+      GI.AttrGetC info widget attr getValue,+      GI.AttrSetTypeConstraint info setValue,+      KnownSymbol attr,+      Typeable attr,+      Eq setValue,+      Typeable setValue+    ) =>+    GI.AttrLabelProxy attr ->+    setValue ->+    CollectedProperty widget  -- | A collected map of key/value pairs, where the type-level property -- names are represented as 'Text' values. This is used to calculate -- differences in old and new property sets when patching. type CollectedProperties widget = HashMap Text (CollectedProperty widget) +-- | Checks if the 'old' collected properties are a subset of the 'new' ones,+-- and thus if a widget thus be updated or if it has to be recreated.+canBeModifiedTo+  :: CollectedProperties widget -> CollectedProperties widget -> Bool+old `canBeModifiedTo` new = Set.fromList (HashMap.keys old)+  `Set.isSubsetOf` Set.fromList (HashMap.keys new)+ -- | All the collected properties and classes for a widget. These are based -- on the 'Attribute' list in the declarative markup, but collected separately -- into more efficient data structures, optimized for patching.-data Collected widget event = Collected-  { collectedClasses :: ClassSet-  , collectedProperties :: CollectedProperties widget-  }+data Collected widget event+  = Collected+      { collectedClasses :: ClassSet,+        collectedProperties :: CollectedProperties widget+      }  instance Semigroup (Collected widget event) where-  c1 <> c2 =-    Collected-      (collectedClasses c1 <> collectedClasses c2)-      (collectedProperties c1 <> collectedProperties c2)+  c1 <> c2 = Collected (collectedClasses c1 <> collectedClasses c2)+                       (collectedProperties c1 <> collectedProperties c2)  instance Monoid (Collected widget event) where   mempty = Collected mempty mempty@@ -85,8 +93,8 @@       , ..       }     Classes classSet ->-      Collected {collectedClasses = collectedClasses <> classSet, ..}-    _ -> Collected {..}+      Collected { collectedClasses = collectedClasses <> classSet, .. }+    _ -> Collected { .. }  -- | Create a list of GTK construct operations based on collected -- properties, used when creating new widgets.@@ -112,7 +120,6 @@     -> CollectedProperty widget     -> Gtk.AttrOp widget 'GI.AttrSet   toSetOp _ (CollectedProperty attr value) = attr Gtk.:= value-   toMaybeSetOp     :: CollectedProperty widget     -> CollectedProperty widget@@ -124,8 +131,7 @@  -- | Update the style context's classes to only include the new set of -- classes (last argument).-updateClasses-  :: Gtk.StyleContext -> ClassSet -> ClassSet -> IO ()+updateClasses :: Gtk.StyleContext -> ClassSet -> ClassSet -> IO () updateClasses ctx old new = do   let toAdd    = HashSet.difference new old       toRemove = HashSet.difference old new
src/GI/Gtk/Declarative/Attributes/Internal.hs view
@@ -6,24 +6,18 @@ -- | Internal helpers for applying attributes and signal handlers to GTK+ -- widgets. module GI.Gtk.Declarative.Attributes.Internal-  ( applyAfterCreated-  , addSignalHandler+  ( addSignalHandler   ) where -import           Control.Monad                            ( (>=>) )-import           Control.Monad.IO.Class                   ( MonadIO )+import           Control.Monad                  ( (>=>) )+import           Control.Monad.IO.Class         ( MonadIO ) import qualified GI.GObject                    as GI import qualified GI.Gtk                        as Gtk  import           GI.Gtk.Declarative.Attributes import           GI.Gtk.Declarative.Attributes.Internal.Conversions import           GI.Gtk.Declarative.EventSource--applyAfterCreated :: widget -> Attribute widget event -> IO ()-applyAfterCreated widget = \case-  (AfterCreated f) -> f widget-  _                -> return ()  addSignalHandler   :: (Gtk.IsWidget widget, MonadIO m)
src/GI/Gtk/Declarative/Attributes/Internal/Conversions.hs view
@@ -9,8 +9,8 @@   ) where -import           Control.Monad                            ( void )-import           Data.Functor                             ( ($>) )+import           Control.Monad                  ( void )+import           Data.Functor                   ( ($>) ) import           Data.Functor.Identity  import           GI.Gtk.Declarative.Attributes.Internal.EventHandler@@ -33,13 +33,11 @@  instance ToGtkCallback (IO Bool) Pure where   toGtkCallback (PureEventHandler (ReturnAndEvent re)) _ f =-    let (r, e) = runIdentity re-    in f e $> r+    let (r, e) = runIdentity re in f e $> r  instance ToGtkCallback (IO ()) Impure where   toGtkCallback (ImpureEventHandler r) w f =-    let OnlyEvent me = r w-    in me >>= f+    let OnlyEvent me = r w in me >>= f  instance ToGtkCallback (IO Bool) Impure where   toGtkCallback (ImpureEventHandler r) w f = do
src/GI/Gtk/Declarative/Attributes/Internal/EventHandler.hs view
@@ -25,25 +25,25 @@ -- the underlying GTK+ callback needs to return a 'Bool', you return -- a @(Bool, event)@ tuple. data EventHandlerReturn m gtkReturn event where-  OnlyEvent :: m e -> EventHandlerReturn m () e-  ReturnAndEvent :: m (Bool, e) -> EventHandlerReturn m Bool e+  OnlyEvent ::m e -> EventHandlerReturn m () e+  ReturnAndEvent ::m (Bool, e) -> EventHandlerReturn m Bool e  instance Functor m => Functor (EventHandlerReturn m gtkEventHandler) where   fmap f = \case-    OnlyEvent e -> OnlyEvent (fmap f e)+    OnlyEvent      e  -> OnlyEvent (fmap f e)     ReturnAndEvent mr -> ReturnAndEvent (fmap (fmap f) mr)  -- | Encodes the user event handler in such a way that we can have -- a 'Functor' instance for arity-polymorphic event handlers. data EventHandler gtkEventHandler widget (purity :: Purity) event where-  PureEventHandler :: EventHandlerReturn Identity ret e -> EventHandler (IO ret) w Pure e-  ImpureEventHandler :: (w -> EventHandlerReturn IO ret e) -> EventHandler (IO ret) w Impure e-  EventHandlerFunction :: (a -> EventHandler b w p e) -> EventHandler (a -> b) w p e+  PureEventHandler ::EventHandlerReturn Identity ret e -> EventHandler (IO ret) w Pure e+  ImpureEventHandler ::(w -> EventHandlerReturn IO ret e) -> EventHandler (IO ret) w Impure e+  EventHandlerFunction ::(a -> EventHandler b w p e) -> EventHandler (a -> b) w p e  instance Functor (EventHandler gtkEventHandler widget purity) where   fmap f = \case-    PureEventHandler r -> PureEventHandler (fmap f r)-    ImpureEventHandler r -> ImpureEventHandler (fmap (fmap f) r)+    PureEventHandler     r  -> PureEventHandler (fmap f r)+    ImpureEventHandler   r  -> ImpureEventHandler (fmap (fmap f) r)     EventHandlerFunction eh -> EventHandlerFunction (\a -> fmap f (eh a))  -- | Convert from a GTK+ callback type to a user event handler type (the ones
src/GI/Gtk/Declarative/Bin.hs view
@@ -18,8 +18,8 @@ where  import           Data.Typeable-import           Data.Vector                             (Vector)-import qualified GI.Gtk                                  as Gtk+import           Data.Vector                    ( Vector )+import qualified GI.Gtk                        as Gtk  import           GI.Gtk.Declarative.Attributes import           GI.Gtk.Declarative.Attributes.Collected@@ -34,7 +34,7 @@ -- child. data Bin widget event where   Bin-    :: ( Typeable widget+    ::( Typeable widget        , Gtk.IsContainer widget        , Gtk.IsBin widget        , Gtk.IsWidget widget@@ -45,8 +45,7 @@     -> Bin widget event  instance Functor (Bin widget) where-  fmap f (Bin ctor attrs child) =-    Bin ctor (fmap f <$> attrs) (fmap f child)+  fmap f (Bin ctor attrs child) = Bin ctor (fmap f <$> attrs) (fmap f child)  -- | Construct a /bin/ widget, i.e. a widget with exactly one child. bin@@ -75,38 +74,48 @@     sc <- Gtk.widgetGetStyleContext widget'     updateClasses sc mempty (collectedClasses collected) -    mapM_ (applyAfterCreated widget') attrs--    childState <- create child+    childState  <- create child     childWidget <- someStateWidget childState     maybe (pure ()) Gtk.widgetDestroy =<< Gtk.binGetChild widget'     Gtk.containerAdd widget' childWidget-    return (SomeState (StateTreeBin (StateTreeNode widget' sc collected ()) childState))+    return+      (SomeState+        (StateTreeBin (StateTreeNode widget' sc collected ()) childState)+      ) -  patch (SomeState (st :: StateTree stateType w1 c1 e1 cs))-        (Bin _ _ oldChild)-        (Bin (ctor :: Gtk.ManagedPtr w2 -> w2) newAttributes newChild) =-    case (st, eqT @w1 @w2) of+  patch (SomeState (st :: StateTree stateType w1 c1 e1 cs)) (Bin _ _ oldChild) (Bin (ctor :: Gtk.ManagedPtr+      w2+    -> w2) newAttributes newChild)+    = case (st, eqT @w1 @w2) of       (StateTreeBin top oldChildState, Just Refl) ->-        Modify $ do-          binWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)-          let oldCollected = stateTreeCollectedAttributes top-              newCollected = collectAttributes newAttributes-          updateProperties binWidget (collectedProperties oldCollected) (collectedProperties newCollected)-          updateClasses (stateTreeStyleContext top) (collectedClasses oldCollected) (collectedClasses newCollected)+        let+          oldCollected      = stateTreeCollectedAttributes top+          newCollected      = collectAttributes newAttributes+          oldCollectedProps = collectedProperties oldCollected+          newCollectedProps = collectedProperties newCollected+        in+          if oldCollectedProps `canBeModifiedTo` newCollectedProps+            then Modify $ do+              binWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)+              updateProperties binWidget oldCollectedProps newCollectedProps+              updateClasses (stateTreeStyleContext top)+                            (collectedClasses oldCollected)+                            (collectedClasses newCollected) -          let top' = top { stateTreeCollectedAttributes = newCollected }-          case patch oldChildState oldChild newChild of-            Modify modify -> SomeState . StateTreeBin top' <$> modify-            Replace createNew -> do-              Gtk.widgetDestroy =<< someStateWidget oldChildState-              newChildState <- createNew-              childWidget <- someStateWidget newChildState-              Gtk.widgetShow childWidget-              maybe (pure ()) Gtk.widgetDestroy =<< Gtk.binGetChild binWidget-              Gtk.containerAdd binWidget childWidget-              return (SomeState (StateTreeBin top' newChildState))-            Keep -> return (SomeState st)+              let top' = top { stateTreeCollectedAttributes = newCollected }+              case patch oldChildState oldChild newChild of+                Modify  modify    -> SomeState . StateTreeBin top' <$> modify+                Replace createNew -> do+                  Gtk.widgetDestroy =<< someStateWidget oldChildState+                  newChildState <- createNew+                  childWidget   <- someStateWidget newChildState+                  Gtk.widgetShow childWidget+                  maybe (pure ()) Gtk.widgetDestroy+                    =<< Gtk.binGetChild binWidget+                  Gtk.containerAdd binWidget childWidget+                  return (SomeState (StateTreeBin top' newChildState))+                Keep -> return (SomeState st)+            else Replace (create (Bin ctor newAttributes newChild))       _ -> Replace (create (Bin ctor newAttributes newChild))  --@@ -114,13 +123,12 @@ --  instance Gtk.IsBin parent => EventSource (Bin parent) where-  subscribe (Bin ctor props child) (SomeState st) cb =-    case st of-      StateTreeBin top childState -> do-        binWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)-        handlers' <- foldMap (addSignalHandler cb binWidget) props-        (<> handlers') <$> subscribe child childState cb-      _ -> error "Cannot subscribe to Bin events with a non-bin state tree."+  subscribe (Bin ctor props child) (SomeState st) cb = case st of+    StateTreeBin top childState -> do+      binWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)+      handlers' <- foldMap (addSignalHandler cb binWidget) props+      (<> handlers') <$> subscribe child childState cb+    _ -> error "Cannot subscribe to Bin events with a non-bin state tree."  instance a ~ b => FromWidget (Bin a) (Bin b) where   fromWidget = id
src/GI/Gtk/Declarative/Container.hs view
@@ -1,17 +1,16 @@-{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedLabels      #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}  -- | Implementations for common "Gtk.Container".- module GI.Gtk.Declarative.Container   ( Container   , container@@ -20,12 +19,11 @@   ) where -import           Control.Monad                           (forM)+import           Control.Monad                  ( forM ) import           Data.Typeable-import           Data.Vector                             (Vector)-import qualified Data.Vector                             as Vector-import qualified GI.Gtk                                  as Gtk-+import           Data.Vector                    ( Vector )+import qualified Data.Vector                   as Vector+import qualified GI.Gtk                        as Gtk import           GI.Gtk.Declarative.Attributes import           GI.Gtk.Declarative.Attributes.Collected import           GI.Gtk.Declarative.Attributes.Internal@@ -42,16 +40,15 @@ -- types of child widgets. These type relations are decided by 'IsContainer', -- and instances can found in "GI.Gtk.Declarative.Container.Patch". data Container widget children event where-  Container-    :: ( Typeable widget-       , Gtk.IsWidget widget-       , Gtk.IsContainer widget-       , Functor children-       )-    => (Gtk.ManagedPtr widget -> widget)-    -> Vector (Attribute widget event)-    -> children event-    -> Container widget children event+  Container ::( Typeable widget,+      Gtk.IsWidget widget,+      Gtk.IsContainer widget,+      Functor children+    ) =>+    (Gtk.ManagedPtr widget -> widget) ->+    Vector (Attribute widget event) ->+    children event ->+    Container widget children event  instance Functor (Container widget children) where   fmap f (Container ctor attrs children) =@@ -66,77 +63,102 @@      , FromWidget (Container widget (Children child)) target      , ToChildren widget parent child      )-  => (Gtk.ManagedPtr widget -> widget) -- ^ A container widget constructor from the underlying gi-gtk library.-  -> Vector (Attribute widget event)   -- ^ 'Attribute's.-  -> parent (child event)              -- ^ The container's 'child' widgets, in a 'MarkupOf' builder.-  -> target event                      -- ^ The target, whose type is decided by 'FromWidget'.+  => +  -- | A container widget constructor from the underlying gi-gtk library.+     (Gtk.ManagedPtr widget -> widget)+  ->+  -- | 'Attribute's.+     Vector (Attribute widget event)+  ->+  -- | The container's 'child' widgets, in a 'MarkupOf' builder.+     parent (child event)+  ->+  -- | The target, whose type is decided by 'FromWidget'.+     target event container ctor attrs = fromWidget . Container ctor attrs . toChildren ctor  -- -- Patchable -- -instance (Patchable child, Typeable child, IsContainer container child) =>-         Patchable (Container container (Children child)) where+instance+  (Patchable child, Typeable child, IsContainer container child) =>+  Patchable (Container container (Children child))+  where+   create (Container ctor attrs children) = do     let collected = collectAttributes attrs     widget' <- Gtk.new ctor (constructProperties collected)     Gtk.widgetShow widget'     sc <- Gtk.widgetGetStyleContext widget'     updateClasses sc mempty (collectedClasses collected)-    mapM_ (applyAfterCreated widget') attrs-    childStates <--      forM (unChildren children) $ \child -> do-        childState <- create child-        appendChild widget' child =<< someStateWidget childState-        return childState-    return (SomeState (StateTreeContainer (StateTreeNode widget' sc collected ()) childStates))-  patch (SomeState (st :: StateTree stateType w1 c1 e1 cs)) (Container _ _ oldChildren) new@(Container (ctor :: Gtk.ManagedPtr w2 -> w2) newAttributes (newChildren :: Children c2 e2)) =-    case (st, eqT @w1 @w2) of-      (StateTreeContainer top childStates, Just Refl) ->-        Modify $ do-          containerWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)-          let oldCollected = stateTreeCollectedAttributes top-              newCollected = collectAttributes newAttributes-          updateProperties containerWidget (collectedProperties oldCollected) (collectedProperties newCollected)-          updateClasses (stateTreeStyleContext top) (collectedClasses oldCollected) (collectedClasses newCollected)+    childStates <- forM (unChildren children) $ \child -> do+      childState <- create child+      appendChild widget' child =<< someStateWidget childState+      return childState+    return+      (SomeState+        (StateTreeContainer (StateTreeNode widget' sc collected ()) childStates)+      ) -          let top' = top { stateTreeCollectedAttributes = newCollected }-          SomeState <$>-            patchInContainer-              (StateTreeContainer top' childStates)-              containerWidget-              (unChildren oldChildren)-              (unChildren newChildren)+  patch (SomeState (st :: StateTree stateType w1 c1 e1 cs)) (Container _ _ oldChildren) new@(Container (ctor :: Gtk.ManagedPtr+      w2+    -> w2) newAttributes (newChildren :: Children c2 e2))+    = case (st, eqT @w1 @w2) of+      (StateTreeContainer top childStates, Just Refl) ->+        let oldCollected      = stateTreeCollectedAttributes top+            newCollected      = collectAttributes newAttributes+            oldCollectedProps = collectedProperties oldCollected+            newCollectedProps = collectedProperties newCollected+        in  if oldCollectedProps `canBeModifiedTo` newCollectedProps+              then Modify $ do+                containerWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)+                updateProperties containerWidget+                                 oldCollectedProps+                                 newCollectedProps+                updateClasses (stateTreeStyleContext top)+                              (collectedClasses oldCollected)+                              (collectedClasses newCollected)+                let top' = top { stateTreeCollectedAttributes = newCollected }+                SomeState <$> patchInContainer+                  (StateTreeContainer top' childStates)+                  containerWidget+                  (unChildren oldChildren)+                  (unChildren newChildren)+              else Replace (create new)       _ -> Replace (create new)  -- -- EventSource -- -instance EventSource child =>-         EventSource (Container widget (Children child)) where-  subscribe (Container ctor props children) (SomeState st) cb =-    case st of-      StateTreeContainer top childStates -> do-        parentWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)-        handlers' <- foldMap (addSignalHandler cb parentWidget) props-        subs <--          flip foldMap (Vector.zip (unChildren children) childStates) $ \(c, childState) ->-            subscribe c childState cb-        return (handlers' <> subs)-      _ -> error "Warning: Cannot subscribe to Container events with a non-container state tree."+instance+  EventSource child =>+  EventSource (Container widget (Children child))+  where+  subscribe (Container ctor props children) (SomeState st) cb = case st of+    StateTreeContainer top childStates -> do+      parentWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top)+      handlers' <- foldMap (addSignalHandler cb parentWidget) props+      subs <- flip foldMap (Vector.zip (unChildren children) childStates)+        $ \(c, childState) -> subscribe c childState cb+      return (handlers' <> subs)+    _ ->+      error+        "Warning: Cannot subscribe to Container events with a non-container state tree."  -- -- FromWidget -- -instance ( Typeable widget-         , Typeable children-         , Patchable (Container widget children)-         , EventSource (Container widget children)-         ) =>-         FromWidget (Container widget children) Widget where+instance+  ( Typeable widget,+    Typeable children,+    Patchable (Container widget children),+    EventSource (Container widget children)+  ) =>+  FromWidget (Container widget children) Widget+  where   fromWidget = Widget  instance a ~ b => FromWidget (Container a children) (Container b children) where
src/GI/Gtk/Declarative/Container/Box.hs view
@@ -14,16 +14,16 @@  -- | Implementation of 'Gtk.Box' as a declarative container. module GI.Gtk.Declarative.Container.Box-  ( BoxChild (..)-  , BoxChildProperties (..)+  ( BoxChild(..)+  , BoxChildProperties(..)   , defaultBoxChildProperties   ) where -import           Data.Default.Class                 (Default (def))-import           Data.Vector                        (Vector)-import           Data.Word                          (Word32)-import qualified GI.Gtk                             as Gtk+import           Data.Default.Class             ( Default(def) )+import           Data.Vector                    ( Vector )+import           Data.Word                      ( Word32 )+import qualified GI.Gtk                        as Gtk  import           GI.Gtk.Declarative.Container.Class import           GI.Gtk.Declarative.EventSource@@ -42,29 +42,30 @@   { expand  :: Bool   , fill    :: Bool   , padding :: Word32-  }+  } deriving (Eq, Show)  -- | Defaults for 'BoxChildProperties'. Use these and override -- specific fields. defaultBoxChildProperties :: BoxChildProperties defaultBoxChildProperties =-  BoxChildProperties {expand = False, fill = False, padding = 0}+  BoxChildProperties { expand = False, fill = False, padding = 0 }  instance Default BoxChildProperties where   def = defaultBoxChildProperties  instance Patchable BoxChild 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 BoxChild where-  subscribe BoxChild{..} = subscribe child+  subscribe BoxChild {..} = subscribe child  instance ToChildren Gtk.Box Vector BoxChild  instance IsContainer Gtk.Box BoxChild where-  appendChild box BoxChild {properties = BoxChildProperties {expand, fill, padding}} widget' =-    Gtk.boxPackStart box widget' expand fill padding+  appendChild box BoxChild { properties = BoxChildProperties { expand, fill, padding } } widget'+    = Gtk.boxPackStart box widget' expand fill padding   replaceChild box boxChild' i old new = do     Gtk.widgetDestroy old     appendChild box boxChild' new
src/GI/Gtk/Declarative/Container/Class.hs view
@@ -6,9 +6,9 @@ -- | Shared interfaces for containers. module GI.Gtk.Declarative.Container.Class where -import           Data.Int    (Int32)-import           Data.Vector (Vector)-import qualified GI.Gtk      as Gtk+import           Data.Int                       ( Int32 )+import           Data.Vector                    ( Vector )+import qualified GI.Gtk                        as Gtk  -- | Describes supported GTK+ containers and their specialized APIs for -- appending and replacing child widgets.
+ src/GI/Gtk/Declarative/Container/Grid.hs view
@@ -0,0 +1,69 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE RecordWildCards       #-}++-- | Implementation of 'Gtk.Grid' as a declarative container.+module GI.Gtk.Declarative.Container.Grid+  ( GridChild(..)+  , GridChildProperties(..)+  , defaultGridChildProperties+  )+where++import           Data.Default.Class             ( Default(def) )+import           Data.Int                       ( Int32 )+import           Data.Vector                    ( Vector )+import qualified GI.Gtk                        as Gtk++import           GI.Gtk.Declarative.Container.Class+import           GI.Gtk.Declarative.EventSource+import           GI.Gtk.Declarative.Patch+import           GI.Gtk.Declarative.Widget++-- | Describes a child widget to be added with to a 'Grid'.+data GridChild event =+  GridChild+    { properties :: GridChildProperties+    , child      :: Widget event+    }+  deriving (Functor)++-- | Values used when /packing/ child widgets into grids.+data GridChildProperties =+  GridChildProperties+    { height     :: Int32+    , width      :: Int32+    , leftAttach :: Int32+    , topAttach  :: Int32+    }++-- | Defaults for 'GridChildProperties'. Use these and override+-- specific fields.+defaultGridChildProperties :: GridChildProperties+defaultGridChildProperties =+  GridChildProperties { height = 1, width = 1, leftAttach = 0, topAttach = 0 }++instance Default GridChildProperties where+  def = defaultGridChildProperties++instance Patchable GridChild where+  create = create . child+  patch s b1 b2 = patch s (child b1) (child b2)++instance EventSource GridChild where+  subscribe GridChild {..} = subscribe child++instance ToChildren Gtk.Grid Vector GridChild++instance IsContainer Gtk.Grid GridChild where+  appendChild grid GridChild { properties } widget' = do+    let GridChildProperties { width, height, leftAttach, topAttach } =+          properties+    Gtk.gridAttach grid widget' leftAttach topAttach width height+  replaceChild grid gridChild' _i old new = do+    Gtk.widgetDestroy old+    appendChild grid gridChild' new+
src/GI/Gtk/Declarative/Container/ListBox.hs view
@@ -5,15 +5,14 @@  module GI.Gtk.Declarative.Container.ListBox where -import           Data.Vector                        (Vector)-import qualified GI.Gtk                             as Gtk+import           Data.Vector                    ( Vector )+import qualified GI.Gtk                        as Gtk  import           GI.Gtk.Declarative.Bin import           GI.Gtk.Declarative.Container.Class  instance IsContainer Gtk.ListBox (Bin Gtk.ListBoxRow) where-  appendChild box _ widget' =-    Gtk.listBoxInsert box widget' (-1)+  appendChild box _ widget' = Gtk.listBoxInsert box widget' (-1)   replaceChild box _ i old new = do     Gtk.widgetDestroy old     Gtk.listBoxInsert box new i
src/GI/Gtk/Declarative/Container/MenuItem.hs view
@@ -18,10 +18,10 @@   ) where -import           Data.Text                          (Text)+import           Data.Text                      ( Text ) import           Data.Typeable-import           Data.Vector                        (Vector)-import qualified GI.Gtk                             as Gtk+import           Data.Vector                    ( Vector )+import qualified GI.Gtk                        as Gtk  import           GI.Gtk.Declarative.Attributes import           GI.Gtk.Declarative.Bin@@ -36,16 +36,16 @@ data MenuItem event where   -- | A single menu item in a 'Gtk.Menu'.   MenuItem-    :: (Gtk.IsMenuItem item, Gtk.IsBin item, Typeable item)+    ::(Gtk.IsMenuItem item, Gtk.IsBin item, Typeable item)     => Bin item event     -> MenuItem event   -- | A sub menu in a 'Gtk.Menu', with a text label and the list of   -- child menu items.   SubMenu-    :: Text -> Container Gtk.Menu (Children MenuItem) event -> MenuItem event+    ::Text -> Container Gtk.Menu (Children MenuItem) event -> MenuItem event  instance Functor MenuItem where-  fmap f (MenuItem item)          = MenuItem (fmap f item)+  fmap f (MenuItem item         ) = MenuItem (fmap f item)   fmap f (SubMenu label subMenu') = SubMenu label (fmap f subMenu')  instance ToChildren Gtk.Menu Vector MenuItem@@ -75,7 +75,8 @@ newSubMenuItem label createSubMenu = do   menuItem' <- Gtk.menuItemNewWithLabel label   sc        <- Gtk.widgetGetStyleContext menuItem'-  SomeState (subMenuState :: StateTree st subMenu children e1 cs) <- createSubMenu+  SomeState (subMenuState :: StateTree st subMenu children e1 cs) <-+    createSubMenu   case eqT @subMenu @Gtk.Menu of     Just Refl -> do       Gtk.menuItemSetSubmenu menuItem' (Just (stateTreeNodeWidget subMenuState))@@ -88,33 +89,28 @@     Nothing -> fail "Failed to create new sub menu item."  instance Patchable MenuItem where-  create =-    \case-      MenuItem item -> create item-      SubMenu label subMenu' -> newSubMenuItem label (create subMenu')+  create = \case+    MenuItem item          -> create item+    SubMenu label subMenu' -> newSubMenuItem label (create subMenu')   patch state (MenuItem (c1 :: Bin i1 e1)) (MenuItem (c2 :: Bin i2 e2)) =     case eqT @i1 @i2 of       Just Refl -> patch state c1 c2       Nothing   -> Replace (create c2)-  patch (SomeState st) (SubMenu l1 c1) (SubMenu l2 c2) =-    case st of-      StateTreeBin top childState | l1 == l2 ->-        case patch childState c1 c2 of-          Modify modify ->-            Modify (SomeState . StateTreeBin top <$> modify)-          Replace newSubMenu ->-            Replace (newSubMenuItem l2 newSubMenu)-          Keep -> Keep-      -- TODO: case for l1 /= l2-      _ -> Replace (create (SubMenu l2 c2))+  patch (SomeState st) (SubMenu l1 c1) (SubMenu l2 c2) = case st of+    StateTreeBin top childState | l1 == l2 -> case patch childState c1 c2 of+      Modify  modify     -> Modify (SomeState . StateTreeBin top <$> modify)+      Replace newSubMenu -> Replace (newSubMenuItem l2 newSubMenu)+      Keep               -> Keep+    -- TODO: case for l1 /= l2+    _ -> Replace (create (SubMenu l2 c2))   patch _ _ b2 = Replace (create b2)  instance EventSource MenuItem where-  subscribe (MenuItem item) state cb = subscribe item state cb-  subscribe (SubMenu _ children) (SomeState st) cb =-    case st of-      StateTreeBin _ childState -> subscribe children childState cb-      _ -> error "Warning: Cannot subscribe to SubMenu events with a non-bin state tree."+  subscribe (MenuItem item     ) state          cb = subscribe item state cb+  subscribe (SubMenu _ children) (SomeState st) cb = case st of+    StateTreeBin _ childState -> subscribe children childState cb+    _                         -> error+      "Warning: Cannot subscribe to SubMenu events with a non-bin state tree."  instance IsContainer Gtk.MenuShell MenuItem where   appendChild shell _ widget' =
src/GI/Gtk/Declarative/Container/Notebook.hs view
@@ -11,15 +11,18 @@   , page   , pageWithTab   , notebook-  ) where+  )+where -import           Control.Monad                      (void)-import           Data.Maybe                         (isNothing)-import           Data.Text                          (Text, pack)-import           Data.Vector                        (Vector)-import           GHC.Ptr                            (nullPtr)-import qualified GI.GLib                            as GLib-import qualified GI.Gtk                             as Gtk+import           Control.Monad                  ( void )+import           Data.Maybe                     ( isNothing )+import           Data.Text                      ( Text+                                                , pack+                                                )+import           Data.Vector                    ( Vector )+import           GHC.Ptr                        ( nullPtr )+import qualified GI.GLib                       as GLib+import qualified GI.Gtk                        as Gtk import           GI.Gtk.Declarative.Attributes import           GI.Gtk.Declarative.Container import           GI.Gtk.Declarative.Container.Class@@ -42,13 +45,13 @@ pageWithTab = Page  -- | Create a 'Notebook' by combining multiple pages.-notebook ::-     Vector (Attribute Gtk.Notebook event)+notebook+  :: Vector (Attribute Gtk.Notebook event)   -> Vector (Page event)   -> Widget event notebook attrs children =   let childrenAndTabs = children >>= (\Page {..} -> [child, tabLabel])-   in container Gtk.Notebook attrs childrenAndTabs+  in  container Gtk.Notebook attrs childrenAndTabs  instance ToChildren Gtk.Notebook Vector Widget @@ -56,9 +59,8 @@   appendChild parent _ new = do     lastPage <- Gtk.notebookGetNthPage parent (-1)     case lastPage of-      Nothing-        -- this is the first page to be added-       -> do+      -- this is the first page to be added+      Nothing -> do         void $ Gtk.notebookAppendPage parent new (Nothing :: Maybe Gtk.Widget)       Just p -> do         label <- Gtk.notebookGetTabLabel parent p@@ -67,8 +69,9 @@           then do             Gtk.notebookSetTabLabel parent p (Just new)           else do-            void $-              Gtk.notebookAppendPage parent new (Nothing :: Maybe Gtk.Widget)+            void $ Gtk.notebookAppendPage parent+                                          new+                                          (Nothing :: Maybe Gtk.Widget)   replaceChild parent _ i old new = do     let i' = i `div` 2     pageI <- Gtk.notebookGetNthPage parent i'@@ -77,9 +80,10 @@         GLib.logDefaultHandler           (Just "gi-gtk-declarative")           [GLib.LogLevelFlagsLevelError]-          (Just $-           "GI.Gtk.Declarative.Container.Notebook.replaceChild called with an index where there is no child: " <>-           pack (show i))+          (Just+          $ "GI.Gtk.Declarative.Container.Notebook.replaceChild called with an index where there is no child: "+          <> pack (show i)+          )           nullPtr       Just p -> do         if i `mod` 2 == 0
src/GI/Gtk/Declarative/Container/Paned.hs view
@@ -17,20 +17,20 @@ -- | Implementation of 'Gtk.Paned' as a declarative container. module GI.Gtk.Declarative.Container.Paned   ( Pane-  , PaneProperties (..)+  , PaneProperties(..)   , defaultPaneProperties   , pane   , paned   ) where -import           Data.Coerce                        (coerce)-import           Data.Default.Class                 (Default (def))-import           Data.Vector                        (Vector)-import qualified Data.Vector                        as Vector-import           GHC.Ptr                            (nullPtr)-import qualified GI.GLib                            as GLib-import qualified GI.Gtk                             as Gtk+import           Data.Coerce                    ( coerce )+import           Data.Default.Class             ( Default(def) )+import           Data.Vector                    ( Vector )+import qualified Data.Vector                   as Vector+import           GHC.Ptr                        ( nullPtr )+import qualified GI.GLib                       as GLib+import qualified GI.Gtk                        as Gtk  import           GI.Gtk.Declarative.Attributes import           GI.Gtk.Declarative.Container@@ -56,7 +56,7 @@ -- | Defaults for 'PaneProperties'. Use these and override specific -- fields. defaultPaneProperties :: PaneProperties-defaultPaneProperties = PaneProperties {resize = False, shrink = True}+defaultPaneProperties = PaneProperties { resize = False, shrink = True }  instance Default PaneProperties where   def = defaultPaneProperties@@ -64,44 +64,56 @@ -- | Construct a pane to be packed with -- 'Gtk.panePack1'/'Gtk.panePack2' in a 'Gtk.Paned'. pane :: PaneProperties -> Widget event -> Pane event-pane paneProperties paneChild = Pane {..}+pane paneProperties paneChild = Pane { .. }  instance Patchable Pane where   create = create . paneChild   patch s b1 b2 = patch s (paneChild b1) (paneChild b2)  instance EventSource Pane where-  subscribe Pane{..} = subscribe paneChild+  subscribe Pane {..} = subscribe paneChild  -- | Construct a 'Gtk.Paned' based on attributes and two child 'Pane's.-paned :: Vector (Attribute Gtk.Paned event) -> Pane event -> Pane event -> Widget event+paned+  :: Vector (Attribute Gtk.Paned event)+  -> Pane event+  -> Pane event+  -> Widget event paned attrs p1 p2 = container Gtk.Paned attrs (Panes p1 p2)  data Panes child = Panes child child   deriving (Functor)  instance IsContainer Gtk.Paned Pane where-  appendChild paned' Pane{paneProperties = PaneProperties{resize, shrink}} widget' = do-    c1 <- Gtk.panedGetChild1 paned'-    c2 <- Gtk.panedGetChild2 paned'-    case (c1, c2) of-      (Nothing, Nothing) -> Gtk.panedPack1 paned' widget' (coerce resize) (coerce shrink)-      (Just _, Nothing) -> Gtk.panedPack2 paned' widget' (coerce resize) (coerce shrink)-      _ -> GLib.logDefaultHandler-           (Just "gi-gtk-declarative")-           [GLib.LogLevelFlagsLevelWarning]-           (Just "appendChild: The `GI.Gtk.Paned` widget can only fit 2 panes. Additional children will be ignored.")-           nullPtr-  replaceChild paned' Pane{paneProperties = PaneProperties{resize, shrink}} i old new = do-    Gtk.widgetDestroy old-    case i of-      0 -> Gtk.panedPack1 paned' new (coerce resize) (coerce shrink)-      1 -> Gtk.panedPack2 paned' new (coerce resize) (coerce shrink)-      _ -> GLib.logDefaultHandler-           (Just "gi-gtk-declarative")-           [GLib.LogLevelFlagsLevelWarning]-           (Just "replaceChild: The `GI.Gtk.Paned` widget can only fit 2 panes. Additional children will be ignored.")-           nullPtr+  appendChild paned' Pane { paneProperties = PaneProperties { resize, shrink } } widget'+    = do+      c1 <- Gtk.panedGetChild1 paned'+      c2 <- Gtk.panedGetChild2 paned'+      case (c1, c2) of+        (Nothing, Nothing) ->+          Gtk.panedPack1 paned' widget' (coerce resize) (coerce shrink)+        (Just _, Nothing) ->+          Gtk.panedPack2 paned' widget' (coerce resize) (coerce shrink)+        _ -> GLib.logDefaultHandler+          (Just "gi-gtk-declarative")+          [GLib.LogLevelFlagsLevelWarning]+          (Just+            "appendChild: The `GI.Gtk.Paned` widget can only fit 2 panes. Additional children will be ignored."+          )+          nullPtr+  replaceChild paned' Pane { paneProperties = PaneProperties { resize, shrink } } i old new+    = do+      Gtk.widgetDestroy old+      case i of+        0 -> Gtk.panedPack1 paned' new (coerce resize) (coerce shrink)+        1 -> Gtk.panedPack2 paned' new (coerce resize) (coerce shrink)+        _ -> GLib.logDefaultHandler+          (Just "gi-gtk-declarative")+          [GLib.LogLevelFlagsLevelWarning]+          (Just+            "replaceChild: The `GI.Gtk.Paned` widget can only fit 2 panes. Additional children will be ignored."+          )+          nullPtr  instance ToChildren Gtk.Paned Panes Pane where   toChildren _ (Panes p1 p2) = Children (Vector.fromList [p1, p2])
src/GI/Gtk/Declarative/Container/Patch.hs view
@@ -19,10 +19,12 @@   ) where -import           Data.Foldable                      (foldMap)-import           Data.Vector                        (Vector, (!?))-import qualified Data.Vector                        as Vector-import qualified GI.Gtk                             as Gtk+import           Data.Foldable                  ( foldMap )+import           Data.Vector                    ( Vector+                                                , (!?)+                                                )+import qualified Data.Vector                   as Vector+import qualified GI.Gtk                        as Gtk  import           GI.Gtk.Declarative.Container.Class import           GI.Gtk.Declarative.Patch@@ -55,58 +57,58 @@    Gtk.widgetQueueResize container   return (StateTreeContainer top newChildren)-  where-    go = \case-      -- In case we have a corresponding old and new declarative widget, we patch-      -- the GTK widget.-      (i, Just oldChildState, Just old, Just new) ->-        case patch oldChildState old new of-          Modify  modify       -> pure <$> modify-          Replace createWidget -> do-            newChildState  <- createWidget-            oldChildWidget <- someStateWidget oldChildState-            newChildWidget <- someStateWidget newChildState-            replaceChild container new i oldChildWidget newChildWidget-            return (pure newChildState)-          Keep -> return (pure oldChildState)+ where+  go = \case+    -- In case we have a corresponding old and new declarative widget, we patch+    -- the GTK widget.+    (i, Just oldChildState, Just old, Just new) ->+      case patch oldChildState old new of+        Modify  modify       -> pure <$> modify+        Replace createWidget -> do+          newChildState  <- createWidget+          oldChildWidget <- someStateWidget oldChildState+          newChildWidget <- someStateWidget newChildState+          replaceChild container new i oldChildWidget newChildWidget+          return (pure newChildState)+        Keep -> return (pure oldChildState) -      -- When there is a new declarative widget, but there already exists a GTK-      -- widget in the corresponding place, we need to replace the GTK widget with-      -- one created from the declarative widget.-      (i, Just oldChildState, Nothing, Just new) -> do-        newChildState  <- create new-        oldChildWidget <- someStateWidget oldChildState-        newChildWidget <- someStateWidget newChildState-        replaceChild container new i oldChildWidget newChildWidget-        return (Vector.singleton newChildState)+    -- When there is a new declarative widget, but there already exists a GTK+    -- widget in the corresponding place, we need to replace the GTK widget with+    -- one created from the declarative widget.+    (i, Just oldChildState, Nothing, Just new) -> do+      newChildState  <- create new+      oldChildWidget <- someStateWidget oldChildState+      newChildWidget <- someStateWidget newChildState+      replaceChild container new i oldChildWidget newChildWidget+      return (Vector.singleton newChildState) -      -- When there is a new declarative widget, or one that lacks a corresponding-      -- GTK widget, create and add it.-      (_i, Nothing, _, Just n) -> do-        newChildState <- create n-        w             <- someStateWidget newChildState-        appendChild container n w-        return (Vector.singleton newChildState)+    -- When there is a new declarative widget, or one that lacks a corresponding+    -- GTK widget, create and add it.+    (_i, Nothing, _, Just n) -> do+      newChildState <- create n+      w             <- someStateWidget newChildState+      appendChild container n w+      return (Vector.singleton newChildState) -      -- When a declarative widget has been removed, remove the GTK widget from-      -- the container.-      (_i, Just childState, Just _, Nothing) -> do-        Gtk.widgetDestroy =<< someStateWidget childState-        return Vector.empty+    -- When a declarative widget has been removed, remove the GTK widget from+    -- the container.+    (_i, Just childState, Just _, Nothing) -> do+      Gtk.widgetDestroy =<< someStateWidget childState+      return Vector.empty -      -- When there are more old declarative widgets than GTK widgets, we can-      -- safely ignore the old declarative widgets.-      (_i, Nothing        , Just _ , Nothing) -> return Vector.empty+    -- When there are more old declarative widgets than GTK widgets, we can+    -- safely ignore the old declarative widgets.+    (_i, Nothing        , Just _ , Nothing) -> return Vector.empty -      -- But, when there are stray GTK widgets without corresponding-      -- declarative widgets, something has gone wrong, and we clean that up by-      -- removing the GTK widgets.-      (_i, Just childState, Nothing, Nothing) -> do-        Gtk.widgetDestroy =<< someStateWidget childState-        return Vector.empty+    -- But, when there are stray GTK widgets without corresponding+    -- declarative widgets, something has gone wrong, and we clean that up by+    -- removing the GTK widgets.+    (_i, Just childState, Nothing, Nothing) -> do+      Gtk.widgetDestroy =<< someStateWidget childState+      return Vector.empty -      -- No more GTK widgets or declarative widgets, we are done.-      (_i, Nothing, Nothing, Nothing) -> return Vector.empty+    -- No more GTK widgets or declarative widgets, we are done.+    (_i, Nothing, Nothing, Nothing) -> return Vector.empty  padMaybes :: Int -> Vector a -> Vector (Maybe a) padMaybes len xs = Vector.generate len (xs !?)
src/GI/Gtk/Declarative/CustomWidget.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DeriveFunctor       #-}-{-# LANGUAGE GADTs               #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeApplications #-}  -- | While you can instantiate 'Patchable' and 'EventSource' for your -- own data types, it's a bit complicated. The 'CustomWidget' data@@ -15,8 +15,8 @@ where  import           Data.Typeable-import           Data.Vector                             (Vector)-import qualified GI.Gtk                                  as Gtk+import           Data.Vector                    ( Vector )+import qualified GI.Gtk                        as Gtk import           GI.Gtk.Declarative.Attributes import           GI.Gtk.Declarative.Attributes.Collected import           GI.Gtk.Declarative.EventSource@@ -38,70 +38,99 @@ --   value threaded through updates, which is often useful for passing --   references to child widgets used in a custom widget -- * emits events of type 'event'-data CustomWidget widget params internalState event =-  CustomWidget-  { customWidget :: Gtk.ManagedPtr widget -> widget-  -- ^ The widget constructor-  , customCreate :: params -> IO (widget, internalState)-  -- ^ Action that creates the initial widget-  , customPatch :: params -> params -> internalState -> CustomPatch widget internalState-  -- ^ Patch function, calculating a 'CustomPatch' based on the state,-  -- old custom data, and new custom data-  , customSubscribe :: params -> internalState -> widget -> (event -> IO ()) -> IO Subscription-  -- ^ Action that creates an event subscription for the custom widget-  , customAttributes :: Vector (Attribute widget event)-  -- ^ Declarative 'Attribute's for the custom widget (properties and-  -- classes are handled automatically in patching)-  , customParams :: params-  -- ^ Parameters passed when constructing the declarative custom widget-  } deriving (Functor)+data CustomWidget widget params internalState event+  = CustomWidget+      { -- | The widget constructor+        customWidget :: Gtk.ManagedPtr widget -> widget,+        -- | Action that creates the initial widget+        customCreate :: params -> IO (widget, internalState),+        -- | Patch function, calculating a 'CustomPatch' based on the state,+        -- old custom data, and new custom data+        customPatch :: params -> params -> internalState -> CustomPatch widget internalState,+        -- | Action that creates an event subscription for the custom widget+        customSubscribe :: params -> internalState -> widget -> (event -> IO ()) -> IO Subscription,+        -- | Declarative 'Attribute's for the custom widget (properties and+        -- classes are handled automatically in patching)+        customAttributes :: Vector (Attribute widget event),+        -- | Parameters passed when constructing the declarative custom widget+        customParams :: params+      }+  deriving (Functor) -instance ( Typeable widget-         , Typeable internalState-         , Gtk.IsWidget widget-         )-  => Patchable (CustomWidget widget params internalState) where+instance+  ( Typeable widget,+    Typeable internalState,+    Gtk.IsWidget widget+  ) =>+  Patchable (CustomWidget widget params internalState)+  where+   create custom = do     (widget, internalState) <- customCreate custom (customParams custom)     Gtk.widgetShow widget-     let collected = collectAttributes (customAttributes custom)     updateProperties widget mempty (collectedProperties collected)     sc <- Gtk.widgetGetStyleContext widget     updateClasses sc mempty (collectedClasses collected)+    pure+      (SomeState+        (StateTreeWidget (StateTreeNode widget sc collected internalState))+      ) -    pure (SomeState (StateTreeWidget (StateTreeNode widget sc collected internalState)))   patch (SomeState (stateTree :: StateTree st w e c cs)) old new =     case (eqT @cs @internalState, eqT @widget @w) of       (Just Refl, Just Refl) ->-        case customPatch-               new-               (customParams old)-               (customParams new)-               (stateTreeCustomState (stateTreeNode stateTree))-        of-          CustomReplace -> Replace (create new)-          CustomModify f -> Modify $ do-            let widget' = stateTreeNodeWidget stateTree--            let oldCollected = stateTreeCollectedAttributes (stateTreeNode stateTree)-                newCollected = collectAttributes (customAttributes new)-            updateProperties widget' (collectedProperties oldCollected) (collectedProperties newCollected)-            updateClasses (stateTreeStyleContext (stateTreeNode stateTree)) (collectedClasses oldCollected) (collectedClasses newCollected)-            internalState' <--              f =<< Gtk.unsafeCastTo (customWidget new) widget'-            let node = stateTreeNode stateTree-            return (SomeState (StateTreeWidget node { stateTreeCustomState = internalState'-                                                    , stateTreeCollectedAttributes = newCollected-                                                    }))-          CustomKeep -> Keep+        let+          oldCollected = stateTreeCollectedAttributes (stateTreeNode stateTree)+          newCollected = collectAttributes (customAttributes new)+          oldCollectedProps = collectedProperties oldCollected+          newCollectedProps = collectedProperties newCollected+          canBeModified = oldCollectedProps `canBeModifiedTo` newCollectedProps+        in+          case+            customPatch new+                        (customParams old)+                        (customParams new)+                        (stateTreeCustomState (stateTreeNode stateTree))+          of+            CustomReplace -> Replace (create new)+            p+              | canBeModified -> Modify $ do+                let widget' = stateTreeNodeWidget stateTree+                updateProperties widget' oldCollectedProps newCollectedProps+                updateClasses+                  (stateTreeStyleContext (stateTreeNode stateTree))+                  (collectedClasses oldCollected)+                  (collectedClasses newCollected)+                let node = stateTreeNode stateTree+                internalState' <- case p of+                  CustomModify f ->+                    f =<< Gtk.unsafeCastTo (customWidget new) widget'+                  CustomKeep    -> pure (stateTreeCustomState node)+                  CustomReplace -> pure (stateTreeCustomState node) -- already handled above+                return+                  (SomeState+                    (StateTreeWidget node+                      { stateTreeCustomState         = internalState'+                      , stateTreeCollectedAttributes = newCollected+                      }+                    )+                  )+              | otherwise -> Replace (create new)       _ -> Replace (create new) -instance (Typeable internalState, Gtk.GObject widget)-  => EventSource (CustomWidget widget params internalState) where+instance+  (Typeable internalState, Gtk.GObject widget) =>+  EventSource (CustomWidget widget params internalState)+  where   subscribe custom (SomeState (stateTree :: StateTree st w e c cs)) cb =     case eqT @cs @internalState of       Just Refl -> do-        w' <- Gtk.unsafeCastTo (customWidget custom) (stateTreeNodeWidget stateTree)-        customSubscribe custom (customParams custom) (stateTreeCustomState (stateTreeNode stateTree)) w' cb+        w' <- Gtk.unsafeCastTo (customWidget custom)+                               (stateTreeNodeWidget stateTree)+        customSubscribe custom+                        (customParams custom)+                        (stateTreeCustomState (stateTreeNode stateTree))+                        w'+                        cb       Nothing -> pure (fromCancellation (pure ()))
src/GI/Gtk/Declarative/EventSource.hs view
@@ -10,7 +10,7 @@   ) where -import           Data.Vector              (Vector)+import           Data.Vector                    ( Vector )  import           GI.Gtk.Declarative.State
src/GI/Gtk/Declarative/Patch.hs view
@@ -5,7 +5,8 @@ module GI.Gtk.Declarative.Patch   ( Patch(..)   , Patchable(..)-  ) where+  )+where  import           GI.Gtk.Declarative.State
src/GI/Gtk/Declarative/SingleWidget.hs view
@@ -18,8 +18,8 @@ where  import           Data.Typeable-import           Data.Vector                             (Vector)-import qualified GI.Gtk                                  as Gtk+import           Data.Vector                    ( Vector )+import qualified GI.Gtk                        as Gtk  import           GI.Gtk.Declarative.Attributes import           GI.Gtk.Declarative.Attributes.Collected@@ -32,7 +32,7 @@ -- | Declarative version of a /leaf/ widget, i.e. a widget without any children. data SingleWidget widget event where   SingleWidget-    :: (Typeable widget, Gtk.IsWidget widget, Functor (Attribute widget))+    ::(Typeable widget, Gtk.IsWidget widget, Functor (Attribute widget))     => (Gtk.ManagedPtr widget -> widget)     -> Vector (Attribute widget event)     -> SingleWidget widget event@@ -43,31 +43,50 @@ instance Patchable (SingleWidget widget) where   create = \case     SingleWidget ctor attrs -> do-        let collected = collectAttributes attrs-        widget' <- Gtk.new ctor (constructProperties collected)-        Gtk.widgetShow widget'-        sc <- Gtk.widgetGetStyleContext widget'-        updateClasses sc mempty (collectedClasses collected)-        mapM_ (applyAfterCreated widget') attrs--        return (SomeState (StateTreeWidget (StateTreeNode widget' sc collected ())))-  patch (SomeState (st :: StateTree stateType w child event cs))-        (SingleWidget (_    :: Gtk.ManagedPtr w1 -> w1) _)-        (SingleWidget (ctor :: Gtk.ManagedPtr w2 -> w2) newAttributes) =-    case (st, eqT @w @w1, eqT @w1 @w2) of-      (StateTreeWidget top, Just Refl, Just Refl) -> Modify $ do-        let w = stateTreeWidget top-        let oldCollected = stateTreeCollectedAttributes top-            newCollected = collectAttributes newAttributes-        updateProperties w (collectedProperties oldCollected) (collectedProperties newCollected)-        updateClasses (stateTreeStyleContext top) (collectedClasses oldCollected) (collectedClasses newCollected)-        let top' = top { stateTreeCollectedAttributes = newCollected }-        return (SomeState (StateTreeWidget top' { stateTreeCollectedAttributes = newCollected }))+      let collected = collectAttributes attrs+      widget' <- Gtk.new ctor (constructProperties collected)+      Gtk.widgetShow widget'+      sc <- Gtk.widgetGetStyleContext widget'+      updateClasses sc mempty (collectedClasses collected)+      return+        (SomeState (StateTreeWidget (StateTreeNode widget' sc collected ())))+  patch (SomeState (st :: StateTree stateType w child event cs)) (SingleWidget (_ :: Gtk.ManagedPtr+      w1+    -> w1) _) (SingleWidget (ctor :: Gtk.ManagedPtr w2 -> w2) newAttributes)+    = case (st, eqT @w @w1, eqT @w1 @w2) of+      (StateTreeWidget top, Just Refl, Just Refl) ->+        let+          oldCollected      = stateTreeCollectedAttributes top+          newCollected      = collectAttributes newAttributes+          oldCollectedProps = collectedProperties oldCollected+          newCollectedProps = collectedProperties newCollected+        in+          if oldCollectedProps `canBeModifiedTo` newCollectedProps+            then Modify $ do+              let w = stateTreeWidget top+              updateProperties w oldCollectedProps newCollectedProps+              updateClasses (stateTreeStyleContext top)+                            (collectedClasses oldCollected)+                            (collectedClasses newCollected)+              let top' = top { stateTreeCollectedAttributes = newCollected }+              return+                (SomeState+                  (StateTreeWidget top'+                    { stateTreeCollectedAttributes = newCollected+                    }+                  )+                )+            else Replace (create (SingleWidget ctor newAttributes))       _ -> Replace (create (SingleWidget ctor newAttributes))  instance EventSource (SingleWidget widget) where-  subscribe (SingleWidget (_ :: Gtk.ManagedPtr w1 -> w1) props) (SomeState (st :: StateTree stateType w2 child event cs)) cb =-    case (st, eqT @w1 @w2) of+  subscribe (SingleWidget (_ :: Gtk.ManagedPtr w1 -> w1) props) (SomeState (st :: StateTree+      stateType+      w2+      child+      event+      cs)) cb+    = case (st, eqT @w1 @w2) of       (StateTreeWidget top, Just Refl) ->         foldMap (addSignalHandler cb (stateTreeWidget top)) props       _ -> pure (fromCancellation (pure ()))
src/GI/Gtk/Declarative/Widget.hs view
@@ -26,7 +26,7 @@ -- checks on different types of widgets when calculating patches. data Widget event where   Widget-    :: ( Typeable widget+    ::( Typeable widget        , Patchable widget        , Functor widget        , EventSource widget@@ -41,10 +41,9 @@ -- widget instances. instance Patchable Widget where   create (Widget w) = create w-  patch s (Widget (w1 :: t1 e1)) (Widget (w2 :: t2 e2)) =-    case eqT @t1 @t2 of-      Just Refl -> patch s w1 w2-      _         -> Replace (create w2)+  patch s (Widget (w1 :: t1 e1)) (Widget (w2 :: t2 e2)) = case eqT @t1 @t2 of+    Just Refl -> patch s w1 w2+    _         -> Replace (create w2)  instance EventSource Widget where   subscribe (Widget w) = subscribe w
test/GI/Gtk/Declarative/CustomWidgetTest.hs view
@@ -12,25 +12,25 @@ import           Control.Concurrent import           Control.Concurrent.STM import           Control.Exception.Safe-import           Control.Monad                  (replicateM_)+import           Control.Monad                  ( replicateM_ ) import           Control.Monad.IO.Class-import           Data.Function                  ((&))-import qualified Data.HashSet                   as HashSet-import qualified Data.Text                      as Text-import           Data.Vector                    (Vector)-import qualified GI.Gdk                         as Gdk-import qualified GI.GLib.Constants              as GLib-import qualified GI.GObject                     as GI-import qualified GI.Gtk                         as Gtk+import           Data.Function                  ( (&) )+import qualified Data.HashSet                  as HashSet+import qualified Data.Text                     as Text+import           Data.Vector                    ( Vector )+import qualified GI.GObject                    as GI+import qualified GI.Gtk                        as Gtk  import           Hedgehog-import qualified Hedgehog.Gen                   as Gen-import qualified Hedgehog.Range                 as Range+import qualified Hedgehog.Gen                  as Gen+import qualified Hedgehog.Range                as Range  import           GI.Gtk.Declarative import           GI.Gtk.Declarative.EventSource import           GI.Gtk.Declarative.State +import           GI.Gtk.Declarative.TestUtils+ prop_sets_the_button_label = property $ do   start       <- forAll (Gen.int (Range.linear 0 10))   clicks      <- forAll (Gen.int (Range.linear 0 10))@@ -39,10 +39,7 @@     do       let markup = testWidget [] start       first <- create markup-      btn <--        someStateWidget first-        >>= Gtk.unsafeCastTo Gtk.Button-        &   liftIO+      btn   <- someStateWidget first >>= Gtk.unsafeCastTo Gtk.Button & liftIO       #add window btn       sub <- subscribe markup first (const (pure ()))       Gtk.widgetShowAll window@@ -54,25 +51,21 @@   expectedLabel === buttonLabel  prop_emits_correct_number_of_click_events = property $ do-  start       <- forAll (Gen.int (Range.linear 0 10))-  clicks      <- forAll (Gen.int (Range.linear 0 10))+  start  <- forAll (Gen.int (Range.linear 0 10))+  clicks <- forAll (Gen.int (Range.linear 0 10)) -  values       <- liftIO (newTBQueueIO (fromIntegral clicks))-  runUI . bracket (Gtk.new Gtk.Window []) #destroy $ \window ->-    do-      let markup = testWidget [] start-      first <- create markup-      btn <--        someStateWidget first-        >>= Gtk.unsafeCastTo Gtk.Button-        &   liftIO-      #add window btn-      sub <- subscribe markup first (atomically . writeTBQueue values)-      Gtk.widgetShowAll window-      replicateM_ clicks (Gtk.buttonClicked btn)-      cancel sub+  values <- liftIO (newTBQueueIO (fromIntegral clicks))+  runUI . bracket (Gtk.new Gtk.Window []) #destroy $ \window -> do+    let markup = testWidget [] start+    first <- create markup+    btn   <- someStateWidget first >>= Gtk.unsafeCastTo Gtk.Button & liftIO+    #add window btn+    sub <- subscribe markup first (atomically . writeTBQueue values)+    Gtk.widgetShowAll window+    replicateM_ clicks (Gtk.buttonClicked btn)+    cancel sub -  let expectedValues = take clicks [succ start..]+  let expectedValues = take clicks [succ start ..]   actualValues <- liftIO (atomically (flushTBQueue values))   expectedValues === actualValues @@ -127,20 +120,7 @@       Gtk.set btn [#label Gtk.:= Text.pack (show current)]     return (fromCancellation (GI.signalHandlerDisconnect btn h)) -runUI ma = do-  ret <- liftIO newEmptyMVar-  _ <- Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ do-    ma >>= putMVar ret-    return False-  liftIO (takeMVar ret)--patch' state markup1 markup2 = case patch state markup1 markup2 of-  Keep      -> pure state-  Modify  f -> f-  Replace f -> f- -- * Test collection  tests :: IO Bool-tests =-  checkParallel $$(discover)+tests = checkParallel $$(discover)
+ test/GI/Gtk/Declarative/PatchTest.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module GI.Gtk.Declarative.PatchTest where++import           Control.Exception.Safe+import           Control.Monad                  ( foldM )+import           Control.Monad.IO.Class+import qualified Data.Text                     as Text+import           Data.Text                      ( Text )+import qualified GI.Gtk                        as Gtk+import           GI.Gtk.Declarative+import           GI.Gtk.Declarative.TestWidget+import           GI.Gtk.Declarative.State+import           GI.Gtk.Declarative.TestUtils+import           Hedgehog+import qualified Hedgehog.Gen                  as Gen+import qualified Hedgehog.Range                as Range++prop_history_of_prior_patches_has_no_effect_on_resulting_widget = property $ do+  (first : intermediate) <- forAll (Gen.list (Range.linear 1 100) genTestWidget)+  last'                  <- forAll genTestWidget+  cover 10 "prior include nested widgets" (any isNested (first : intermediate))+  cover 5  "last is nested widget"        (isNested last')+  -- Directly creating the 'last' widget.+  direct      <- assertRight =<< patchAllInNewWindow last' []+  -- Creating and patching all prior widgets before patching with the 'last' widget.+  afterOthers <- assertRight+    =<< patchAllInNewWindow first (intermediate <> pure last')+  -- They (converted back to TestWidgets) should be the same.+  direct === afterOthers+  -- And the result should be equal to the TestWidget we started with.+  afterOthers === setDefaults last'++assertRight :: MonadTest m => Either Text a -> m a+assertRight (Left  err) = annotate (Text.unpack err) >> failure+assertRight (Right a  ) = pure a++patchAll :: SomeState -> Widget event -> [Widget event] -> IO SomeState+patchAll s1 w ws =+  fst <$> foldM (\(s, w1) w2 -> (, w2) <$> patch' s w1 w2) (s1, w) ws++patchAllInNewWindow+  :: MonadIO m => TestWidget -> [TestWidget] -> m (Either Text TestWidget)+patchAllInNewWindow first rest =+  runUI . bracket (Gtk.new Gtk.Window []) #destroy $ \window -> do+    firstState <- create (toTestWidget first)+    #add window =<< someStateWidget firstState+    Gtk.widgetShowAll window+    lastState <- patchAll firstState+                          (toTestWidget first)+                          (map toTestWidget rest)+    fromGtkWidget =<< someStateWidget lastState++-- * Test collection++tests :: IO Bool+tests = checkParallel $$(discover)
+ test/GI/Gtk/Declarative/TestUtils.hs view
@@ -0,0 +1,23 @@+module GI.Gtk.Declarative.TestUtils where++import           Control.Concurrent+import           Control.Monad.IO.Class+import qualified GI.GLib.Constants             as GLib+import qualified GI.Gdk                        as Gdk+import           GI.Gtk.Declarative+import           GI.Gtk.Declarative.State++runUI :: MonadIO m => IO b -> m b+runUI ma = do+  ret <- liftIO newEmptyMVar+  _   <- Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ do+    ma >>= putMVar ret+    return False+  liftIO (takeMVar ret)++patch'+  :: Patchable widget => SomeState -> widget e1 -> widget e2 -> IO SomeState+patch' state markup1 markup2 = case patch state markup1 markup2 of+  Keep      -> pure state+  Modify  f -> f+  Replace f -> f
+ test/GI/Gtk/Declarative/TestWidget.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++module GI.Gtk.Declarative.TestWidget where++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.Void+import qualified GI.Gtk                        as Gtk+import           GI.Gtk.Declarative+import           GI.Gtk.Declarative.EventSource+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+-- in tests, so we represent widgets in property tests using this data+-- structure. We convert between this representation, declarative widgets, and+-- instantiated GTK widgets.+data TestWidget+  = TestButton Text (Maybe Bool)+  | TestCustomWidget (Maybe Text)+  | TestScrolledWindow (Maybe Gtk.PolicyType) TestWidget+  | TestBox (Maybe Gtk.Orientation) [TestBoxChild]+  deriving (Eq, Show)++data TestBoxChild = TestBoxChild BoxChildProperties TestWidget+  deriving (Eq, Show)++isNested :: TestWidget -> Bool+isNested = \case+  TestButton{}                  -> False+  TestCustomWidget{}            -> False+  TestScrolledWindow _ _        -> True+  TestBox            _ children -> not (null children)++class HasGtkDefaults a where+  setDefaults :: a -> a++instance HasGtkDefaults TestWidget where+  setDefaults = \case+    TestButton label useUnderline ->+      TestButton label (useUnderline <|> Just False)+    TestCustomWidget fontName -> TestCustomWidget (fontName <|> Just "Sans 12")+    TestScrolledWindow policy child -> TestScrolledWindow+      (policy <|> Just Gtk.PolicyTypeAutomatic)+      (setDefaults child)+    TestBox orientation children -> TestBox+      (orientation <|> Just Gtk.OrientationHorizontal)+      (map setDefaults children)++instance HasGtkDefaults TestBoxChild where+  setDefaults = \case+    TestBoxChild props child -> TestBoxChild props (setDefaults child)++onlyJusts :: Vector (Maybe a) -> Vector a+onlyJusts = Vector.concatMap (maybe Vector.empty Vector.singleton)++toTestWidget :: TestWidget -> Widget Void+toTestWidget = \case+  TestCustomWidget fontName -> Widget (CustomWidget { .. })+   where+    customParams     = ()+    customAttributes = case fontName of+      Just t  -> [#fontName := t]+      Nothing -> []+    customWidget = Gtk.FontButton+    customCreate () = do+      btn <- Gtk.new Gtk.FontButton []+      return (btn, ())+    customPatch :: () -> () -> () -> CustomPatch Gtk.FontButton ()+    customPatch _ () () = CustomKeep+    customSubscribe+      :: () -> () -> Gtk.FontButton -> (Void -> IO ()) -> IO Subscription+    customSubscribe () () _lbl _cb = do+      return (fromCancellation (pure ()))+  TestButton label useUnderline -> widget+    Gtk.Button+    (onlyJusts [Just (#label := label), (#useUnderline :=) <$> useUnderline])+  TestScrolledWindow policy child -> bin+    Gtk.ScrolledWindow+    (onlyJusts [(#vscrollbarPolicy :=) <$> policy])+    (toTestWidget child)+  TestBox orientation children -> container+    Gtk.Box+    (onlyJusts [(#orientation :=) <$> orientation])+    (Vector.map+      (\(TestBoxChild props child) -> BoxChild props (toTestWidget child))+      (Vector.fromList children)+    )++fromGtkWidget :: (MonadIO m) => Gtk.Widget -> m (Either Text TestWidget)+fromGtkWidget = runExceptT . go+ where+  go :: (MonadIO m) => Gtk.Widget -> ExceptT Text m TestWidget+  go w = do+    name <- #getName w+    case name of+      "GtkButton" -> withCast+        w+        Gtk.Button+        (\btn ->+          TestButton+            <$> Gtk.get btn #label+            <*> (Just <$> Gtk.get btn #useUnderline)+        )+      "GtkFontButton" -> withCast+        w+        Gtk.FontButton+        (\btn -> TestCustomWidget . Just <$> Gtk.get btn #fontName)+      "GtkScrolledWindow" -> withCast w Gtk.ScrolledWindow $ \win -> do+        w' <-+          #getChild win+            >>= maybe (throwError "No viewport in scrolled window") pure+        vscrollbarPolicy <- Just <$> Gtk.get win #vscrollbarPolicy+        withCast w' Gtk.Viewport $ \viewport -> do+          child <-+            #getChild viewport+              >>= maybe (throwError "No child in scrolled window") pure+          TestScrolledWindow vscrollbarPolicy <$> go child+      "GtkBox" -> withCast w Gtk.Box $ \box -> do+        childGtkWidgets <- #getChildren box+        boxChildProps   <- for childGtkWidgets $ \childGtkWidget -> do+          (expand, fill, padding, _) <- #queryChildPacking box childGtkWidget+          pure (BoxChildProperties expand fill padding)+        childWidgets <- traverse go childGtkWidgets+        orientation  <- Just <$> Gtk.get box #orientation+        pure+          (TestBox orientation (zipWith TestBoxChild boxChildProps childWidgets)+          )+      _ -> throwError ("Unsupported TestWidget: " <> name)+  withCast+    :: (MonadIO m, Gtk.GObject w, Gtk.GObject w')+    => w+    -> (Gtk.ManagedPtr w' -> w')+    -> (w' -> ExceptT Text m a)+    -> ExceptT Text m a+  withCast w ctor f = liftIO (Gtk.castTo ctor w) >>= \case+    Just w' -> f w'+    Nothing -> throwError "Failed to cast widget"++-- * Generators++genTestWidget :: Gen TestWidget+genTestWidget = Gen.frequency+  (map (3, ) leaves <> pure+    ( 2+    , Gen.recursive+      Gen.choice+      leaves+      (  subwidgets genTestBoxFrom+      <> [ Gen.subtermM+             genTestWidget+             (\c -> TestScrolledWindow <$> Gen.maybe genPolicyType <*> pure c)+         ]+      )+    )+  )+ where+  leaves = [genCustomWidget, genButton]+  -- In lack of `subtermN` (https://github.com/hedgehogqa/haskell-hedgehog/issues/119), we use this terrible hack:+  subwidgets :: ([TestWidget] -> Gen TestWidget) -> [Gen TestWidget]+  subwidgets f =+    [ f []+    , Gen.subtermM genTestWidget (\w -> f [w])+    , Gen.subtermM2 genTestWidget genTestWidget (\w1 w2 -> f [w1, w2])+    , Gen.subtermM3 genTestWidget+                    genTestWidget+                    genTestWidget+                    (\w1 w2 w3 -> f [w1, w2, w3])+    ]+  genTestBoxFrom ws = do+    children <- for ws $ \w -> do+      props <- genBoxChildProperties+      pure (TestBoxChild props w)+    o <- Gen.maybe genOrientation+    pure (TestBox o children)++genOrientation :: Gen Gtk.Orientation+genOrientation =+  Gen.choice [pure Gtk.OrientationVertical, pure Gtk.OrientationHorizontal]++genPolicyType :: Gen Gtk.PolicyType+genPolicyType = Gen.choice+  (map+    pure+    [ Gtk.PolicyTypeAlways+    , Gtk.PolicyTypeAutomatic+    , Gtk.PolicyTypeExternal+    , Gtk.PolicyTypeNever+    ]+  )++genBoxChildProperties :: Gen BoxChildProperties+genBoxChildProperties =+  BoxChildProperties <$> Gen.bool <*> Gen.bool <*> Gen.word32+    (Range.linear 0 10)++genCustomWidget :: Gen TestWidget+genCustomWidget = do+  TestCustomWidget <$> Gen.maybe (Gen.choice [pure "Sans 10"])++genButton :: Gen TestWidget+genButton = do+  TestButton <$> Gen.text (Range.linear 0 10) Gen.unicode <*> Gen.maybe Gen.bool
test/Main.hs view
@@ -2,21 +2,26 @@  import           Control.Concurrent import           Control.Monad-import qualified GI.Gtk                              as Gtk+import qualified GI.Gtk                        as Gtk import           System.Exit import           System.IO -import qualified GI.Gtk.Declarative.CustomWidgetTest as CustomWidget+import qualified GI.Gtk.Declarative.CustomWidgetTest+                                               as CustomWidget+import qualified GI.Gtk.Declarative.PatchTest  as PatchTest   main :: IO () main = do-  _ <- Gtk.init Nothing-  _ <- forkOS $ do-    results <- sequence [CustomWidget.tests]+  _    <- Gtk.init Nothing+  pass <- newEmptyMVar+  _    <- forkOS $ do+    results <- sequence [CustomWidget.tests, PatchTest.tests]     Gtk.mainQuit-    unless (and results) $ do-      hPutStrLn stderr "Tests failed."-      exitFailure+    putMVar pass (and results)   Gtk.main+  allPassed <- takeMVar pass+  unless allPassed $ do+    hPutStrLn stderr "Tests failed."+    exitFailure