gi-gtk-declarative 0.4.3 → 0.5.0

raw patch · 9 files changed

+127/−94 lines, 9 filesdep +asyncdep +data-default-classdep +hedgehogdep −criteriondep −randomdep ~gi-gobjectdep ~unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies added: async, data-default-class, hedgehog, safe-exceptions, stm

Dependencies removed: criterion, random

Dependency ranges changed: gi-gobject, unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• bench/Benchmark.hs +0/−58
• gi-gtk-declarative.cabal +11/−6
• src/GI/Gtk/Declarative/Attributes/Collected.hs +5/−4
• src/GI/Gtk/Declarative/Container/Box.hs +4/−0
• src/GI/Gtk/Declarative/Container/Paned.hs +4/−0
• src/GI/Gtk/Declarative/CustomWidget.hs +76/−25
• src/GI/Gtk/Declarative/SingleWidget.hs +1/−1
• test/Main.hs +22/−0

@@ -1,3 +1,7 @@+* 0.5.0+  - New `CustomWidget` API:+    - easier-to-use internal state+    - pass-through attributes to top widget * 0.4.0     - Use `Vector` instead of `[]` for child widgets * 0.3.0

@@ -1,58 +0,0 @@-{-# LANGUAGE OverloadedLabels  #-}-{-# LANGUAGE OverloadedLists   #-}-{-# LANGUAGE OverloadedStrings #-}-module Main where--import           Control.Concurrent-import           Control.Monad-import           Criterion.Main-import           Data.Functor             ((<&>))-import           Data.Text-import           Data.Vector              (Vector)-import qualified Data.Vector              as Vector-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 :: Vector Int -> Widget ()-testView ns = bin Window [] $ container Box [] $ ns <&> \n ->-  BoxChild defaultBoxChildProperties { expand  = True-                                     , fill    = True-                                     , padding = 10-                                     }-    $ widget Label [#label := pack (show n), classes ["a", "b"]]--testPatch :: Patchable widget => SomeState -> widget e1 -> widget e2 -> IO SomeState-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 (Vector.enumFromN 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 (Vector.enumFromN 2 101))-          ]-      ]-    Gtk.mainQuit-  Gtk.main

@@ -1,5 +1,5 @@ name:                 gi-gtk-declarative-version:              0.4.3+version:              0.5.0 synopsis:             Declarative GTK+ programming in Haskell description:          A declarative programming model for GTK+ user                       interfaces, implementing support for various widgets@@ -51,6 +51,7 @@                       , GI.Gtk.Declarative.Widget                       , GI.Gtk.Declarative.Widget.Conversions   build-depends:        base >=4.10 && <5+                      , data-default-class     >= 0.1  && <0.2                       , gi-gobject             >= 2    && <3                       , gi-glib                >= 2    && <3                       , gi-gtk                 >= 3    && <4@@ -65,18 +66,22 @@   default-language:     Haskell2010   ghc-options:          -Wall -benchmark gi-gtk-declarative-benchmark+test-suite gi-gtk-declarative-tests   type:              exitcode-stdio-1.0-  hs-source-dirs:    bench-  main-is:           Benchmark.hs+  hs-source-dirs:    test+  main-is:           Main.hs   build-depends:     base                 >= 4        && < 5-                   , criterion >= 1.5.3.0+                   , async                    , gi-glib                    , gi-gdk+                   , gi-gobject                    , gi-gtk                    , gi-gtk-declarative-                   , random+                   , hedgehog >= 1 && < 2+                   , safe-exceptions+                   , stm                    , text                    , vector+                   , unordered-containers   ghc-options:       -Wall -O2 -rtsopts -with-rtsopts=-N -threaded   default-language:  Haskell2010

@@ -124,9 +124,10 @@  -- | 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+updateClasses+  :: Gtk.StyleContext -> ClassSet -> ClassSet -> IO ()+updateClasses ctx old new = do   let toAdd    = HashSet.difference new old       toRemove = HashSet.difference old new-  mapM_ (Gtk.styleContextAddClass sc)    toAdd-  mapM_ (Gtk.styleContextRemoveClass sc) toRemove+  mapM_ (Gtk.styleContextAddClass ctx)    toAdd+  mapM_ (Gtk.styleContextRemoveClass ctx) toRemove

@@ -20,6 +20,7 @@   ) where +import           Data.Default.Class                 (Default (def)) import           Data.Vector                        (Vector) import           Data.Word                          (Word32) import qualified GI.Gtk                             as Gtk@@ -48,6 +49,9 @@ defaultBoxChildProperties :: BoxChildProperties defaultBoxChildProperties =   BoxChildProperties {expand = False, fill = False, padding = 0}++instance Default BoxChildProperties where+  def = defaultBoxChildProperties  instance Patchable BoxChild where   create = create . child

