gi-gtk-declarative 0.1.0 → 0.2.0

raw patch · 22 files changed

+953/−459 lines, 22 filesdep +criteriondep +gi-gdkdep +gi-glibdep ~basedep ~gi-gtksetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, gi-gdk, gi-glib, gi-gtk-declarative, random, vector

Dependency ranges changed: base, gi-gtk

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• Setup.hs +0/−2
• bench/Benchmark.hs +51/−0
• gi-gtk-declarative.cabal +23/−2
• src/GI/Gtk/Declarative.hs +9/−8
• src/GI/Gtk/Declarative/Attributes.hs +59/−137
• src/GI/Gtk/Declarative/Attributes/Collected.hs +132/−0
• src/GI/Gtk/Declarative/Attributes/Internal.hs +32/−43
• src/GI/Gtk/Declarative/Attributes/Internal/Conversions.hs +52/−0
• src/GI/Gtk/Declarative/Attributes/Internal/EventHandler.hs +80/−0
• src/GI/Gtk/Declarative/Bin.hs +58/−57
• src/GI/Gtk/Declarative/CSS.hs +0/−35
• src/GI/Gtk/Declarative/Container.hs +65/−46
• src/GI/Gtk/Declarative/Container/Box.hs +1/−1
• src/GI/Gtk/Declarative/Container/Class.hs +23/−0
• src/GI/Gtk/Declarative/Container/MenuItem.hs +137/−0
• src/GI/Gtk/Declarative/Container/Patch.hs +93/−82
• src/GI/Gtk/Declarative/EventSource.hs +6/−5
• src/GI/Gtk/Declarative/Markup.hs +7/−6
• src/GI/Gtk/Declarative/Patch.hs +6/−5
• src/GI/Gtk/Declarative/SingleWidget.hs +34/−30
• src/GI/Gtk/Declarative/State.hs +78/−0

@@ -1,3 +1,10 @@+* 0.2.0+    - Introduce shadow state (breaking change!)+    - Optimized patching (2x-7x faster!)+    - Many bug fixes in patching+    - Reimplement callback conversions+    - Return pairs in declarative event handlers, for non-`()` GTK+ callback return values+ * 0.1.0     - First version of `gi-gtk-declarative`!     - Basic widget without event handling

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedLabels  #-}+{-# LANGUAGE OverloadedLists   #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import           Control.Concurrent+import           Control.Monad+import           Criterion.Main+import           Data.Text+import qualified GI.Gdk                   as Gdk+import qualified GI.GLib.Constants        as GLib++import           GI.Gtk                   (Box (..), Label (..), Window (..))+import qualified GI.Gtk                   as Gtk+import           GI.Gtk.Declarative+import           GI.Gtk.Declarative.State++testView :: [Int] -> Widget ()+testView ns = bin Window [] $ container Box [] $ forM_ ns $ \n ->+  boxChild True True 10+    $ widget Label [#label := pack (show n), classes ["a", "b"]]++testPatch state oldView newView = case patch state oldView newView of+  Modify ma -> do+    ret <- newEmptyMVar+    void . Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ do+      ma >>= putMVar ret+      return False+    takeMVar ret+  _ -> error "Expected a modification."++main :: IO ()+main = do+  _ <- Gtk.init Nothing+  let initialView = testView [1 .. 100]+  initialState <- create initialView+  #showAll =<< someStateWidget initialState+  _ <- forkOS $ do+    defaultMain+      [ bgroup+          "patch"+          [ bench "Modify (equal)" . whnfIO . replicateM_ 10 $ do+            s1 <- testPatch initialState initialView initialView+            void $ testPatch s1 initialView initialView+          , bench "Modify (diff)" . whnfIO . replicateM_ 10 $ do+            s1 <- testPatch initialState initialView initialView+            void $ testPatch s1 initialView (testView [2 .. 101])+          ]+      ]+    Gtk.mainQuit+  Gtk.main

@@ -1,5 +1,5 @@ name:                 gi-gtk-declarative-version:              0.1.0+version:              0.2.0 synopsis:             Declarative GTK+ programming in Haskell description:          A declarative programming model for GTK+ user                       interfaces, implementing support for various widgets@@ -23,16 +23,21 @@ library   exposed-modules:      GI.Gtk.Declarative                       , GI.Gtk.Declarative.Attributes+                      , GI.Gtk.Declarative.Attributes.Collected                       , GI.Gtk.Declarative.Attributes.Internal+                      , GI.Gtk.Declarative.Attributes.Internal.EventHandler+                      , GI.Gtk.Declarative.Attributes.Internal.Conversions                       , GI.Gtk.Declarative.Bin                       , GI.Gtk.Declarative.Container                       , GI.Gtk.Declarative.Container.Box+                      , GI.Gtk.Declarative.Container.Class+                      , GI.Gtk.Declarative.Container.MenuItem                       , GI.Gtk.Declarative.Container.Patch-                      , GI.Gtk.Declarative.CSS                       , GI.Gtk.Declarative.EventSource                       , GI.Gtk.Declarative.Markup                       , GI.Gtk.Declarative.Patch                       , GI.Gtk.Declarative.SingleWidget+                      , GI.Gtk.Declarative.State   build-depends:        base >=4.10 && <4.12                       , gi-gobject             >= 2    && <3                       , gi-gtk                 >= 3    && <4@@ -42,6 +47,22 @@                       , mtl                       , text                       , unordered-containers >= 0.2 && < 0.3+                      , vector   hs-source-dirs:       src   default-language:     Haskell2010   ghc-options:          -Wall++benchmark gi-gtk-declarative-benchmark+  type:              exitcode-stdio-1.0+  hs-source-dirs:    bench+  main-is:           Benchmark.hs+  build-depends:     base                 >= 4        && < 5+                   , criterion+                   , gi-glib+                   , gi-gdk+                   , gi-gtk+                   , gi-gtk-declarative+                   , random+                   , text+  ghc-options:       -Wall -O2 -rtsopts -with-rtsopts=-N -threaded+  default-language:  Haskell2010

@@ -9,11 +9,12 @@   ( module Export   ) where -import           GI.Gtk.Declarative.Attributes    as Export-import           GI.Gtk.Declarative.Bin           as Export-import           GI.Gtk.Declarative.Container     as Export-import           GI.Gtk.Declarative.Container.Box as Export-import           GI.Gtk.Declarative.CSS           as Export-import           GI.Gtk.Declarative.Markup        as Export-import           GI.Gtk.Declarative.Patch         as Export-import           GI.Gtk.Declarative.SingleWidget  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.MenuItem as Export+import           GI.Gtk.Declarative.Markup             as Export+import           GI.Gtk.Declarative.Patch              as Export+import           GI.Gtk.Declarative.SingleWidget       as Export

