diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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!) diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs --- a/bench/Benchmark.hs +++ b/bench/Benchmark.hs @@ -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 diff --git a/gi-gtk-declarative.cabal b/gi-gtk-declarative.cabal --- a/gi-gtk-declarative.cabal +++ b/gi-gtk-declarative.cabal @@ -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 diff --git a/src/GI/Gtk/Declarative.hs b/src/GI/Gtk/Declarative.hs --- a/src/GI/Gtk/Declarative.hs +++ b/src/GI/Gtk/Declarative.hs @@ -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 () diff --git a/src/GI/Gtk/Declarative/Bin.hs b/src/GI/Gtk/Declarative/Bin.hs --- a/src/GI/Gtk/Declarative/Bin.hs +++ b/src/GI/Gtk/Declarative/Bin.hs @@ -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 diff --git a/src/GI/Gtk/Declarative/Container.hs b/src/GI/Gtk/Declarative/Container.hs --- a/src/GI/Gtk/Declarative/Container.hs +++ b/src/GI/Gtk/Declarative/Container.hs @@ -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 diff --git a/src/GI/Gtk/Declarative/Container/Box.hs b/src/GI/Gtk/Declarative/Container/Box.hs --- a/src/GI/Gtk/Declarative/Container/Box.hs +++ b/src/GI/Gtk/Declarative/Container/Box.hs @@ -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 diff --git a/src/GI/Gtk/Declarative/Container/Class.hs b/src/GI/Gtk/Declarative/Container/Class.hs --- a/src/GI/Gtk/Declarative/Container/Class.hs +++ b/src/GI/Gtk/Declarative/Container/Class.hs @@ -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 diff --git a/src/GI/Gtk/Declarative/Container/ListBox.hs b/src/GI/Gtk/Declarative/Container/ListBox.hs new file mode 100644 --- /dev/null +++ b/src/GI/Gtk/Declarative/Container/ListBox.hs @@ -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) diff --git a/src/GI/Gtk/Declarative/Container/MenuItem.hs b/src/GI/Gtk/Declarative/Container/MenuItem.hs --- a/src/GI/Gtk/Declarative/Container/MenuItem.hs +++ b/src/GI/Gtk/Declarative/Container/MenuItem.hs @@ -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 diff --git a/src/GI/Gtk/Declarative/Container/Paned.hs b/src/GI/Gtk/Declarative/Container/Paned.hs new file mode 100644 --- /dev/null +++ b/src/GI/Gtk/Declarative/Container/Paned.hs @@ -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]) diff --git a/src/GI/Gtk/Declarative/Container/Patch.hs b/src/GI/Gtk/Declarative/Container/Patch.hs --- a/src/GI/Gtk/Declarative/Container/Patch.hs +++ b/src/GI/Gtk/Declarative/Container/Patch.hs @@ -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 diff --git a/src/GI/Gtk/Declarative/CustomWidget.hs b/src/GI/Gtk/Declarative/CustomWidget.hs new file mode 100644 --- /dev/null +++ b/src/GI/Gtk/Declarative/CustomWidget.hs @@ -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 diff --git a/src/GI/Gtk/Declarative/Markup.hs b/src/GI/Gtk/Declarative/Markup.hs deleted file mode 100644 --- a/src/GI/Gtk/Declarative/Markup.hs +++ /dev/null @@ -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 diff --git a/src/GI/Gtk/Declarative/SingleWidget.hs b/src/GI/Gtk/Declarative/SingleWidget.hs --- a/src/GI/Gtk/Declarative/SingleWidget.hs +++ b/src/GI/Gtk/Declarative/SingleWidget.hs @@ -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 diff --git a/src/GI/Gtk/Declarative/Widget.hs b/src/GI/Gtk/Declarative/Widget.hs new file mode 100644 --- /dev/null +++ b/src/GI/Gtk/Declarative/Widget.hs @@ -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 diff --git a/src/GI/Gtk/Declarative/Widget/Conversions.hs b/src/GI/Gtk/Declarative/Widget/Conversions.hs new file mode 100644 --- /dev/null +++ b/src/GI/Gtk/Declarative/Widget/Conversions.hs @@ -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