@@ -25,6 +25,7 @@ where  import           Data.Coerce                        (coerce)+import           Data.Default.Class                 (Default (def)) import           Data.Typeable import           Data.Vector                        (Vector) import qualified Data.Vector                        as Vector@@ -57,6 +58,9 @@ -- fields. defaultPaneProperties :: PaneProperties defaultPaneProperties = PaneProperties {resize = False, shrink = True}++instance Default PaneProperties where+  def = defaultPaneProperties  -- | Construct a pane to be packed with -- 'Gtk.panePack1'/'Gtk.panePack2' in a 'Gtk.Paned'.

@@ -1,4 +1,7 @@-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}  -- | While you can instantiate 'Patchable' and 'EventSource' for your -- own data types, it's a bit complicated. The 'CustomWidget' data@@ -11,46 +14,94 @@   ) where -import qualified GI.Gtk                         as Gtk+import           Data.Typeable+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 import           GI.Gtk.Declarative.Patch import           GI.Gtk.Declarative.State  -- | Similar to 'Patch', describing a possible action to perform on a -- 'Gtk.Widget', decided by 'customPatch'.-data CustomPatch widget customData+data CustomPatch widget internalState   = CustomReplace-  | CustomModify (widget -> IO SomeState)+  | CustomModify (widget -> IO internalState)   | CustomKeep  -- | A custom widget specification, with all functions needed to--- instantiate 'Patchable' and 'EventSource'. A custom widget is based--- on a top 'widget', can use 'customData' as a way of passing--- parameters, and emits events of type 'event'.-data CustomWidget widget customData event =+-- instantiate 'Patchable' and 'EventSource'. A custom widget:+--+-- * is based on a top 'widget'+-- * can use 'internalState' as a way of keeping an internal state+--   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 :: customData -> IO SomeState+  , customCreate :: params -> IO (widget, internalState)   -- ^ Action that creates the initial widget-  , customPatch :: SomeState -> customData -> customData -> CustomPatch widget customData+  , customPatch :: params -> params -> internalState -> CustomPatch widget internalState   -- ^ Patch function, calculating a 'CustomPatch' based on the state,-  -- old custom data, and new custom data.-  , customSubscribe :: customData -> widget -> (event -> IO ()) -> IO Subscription+  -- 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-  , customData :: customData-  -- ^ The custom data (e.g. parameters) of 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) -instance Gtk.IsWidget widget => Patchable (CustomWidget widget customData) where-  create custom = customCreate custom (customData custom)-  patch state' old new =-    case customPatch old state' (customData old) (customData new) of-      CustomReplace -> Replace (customCreate new (customData new))-      CustomModify f -> Modify (f =<< Gtk.unsafeCastTo (customWidget new) =<< someStateWidget state')-      CustomKeep -> Keep+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 -instance Gtk.GObject widget => EventSource (CustomWidget widget customData) where-  subscribe custom state' cb = do-    w' <- Gtk.unsafeCastTo (customWidget custom) =<< someStateWidget state'-    customSubscribe custom (customData custom) w' cb+    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)))+  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+      _ -> Replace (create new)++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+      Nothing -> pure (fromCancellation (pure ()))

@@ -70,7 +70,7 @@     case (st, eqT @w1 @w2) of       (StateTreeWidget top, Just Refl) ->         foldMap (addSignalHandler cb (stateTreeWidget top)) props-      _ -> fail ""+      _ -> pure (fromCancellation (pure ()))  -- instance (Typeable widget, Functor (SingleWidget widget)) --   => FromWidget (SingleWidget widget) Widget where

@@ -0,0 +1,22 @@+module Main where++import           Control.Concurrent+import           Control.Monad+import qualified GI.Gtk                              as Gtk+import           System.Exit+import           System.IO++import qualified GI.Gtk.Declarative.CustomWidgetTest as CustomWidget+++main :: IO ()+main = do+  _ <- Gtk.init Nothing+  _ <- forkOS $ do+    results <- sequence [CustomWidget.tests]+    Gtk.mainQuit+    unless (and results) $ do+      hPutStrLn stderr "Tests failed."+      exitFailure+  Gtk.main+