packages feed

gi-gtk-declarative 0.2.0 → 0.3.0

raw patch · 17 files changed

+421/−255 lines, 17 filesdep ~basedep ~criteriondep ~gi-glib

Dependency ranges changed: base, criterion, gi-glib

Files

CHANGELOG.md view
@@ -1,3 +1,8 @@+* 0.3.0+    - Add user documentation+    - Use record for `BoxChild` properties (breaking change!)+    - Use lists for child widgets instead of `MarkupOf` monad (breaking change!)+    - Add support for `Paned` widget * 0.2.0     - Introduce shadow state (breaking change!)     - Optimized patching (2x-7x faster!)
bench/Benchmark.hs view
@@ -6,6 +6,7 @@ import           Control.Concurrent import           Control.Monad import           Criterion.Main+import           Data.Functor             ((<&>)) import           Data.Text import qualified GI.Gdk                   as Gdk import qualified GI.GLib.Constants        as GLib@@ -16,10 +17,14 @@ import           GI.Gtk.Declarative.State  testView :: [Int] -> Widget ()-testView ns = bin Window [] $ container Box [] $ forM_ ns $ \n ->-  boxChild True True 10+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
gi-gtk-declarative.cabal view
@@ -1,5 +1,5 @@ name:                 gi-gtk-declarative-version:              0.2.0+version:              0.3.0 synopsis:             Declarative GTK+ programming in Haskell description:          A declarative programming model for GTK+ user                       interfaces, implementing support for various widgets@@ -15,11 +15,19 @@ author:               Oskar Wickström maintainer:           oskar.wickstrom@gmail.com copyright:            Oskar Wickström+homepage:             https://github.com/owickstrom/gi-gtk-declarative+bug-reports:          https://github.com/owickstrom/gi-gtk-declarative/issues category:             Graphics build-type:           Simple cabal-version:        >=1.10 extra-source-files:   CHANGELOG.md+tested-with:          GHC == 8.6.3 +source-repository head+  type:     git+  location: https://github.com/owickstrom/gi-gtk-declarative++ library   exposed-modules:      GI.Gtk.Declarative                       , GI.Gtk.Declarative.Attributes@@ -28,18 +36,23 @@                       , GI.Gtk.Declarative.Attributes.Internal.EventHandler                       , GI.Gtk.Declarative.Attributes.Internal.Conversions                       , GI.Gtk.Declarative.Bin+                      , GI.Gtk.Declarative.CustomWidget                       , GI.Gtk.Declarative.Container                       , GI.Gtk.Declarative.Container.Box                       , GI.Gtk.Declarative.Container.Class+                      , GI.Gtk.Declarative.Container.ListBox                       , GI.Gtk.Declarative.Container.MenuItem+                      , GI.Gtk.Declarative.Container.Paned                       , GI.Gtk.Declarative.Container.Patch                       , 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.Gtk.Declarative.Widget+                      , GI.Gtk.Declarative.Widget.Conversions+  build-depends:        base >=4.10 && <5                       , gi-gobject             >= 2    && <3+                      , gi-glib                >= 2    && <3                       , gi-gtk                 >= 3    && <4                       , haskell-gi             >= 0.21 && <0.22                       , haskell-gi-base        >= 0.21 && <0.22@@ -57,7 +70,7 @@   hs-source-dirs:    bench   main-is:           Benchmark.hs   build-depends:     base                 >= 4        && < 5-                   , criterion+                   , criterion >= 1.5.3.0                    , gi-glib                    , gi-gdk                    , gi-gtk
src/GI/Gtk/Declarative.hs view
@@ -14,7 +14,11 @@ 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.Markup             as Export+import           GI.Gtk.Declarative.Container.Paned    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/Bin.hs view
@@ -27,9 +27,9 @@ 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+import           GI.Gtk.Declarative.Widget   -- | Supported 'Gtk.Bin's.@@ -38,6 +38,7 @@ instance BinChild Gtk.ScrolledWindow Widget where instance BinChild Gtk.ListBoxRow Widget where instance BinChild Gtk.Window Widget where+instance BinChild Gtk.ApplicationWindow Widget where instance BinChild Gtk.Dialog Widget where instance BinChild Gtk.MenuItem Widget where @@ -70,12 +71,12 @@      , Gtk.IsContainer widget      , Gtk.IsBin widget      , Gtk.IsWidget widget-     , FromWidget (Bin widget child) event target+     , FromWidget (Bin widget child) target      )   => (Gtk.ManagedPtr widget -> widget) -- ^ A bin widget constructor from the underlying gi-gtk library.   -> 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'.+  -> target event                      -- ^ The target, whose type is decided by 'FromWidget'. bin ctor attrs = fromWidget . Bin ctor attrs  --@@ -91,8 +92,7 @@     sc <- Gtk.widgetGetStyleContext widget'     updateClasses sc mempty (collectedClasses collected) -    -- TODO:-    -- mapM_ (applyAfterCreated widget') props+    mapM_ (applyAfterCreated widget') attrs      childState <- create child     childWidget <- someStateWidget childState@@ -138,31 +138,9 @@         (<> handlers') <$> subscribe child childState cb       _ -> error "Cannot subscribe to Bin events with a non-bin state tree." ------ FromWidget---+instance (a ~ b, c ~ d) => FromWidget (Bin a c) (Bin b d) where+  fromWidget = id -instance ( BinChild widget child-         , Typeable widget-         , Patchable child-         , EventSource child-         , Functor (Bin widget child)-         ) =>-         FromWidget (Bin widget child) event (Widget event) where+instance (BinChild widget child, Patchable child, EventSource child)+         => FromWidget (Bin widget child) Widget where   fromWidget = Widget--instance a ~ () => FromWidget (Bin widget child) event (MarkupOf (Bin widget child) event a) where-  fromWidget = single--instance ( BinChild widget child-         , a ~ ()-         , Typeable widget-         , Patchable child-         , EventSource child-         , Functor (Bin widget child)-         ) =>-         FromWidget (Bin widget child) event (Markup event a) where-  fromWidget = single . Widget--instance FromWidget (Bin widget child) event (Bin widget child event) where-  fromWidget = id
src/GI/Gtk/Declarative/Container.hs view
@@ -1,15 +1,17 @@ {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedLabels      #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DefaultSignatures      #-}+{-# LANGUAGE DeriveFunctor          #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE OverloadedLabels       #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}  -- | Implementations for common "Gtk.Container". @@ -17,6 +19,7 @@   ( Container   , container   , Children+  , ToChildren(..)   ) where @@ -29,11 +32,12 @@ import           GI.Gtk.Declarative.Attributes import           GI.Gtk.Declarative.Attributes.Collected import           GI.Gtk.Declarative.Attributes.Internal+import           GI.Gtk.Declarative.Container.Class 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+import           GI.Gtk.Declarative.Widget  -- | Declarative version of a /container/ widget, i.e. a widget with zero -- or more child widgets. The type of 'children' is parameterized, and differs@@ -65,19 +69,14 @@      , Functor child      , Gtk.IsWidget widget      , Gtk.IsContainer widget-     , FromWidget (Container widget (Children child)) event target+     , 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)          -- ^ 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 :: Vector (child event) }-  deriving (Functor)--toChildren :: MarkupOf child event () -> Children child event-toChildren = Children . runMarkup+  -> 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'.+container ctor attrs = fromWidget . Container ctor attrs . toChildren ctor  -- -- Patchable@@ -91,8 +90,7 @@     Gtk.widgetShow widget'     sc <- Gtk.widgetGetStyleContext widget'     updateClasses sc mempty (collectedClasses collected)-    -- TODO:-    -- mapM_ (applyAfterCreated widget') props+    mapM_ (applyAfterCreated widget') attrs     childStates <-       forM (unChildren children) $ \child -> do         childState <- create child@@ -145,21 +143,8 @@          , EventSource (Container widget children)          , Functor (Container widget children)          ) =>-         FromWidget (Container widget children) event (Widget event) where+         FromWidget (Container widget children) Widget where   fromWidget = Widget -instance a ~ () =>-         FromWidget (Container widget children) event (MarkupOf (Container widget children) event a) where-  fromWidget = single--instance ( a ~ ()-         , Typeable widget-         , Typeable children-         , Patchable (Container widget children)-         , EventSource (Container widget children)-         , Functor (Container widget children)-         ) =>-         FromWidget (Container widget children) event (Markup event a) where-  fromWidget = single . Widget-instance FromWidget (Container widget children) event (Container widget children event) where+instance a ~ b => FromWidget (Container a children) (Container b children) where   fromWidget = id
src/GI/Gtk/Declarative/Container/Box.hs view
@@ -1,48 +1,51 @@-{-# 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 RecordWildCards        #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors -fno-warn-orphans #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}  -- | Implementation of 'Gtk.Box' as a declarative container. module GI.Gtk.Declarative.Container.Box-  ( BoxChild(..)-  , boxChild+  ( BoxChild (..)+  , BoxChildProperties (..)+  , defaultBoxChildProperties   ) where -import           Data.Word                      (Word32)+import           Data.Word                          (Word32)+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.Markup+import           GI.Gtk.Declarative.Widget --- | Described a child widget to be added with 'boxAppend' to a 'Box'.+-- | Describes a child widget to be added with 'boxAppend' to a 'Box'. data BoxChild event = BoxChild+  { properties :: BoxChildProperties+  , child      :: Widget event+  }+  deriving (Functor)++-- | Values used when /packing/ child widgets into boxes.+data BoxChildProperties = BoxChildProperties   { expand  :: Bool   , fill    :: Bool   , padding :: Word32-  , child   :: Widget event   }-  deriving (Functor) --- | Construct a box child with the given 'boxAppend' parameters.-boxChild-  :: Bool-  -> Bool-  -> Word32-  -> Widget event-  -> MarkupOf BoxChild event ()-boxChild expand fill padding child = single BoxChild {..}+-- | Defaults for 'BoxChildProperties'. Use these and override+-- specific fields.+defaultBoxChildProperties :: BoxChildProperties+defaultBoxChildProperties =+  BoxChildProperties {expand = False, fill = False, padding = 0}  instance Patchable BoxChild where   create = create . child@@ -50,3 +53,5 @@  instance EventSource BoxChild where   subscribe BoxChild{..} = subscribe child++instance ToChildren Gtk.Box [] BoxChild
src/GI/Gtk/Declarative/Container/Class.hs view
@@ -1,7 +1,14 @@ {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE DefaultSignatures      #-}+{-# LANGUAGE DeriveFunctor          #-}+{-# LANGUAGE TypeFamilies           #-}++-- | Shared interfaces for containers. module GI.Gtk.Declarative.Container.Class where  import qualified GI.Gtk                           as Gtk+import           Data.Vector                             (Vector)+import qualified Data.Vector                             as Vector import           Data.Int                         (Int32)  -- | Describes supported GTK+ containers and their specialized APIs for@@ -21,3 +28,14 @@     -> Gtk.Widget   -- ^ Old GTK widget to replace     -> Gtk.Widget   -- ^ New GTK widget to replace with     -> IO ()++-- | Common collection type for child widgets, used when patching containers.+newtype Children child event = Children { unChildren :: Vector (child event) }+  deriving (Functor)++-- | Converts a specific collection type to 'Children'.+class ToChildren widget parent child | widget -> parent, widget -> child where+  toChildren :: (Gtk.ManagedPtr widget -> widget) -> parent (child event) -> Children child event++  default toChildren :: parent ~ [] => (Gtk.ManagedPtr widget -> widget) -> parent (child event) -> Children child event+  toChildren _ = Children . Vector.fromList
+ src/GI/Gtk/Declarative/Container/ListBox.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module GI.Gtk.Declarative.Container.ListBox where++import qualified GI.Gtk                             as Gtk++import           GI.Gtk.Declarative.Bin+import           GI.Gtk.Declarative.Container.Class+import           GI.Gtk.Declarative.Widget++instance ToChildren Gtk.ListBox [] (Bin Gtk.ListBoxRow Widget)
src/GI/Gtk/Declarative/Container/MenuItem.hs view
@@ -1,15 +1,15 @@ {-# 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          #-}+{-# 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@@ -18,32 +18,41 @@   ) 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 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+import           GI.Gtk.Declarative.Widget +-- | A menu item widget used for 'Gtk.Menu' children. data MenuItem event where+  -- | A single menu item in a 'Gtk.Menu'.   MenuItem     :: (Gtk.IsMenuItem item, BinChild item Widget, Typeable item)     => Bin item Widget 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 (SubMenu label subMenu')= SubMenu label (fmap f subMenu')+  fmap f (MenuItem item)          = MenuItem (fmap f item)+  fmap f (SubMenu label subMenu')=SubMenu label (fmap f subMenu') +instance ToChildren Gtk.Menu [] MenuItem++instance ToChildren Gtk.MenuBar [] MenuItem++-- | Construct a single menu item for a 'Gtk.Menu'. menuItem   :: ( Gtk.IsMenuItem item      , Typeable event@@ -56,15 +65,17 @@   => (Gtk.ManagedPtr item -> item)   -> Vector (Attribute item event)   -> Widget event-  -> MarkupOf MenuItem event ()-menuItem item attrs = single . MenuItem . Bin item attrs+  -> MenuItem event+menuItem item attrs = MenuItem . Bin item attrs +-- | Construct a sub menu for a 'Gtk.Menu', wit a text label and the+-- child menu items. subMenu   :: (Typeable event)   => Text-  -> MarkupOf MenuItem event ()-  -> MarkupOf MenuItem event ()-subMenu label = single . SubMenu label . container Gtk.Menu mempty+  -> [MenuItem event]+  -> MenuItem event+subMenu label = SubMenu label . container Gtk.Menu mempty  newSubMenuItem :: Text -> IO SomeState -> IO SomeState newSubMenuItem label createSubMenu = do
+ src/GI/Gtk/Declarative/Container/Paned.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors -fno-warn-orphans #-}++{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++-- | Implementation of 'Gtk.Paned' as a declarative container.+module GI.Gtk.Declarative.Container.Paned+  ( Pane+  , PaneProperties (..)+  , defaultPaneProperties+  , pane+  , paned+  )+where++import           Data.Coerce                        (coerce)+import           Data.Typeable+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+import           GI.Gtk.Declarative.Container.Class+import           GI.Gtk.Declarative.EventSource+import           GI.Gtk.Declarative.Patch+import           GI.Gtk.Declarative.Widget++-- | Describes a pane to be packed with+-- 'Gtk.panePack1'/'Gtk.panePack2' in a 'Gtk.Paned'.+data Pane event = Pane+  { paneProperties :: PaneProperties+  , paneChild      :: Widget event+  }+  deriving (Functor)++-- | Values used when packing a pane into a 'Gtk.Paned'.+data PaneProperties = PaneProperties+  { resize :: Bool+  , shrink :: Bool+  }++-- | Defaults for 'PaneProperties'. Use these and override specific+-- fields.+defaultPaneProperties :: PaneProperties+defaultPaneProperties = PaneProperties {resize = False, shrink = True}++-- | 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 {..}++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++-- | Construct a 'Gtk.Paned' based on attributes and two child 'Pane's.+paned :: Typeable event => 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++instance ToChildren Gtk.Paned Panes Pane where+  toChildren _ (Panes p1 p2) = Children (Vector.fromList [p1, p2])
src/GI/Gtk/Declarative/Container/Patch.hs view
@@ -6,9 +6,10 @@ {-# LANGUAGE GADTs                 #-} {-# LANGUAGE LambdaCase            #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE OverloadedLabels      #-} {-# LANGUAGE OverloadedLists       #-}-{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-}@@ -28,9 +29,9 @@ 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 import           GI.Gtk.Declarative.State+import           GI.Gtk.Declarative.Widget  -- | 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@@ -123,7 +124,7 @@     Gtk.listBoxInsert box new i  instance IsContainer Gtk.Box BoxChild where-  appendChild box BoxChild {..} widget' =+  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
+ src/GI/Gtk/Declarative/CustomWidget.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveFunctor #-}++-- | While you can instantiate 'Patchable' and 'EventSource' for your+-- own data types, it's a bit complicated. The 'CustomWidget' data+-- type takes care of some lower-level detail, so that you can focus+-- on the custom behavior of your widget. You still need to think+-- about and implement a patching function, but in an easier way.+module GI.Gtk.Declarative.CustomWidget+  ( CustomPatch(..)+  , CustomWidget(..)+  )+where++import qualified GI.Gtk                         as Gtk+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+  = CustomReplace+  | CustomModify (widget -> IO SomeState)+  | 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 =+  CustomWidget+  { customWidget :: Gtk.ManagedPtr widget -> widget+  -- ^ The widget constructor+  , customCreate :: customData -> IO SomeState+  -- ^ Action that creates the initial widget+  , customPatch :: SomeState -> customData -> customData -> CustomPatch widget customData+  -- ^ Patch function, calculating a 'CustomPatch' based on the state,+  -- old custom data, and new custom data.+  , customSubscribe :: customData -> 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+  } 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 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
− src/GI/Gtk/Declarative/Markup.hs 
@@ -1,105 +0,0 @@-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FunctionalDependencies     #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE TypeOperators              #-}---- | 'MarkupOf' is the common builder type for the (declarative) GTK+ markup--- language, supporting do syntax. 'MarkupOf' wraps many widgets, usually of--- type 'Widget', but they can be of other types.------ A 'Widget' value can wrap any 'Patchable' widget, hiding the underlying--- widget type, such that you can embed heterogeneous collections of widgets in--- containers.-module GI.Gtk.Declarative.Markup-  ( Widget(..)-  -- * Markup-  , MarkupOf-  , Markup-  , single-  , multiple-  , runMarkup-  -- * Widget to Markup conversion-  , FromWidget(..)-  )-where--import           Control.Monad.Writer-import           Data.Typeable-import           Data.Vector                    (Vector)--import           GI.Gtk.Declarative.EventSource-import           GI.Gtk.Declarative.Patch---- | A 'Widget' value wraps a 'Patchable' and 'EventSource' widget, providing--- a constrained equivalent of a 'Dynamic' value. It is used to support--- heterogeneous containers of widgets, and to support equality--- checks on different types of widgets when calculating patches.-data Widget event where-  Widget-    :: ( Typeable widget-       , Patchable widget-       , Functor widget-       , EventSource widget-       )-    => widget event-    -> Widget event--instance Functor Widget where-  fmap f (Widget w) = Widget (fmap f w)---- | 'Widget' is itself patchable, by delegating to the underlying--- 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)--instance EventSource Widget where-  subscribe (Widget w) = subscribe w---- * Markup---- | The declarative markup builder, primarily for using its 'Monad' instance--- and do notation to construct adjacent widgets in containers.------ It is parameterized with 'widget' and 'event', such that containers can--- restrict the type of their children to other types than 'Widget'.------ Note that the return type, 'a', is not used in this library. It's a more a--- 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 (Vector (widget event)) a)-  deriving (Functor, Applicative, Monad)---- | Run a 'MarkupOf' builder and get its widgets.-runMarkup :: MarkupOf widget event () -> Vector (widget event)-runMarkup (MarkupOf w) = execWriter w---- | Handy type alias for the common case of markup containing 'Widget's.-type Markup event a = MarkupOf Widget event a---- | Construct markup from a single widget.-single :: widget event -> MarkupOf widget event ()-single = MarkupOf . tell . pure---- | Construct markup from multiple widgets.-multiple :: Vector (widget event) -> MarkupOf widget event ()-multiple = MarkupOf . tell---- | Convert a widget to a target type. This is deliberately unconstrained in--- it's types, and is used by smart constructors to implement return type--- polymorphism, so that a smart contructor can return either a 'Widget', or--- some specifically typed 'MarkupOf', depending on the context in which it's--- used.-class FromWidget widget event target | target -> event where-  fromWidget :: (Typeable widget, Typeable event) => widget event -> target--instance FromWidget Widget event (Widget event) where-  fromWidget = id
src/GI/Gtk/Declarative/SingleWidget.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}@@ -8,6 +7,7 @@ {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-}  -- | A declarative representation of 'Gtk.Widget' in GTK without children.@@ -25,9 +25,9 @@ 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+import           GI.Gtk.Declarative.Widget  -- | Declarative version of a /leaf/ widget, i.e. a widget without any children. data SingleWidget widget event where@@ -48,8 +48,7 @@         Gtk.widgetShow widget'         sc <- Gtk.widgetGetStyleContext widget'         updateClasses sc mempty (collectedClasses collected)-        -- TODO:-        -- mapM_ (applyAfterCreated widget') props+        mapM_ (applyAfterCreated widget') attrs          return (SomeState (StateTreeWidget (StateTreeNode widget' sc collected ())))   patch (SomeState (st :: StateTree stateType w child event cs))@@ -67,22 +66,15 @@       _ -> 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 = do+  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       _ -> fail "" -instance (Typeable widget, Functor (SingleWidget widget))-  => FromWidget (SingleWidget widget) event (Widget event) where-  fromWidget = Widget--instance FromWidget (SingleWidget widget) event (MarkupOf (SingleWidget widget) event ()) where-  fromWidget = single--instance (Typeable widget, Functor (SingleWidget widget))-  => FromWidget (SingleWidget widget) event (Markup event ()) where-  fromWidget = single . Widget+-- instance (Typeable widget, Functor (SingleWidget widget))+--   => FromWidget (SingleWidget widget) Widget where+--   fromWidget = Widget  -- | Construct a /leaf/ widget, i.e. one without any children. widget@@ -90,9 +82,9 @@      , Typeable event      , Functor (Attribute widget)      , Gtk.IsWidget widget-     , FromWidget (SingleWidget widget) event target+     , FromWidget (SingleWidget widget) target      )   => (Gtk.ManagedPtr widget -> widget) -- ^ A widget constructor from the underlying gi-gtk library.   -> Vector (Attribute widget event)   -- ^ List of 'Attribute's.-  -> target                            -- ^ The target, whose type is decided by 'FromWidget'.+  -> target event                      -- ^ The target, whose type is decided by 'FromWidget'. widget ctor = fromWidget . SingleWidget ctor
+ src/GI/Gtk/Declarative/Widget.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeOperators          #-}++-- | A 'Widget' value can wrap any 'Patchable' widget, hiding the underlying+-- widget type, such that you can embed heterogeneous collections of widgets in+-- containers.+module GI.Gtk.Declarative.Widget+  ( Widget(..)+  -- * Widget to Markup conversion+  , FromWidget(..)+  )+where++import           Data.Typeable++import           GI.Gtk.Declarative.EventSource+import           GI.Gtk.Declarative.Patch++-- | A 'Widget' value wraps a 'Patchable' and 'EventSource' widget, providing+-- a constrained equivalent of a 'Dynamic' value. It is used to support+-- heterogeneous containers of widgets, and to support equality+-- checks on different types of widgets when calculating patches.+data Widget event where+  Widget+    :: ( Typeable widget+       , Patchable widget+       , Functor widget+       , EventSource widget+       )+    => widget event+    -> Widget event++instance Functor Widget where+  fmap f (Widget w) = Widget (fmap f w)++-- | 'Widget' is itself patchable, by delegating to the underlying+-- 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)++instance EventSource Widget where+  subscribe (Widget w) = subscribe w++-- | Convert a widget to a target type. This is deliberately unconstrained in+-- it's types, and is used by smart constructors to implement return type+-- polymorphism, so that a smart contructor can return either a 'Widget', or+-- some specifically typed widget, depending on the context in which it's+-- used.+class FromWidget widget target where+  fromWidget :: (Typeable widget, Typeable event) => widget event -> target event++instance (Patchable (parent child), Functor (parent child), EventSource (parent child))+         => FromWidget (parent child) Widget where+  fromWidget = Widget
+ src/GI/Gtk/Declarative/Widget/Conversions.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances  #-}++-- | Orphan instances for automatically converting between different+-- widget types. As these use 'UndecidableInstances', they are kept+-- here in solitary confinement.+module GI.Gtk.Declarative.Widget.Conversions where++import           GI.Gtk.Declarative.Container.Box+import           GI.Gtk.Declarative.Widget++-- | Any widget that can be converted to a 'Widget' can be wrapped+-- as a 'BoxChild' with the default properties.+instance FromWidget widget Widget => FromWidget widget BoxChild where+  fromWidget = BoxChild defaultBoxChildProperties . fromWidget