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