@@ -1,44 +1,44 @@+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}+ {-# LANGUAGE DataKinds              #-} {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs                  #-}-{-# LANGUAGE KindSignatures         #-} {-# LANGUAGE LambdaCase             #-} {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE OverloadedLabels       #-}-{-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-} {-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}  -- | Attribute lists on declarative objects, supporting the underlying -- attributes from "Data.GI.Base.Attributes", along with CSS class lists, and--- pure and impure event callbacks.+-- pure and impure event EventHandlers.  module GI.Gtk.Declarative.Attributes   ( Attribute(..)-  -- *   , classes+  , afterCreated+  , ClassSet   -- * Event Handling   , on   , onM-  -- * Callbacks-  , ToGtkCallback(..)+  -- * EventHandlers+  , EventHandler(..)   ) where -import           Control.Monad                  (void)-import qualified Data.GI.Base.Attributes        as GI-import qualified Data.GI.Base.Signals           as GI-import qualified Data.HashSet                   as HashSet-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.CSS+import           GI.Gtk.Declarative.Attributes.Internal.EventHandler+import           GI.Gtk.Declarative.Attributes.Internal.Conversions  -- * Attributes @@ -57,6 +57,8 @@       , GI.AttrSetTypeConstraint info setValue       , KnownSymbol attr       , Typeable attr+      , Eq setValue+      , Typeable setValue       )    => GI.AttrLabelProxy (attr :: Symbol) -> setValue -> Attribute widget event   -- | Defines a set of CSS classes for the underlying widget's style context.@@ -65,163 +67,83 @@     :: Gtk.IsWidget widget     => ClassSet     -> Attribute widget event-  -- | Emit events using a pure callback. Use the 'on function instead of this+  -- | Emit events using a pure event handler. Use the 'on' function, instead of this   -- constructor directly.   OnSignalPure     :: ( Gtk.GObject widget        , GI.SignalInfo info-       , callback ~ GI.HaskellCallbackType info-       , Functor (PureCallback callback)-       , ToGtkCallback (PureCallback callback)-       , callback ~ CustomGtkCallback (PureCallback callback)+       , gtkCallback ~ GI.HaskellCallbackType info+       , ToGtkCallback gtkCallback Pure        )     => Gtk.SignalProxy widget info-    -> PureCallback callback event+    -> EventHandler gtkCallback widget Pure event     -> Attribute widget event-  -- | Emit events using an impure callback. Use the 'on function instead of-  -- this constructor directly.+  -- | Emit events using a pure event handler. Use the 'on' function, instead of this+  -- constructor directly.   OnSignalImpure     :: ( Gtk.GObject widget        , GI.SignalInfo info-       , callback ~ GI.HaskellCallbackType info-       , Functor (ImpureCallback callback widget)-       , ToGtkCallback (ImpureCallback callback widget)-       , (widget -> callback) ~ CustomGtkCallback (ImpureCallback callback widget)+       , gtkCallback ~ GI.HaskellCallbackType info+       , ToGtkCallback gtkCallback Impure        )     => Gtk.SignalProxy widget info-    -> ImpureCallback callback widget event+    -> 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 --- | Attributes have a 'Functor' instance that maps events in all event--- callbacks.+-- | A set of CSS classes.+type ClassSet = HashSet Text++-- | Attributes have a 'Functor' instance that maps events in all+-- event handler. instance Functor (Attribute widget) where   fmap f = \case     attr := value -> attr := value     Classes cs -> Classes cs-    OnSignalPure signal cb -> OnSignalPure signal (fmap f cb)-    OnSignalImpure signal cb -> OnSignalImpure signal (fmap f cb)+    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 -- loaded, to be added to the GDK screen. You probably want to do this in your -- entry point when setting up GTK.-classes :: Gtk.IsWidget widget => [Text] -> Attribute widget event+classes :: Gtk.IsWidget widget => [T.Text] -> Attribute widget event classes = Classes . HashSet.fromList --- | Emit events, using a pure callback, by subcribing to the specified+-- | Emit events, using a pure event handler, by subcribing to the specified -- signal. on   :: ( Gtk.GObject widget      , GI.SignalInfo info-     , callback ~ GI.HaskellCallbackType info-     , pure ~ ToPureCallback callback event-     , Functor (PureCallback callback)-     , ToGtkCallback (PureCallback callback)-     , callback ~ CustomGtkCallback (PureCallback callback)+     , gtkCallback ~ GI.HaskellCallbackType info+     , ToGtkCallback gtkCallback Pure+     , ToEventHandler gtkCallback widget Pure+     , userEventHandler ~ UserEventHandler gtkCallback widget Pure event      )   => Gtk.SignalProxy widget info-  -> pure+  -> userEventHandler   -> Attribute widget event-on signal = OnSignalPure signal . PureCallback+on signal = OnSignalPure signal . toEventHandler --- | Emit events, using an impure callback receiving the 'widget' and returning+-- | Emit events, using an impure event handler receiving the 'widget' and returning -- an 'IO' action of 'event', by subcribing to the specified signal. onM   :: ( Gtk.GObject widget      , GI.SignalInfo info-     , callback ~ GI.HaskellCallbackType info-     , impure ~ ToImpureCallback callback event-     , withWidget ~ (widget -> impure)-     , Functor (ImpureCallback callback widget)-     , ToGtkCallback (ImpureCallback callback widget)-     , (widget -> callback) ~ CustomGtkCallback (ImpureCallback callback widget)+     , gtkCallback ~ GI.HaskellCallbackType info+     , ToGtkCallback gtkCallback Impure+     , ToEventHandler gtkCallback widget Impure+     , userEventHandler ~ UserEventHandler gtkCallback widget Impure event      )   => Gtk.SignalProxy widget info-  -> withWidget+  -> userEventHandler   -> Attribute widget event-onM signal = OnSignalImpure signal . ImpureCallback---- * Pure Callbacks---- | Convert a GTK+ callback type to a pure callback type, i.e. a type--- without 'IO'. The pure callback is either a single 'event', or a function of--- the same arity and arguments as the GTK+ callback, but with the 'event' as--- the range.-type family ToPureCallback gtkCallback event where-  ToPureCallback (IO ()) event = event-  ToPureCallback (a -> b) event = a -> ToPureCallback b event---- | A 'PureCallback' holds a pure callback, as defined by 'ToPureCallback'.-data PureCallback callback event where-  PureCallback-    :: (pure ~ ToPureCallback callback event)-    => pure-    -> PureCallback callback event---- The functor instances are pretty annoying, being repeated for each function--- arity. Could this be done in another way?--instance Functor (PureCallback (IO ())) where-  fmap f (PureCallback e) = PureCallback (f e)--instance Functor (PureCallback (x -> IO ())) where-  fmap f (PureCallback g) = PureCallback (f . g)--instance Functor (PureCallback (x -> y -> IO ())) where-  fmap f (PureCallback g) = PureCallback (\x -> f . g x)---- * Impure Callbacks---- | Convert a GTK+ callback type to an impure callback type, i.e. a type--- with 'IO event' as the range, instead of 'IO ()'. The impure callback is--- either a single 'IO event', or a function of the same arity and arguments as--- the GTK+ callback, but with 'IO event' as the range.-type family ToImpureCallback t e where-  ToImpureCallback (IO ()) e  = IO e-  ToImpureCallback (a -> b) e = a -> ToImpureCallback b e---- | An 'ImpureCallback' holds an impure callback, as defined by--- 'ToImpureCallback', but with an extra 'widget' argument. This is so that--- impure callbacks can query their underlying GTK+ widgets for data.-data ImpureCallback callback widget event where-  ImpureCallback-    :: (impure ~ ToImpureCallback callback event)-    => (widget -> impure)-    -> ImpureCallback callback widget event---- The functor instances are pretty annoying, being repeated for each function--- arity. Could this be done in another way?--instance Functor (ImpureCallback (IO ()) widget) where-  fmap f (ImpureCallback g) = ImpureCallback (\w -> f <$> g w)--instance Functor (ImpureCallback (x -> IO ()) widget) where-  fmap f (ImpureCallback g) = ImpureCallback (\w -> fmap f . g w)--instance Functor (ImpureCallback (x -> y -> IO ()) widget) where-  fmap f (ImpureCallback g) = ImpureCallback (\w x -> fmap f . g w x)---- * GTK+ Callback Conversions---- | Internal class for converting user callbacks to gi-gtk callbacks.-class ToGtkCallback userCallback where-  type CustomGtkCallback userCallback :: *-  -- | Converts a user callback, i.e. a pure or an impure callback, back to a-  -- GTK+ callback.-  toGtkCallback :: userCallback event -> (event -> IO ()) -> CustomGtkCallback userCallback--instance ToGtkCallback (PureCallback (IO ())) where-  type CustomGtkCallback (PureCallback (IO ())) = IO ()-  toGtkCallback (PureCallback cb) f = void (f cb)--instance ToGtkCallback (PureCallback (x -> IO ())) where-  type CustomGtkCallback (PureCallback (x -> IO ())) = x -> IO ()-  toGtkCallback (PureCallback cb) f x = void (f (cb x))--instance ToGtkCallback (PureCallback (x -> y -> IO ()))  where-  type CustomGtkCallback (PureCallback (x -> y -> IO ())) = x -> y -> IO ()-  toGtkCallback (PureCallback cb) f x y = void (f (cb x y))+onM signal = OnSignalImpure signal . toEventHandler -instance ToGtkCallback (ImpureCallback (IO ()) widget)  where-  type CustomGtkCallback (ImpureCallback (IO ()) widget) = widget -> IO ()-  toGtkCallback (ImpureCallback cb) f w = void (cb w >>= f)+-- | Provide a EventHandler to modify the widget after it's been created.+afterCreated :: (widget -> IO ()) -> Attribute widget event+afterCreated = AfterCreated

@@ -0,0 +1,132 @@+{-# LANGUAGE DataKinds  #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE RecordWildCards  #-}+{-# LANGUAGE GADTs      #-}+{-# LANGUAGE LambdaCase #-}++-- | Internal helpers for applying attributes and signal handlers to GTK++-- widgets.+module GI.Gtk.Declarative.Attributes.Collected+  ( CollectedProperties+  , Collected(..)+  , collectAttributes+  , constructProperties+  , updateProperties+  , updateClasses+  )+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           Data.Typeable+import           GHC.TypeLits+import           Data.Vector                              ( Vector )++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++-- | 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)++-- | 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+  }++instance Semigroup (Collected widget event) where+  c1 <> c2 =+    Collected+      (collectedClasses c1 <> collectedClasses c2)+      (collectedProperties c1 <> collectedProperties c2)++instance Monoid (Collected widget event) where+  mempty = Collected mempty mempty++-- | Collect declarative markup attributes to the patching-optimized+-- 'Collected' data structure.+collectAttributes :: Vector (Attribute widget event) -> Collected widget event+collectAttributes = foldl' go mempty+ where+  go+    :: Collected widget event+    -> Attribute widget event+    -> Collected widget event+  go Collected {..} = \case+    attr := value -> Collected+      { collectedProperties = HashMap.insert (Text.pack (symbolVal attr))+                                             (CollectedProperty attr value)+                                             collectedProperties+      , ..+      }+    Classes classSet ->+      Collected {collectedClasses = collectedClasses <> classSet, ..}+    _ -> Collected {..}++-- | Create a list of GTK construct operations based on collected+-- properties, used when creating new widgets.+constructProperties+  :: Collected widget event -> [GI.AttrOp widget 'GI.AttrConstruct]+constructProperties c = map+  (\(CollectedProperty attr value) -> attr Gtk.:= value)+  (HashMap.elems (collectedProperties c))++-- | Update the changed properties of a widget, based on the old and new+-- collected properties.+updateProperties+  :: widget -> CollectedProperties widget -> CollectedProperties widget -> IO ()+updateProperties (widget' :: widget) oldProps newProps = do+  let toAdd  = HashMap.elems (HashMap.difference newProps oldProps)+      setOps = mconcat+        (HashMap.elems (HashMap.intersectionWith toMaybeSetOp oldProps newProps)+        )+  GI.set widget' (map (toSetOp (Proxy @widget)) toAdd <> setOps)+ where+  toSetOp+    :: Proxy widget+    -> CollectedProperty widget+    -> Gtk.AttrOp widget 'GI.AttrSet+  toSetOp _ (CollectedProperty attr value) = attr Gtk.:= value++  toMaybeSetOp+    :: CollectedProperty widget+    -> CollectedProperty widget+    -> [Gtk.AttrOp widget 'GI.AttrSet]+  toMaybeSetOp (CollectedProperty attr (v1 :: t1)) (CollectedProperty _ (v2 :: t2))+    = case eqT @t1 @t2 of+      Just Refl | v1 /= v2 -> pure (attr Gtk.:= v2)+      _                    -> mempty++-- | Update the style context's classes to only include the new set of+-- classes (last argument).+updateClasses :: Gtk.StyleContext -> ClassSet -> ClassSet -> IO ()+updateClasses sc old new = do+  let toAdd    = HashSet.difference new old+      toRemove = HashSet.difference old new+  mapM_ (Gtk.styleContextAddClass sc)    toAdd+  mapM_ (Gtk.styleContextRemoveClass sc) toRemove

@@ -1,59 +1,48 @@-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE LambdaCase             #-}+{-# LANGUAGE DataKinds  #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE RecordWildCards  #-}+{-# LANGUAGE GADTs      #-}+{-# LANGUAGE LambdaCase #-}  -- | Internal helpers for applying attributes and signal handlers to GTK+ -- widgets. module GI.Gtk.Declarative.Attributes.Internal-  ( extractAttrConstructOps-  , extractAttrSetOps-  , addClass-  , removeClass+  ( applyAfterCreated   , addSignalHandler-  ) where+  )+where -import qualified Data.GI.Base.Attributes        as GI-import qualified GI.GObject           as GI-import qualified GI.Gtk                         as Gtk-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 -extractAttrConstructOps-  :: Attribute widget event -> [GI.AttrOp widget 'GI.AttrConstruct]-extractAttrConstructOps = \case-  (attr := value) -> pure (attr Gtk.:= value)-  _               -> mempty--extractAttrSetOps :: Attribute widget event -> [GI.AttrOp widget 'GI.AttrSet]-extractAttrSetOps = \case-  (attr := value) -> pure (attr Gtk.:= value)-  _               -> mempty--addClass :: MonadIO m => Gtk.StyleContext -> Attribute widget event -> m ()-addClass sc = \case-  Classes cs -> mapM_ (Gtk.styleContextAddClass sc) cs-  _          -> pure ()--removeClass :: MonadIO m => Gtk.StyleContext -> Attribute widget event -> m ()-removeClass sc = \case-  Classes cs -> mapM_ (Gtk.styleContextRemoveClass sc) cs-  _          -> pure ()+applyAfterCreated :: widget -> Attribute widget event -> IO ()+applyAfterCreated widget = \case+  (AfterCreated f) -> f widget+  _                -> return ()  addSignalHandler   :: (Gtk.IsWidget widget, MonadIO m)   => (event -> IO ())   -> widget   -> Attribute widget event-  -> m (Maybe Subscription)-addSignalHandler onEvent widget' = \case-  OnSignalPure signal handler -> do-    handlerId <- Gtk.on widget' signal (toGtkCallback handler onEvent)-    w         <- Gtk.toWidget widget'-    pure (Just (fromCancellation (GI.signalHandlerDisconnect w handlerId)))-  OnSignalImpure signal handler -> do-    handlerId <- Gtk.on widget' signal (toGtkCallback handler onEvent widget')-    w         <- Gtk.toWidget widget'-    pure (Just (fromCancellation (GI.signalHandlerDisconnect w handlerId)))-  _ -> pure Nothing-+  -> m Subscription+addSignalHandler onEvent widget' = listenToSignal >=> \case+  Just eh -> setupCancellation eh+  Nothing -> pure mempty+ where+  listenToSignal = \case+    OnSignalPure signal handler ->+      Just <$> Gtk.on widget' signal (toGtkCallback handler widget' onEvent)+    OnSignalImpure signal handler ->+      Just <$> Gtk.on widget' signal (toGtkCallback handler widget' onEvent)+    _ -> pure Nothing+  setupCancellation handlerId = do+    w <- Gtk.toWidget widget'+    pure (fromCancellation (GI.signalHandlerDisconnect w handlerId))

@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}++{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module GI.Gtk.Declarative.Attributes.Internal.Conversions+  ( ToGtkCallback(..)+  )+where++import           Control.Monad                            ( void )+import           Data.Functor                             ( ($>) )+import           Data.Functor.Identity++import           GI.Gtk.Declarative.Attributes.Internal.EventHandler++-- * GTK+ EventHandler Conversions++-- | Internal class for converting 'EventHandler's to gi-gtk callbacks.+class ToGtkCallback gtkCallback purity where+  -- | Converts an 'EventHandler', i.e. the internal encoding of a pure or an impure+  -- callback, back to a GTK+ callback. Impure callbacks will also receive a+  -- 'widget' as the last argument.+  toGtkCallback+    :: EventHandler gtkCallback widget purity event+    -> widget+    -> (event -> IO ())+    -> gtkCallback++instance ToGtkCallback (IO ()) Pure where+  toGtkCallback (PureEventHandler (OnlyEvent e)) _ f = void (f (runIdentity e))++instance ToGtkCallback (IO Bool) Pure where+  toGtkCallback (PureEventHandler (ReturnAndEvent re)) _ f =+    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++instance ToGtkCallback (IO Bool) Impure where+  toGtkCallback (ImpureEventHandler r) w f = do+    let ReturnAndEvent re = r w+    (r', e) <- re+    f e+    return r'++instance ToGtkCallback y purity => ToGtkCallback (x -> y) purity where+  toGtkCallback (EventHandlerFunction cb) f w x = toGtkCallback (cb x) f w

@@ -0,0 +1,80 @@+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}++{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+module GI.Gtk.Declarative.Attributes.Internal.EventHandler+  ( Purity(..)+  , EventHandlerReturn(..)+  , EventHandler(..)+  , UserEventHandler+  , ToEventHandler(..)+  )+where++import           Data.Functor.Identity++-- | A 'EventHandler' can be either pure or impure.+data Purity = Pure | Impure++-- | The two supported types of return values in user event handlers are encoded+-- by the 'EventHandlerReturn' type; either you can return only an 'event', or if+-- 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++instance Functor m => Functor (EventHandlerReturn m gtkEventHandler) where+  fmap f = \case+    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++instance Functor (EventHandler gtkEventHandler widget purity) where+  fmap f = \case+    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+-- you'd apply 'on' and 'onM' with) based on the given widget, purity, and event+-- types.+type family UserEventHandler gtkCallback widget (purity :: Purity) event where+  UserEventHandler (IO ())   widget Pure   event = event+  UserEventHandler (IO Bool) widget Pure   event = (Bool, event)+  UserEventHandler (IO ())   widget Impure event = widget -> IO event+  UserEventHandler (IO Bool) widget Impure event = widget -> IO (Bool, event)+  UserEventHandler (a -> b)  widget purity event = a -> UserEventHandler b widget purity event++-- | Internal class for converting user event handlers to encoded 'EventHandler' values.+class ToEventHandler gtkEventHandler widget purity where+  -- | Convert from a user event handler to an 'EventHandler'.+  toEventHandler+    :: UserEventHandler gtkEventHandler widget purity event+    -> EventHandler gtkEventHandler widget purity event++instance ToEventHandler (IO ()) widget Pure where+  toEventHandler = PureEventHandler . OnlyEvent . pure++instance ToEventHandler (IO Bool) widget Pure where+  toEventHandler = PureEventHandler . ReturnAndEvent . pure++instance ToEventHandler (IO ()) widget Impure where+  toEventHandler eh = ImpureEventHandler (OnlyEvent . eh)++instance ToEventHandler (IO Bool) widget Impure where+  toEventHandler eh = ImpureEventHandler (ReturnAndEvent . eh)++instance (ToEventHandler b widget purity) => ToEventHandler (a -> b) widget purity where+  toEventHandler f = EventHandlerFunction (toEventHandler . f)

@@ -4,44 +4,42 @@ {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs                  #-}-{-# LANGUAGE LambdaCase             #-} {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE OverloadedLabels       #-} {-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-} {-# LANGUAGE TypeFamilies           #-} {-# LANGUAGE TypeOperators          #-}  -- | A declarative representation of 'Gtk.Bin' in GTK. module GI.Gtk.Declarative.Bin-  ( Bin+  ( Bin(..)   , bin+  , BinChild   ) where -import           Control.Monad                          ((>=>))-import           Data.Maybe import           Data.Typeable-import qualified GI.GObject                             as GI-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.Attributes.Internal import           GI.Gtk.Declarative.EventSource import           GI.Gtk.Declarative.Markup import           GI.Gtk.Declarative.Patch+import           GI.Gtk.Declarative.State   -- | Supported 'Gtk.Bin's.-class BinChild bin (child :: * -> *) | bin -> child where-  getChild :: bin -> IO Gtk.Widget+class BinChild bin (child :: * -> *) | bin -> child  instance BinChild Gtk.ScrolledWindow Widget where-  getChild scrolledWindow = do-    viewPort <- getBinChild Gtk.Viewport scrolledWindow-    getBinChild Gtk.Widget viewPort- instance BinChild Gtk.ListBoxRow Widget where-  getChild = getBinChild Gtk.Widget+instance BinChild Gtk.Window Widget where+instance BinChild Gtk.Dialog Widget where+instance BinChild Gtk.MenuItem Widget where  -- | Declarative version of a /bin/ widget, i.e. a widget with exactly one -- child.@@ -54,7 +52,7 @@        , Functor child        )     => (Gtk.ManagedPtr widget -> widget)-    -> [Attribute widget event]+    -> Vector (Attribute widget event)     -> child event     -> Bin widget child event @@ -63,8 +61,8 @@     Bin ctor (fmap f <$> attrs) (fmap f child)  -- | Construct a /bin/ widget, i.e. a widget with exactly one child.-bin ::-     ( Patchable (Bin widget child)+bin+  :: ( Patchable (Bin widget child)      , Typeable widget      , Typeable child      , Typeable event@@ -73,10 +71,9 @@      , Gtk.IsBin widget      , Gtk.IsWidget widget      , FromWidget (Bin widget child) event target-     , BinChild widget child      )   => (Gtk.ManagedPtr widget -> widget) -- ^ A bin widget constructor from the underlying gi-gtk library.-  -> [Attribute widget event]          -- ^ List of 'Attribute's.+  -> Vector (Attribute widget event)   -- ^ List of 'Attribute's.   -> child event                       -- ^ The bin's child widget, whose type is decided by the 'BinChild' instance.   -> target                            -- ^ The target, whose type is decided by 'FromWidget'. bin ctor attrs = fromWidget . Bin ctor attrs@@ -86,34 +83,46 @@ --  instance (BinChild parent child, Patchable child) => Patchable (Bin parent child) where-  create (Bin ctor props child) = do-    let attrOps = concatMap extractAttrConstructOps props-    widget' <- Gtk.new ctor attrOps+  create (Bin ctor attrs child) = do+    let collected = collectAttributes attrs+    widget' <- Gtk.new ctor (constructProperties collected)+    Gtk.widgetShow widget'      sc <- Gtk.widgetGetStyleContext widget'-    mapM_ (addClass sc) props--    Gtk.containerAdd widget' =<< create child-    Gtk.toWidget widget'--  patch (Bin _ oldAttributes oldChild) (Bin ctor newAttributes newChild) =-    Modify $ \widget' -> do+    updateClasses sc mempty (collectedClasses collected) -      binWidget <- Gtk.unsafeCastTo ctor widget'-      Gtk.set binWidget (concatMap extractAttrSetOps newAttributes)+    -- TODO:+    -- mapM_ (applyAfterCreated widget') props -      sc <- Gtk.widgetGetStyleContext binWidget-      mapM_ (removeClass sc) oldAttributes-      mapM_ (addClass sc) newAttributes+    childState <- create child+    childWidget <- someStateWidget childState+    Gtk.containerAdd widget' childWidget+    return (SomeState (StateTreeBin (StateTreeNode widget' sc collected ()) childState)) -      childWidget <- getChild binWidget+  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) -      case patch oldChild newChild of-        Modify modify -> modify childWidget-        Replace createNew -> do-          Gtk.containerRemove binWidget childWidget-          Gtk.containerAdd binWidget =<< createNew-        Keep -> return ()+          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+              Gtk.containerAdd binWidget childWidget+              return (SomeState (StateTreeBin top' newChildState))+            Keep -> return (SomeState st)+      _ -> Replace (create (Bin ctor newAttributes newChild))  -- -- EventSource@@ -121,12 +130,13 @@  instance (BinChild parent child, EventSource child) =>          EventSource (Bin parent child) where-  subscribe (Bin ctor props child) widget' cb = do-    binWidget <- Gtk.unsafeCastTo ctor widget'-    handlers' <--      mconcat . catMaybes <$> mapM (addSignalHandler cb binWidget) props-    childWidget <- getChild binWidget-    (<> handlers') <$> subscribe child childWidget cb+  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."  -- -- FromWidget@@ -154,14 +164,5 @@          FromWidget (Bin widget child) event (Markup event a) where   fromWidget = single . Widget ---- | Get a "Gtk.Bin" child, or fail, and cast it to the given widget type.-getBinChild-  :: (Gtk.IsBin bin, GI.GObject child)-  => (Gtk.ManagedPtr child -> child)-  -> bin-  -> IO child-getBinChild ctor =-  Gtk.binGetChild-    >=> maybe (fail "expected Bin to have a child") return-    >=> Gtk.unsafeCastTo ctor+instance FromWidget (Bin widget child) event (Bin widget child event) where+  fromWidget = id

@@ -1,35 +0,0 @@--- | Helpers for modifying CSS classes in 'Gtk.StyleContext'--- objects.--module GI.Gtk.Declarative.CSS where--import           Data.HashSet (HashSet)-import qualified Data.HashSet as HashSet-import           Data.Text    (Text)-import qualified GI.Gtk       as Gtk---- | A set of CSS classes.-type ClassSet = HashSet Text---- | Add the classes to the widget's style context.-addClasses-  :: Gtk.IsWidget w-  => w        -- ^ The widget to add classes to.-  -> ClassSet -- ^ New classes to add.-  -> IO ()-addClasses widget cs = do-  sc <- Gtk.widgetGetStyleContext widget-  mapM_ (Gtk.styleContextAddClass sc) cs---- | Replace all classes in 'old' with the ones in 'old' in the widget's style--- context.-replaceClasses-  :: Gtk.IsWidget w-  => w        -- ^ The widget to replace classes in.-  -> ClassSet -- ^ Old classes to replace.-  -> ClassSet -- ^ New classes to replace with.-  -> IO ()-replaceClasses widget old new = do-  sc <- Gtk.widgetGetStyleContext widget-  mapM_ (Gtk.styleContextRemoveClass sc) (HashSet.difference old new)-  mapM_ (Gtk.styleContextAddClass sc)    (HashSet.difference new old)

@@ -1,36 +1,39 @@ {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE DeriveFunctor          #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE LambdaCase             #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE OverloadedLabels       #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}  -- | Implementations for common "Gtk.Container".  module GI.Gtk.Declarative.Container   ( Container   , container+  , Children   ) where -import           Control.Monad                      (forM_)-import           Data.Maybe+import           Control.Monad                           (forM) import           Data.Typeable-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 import           GI.Gtk.Declarative.Container.Patch import           GI.Gtk.Declarative.EventSource import           GI.Gtk.Declarative.Markup import           GI.Gtk.Declarative.Patch+import           GI.Gtk.Declarative.State  -- | Declarative version of a /container/ widget, i.e. a widget with zero -- or more child widgets. The type of 'children' is parameterized, and differs@@ -45,7 +48,7 @@        , Functor children        )     => (Gtk.ManagedPtr widget -> widget)-    -> [Attribute widget event]+    -> Vector (Attribute widget event)     -> children event     -> Container widget children event @@ -65,12 +68,12 @@      , FromWidget (Container widget (Children child)) event target      )   => (Gtk.ManagedPtr widget -> widget) -- ^ A container widget constructor from the underlying gi-gtk library.-  -> [Attribute widget event]          -- ^ List of 'Attribute's.+  -> Vector (Attribute widget event)          -- ^ List of 'Attribute's.   -> MarkupOf child event ()           -- ^ The container's 'child' widgets, in a 'MarkupOf' builder.   -> target                            -- ^ The target, whose type is decided by 'FromWidget'. container ctor attrs = fromWidget . Container ctor attrs . toChildren -newtype Children child event = Children { unChildren :: [child event] }+newtype Children child event = Children { unChildren :: Vector (child event) }   deriving (Functor)  toChildren :: MarkupOf child event () -> Children child event@@ -80,43 +83,57 @@ -- Patchable -- -instance (Patchable child, IsContainer container child) =>+instance (Patchable child, Typeable child, IsContainer container child) =>          Patchable (Container container (Children child)) where-  create (Container ctor props children) = do-    let attrOps = concatMap extractAttrConstructOps props-    widget' <- Gtk.new ctor attrOps+  create (Container ctor attrs children) = do+    let collected = collectAttributes attrs+    widget' <- Gtk.new ctor (constructProperties collected)+    Gtk.widgetShow widget'     sc <- Gtk.widgetGetStyleContext widget'-    mapM_ (addClass sc) props-    forM_ (unChildren children) $ \child -> do-      childWidget <- create child-      appendChild widget' child childWidget-    Gtk.toWidget widget'-  patch (Container _ oldAttributes oldChildren) (Container ctor newAttributes newChildren) =-    Modify $ \widget' -> do-      containerWidget <- Gtk.unsafeCastTo ctor widget'-      Gtk.set containerWidget (concatMap extractAttrSetOps newAttributes)-      sc <- Gtk.widgetGetStyleContext widget'-      mapM_ (removeClass sc) oldAttributes-      mapM_ (addClass sc) newAttributes-      patchInContainer-        containerWidget-        (unChildren oldChildren)-        (unChildren newChildren)+    updateClasses sc mempty (collectedClasses collected)+    -- TODO:+    -- mapM_ (applyAfterCreated widget') props+    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) +          let top' = top { stateTreeCollectedAttributes = newCollected }+          SomeState <$>+            patchInContainer+              (StateTreeContainer top' childStates)+              containerWidget+              (unChildren oldChildren)+              (unChildren newChildren)+      _ -> Replace (create new)+ -- -- EventSource --  instance (Typeable child, EventSource child) =>          EventSource (Container widget (Children child)) where-  subscribe (Container ctor props children) widget' cb = do-    parentWidget <- Gtk.unsafeCastTo ctor widget'-    handlers' <- mconcat . catMaybes <$> mapM (addSignalHandler cb parentWidget) props-    childWidgets <- Gtk.containerGetChildren parentWidget-    subs <--      flip foldMap (zip (unChildren children) childWidgets) $ \(c, w) ->-        subscribe c w cb-    return (handlers' <> subs)+  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@@ -144,3 +161,5 @@          ) =>          FromWidget (Container widget children) event (Markup event a) where   fromWidget = single . Widget+instance FromWidget (Container widget children) event (Container widget children event) where+  fromWidget = id

@@ -46,7 +46,7 @@  instance Patchable BoxChild where   create = create . child-  patch b1 b2 = patch (child b1) (child b2)+  patch s b1 b2 = patch s (child b1) (child b2)  instance EventSource BoxChild where   subscribe BoxChild{..} = subscribe child

@@ -0,0 +1,23 @@+{-# LANGUAGE FunctionalDependencies #-}+module GI.Gtk.Declarative.Container.Class where++import qualified GI.Gtk                           as Gtk+import           Data.Int                         (Int32)++-- | Describes supported GTK+ containers and their specialized APIs for+-- appending and replacing child widgets.+class IsContainer container child | container -> child where+  -- | Append a child widget to the container.+  appendChild+    :: container    -- ^ Container widget+    -> child event  -- ^ Declarative child widget+    -> Gtk.Widget   -- ^ GTK child widget to append+    -> IO ()+  -- | Replace the child widget at the given index in the container.+  replaceChild+    :: container    -- ^ Container widget+    -> child event  -- ^ Declarative child widget+    -> Int32        -- ^ Index to replace at+    -> Gtk.Widget   -- ^ Old GTK widget to replace+    -> Gtk.Widget   -- ^ New GTK widget to replace with+    -> IO ()

@@ -0,0 +1,137 @@+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors -fno-warn-orphans #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE LambdaCase             #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE OverloadedLabels       #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}++module GI.Gtk.Declarative.Container.MenuItem+  ( MenuItem+  , menuItem+  , subMenu+  )+where++import           Data.Text                                ( Text )+import           Data.Typeable+import           Data.Vector                              ( Vector )+import qualified GI.Gtk                        as Gtk++import           GI.Gtk.Declarative.Attributes+import           GI.Gtk.Declarative.Bin+import           GI.Gtk.Declarative.Container+import           GI.Gtk.Declarative.Container.Patch+import           GI.Gtk.Declarative.EventSource+import           GI.Gtk.Declarative.Markup+import           GI.Gtk.Declarative.Patch+import           GI.Gtk.Declarative.State++data MenuItem event where+  MenuItem+    :: (Gtk.IsMenuItem item, BinChild item Widget, Typeable item)+    => Bin item Widget event+    -> MenuItem event+  SubMenu+    :: Text -> (Container Gtk.Menu (Children MenuItem) event) -> MenuItem event++instance Functor MenuItem where+  fmap f (MenuItem item) = MenuItem (fmap f item)+  fmap f (SubMenu label subMenu')= SubMenu label (fmap f subMenu')++menuItem+  :: ( Gtk.IsMenuItem item+     , Typeable event+     , BinChild item Widget+     , Typeable item+     , Gtk.IsContainer item+     , Gtk.IsBin item+     , Gtk.IsWidget item+     )+  => (Gtk.ManagedPtr item -> item)+  -> Vector (Attribute item event)+  -> Widget event+  -> MarkupOf MenuItem event ()+menuItem item attrs = single . MenuItem . Bin item attrs++subMenu+  :: (Typeable event)+  => Text+  -> MarkupOf MenuItem event ()+  -> MarkupOf MenuItem event ()+subMenu label = single . SubMenu label . container Gtk.Menu mempty++newSubMenuItem :: Text -> IO SomeState -> IO SomeState+newSubMenuItem label createSubMenu = do+  menuItem' <- Gtk.menuItemNewWithLabel label+  sc        <- Gtk.widgetGetStyleContext menuItem'+  SomeState (subMenuState :: StateTree st subMenu children e1 cs) <- createSubMenu+  case eqT @subMenu @Gtk.Menu of+    Just Refl -> do+      Gtk.menuItemSetSubmenu menuItem' (Just (stateTreeNodeWidget subMenuState))+      return+        (SomeState+          (StateTreeBin (StateTreeNode menuItem' sc mempty ())+                        (SomeState subMenuState)+          )+        )+    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')+  patch state (MenuItem (c1 :: Bin i1 Widget e1)) (MenuItem (c2 :: Bin i2 Widget 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 _ _ 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."++instance IsContainer Gtk.MenuShell MenuItem where+  appendChild shell _ widget' =+    Gtk.menuShellAppend shell =<< Gtk.unsafeCastTo Gtk.MenuItem widget'+  replaceChild shell _ i old new = do+    Gtk.containerRemove shell old+    menuItem' <- Gtk.unsafeCastTo Gtk.MenuItem new+    Gtk.menuShellInsert shell menuItem' i+    Gtk.widgetShowAll shell++instance IsContainer Gtk.MenuBar MenuItem where+  appendChild menuBar d w = do+    s <- Gtk.toMenuShell menuBar+    appendChild s d w+  replaceChild menuBar d i old new = do+    s <- Gtk.toMenuShell menuBar+    replaceChild s d i old new++instance IsContainer Gtk.Menu MenuItem where+  appendChild menuBar d w = do+    s <- Gtk.toMenuShell menuBar+    appendChild s d w+  replaceChild menuBar d i old new = do+    s <- Gtk.toMenuShell menuBar+    replaceChild s d i old new

@@ -1,49 +1,36 @@-{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors -fno-warn-orphans #-} -{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE LambdaCase             #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE OverloadedLabels       #-}-{-# LANGUAGE RecordWildCards        #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE OverloadedLists       #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}  -- | This module implements the patch algorithm for containers.-module GI.Gtk.Declarative.Container.Patch (IsContainer(..), patchInContainer) where+module GI.Gtk.Declarative.Container.Patch+  ( IsContainer(..)+  , patchInContainer+  )+where -import           Control.Monad                    (forM_)-import           Data.Int                         (Int32)-import           Data.List                        (zip4)-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.Bin import           GI.Gtk.Declarative.Container.Box+import           GI.Gtk.Declarative.Container.Class import           GI.Gtk.Declarative.Markup import           GI.Gtk.Declarative.Patch----- | Describes supported GTK+ containers and their specialized APIs for--- appending and replacing child widgets.-class IsContainer container child | container -> child where-  -- | Append a child widget to the container.-  appendChild-    :: container    -- ^ Container widget-    -> child event  -- ^ Declarative child widget-    -> Gtk.Widget   -- ^ GTK child widget to append-    -> IO ()-  -- | Replace the child widget at the given index in the container.-  replaceChild-    :: container    -- ^ Container widget-    -> child event  -- ^ Declarative child widget-    -> Int32        -- ^ Index to replace at-    -> Gtk.Widget   -- ^ Old GTK widget to replace-    -> Gtk.Widget   -- ^ New GTK widget to replace with-    -> IO ()+import           GI.Gtk.Declarative.State  -- | Patch all children in a container. This does not feature any ID checking, -- as seen in React, so reordering children in a container can produce many@@ -54,67 +41,91 @@      , Patchable child      , IsContainer container child      )-  => container-  -> [child e1]-  -> [child e2]-  -> IO ()-patchInContainer container os' ns' = do-  cs <- Gtk.containerGetChildren container-  let maxLength = maximum [length cs, length os', length ns']-      indices   = [0 .. pred (fromIntegral maxLength)]-  forM_ (zip4 indices (padMaybes cs) (padMaybes os') (padMaybes ns')) $ \case+  => StateTree 'ContainerState container child event cs+  -> container+  -> Vector (child e1)+  -> Vector (child e2)+  -> IO (StateTree 'ContainerState container child event cs)+patchInContainer (StateTreeContainer top children) container os' ns' = do+  let maxLength = maximum ([length children, length os', length ns'] :: [Int])+      indices   = Vector.enumFromN 0 (fromIntegral maxLength)+  newChildren <- foldMap+    go+    (Vector.zip4 indices+                 (padMaybes maxLength children)+                 (padMaybes maxLength os')+                 (padMaybes maxLength ns')+    ) -    -- In case we have a corresponding old and new declarative widget, we patch-    -- the GTK widget.-    (i, Just w, Just old, Just new) -> case patch old new of-      Modify  modify       -> modify w-      Replace createWidget -> replaceChild container new i w =<< createWidget-      Keep                 -> return ()+  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) -    -- 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 w, Nothing, Just new) ->-      replaceChild container new i w =<< create new+      -- 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 ) -> create n >>= appendChild container n+      -- 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 an declarative widget has been removed, remove the GTK widget from-    -- the container.-    (_i, Just w , Just _ , Nothing) -> Gtk.containerRemove container w+      -- 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 ()+      -- 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 w , Nothing, Nothing) -> Gtk.containerRemove container w+      -- 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 ()+      -- No more GTK widgets or declarative widgets, we are done.+      (_i, Nothing, Nothing, Nothing) -> return Vector.empty -  Gtk.widgetQueueResize container+padMaybes :: Int -> Vector a -> Vector (Maybe a)+padMaybes len xs = Vector.generate len (xs !?)  instance IsContainer Gtk.ListBox (Bin Gtk.ListBoxRow Widget) where-  appendChild box _ widget' = Gtk.listBoxInsert box widget' (-1)+  appendChild box _ widget' =+    Gtk.listBoxInsert box widget' (-1)   replaceChild box _ i old new = do-    Gtk.containerRemove box old+    Gtk.widgetDestroy old     Gtk.listBoxInsert box new i-    Gtk.widgetShowAll box  instance IsContainer Gtk.Box BoxChild where   appendChild box BoxChild {..} widget' =     Gtk.boxPackStart box widget' expand fill padding-   replaceChild box boxChild' i old new = do-    Gtk.containerRemove box old+    Gtk.widgetDestroy old     appendChild box boxChild' new     Gtk.boxReorderChild box new i-    Gtk.widgetShowAll box--padMaybes :: [a] -> [Maybe a]-padMaybes xs = map Just xs ++ repeat Nothing

@@ -1,18 +1,19 @@-{-# LANGUAGE FunctionalDependencies     #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-}  -- | Event handling for declarative widgets. module GI.Gtk.Declarative.EventSource-  ( EventSource (..)+  ( EventSource(..)   , Subscription   , fromCancellation   , cancel   ) where -import qualified GI.Gtk               as Gtk+import           Data.Vector              (Vector) +import           GI.Gtk.Declarative.State+ -- | Cancel a 'Subscription', meaning that the callback will not be invoked on -- any subsequent signal emissions. cancel :: Subscription -> IO ()@@ -23,7 +24,7 @@ class EventSource widget where   subscribe     :: widget event     -- ^ Declarative widget with event handlers.-    -> Gtk.Widget       -- ^ Actual 'Gtk.Widget' that has been created or patched.+    -> SomeState        -- ^ State of rendered widget tree.     -> (event -> IO ()) -- ^ Event callback, invoked on each emitted event until                         -- the 'Subscription' is cancelled, or widget is otherwise                         -- destroyed.@@ -33,7 +34,7 @@ -- handlers (to a tree of widgets.) When subscribing to a container widget, all -- child widgets are also subscribed to, and the 'Subscription's are combined -- using the 'Semigroup' instance.-newtype Subscription = Subscription { cancellations :: [IO ()] }+newtype Subscription = Subscription { cancellations :: Vector (IO ()) }   deriving (Semigroup, Monoid)  -- | Create a subscription from a cancellation IO action.

@@ -29,6 +29,7 @@  import           Control.Monad.Writer import           Data.Typeable+import           Data.Vector                    (Vector)  import           GI.Gtk.Declarative.EventSource import           GI.Gtk.Declarative.Patch@@ -54,9 +55,9 @@ -- widget instances. instance Patchable Widget where   create (Widget w) = create w-  patch (Widget (w1 :: t1 e1)) (Widget (w2 :: t2 e2)) =+  patch s (Widget (w1 :: t1 e1)) (Widget (w2 :: t2 e2)) =     case eqT @t1 @t2 of-      Just Refl -> patch w1 w2+      Just Refl -> patch s w1 w2       _         -> Replace (create w2)  instance EventSource Widget where@@ -74,11 +75,11 @@ -- technical necessity to have the 'Monad' instance. You can still use it if -- you need to return a value from a markup function, though. newtype MarkupOf widget event a =-  MarkupOf (Writer [widget event] a)+  MarkupOf (Writer (Vector (widget event)) a)   deriving (Functor, Applicative, Monad)  -- | Run a 'MarkupOf' builder and get its widgets.-runMarkup :: MarkupOf widget event () -> [widget event]+runMarkup :: MarkupOf widget event () -> Vector (widget event) runMarkup (MarkupOf w) = execWriter w  -- | Handy type alias for the common case of markup containing 'Widget's.@@ -86,10 +87,10 @@  -- | Construct markup from a single widget. single :: widget event -> MarkupOf widget event ()-single w = MarkupOf (tell [w])+single = MarkupOf . tell . pure  -- | Construct markup from multiple widgets.-multiple :: [widget event] -> MarkupOf widget event ()+multiple :: Vector (widget event) -> MarkupOf widget event () multiple = MarkupOf . tell  -- | Convert a widget to a target type. This is deliberately unconstrained in

@@ -1,21 +1,22 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes            #-} +-- | The central patching type class of this library. module GI.Gtk.Declarative.Patch   ( Patch(..)   , Patchable(..)   ) where -import qualified GI.Gtk as Gtk+import           GI.Gtk.Declarative.State  -- | A possible action to take on an existing 'Gtk.Widget', decided by the -- 'patch' method when comparing declarative widgets. data Patch-  = Modify (Gtk.Widget -> IO ())+  = Modify (IO SomeState)   -- ^ An 'IO' action to apply to a 'Gtk.Widget' to make it reflect an updated   -- declarative widget. The action to apply is calculated from the difference   -- between the old and the new declarative widget.-  | Replace (IO Gtk.Widget)+  | Replace (IO SomeState)   -- ^ Replace the current 'Gtk.Widget' by the widget returned by the IO   -- action.   | Keep@@ -28,7 +29,7 @@   -- | Given a declarative widget that is 'Patchable', return an IO action that   -- can create a new corresponding 'Gtk.Widget'. The created widget should be   -- use in corresponding patch modifications, until it is replaced.-  create :: widget e -> IO Gtk.Widget+  create :: widget e -> IO SomeState   -- | Given two declarative widgets of the same widget type (but not   -- necessarily of the same event types,) calculate a 'Patch'.-  patch :: widget e1 -> widget e2 -> Patch+  patch :: SomeState -> widget e1 -> widget e2 -> Patch

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}@@ -16,22 +17,24 @@   ) where -import           Data.Maybe import           Data.Typeable-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.Attributes.Internal import           GI.Gtk.Declarative.EventSource import           GI.Gtk.Declarative.Markup import           GI.Gtk.Declarative.Patch+import           GI.Gtk.Declarative.State  -- | 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))     => (Gtk.ManagedPtr widget -> widget)-    -> [Attribute widget event]+    -> Vector (Attribute widget event)     -> SingleWidget widget event  instance Functor (SingleWidget widget) where@@ -39,35 +42,36 @@  instance Patchable (SingleWidget widget) where   create = \case-    (SingleWidget ctor props) -> do-        let attrOps = concatMap extractAttrConstructOps props-        widget' <- Gtk.new ctor attrOps-+    SingleWidget ctor attrs -> do+        let collected = collectAttributes attrs+        widget' <- Gtk.new ctor (constructProperties collected)+        Gtk.widgetShow widget'         sc <- Gtk.widgetGetStyleContext widget'-        mapM_ (addClass sc) props+        updateClasses sc mempty (collectedClasses collected)+        -- TODO:+        -- mapM_ (applyAfterCreated widget') props -        Gtk.widgetShowAll widget'-        Gtk.toWidget widget'-  patch (SingleWidget (_    :: Gtk.ManagedPtr w1 -> w1) oldAttributes)+        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 eqT @w1 @w2 of-      Just Refl ->-        Modify $ \widget' -> do-          w <- Gtk.unsafeCastTo ctor widget'-          Gtk.set w (concatMap extractAttrSetOps newAttributes)--          sc <- Gtk.widgetGetStyleContext widget'-          mapM_ (removeClass sc) oldAttributes-          mapM_ (addClass sc) newAttributes--          Gtk.widgetShowAll w--      Nothing -> Replace (create (SingleWidget ctor 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 }))+      _ -> Replace (create (SingleWidget ctor newAttributes))  instance EventSource (SingleWidget widget) where-  subscribe (SingleWidget ctor props) widget' cb = do-    w <- Gtk.unsafeCastTo ctor widget'-    mconcat . catMaybes <$> mapM (addSignalHandler cb w) props+  subscribe (SingleWidget (_ :: Gtk.ManagedPtr w1 -> w1) props) (SomeState (st :: StateTree stateType w2 child event cs)) cb = do+    case (st, eqT @w1 @w2) of+      (StateTreeWidget top, Just Refl) ->+        foldMap (addSignalHandler cb (stateTreeWidget top)) props+      _ -> fail ""  instance (Typeable widget, Functor (SingleWidget widget))   => FromWidget (SingleWidget widget) event (Widget event) where@@ -81,14 +85,14 @@   fromWidget = single . Widget  -- | Construct a /leaf/ widget, i.e. one without any children.-widget ::-     ( Typeable widget+widget+  :: ( Typeable widget      , Typeable event      , Functor (Attribute widget)      , Gtk.IsWidget widget      , FromWidget (SingleWidget widget) event target      )   => (Gtk.ManagedPtr widget -> widget) -- ^ A widget constructor from the underlying gi-gtk library.-  -> [Attribute widget event]          -- ^ List of 'Attribute's.+  -> Vector (Attribute widget event)   -- ^ List of 'Attribute's.   -> target                            -- ^ The target, whose type is decided by 'FromWidget'. widget ctor = fromWidget . SingleWidget ctor

@@ -0,0 +1,78 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes     #-}+-- | The 'StateTree' and 'SomeState' form a "shadow state"+-- representation, used in patching. Declarative widgets can return,+-- and later on reuse, its underlying GTK+ widget, collected+-- properties and classes, style context, custom internal state, and+-- child states. This reduces the need for querying GTK+ widgets+-- excessively, and recalculating/resetting, greatly improving the+-- performance of patching.+module GI.Gtk.Declarative.State where++import           Data.Typeable++import           Data.Vector                             (Vector)+import qualified GI.Gtk                                  as Gtk++import           GI.Gtk.Declarative.Attributes.Collected+import           GI.Gtk.Declarative.Container.Class++-- | A 'Data.Dynamic.Dynamic'-like container of a 'StateTree' value.+data SomeState where+  SomeState+    :: ( Gtk.IsWidget widget+      , Typeable widget+      , Typeable customState+      )+    => StateTree stateType widget child event customState+    -> SomeState++-- | The types of state trees that are available, matching the types+-- of GTK+ widgets (single widget, bin, and container.)+data StateType = WidgetState | BinState | ContainerState++-- | A state tree for a specific 'widget'. This is built up recursively+-- to contain child state trees, for bin and container child widgets.+data StateTree (stateType :: StateType) widget child event customState where+  StateTreeWidget+    :: !(StateTreeNode widget event customState)+    -> StateTree 'WidgetState widget child event customState+  StateTreeBin+    :: !(StateTreeNode widget event customState)+    -> SomeState+    -> StateTree 'BinState widget child event customState+  StateTreeContainer+    :: ( Gtk.IsContainer widget+       , IsContainer widget child+       )+    => !(StateTreeNode widget event customState)+    -> Vector SomeState+    -> StateTree 'ContainerState widget child event customState++-- | The common structure for all state tree nodes.+data StateTreeNode widget event customState = StateTreeNode+  { stateTreeWidget              :: !widget+  , stateTreeStyleContext        :: !Gtk.StyleContext+  , stateTreeCollectedAttributes :: !(Collected widget event)+  , stateTreeCustomState         :: customState+  }++-- * Convenience accessor functions++-- | Get the common state tree node information.+stateTreeNode+  :: StateTree stateType widget child event customState+  -> StateTreeNode widget event customState+stateTreeNode (StateTreeWidget s     ) = s+stateTreeNode (StateTreeBin       s _) = s+stateTreeNode (StateTreeContainer s _) = s++-- | Get the specific type of GTK+ widget of a state tree.+stateTreeNodeWidget :: StateTree stateType widget child event customState -> widget+stateTreeNodeWidget = stateTreeWidget . stateTreeNode++-- | Get the GTK+ widget, cast to 'Gtk.Widget', of /some/ state tree.+someStateWidget :: SomeState -> IO Gtk.Widget+someStateWidget (SomeState st) = Gtk.toWidget (stateTreeNodeWidget st)