diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +* 0.2.0 + - Introduce shadow state (breaking change!) + - Optimized patching (2x-7x faster!) + - Many bug fixes in patching + - Reimplement callback conversions + - Return pairs in declarative event handlers, for non-`()` GTK+ callback return values + * 0.1.0 - First version of `gi-gtk-declarative`! - Basic widget without event handling diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs new file mode 100644 --- /dev/null +++ b/bench/Benchmark.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Concurrent +import Control.Monad +import Criterion.Main +import Data.Text +import qualified GI.Gdk as Gdk +import qualified GI.GLib.Constants as GLib + +import GI.Gtk (Box (..), Label (..), Window (..)) +import qualified GI.Gtk as Gtk +import GI.Gtk.Declarative +import GI.Gtk.Declarative.State + +testView :: [Int] -> Widget () +testView ns = bin Window [] $ container Box [] $ forM_ ns $ \n -> + boxChild True True 10 + $ widget Label [#label := pack (show n), classes ["a", "b"]] + +testPatch state oldView newView = case patch state oldView newView of + Modify ma -> do + ret <- newEmptyMVar + void . Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ do + ma >>= putMVar ret + return False + takeMVar ret + _ -> error "Expected a modification." + +main :: IO () +main = do + _ <- Gtk.init Nothing + let initialView = testView [1 .. 100] + initialState <- create initialView + #showAll =<< someStateWidget initialState + _ <- forkOS $ do + defaultMain + [ bgroup + "patch" + [ bench "Modify (equal)" . whnfIO . replicateM_ 10 $ do + s1 <- testPatch initialState initialView initialView + void $ testPatch s1 initialView initialView + , bench "Modify (diff)" . whnfIO . replicateM_ 10 $ do + s1 <- testPatch initialState initialView initialView + void $ testPatch s1 initialView (testView [2 .. 101]) + ] + ] + Gtk.mainQuit + Gtk.main 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.1.0 +version: 0.2.0 synopsis: Declarative GTK+ programming in Haskell description: A declarative programming model for GTK+ user interfaces, implementing support for various widgets @@ -23,16 +23,21 @@ library exposed-modules: GI.Gtk.Declarative , GI.Gtk.Declarative.Attributes + , GI.Gtk.Declarative.Attributes.Collected , GI.Gtk.Declarative.Attributes.Internal + , GI.Gtk.Declarative.Attributes.Internal.EventHandler + , GI.Gtk.Declarative.Attributes.Internal.Conversions , GI.Gtk.Declarative.Bin , GI.Gtk.Declarative.Container , GI.Gtk.Declarative.Container.Box + , GI.Gtk.Declarative.Container.Class + , GI.Gtk.Declarative.Container.MenuItem , GI.Gtk.Declarative.Container.Patch - , GI.Gtk.Declarative.CSS , GI.Gtk.Declarative.EventSource , GI.Gtk.Declarative.Markup , GI.Gtk.Declarative.Patch , GI.Gtk.Declarative.SingleWidget + , GI.Gtk.Declarative.State build-depends: base >=4.10 && <4.12 , gi-gobject >= 2 && <3 , gi-gtk >= 3 && <4 @@ -42,6 +47,22 @@ , mtl , text , unordered-containers >= 0.2 && < 0.3 + , vector hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + +benchmark gi-gtk-declarative-benchmark + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Benchmark.hs + build-depends: base >= 4 && < 5 + , criterion + , gi-glib + , gi-gdk + , gi-gtk + , gi-gtk-declarative + , random + , text + ghc-options: -Wall -O2 -rtsopts -with-rtsopts=-N -threaded + default-language: Haskell2010 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 @@ -9,11 +9,12 @@ ( module Export ) where -import GI.Gtk.Declarative.Attributes as Export -import GI.Gtk.Declarative.Bin as Export -import GI.Gtk.Declarative.Container as Export -import GI.Gtk.Declarative.Container.Box as Export -import GI.Gtk.Declarative.CSS as Export -import GI.Gtk.Declarative.Markup as Export -import GI.Gtk.Declarative.Patch as Export -import GI.Gtk.Declarative.SingleWidget as Export +import GI.Gtk.Declarative.Attributes as Export +import GI.Gtk.Declarative.Bin as Export (Bin, bin) +import GI.Gtk.Declarative.Container as Export (Container, + container) +import GI.Gtk.Declarative.Container.Box as Export +import GI.Gtk.Declarative.Container.MenuItem as Export +import GI.Gtk.Declarative.Markup as Export +import GI.Gtk.Declarative.Patch as Export +import GI.Gtk.Declarative.SingleWidget as Export 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 @@ -1,44 +1,44 @@ +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -- | Attribute lists on declarative objects, supporting the underlying -- attributes from "Data.GI.Base.Attributes", along with CSS class lists, and --- pure and impure event callbacks. +-- pure and impure event EventHandlers. module GI.Gtk.Declarative.Attributes ( Attribute(..) - -- * , classes + , afterCreated + , ClassSet -- * Event Handling , on , onM - -- * Callbacks - , ToGtkCallback(..) + -- * EventHandlers + , EventHandler(..) ) where -import Control.Monad (void) -import qualified Data.GI.Base.Attributes as GI -import qualified Data.GI.Base.Signals as GI -import qualified Data.HashSet as HashSet -import Data.Text (Text) +import qualified Data.GI.Base.Attributes as GI +import qualified Data.GI.Base.Signals as GI +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import qualified Data.Text as T +import Data.Text (Text) import Data.Typeable -import GHC.TypeLits (KnownSymbol, Symbol) -import qualified GI.Gtk as Gtk +import GHC.TypeLits (KnownSymbol, + Symbol) +import qualified GI.Gtk as Gtk -import GI.Gtk.Declarative.CSS +import GI.Gtk.Declarative.Attributes.Internal.EventHandler +import GI.Gtk.Declarative.Attributes.Internal.Conversions -- * Attributes @@ -57,6 +57,8 @@ , GI.AttrSetTypeConstraint info setValue , KnownSymbol attr , Typeable attr + , Eq setValue + , Typeable setValue ) => GI.AttrLabelProxy (attr :: Symbol) -> setValue -> Attribute widget event -- | Defines a set of CSS classes for the underlying widget's style context. @@ -65,163 +67,83 @@ :: Gtk.IsWidget widget => ClassSet -> Attribute widget event - -- | Emit events using a pure callback. Use the 'on function instead of this + -- | Emit events using a pure event handler. Use the 'on' function, instead of this -- constructor directly. OnSignalPure :: ( Gtk.GObject widget , GI.SignalInfo info - , callback ~ GI.HaskellCallbackType info - , Functor (PureCallback callback) - , ToGtkCallback (PureCallback callback) - , callback ~ CustomGtkCallback (PureCallback callback) + , gtkCallback ~ GI.HaskellCallbackType info + , ToGtkCallback gtkCallback Pure ) => Gtk.SignalProxy widget info - -> PureCallback callback event + -> EventHandler gtkCallback widget Pure event -> Attribute widget event - -- | Emit events using an impure callback. Use the 'on function instead of - -- this constructor directly. + -- | Emit events using a pure event handler. Use the 'on' function, instead of this + -- constructor directly. OnSignalImpure :: ( Gtk.GObject widget , GI.SignalInfo info - , callback ~ GI.HaskellCallbackType info - , Functor (ImpureCallback callback widget) - , ToGtkCallback (ImpureCallback callback widget) - , (widget -> callback) ~ CustomGtkCallback (ImpureCallback callback widget) + , gtkCallback ~ GI.HaskellCallbackType info + , ToGtkCallback gtkCallback Impure ) => Gtk.SignalProxy widget info - -> ImpureCallback callback widget event + -> EventHandler gtkCallback widget Impure event -> Attribute widget event + -- | Provide a callback to modify the widget after it's been created. + AfterCreated + :: (widget -> IO ()) + -> Attribute widget event --- | Attributes have a 'Functor' instance that maps events in all event --- callbacks. +-- | A set of CSS classes. +type ClassSet = HashSet Text + +-- | Attributes have a 'Functor' instance that maps events in all +-- event handler. instance Functor (Attribute widget) where fmap f = \case attr := value -> attr := value Classes cs -> Classes cs - OnSignalPure signal cb -> OnSignalPure signal (fmap f cb) - OnSignalImpure signal cb -> OnSignalImpure signal (fmap f cb) + OnSignalPure signal eh -> OnSignalPure signal (fmap f eh) + OnSignalImpure signal eh -> OnSignalImpure signal (fmap f eh) + AfterCreated eh -> AfterCreated eh -- | Define the CSS classes for the underlying widget's style context. For these -- classes to have any effect, this requires a 'Gtk.CssProvider' with CSS files -- loaded, to be added to the GDK screen. You probably want to do this in your -- entry point when setting up GTK. -classes :: Gtk.IsWidget widget => [Text] -> Attribute widget event +classes :: Gtk.IsWidget widget => [T.Text] -> Attribute widget event classes = Classes . HashSet.fromList --- | Emit events, using a pure callback, by subcribing to the specified +-- | Emit events, using a pure event handler, by subcribing to the specified -- signal. on :: ( Gtk.GObject widget , GI.SignalInfo info - , callback ~ GI.HaskellCallbackType info - , pure ~ ToPureCallback callback event - , Functor (PureCallback callback) - , ToGtkCallback (PureCallback callback) - , callback ~ CustomGtkCallback (PureCallback callback) + , gtkCallback ~ GI.HaskellCallbackType info + , ToGtkCallback gtkCallback Pure + , ToEventHandler gtkCallback widget Pure + , userEventHandler ~ UserEventHandler gtkCallback widget Pure event ) => Gtk.SignalProxy widget info - -> pure + -> userEventHandler -> Attribute widget event -on signal = OnSignalPure signal . PureCallback +on signal = OnSignalPure signal . toEventHandler --- | Emit events, using an impure callback receiving the 'widget' and returning +-- | Emit events, using an impure event handler receiving the 'widget' and returning -- an 'IO' action of 'event', by subcribing to the specified signal. onM :: ( Gtk.GObject widget , GI.SignalInfo info - , callback ~ GI.HaskellCallbackType info - , impure ~ ToImpureCallback callback event - , withWidget ~ (widget -> impure) - , Functor (ImpureCallback callback widget) - , ToGtkCallback (ImpureCallback callback widget) - , (widget -> callback) ~ CustomGtkCallback (ImpureCallback callback widget) + , gtkCallback ~ GI.HaskellCallbackType info + , ToGtkCallback gtkCallback Impure + , ToEventHandler gtkCallback widget Impure + , userEventHandler ~ UserEventHandler gtkCallback widget Impure event ) => Gtk.SignalProxy widget info - -> withWidget + -> userEventHandler -> Attribute widget event -onM signal = OnSignalImpure signal . ImpureCallback - --- * Pure Callbacks - --- | Convert a GTK+ callback type to a pure callback type, i.e. a type --- without 'IO'. The pure callback is either a single 'event', or a function of --- the same arity and arguments as the GTK+ callback, but with the 'event' as --- the range. -type family ToPureCallback gtkCallback event where - ToPureCallback (IO ()) event = event - ToPureCallback (a -> b) event = a -> ToPureCallback b event - --- | A 'PureCallback' holds a pure callback, as defined by 'ToPureCallback'. -data PureCallback callback event where - PureCallback - :: (pure ~ ToPureCallback callback event) - => pure - -> PureCallback callback event - --- The functor instances are pretty annoying, being repeated for each function --- arity. Could this be done in another way? - -instance Functor (PureCallback (IO ())) where - fmap f (PureCallback e) = PureCallback (f e) - -instance Functor (PureCallback (x -> IO ())) where - fmap f (PureCallback g) = PureCallback (f . g) - -instance Functor (PureCallback (x -> y -> IO ())) where - fmap f (PureCallback g) = PureCallback (\x -> f . g x) - --- * Impure Callbacks - --- | Convert a GTK+ callback type to an impure callback type, i.e. a type --- with 'IO event' as the range, instead of 'IO ()'. The impure callback is --- either a single 'IO event', or a function of the same arity and arguments as --- the GTK+ callback, but with 'IO event' as the range. -type family ToImpureCallback t e where - ToImpureCallback (IO ()) e = IO e - ToImpureCallback (a -> b) e = a -> ToImpureCallback b e - --- | An 'ImpureCallback' holds an impure callback, as defined by --- 'ToImpureCallback', but with an extra 'widget' argument. This is so that --- impure callbacks can query their underlying GTK+ widgets for data. -data ImpureCallback callback widget event where - ImpureCallback - :: (impure ~ ToImpureCallback callback event) - => (widget -> impure) - -> ImpureCallback callback widget event - --- The functor instances are pretty annoying, being repeated for each function --- arity. Could this be done in another way? - -instance Functor (ImpureCallback (IO ()) widget) where - fmap f (ImpureCallback g) = ImpureCallback (\w -> f <$> g w) - -instance Functor (ImpureCallback (x -> IO ()) widget) where - fmap f (ImpureCallback g) = ImpureCallback (\w -> fmap f . g w) - -instance Functor (ImpureCallback (x -> y -> IO ()) widget) where - fmap f (ImpureCallback g) = ImpureCallback (\w x -> fmap f . g w x) - --- * GTK+ Callback Conversions - --- | Internal class for converting user callbacks to gi-gtk callbacks. -class ToGtkCallback userCallback where - type CustomGtkCallback userCallback :: * - -- | Converts a user callback, i.e. a pure or an impure callback, back to a - -- GTK+ callback. - toGtkCallback :: userCallback event -> (event -> IO ()) -> CustomGtkCallback userCallback - -instance ToGtkCallback (PureCallback (IO ())) where - type CustomGtkCallback (PureCallback (IO ())) = IO () - toGtkCallback (PureCallback cb) f = void (f cb) - -instance ToGtkCallback (PureCallback (x -> IO ())) where - type CustomGtkCallback (PureCallback (x -> IO ())) = x -> IO () - toGtkCallback (PureCallback cb) f x = void (f (cb x)) - -instance ToGtkCallback (PureCallback (x -> y -> IO ())) where - type CustomGtkCallback (PureCallback (x -> y -> IO ())) = x -> y -> IO () - toGtkCallback (PureCallback cb) f x y = void (f (cb x y)) +onM signal = OnSignalImpure signal . toEventHandler -instance ToGtkCallback (ImpureCallback (IO ()) widget) where - type CustomGtkCallback (ImpureCallback (IO ()) widget) = widget -> IO () - toGtkCallback (ImpureCallback cb) f w = void (cb w >>= f) +-- | Provide a EventHandler to modify the widget after it's been created. +afterCreated :: (widget -> IO ()) -> Attribute widget event +afterCreated = AfterCreated diff --git a/src/GI/Gtk/Declarative/Attributes/Collected.hs b/src/GI/Gtk/Declarative/Attributes/Collected.hs new file mode 100644 --- /dev/null +++ b/src/GI/Gtk/Declarative/Attributes/Collected.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} + +-- | Internal helpers for applying attributes and signal handlers to GTK+ +-- widgets. +module GI.Gtk.Declarative.Attributes.Collected + ( CollectedProperties + , Collected(..) + , collectAttributes + , constructProperties + , updateProperties + , updateClasses + ) +where + +import Data.Foldable +import qualified Data.Text as Text +import Data.Text ( Text ) +import qualified Data.HashSet as HashSet +import qualified Data.HashMap.Strict as HashMap +import Data.HashMap.Strict ( HashMap ) +import qualified Data.GI.Base.Attributes as GI +import qualified GI.Gtk as Gtk +import Data.Typeable +import GHC.TypeLits +import Data.Vector ( Vector ) + +import GI.Gtk.Declarative.Attributes + +-- | A collected property key/value pair, to be used when +-- settings properties when patching widgets. +data CollectedProperty widget where + CollectedProperty + :: (GI.AttrOpAllowed 'GI.AttrConstruct info widget + , GI.AttrOpAllowed 'GI.AttrSet info widget + , GI.AttrGetC info widget attr getValue + , GI.AttrSetTypeConstraint info setValue + , KnownSymbol attr + , Typeable attr + , Eq setValue + , Typeable setValue + ) + => GI.AttrLabelProxy attr -> setValue -> CollectedProperty widget + +-- | A collected map of key/value pairs, where the type-level property +-- names are represented as 'Text' values. This is used to calculate +-- differences in old and new property sets when patching. +type CollectedProperties widget = HashMap Text (CollectedProperty widget) + +-- | All the collected properties and classes for a widget. These are based +-- on the 'Attribute' list in the declarative markup, but collected separately +-- into more efficient data structures, optimized for patching. +data Collected widget event = Collected + { collectedClasses :: ClassSet + , collectedProperties :: CollectedProperties widget + } + +instance Semigroup (Collected widget event) where + c1 <> c2 = + Collected + (collectedClasses c1 <> collectedClasses c2) + (collectedProperties c1 <> collectedProperties c2) + +instance Monoid (Collected widget event) where + mempty = Collected mempty mempty + +-- | Collect declarative markup attributes to the patching-optimized +-- 'Collected' data structure. +collectAttributes :: Vector (Attribute widget event) -> Collected widget event +collectAttributes = foldl' go mempty + where + go + :: Collected widget event + -> Attribute widget event + -> Collected widget event + go Collected {..} = \case + attr := value -> Collected + { collectedProperties = HashMap.insert (Text.pack (symbolVal attr)) + (CollectedProperty attr value) + collectedProperties + , .. + } + Classes classSet -> + Collected {collectedClasses = collectedClasses <> classSet, ..} + _ -> Collected {..} + +-- | Create a list of GTK construct operations based on collected +-- properties, used when creating new widgets. +constructProperties + :: Collected widget event -> [GI.AttrOp widget 'GI.AttrConstruct] +constructProperties c = map + (\(CollectedProperty attr value) -> attr Gtk.:= value) + (HashMap.elems (collectedProperties c)) + +-- | Update the changed properties of a widget, based on the old and new +-- collected properties. +updateProperties + :: widget -> CollectedProperties widget -> CollectedProperties widget -> IO () +updateProperties (widget' :: widget) oldProps newProps = do + let toAdd = HashMap.elems (HashMap.difference newProps oldProps) + setOps = mconcat + (HashMap.elems (HashMap.intersectionWith toMaybeSetOp oldProps newProps) + ) + GI.set widget' (map (toSetOp (Proxy @widget)) toAdd <> setOps) + where + toSetOp + :: Proxy widget + -> CollectedProperty widget + -> Gtk.AttrOp widget 'GI.AttrSet + toSetOp _ (CollectedProperty attr value) = attr Gtk.:= value + + toMaybeSetOp + :: CollectedProperty widget + -> CollectedProperty widget + -> [Gtk.AttrOp widget 'GI.AttrSet] + toMaybeSetOp (CollectedProperty attr (v1 :: t1)) (CollectedProperty _ (v2 :: t2)) + = case eqT @t1 @t2 of + Just Refl | v1 /= v2 -> pure (attr Gtk.:= v2) + _ -> mempty + +-- | Update the style context's classes to only include the new set of +-- classes (last argument). +updateClasses :: Gtk.StyleContext -> ClassSet -> ClassSet -> IO () +updateClasses sc old new = do + let toAdd = HashSet.difference new old + toRemove = HashSet.difference old new + mapM_ (Gtk.styleContextAddClass sc) toAdd + mapM_ (Gtk.styleContextRemoveClass sc) toRemove 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 @@ -1,59 +1,48 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} -- | Internal helpers for applying attributes and signal handlers to GTK+ -- widgets. module GI.Gtk.Declarative.Attributes.Internal - ( extractAttrConstructOps - , extractAttrSetOps - , addClass - , removeClass + ( applyAfterCreated , addSignalHandler - ) where + ) +where -import qualified Data.GI.Base.Attributes as GI -import qualified GI.GObject as GI -import qualified GI.Gtk as Gtk -import Control.Monad.IO.Class (MonadIO) +import Control.Monad ( (>=>) ) +import Control.Monad.IO.Class ( MonadIO ) +import qualified GI.GObject as GI +import qualified GI.Gtk as Gtk import GI.Gtk.Declarative.Attributes +import GI.Gtk.Declarative.Attributes.Internal.Conversions import GI.Gtk.Declarative.EventSource -extractAttrConstructOps - :: Attribute widget event -> [GI.AttrOp widget 'GI.AttrConstruct] -extractAttrConstructOps = \case - (attr := value) -> pure (attr Gtk.:= value) - _ -> mempty - -extractAttrSetOps :: Attribute widget event -> [GI.AttrOp widget 'GI.AttrSet] -extractAttrSetOps = \case - (attr := value) -> pure (attr Gtk.:= value) - _ -> mempty - -addClass :: MonadIO m => Gtk.StyleContext -> Attribute widget event -> m () -addClass sc = \case - Classes cs -> mapM_ (Gtk.styleContextAddClass sc) cs - _ -> pure () - -removeClass :: MonadIO m => Gtk.StyleContext -> Attribute widget event -> m () -removeClass sc = \case - Classes cs -> mapM_ (Gtk.styleContextRemoveClass sc) cs - _ -> pure () +applyAfterCreated :: widget -> Attribute widget event -> IO () +applyAfterCreated widget = \case + (AfterCreated f) -> f widget + _ -> return () addSignalHandler :: (Gtk.IsWidget widget, MonadIO m) => (event -> IO ()) -> widget -> Attribute widget event - -> m (Maybe Subscription) -addSignalHandler onEvent widget' = \case - OnSignalPure signal handler -> do - handlerId <- Gtk.on widget' signal (toGtkCallback handler onEvent) - w <- Gtk.toWidget widget' - pure (Just (fromCancellation (GI.signalHandlerDisconnect w handlerId))) - OnSignalImpure signal handler -> do - handlerId <- Gtk.on widget' signal (toGtkCallback handler onEvent widget') - w <- Gtk.toWidget widget' - pure (Just (fromCancellation (GI.signalHandlerDisconnect w handlerId))) - _ -> pure Nothing - + -> m Subscription +addSignalHandler onEvent widget' = listenToSignal >=> \case + Just eh -> setupCancellation eh + Nothing -> pure mempty + where + listenToSignal = \case + OnSignalPure signal handler -> + Just <$> Gtk.on widget' signal (toGtkCallback handler widget' onEvent) + OnSignalImpure signal handler -> + Just <$> Gtk.on widget' signal (toGtkCallback handler widget' onEvent) + _ -> pure Nothing + setupCancellation handlerId = do + w <- Gtk.toWidget widget' + pure (fromCancellation (GI.signalHandlerDisconnect w handlerId)) diff --git a/src/GI/Gtk/Declarative/Attributes/Internal/Conversions.hs b/src/GI/Gtk/Declarative/Attributes/Internal/Conversions.hs new file mode 100644 --- /dev/null +++ b/src/GI/Gtk/Declarative/Attributes/Internal/Conversions.hs @@ -0,0 +1,52 @@ +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module GI.Gtk.Declarative.Attributes.Internal.Conversions + ( ToGtkCallback(..) + ) +where + +import Control.Monad ( void ) +import Data.Functor ( ($>) ) +import Data.Functor.Identity + +import GI.Gtk.Declarative.Attributes.Internal.EventHandler + +-- * GTK+ EventHandler Conversions + +-- | Internal class for converting 'EventHandler's to gi-gtk callbacks. +class ToGtkCallback gtkCallback purity where + -- | Converts an 'EventHandler', i.e. the internal encoding of a pure or an impure + -- callback, back to a GTK+ callback. Impure callbacks will also receive a + -- 'widget' as the last argument. + toGtkCallback + :: EventHandler gtkCallback widget purity event + -> widget + -> (event -> IO ()) + -> gtkCallback + +instance ToGtkCallback (IO ()) Pure where + toGtkCallback (PureEventHandler (OnlyEvent e)) _ f = void (f (runIdentity e)) + +instance ToGtkCallback (IO Bool) Pure where + toGtkCallback (PureEventHandler (ReturnAndEvent re)) _ f = + let (r, e) = runIdentity re + in f e $> r + +instance ToGtkCallback (IO ()) Impure where + toGtkCallback (ImpureEventHandler r) w f = + let OnlyEvent me = r w + in me >>= f + +instance ToGtkCallback (IO Bool) Impure where + toGtkCallback (ImpureEventHandler r) w f = do + let ReturnAndEvent re = r w + (r', e) <- re + f e + return r' + +instance ToGtkCallback y purity => ToGtkCallback (x -> y) purity where + toGtkCallback (EventHandlerFunction cb) f w x = toGtkCallback (cb x) f w diff --git a/src/GI/Gtk/Declarative/Attributes/Internal/EventHandler.hs b/src/GI/Gtk/Declarative/Attributes/Internal/EventHandler.hs new file mode 100644 --- /dev/null +++ b/src/GI/Gtk/Declarative/Attributes/Internal/EventHandler.hs @@ -0,0 +1,80 @@ +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module GI.Gtk.Declarative.Attributes.Internal.EventHandler + ( Purity(..) + , EventHandlerReturn(..) + , EventHandler(..) + , UserEventHandler + , ToEventHandler(..) + ) +where + +import Data.Functor.Identity + +-- | A 'EventHandler' can be either pure or impure. +data Purity = Pure | Impure + +-- | The two supported types of return values in user event handlers are encoded +-- by the 'EventHandlerReturn' type; either you can return only an 'event', or if +-- the underlying GTK+ callback needs to return a 'Bool', you return +-- a @(Bool, event)@ tuple. +data EventHandlerReturn m gtkReturn event where + OnlyEvent :: m e -> EventHandlerReturn m () e + ReturnAndEvent :: m (Bool, e) -> EventHandlerReturn m Bool e + +instance Functor m => Functor (EventHandlerReturn m gtkEventHandler) where + fmap f = \case + OnlyEvent e -> OnlyEvent (fmap f e) + ReturnAndEvent mr -> ReturnAndEvent (fmap (fmap f) mr) + +-- | Encodes the user event handler in such a way that we can have +-- a 'Functor' instance for arity-polymorphic event handlers. +data EventHandler gtkEventHandler widget (purity :: Purity) event where + PureEventHandler :: EventHandlerReturn Identity ret e -> EventHandler (IO ret) w Pure e + ImpureEventHandler :: (w -> EventHandlerReturn IO ret e) -> EventHandler (IO ret) w Impure e + EventHandlerFunction :: (a -> EventHandler b w p e) -> EventHandler (a -> b) w p e + +instance Functor (EventHandler gtkEventHandler widget purity) where + fmap f = \case + PureEventHandler r -> PureEventHandler (fmap f r) + ImpureEventHandler r -> ImpureEventHandler (fmap (fmap f) r) + EventHandlerFunction eh -> EventHandlerFunction (\a -> fmap f (eh a)) + +-- | Convert from a GTK+ callback type to a user event handler type (the ones +-- you'd apply 'on' and 'onM' with) based on the given widget, purity, and event +-- types. +type family UserEventHandler gtkCallback widget (purity :: Purity) event where + UserEventHandler (IO ()) widget Pure event = event + UserEventHandler (IO Bool) widget Pure event = (Bool, event) + UserEventHandler (IO ()) widget Impure event = widget -> IO event + UserEventHandler (IO Bool) widget Impure event = widget -> IO (Bool, event) + UserEventHandler (a -> b) widget purity event = a -> UserEventHandler b widget purity event + +-- | Internal class for converting user event handlers to encoded 'EventHandler' values. +class ToEventHandler gtkEventHandler widget purity where + -- | Convert from a user event handler to an 'EventHandler'. + toEventHandler + :: UserEventHandler gtkEventHandler widget purity event + -> EventHandler gtkEventHandler widget purity event + +instance ToEventHandler (IO ()) widget Pure where + toEventHandler = PureEventHandler . OnlyEvent . pure + +instance ToEventHandler (IO Bool) widget Pure where + toEventHandler = PureEventHandler . ReturnAndEvent . pure + +instance ToEventHandler (IO ()) widget Impure where + toEventHandler eh = ImpureEventHandler (OnlyEvent . eh) + +instance ToEventHandler (IO Bool) widget Impure where + toEventHandler eh = ImpureEventHandler (ReturnAndEvent . eh) + +instance (ToEventHandler b widget purity) => ToEventHandler (a -> b) widget purity where + toEventHandler f = EventHandlerFunction (toEventHandler . f) 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 @@ -4,44 +4,42 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | A declarative representation of 'Gtk.Bin' in GTK. module GI.Gtk.Declarative.Bin - ( Bin + ( Bin(..) , bin + , BinChild ) where -import Control.Monad ((>=>)) -import Data.Maybe import Data.Typeable -import qualified GI.GObject as GI -import qualified GI.Gtk as Gtk +import Data.Vector (Vector) +import qualified GI.Gtk as Gtk import GI.Gtk.Declarative.Attributes +import GI.Gtk.Declarative.Attributes.Collected import GI.Gtk.Declarative.Attributes.Internal import GI.Gtk.Declarative.EventSource import GI.Gtk.Declarative.Markup import GI.Gtk.Declarative.Patch +import GI.Gtk.Declarative.State -- | Supported 'Gtk.Bin's. -class BinChild bin (child :: * -> *) | bin -> child where - getChild :: bin -> IO Gtk.Widget +class BinChild bin (child :: * -> *) | bin -> child instance BinChild Gtk.ScrolledWindow Widget where - getChild scrolledWindow = do - viewPort <- getBinChild Gtk.Viewport scrolledWindow - getBinChild Gtk.Widget viewPort - instance BinChild Gtk.ListBoxRow Widget where - getChild = getBinChild Gtk.Widget +instance BinChild Gtk.Window Widget where +instance BinChild Gtk.Dialog Widget where +instance BinChild Gtk.MenuItem Widget where -- | Declarative version of a /bin/ widget, i.e. a widget with exactly one -- child. @@ -54,7 +52,7 @@ , Functor child ) => (Gtk.ManagedPtr widget -> widget) - -> [Attribute widget event] + -> Vector (Attribute widget event) -> child event -> Bin widget child event @@ -63,8 +61,8 @@ Bin ctor (fmap f <$> attrs) (fmap f child) -- | Construct a /bin/ widget, i.e. a widget with exactly one child. -bin :: - ( Patchable (Bin widget child) +bin + :: ( Patchable (Bin widget child) , Typeable widget , Typeable child , Typeable event @@ -73,10 +71,9 @@ , Gtk.IsBin widget , Gtk.IsWidget widget , FromWidget (Bin widget child) event target - , BinChild widget child ) => (Gtk.ManagedPtr widget -> widget) -- ^ A bin widget constructor from the underlying gi-gtk library. - -> [Attribute widget event] -- ^ List of 'Attribute's. + -> Vector (Attribute widget event) -- ^ List of 'Attribute's. -> child event -- ^ The bin's child widget, whose type is decided by the 'BinChild' instance. -> target -- ^ The target, whose type is decided by 'FromWidget'. bin ctor attrs = fromWidget . Bin ctor attrs @@ -86,34 +83,46 @@ -- instance (BinChild parent child, Patchable child) => Patchable (Bin parent child) where - create (Bin ctor props child) = do - let attrOps = concatMap extractAttrConstructOps props - widget' <- Gtk.new ctor attrOps + create (Bin ctor attrs child) = do + let collected = collectAttributes attrs + widget' <- Gtk.new ctor (constructProperties collected) + Gtk.widgetShow widget' sc <- Gtk.widgetGetStyleContext widget' - mapM_ (addClass sc) props - - Gtk.containerAdd widget' =<< create child - Gtk.toWidget widget' - - patch (Bin _ oldAttributes oldChild) (Bin ctor newAttributes newChild) = - Modify $ \widget' -> do + updateClasses sc mempty (collectedClasses collected) - binWidget <- Gtk.unsafeCastTo ctor widget' - Gtk.set binWidget (concatMap extractAttrSetOps newAttributes) + -- TODO: + -- mapM_ (applyAfterCreated widget') props - sc <- Gtk.widgetGetStyleContext binWidget - mapM_ (removeClass sc) oldAttributes - mapM_ (addClass sc) newAttributes + childState <- create child + childWidget <- someStateWidget childState + Gtk.containerAdd widget' childWidget + return (SomeState (StateTreeBin (StateTreeNode widget' sc collected ()) childState)) - childWidget <- getChild binWidget + patch (SomeState (st :: StateTree stateType w1 c1 e1 cs)) + (Bin _ _ oldChild) + (Bin (ctor :: Gtk.ManagedPtr w2 -> w2) newAttributes newChild) = + case (st, eqT @w1 @w2) of + (StateTreeBin top oldChildState, Just Refl) -> + Modify $ do + binWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top) + let oldCollected = stateTreeCollectedAttributes top + newCollected = collectAttributes newAttributes + updateProperties binWidget (collectedProperties oldCollected) (collectedProperties newCollected) + updateClasses (stateTreeStyleContext top) (collectedClasses oldCollected) (collectedClasses newCollected) - case patch oldChild newChild of - Modify modify -> modify childWidget - Replace createNew -> do - Gtk.containerRemove binWidget childWidget - Gtk.containerAdd binWidget =<< createNew - Keep -> return () + let top' = top { stateTreeCollectedAttributes = newCollected } + case patch oldChildState oldChild newChild of + Modify modify -> SomeState . StateTreeBin top' <$> modify + Replace createNew -> do + Gtk.widgetDestroy =<< someStateWidget oldChildState + newChildState <- createNew + childWidget <- someStateWidget newChildState + Gtk.widgetShow childWidget + Gtk.containerAdd binWidget childWidget + return (SomeState (StateTreeBin top' newChildState)) + Keep -> return (SomeState st) + _ -> Replace (create (Bin ctor newAttributes newChild)) -- -- EventSource @@ -121,12 +130,13 @@ instance (BinChild parent child, EventSource child) => EventSource (Bin parent child) where - subscribe (Bin ctor props child) widget' cb = do - binWidget <- Gtk.unsafeCastTo ctor widget' - handlers' <- - mconcat . catMaybes <$> mapM (addSignalHandler cb binWidget) props - childWidget <- getChild binWidget - (<> handlers') <$> subscribe child childWidget cb + subscribe (Bin ctor props child) (SomeState st) cb = + case st of + StateTreeBin top childState -> do + binWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top) + handlers' <- foldMap (addSignalHandler cb binWidget) props + (<> handlers') <$> subscribe child childState cb + _ -> error "Cannot subscribe to Bin events with a non-bin state tree." -- -- FromWidget @@ -154,14 +164,5 @@ FromWidget (Bin widget child) event (Markup event a) where fromWidget = single . Widget - --- | Get a "Gtk.Bin" child, or fail, and cast it to the given widget type. -getBinChild - :: (Gtk.IsBin bin, GI.GObject child) - => (Gtk.ManagedPtr child -> child) - -> bin - -> IO child -getBinChild ctor = - Gtk.binGetChild - >=> maybe (fail "expected Bin to have a child") return - >=> Gtk.unsafeCastTo ctor +instance FromWidget (Bin widget child) event (Bin widget child event) where + fromWidget = id diff --git a/src/GI/Gtk/Declarative/CSS.hs b/src/GI/Gtk/Declarative/CSS.hs deleted file mode 100644 --- a/src/GI/Gtk/Declarative/CSS.hs +++ /dev/null @@ -1,35 +0,0 @@ --- | Helpers for modifying CSS classes in 'Gtk.StyleContext' --- objects. - -module GI.Gtk.Declarative.CSS where - -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.Text (Text) -import qualified GI.Gtk as Gtk - --- | A set of CSS classes. -type ClassSet = HashSet Text - --- | Add the classes to the widget's style context. -addClasses - :: Gtk.IsWidget w - => w -- ^ The widget to add classes to. - -> ClassSet -- ^ New classes to add. - -> IO () -addClasses widget cs = do - sc <- Gtk.widgetGetStyleContext widget - mapM_ (Gtk.styleContextAddClass sc) cs - --- | Replace all classes in 'old' with the ones in 'old' in the widget's style --- context. -replaceClasses - :: Gtk.IsWidget w - => w -- ^ The widget to replace classes in. - -> ClassSet -- ^ Old classes to replace. - -> ClassSet -- ^ New classes to replace with. - -> IO () -replaceClasses widget old new = do - sc <- Gtk.widgetGetStyleContext widget - mapM_ (Gtk.styleContextRemoveClass sc) (HashSet.difference old new) - mapM_ (Gtk.styleContextAddClass sc) (HashSet.difference new old) 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,36 +1,39 @@ {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | Implementations for common "Gtk.Container". module GI.Gtk.Declarative.Container ( Container , container + , Children ) where -import Control.Monad (forM_) -import Data.Maybe +import Control.Monad (forM) import Data.Typeable -import qualified GI.Gtk as Gtk +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import qualified GI.Gtk as Gtk import GI.Gtk.Declarative.Attributes +import GI.Gtk.Declarative.Attributes.Collected import GI.Gtk.Declarative.Attributes.Internal import GI.Gtk.Declarative.Container.Patch import GI.Gtk.Declarative.EventSource import GI.Gtk.Declarative.Markup import GI.Gtk.Declarative.Patch +import GI.Gtk.Declarative.State -- | Declarative version of a /container/ widget, i.e. a widget with zero -- or more child widgets. The type of 'children' is parameterized, and differs @@ -45,7 +48,7 @@ , Functor children ) => (Gtk.ManagedPtr widget -> widget) - -> [Attribute widget event] + -> Vector (Attribute widget event) -> children event -> Container widget children event @@ -65,12 +68,12 @@ , FromWidget (Container widget (Children child)) event target ) => (Gtk.ManagedPtr widget -> widget) -- ^ A container widget constructor from the underlying gi-gtk library. - -> [Attribute widget event] -- ^ List of 'Attribute's. + -> Vector (Attribute widget event) -- ^ List of 'Attribute's. -> MarkupOf child event () -- ^ The container's 'child' widgets, in a 'MarkupOf' builder. -> target -- ^ The target, whose type is decided by 'FromWidget'. container ctor attrs = fromWidget . Container ctor attrs . toChildren -newtype Children child event = Children { unChildren :: [child event] } +newtype Children child event = Children { unChildren :: Vector (child event) } deriving (Functor) toChildren :: MarkupOf child event () -> Children child event @@ -80,43 +83,57 @@ -- Patchable -- -instance (Patchable child, IsContainer container child) => +instance (Patchable child, Typeable child, IsContainer container child) => Patchable (Container container (Children child)) where - create (Container ctor props children) = do - let attrOps = concatMap extractAttrConstructOps props - widget' <- Gtk.new ctor attrOps + create (Container ctor attrs children) = do + let collected = collectAttributes attrs + widget' <- Gtk.new ctor (constructProperties collected) + Gtk.widgetShow widget' sc <- Gtk.widgetGetStyleContext widget' - mapM_ (addClass sc) props - forM_ (unChildren children) $ \child -> do - childWidget <- create child - appendChild widget' child childWidget - Gtk.toWidget widget' - patch (Container _ oldAttributes oldChildren) (Container ctor newAttributes newChildren) = - Modify $ \widget' -> do - containerWidget <- Gtk.unsafeCastTo ctor widget' - Gtk.set containerWidget (concatMap extractAttrSetOps newAttributes) - sc <- Gtk.widgetGetStyleContext widget' - mapM_ (removeClass sc) oldAttributes - mapM_ (addClass sc) newAttributes - patchInContainer - containerWidget - (unChildren oldChildren) - (unChildren newChildren) + updateClasses sc mempty (collectedClasses collected) + -- TODO: + -- mapM_ (applyAfterCreated widget') props + childStates <- + forM (unChildren children) $ \child -> do + childState <- create child + appendChild widget' child =<< someStateWidget childState + return childState + return (SomeState (StateTreeContainer (StateTreeNode widget' sc collected ()) childStates)) + patch (SomeState (st :: StateTree stateType w1 c1 e1 cs)) (Container _ _ oldChildren) new@(Container (ctor :: Gtk.ManagedPtr w2 -> w2) newAttributes (newChildren :: Children c2 e2)) = + case (st, eqT @w1 @w2) of + (StateTreeContainer top childStates, Just Refl) -> + Modify $ do + containerWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top) + let oldCollected = stateTreeCollectedAttributes top + newCollected = collectAttributes newAttributes + updateProperties containerWidget (collectedProperties oldCollected) (collectedProperties newCollected) + updateClasses (stateTreeStyleContext top) (collectedClasses oldCollected) (collectedClasses newCollected) + let top' = top { stateTreeCollectedAttributes = newCollected } + SomeState <$> + patchInContainer + (StateTreeContainer top' childStates) + containerWidget + (unChildren oldChildren) + (unChildren newChildren) + _ -> Replace (create new) + -- -- EventSource -- instance (Typeable child, EventSource child) => EventSource (Container widget (Children child)) where - subscribe (Container ctor props children) widget' cb = do - parentWidget <- Gtk.unsafeCastTo ctor widget' - handlers' <- mconcat . catMaybes <$> mapM (addSignalHandler cb parentWidget) props - childWidgets <- Gtk.containerGetChildren parentWidget - subs <- - flip foldMap (zip (unChildren children) childWidgets) $ \(c, w) -> - subscribe c w cb - return (handlers' <> subs) + subscribe (Container ctor props children) (SomeState st) cb = + case st of + StateTreeContainer top childStates -> do + parentWidget <- Gtk.unsafeCastTo ctor (stateTreeWidget top) + handlers' <- foldMap (addSignalHandler cb parentWidget) props + subs <- + flip foldMap (Vector.zip (unChildren children) childStates) $ \(c, childState) -> + subscribe c childState cb + return (handlers' <> subs) + _ -> error "Warning: Cannot subscribe to Container events with a non-container state tree." -- -- FromWidget @@ -144,3 +161,5 @@ ) => FromWidget (Container widget children) event (Markup event a) where fromWidget = single . Widget +instance FromWidget (Container widget children) event (Container widget children event) where + fromWidget = id 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 @@ -46,7 +46,7 @@ instance Patchable BoxChild where create = create . child - patch b1 b2 = patch (child b1) (child b2) + patch s b1 b2 = patch s (child b1) (child b2) instance EventSource BoxChild where subscribe BoxChild{..} = subscribe child diff --git a/src/GI/Gtk/Declarative/Container/Class.hs b/src/GI/Gtk/Declarative/Container/Class.hs new file mode 100644 --- /dev/null +++ b/src/GI/Gtk/Declarative/Container/Class.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE FunctionalDependencies #-} +module GI.Gtk.Declarative.Container.Class where + +import qualified GI.Gtk as Gtk +import Data.Int (Int32) + +-- | Describes supported GTK+ containers and their specialized APIs for +-- appending and replacing child widgets. +class IsContainer container child | container -> child where + -- | Append a child widget to the container. + appendChild + :: container -- ^ Container widget + -> child event -- ^ Declarative child widget + -> Gtk.Widget -- ^ GTK child widget to append + -> IO () + -- | Replace the child widget at the given index in the container. + replaceChild + :: container -- ^ Container widget + -> child event -- ^ Declarative child widget + -> Int32 -- ^ Index to replace at + -> Gtk.Widget -- ^ Old GTK widget to replace + -> Gtk.Widget -- ^ New GTK widget to replace with + -> IO () diff --git a/src/GI/Gtk/Declarative/Container/MenuItem.hs b/src/GI/Gtk/Declarative/Container/MenuItem.hs new file mode 100644 --- /dev/null +++ b/src/GI/Gtk/Declarative/Container/MenuItem.hs @@ -0,0 +1,137 @@ +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors -fno-warn-orphans #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module GI.Gtk.Declarative.Container.MenuItem + ( MenuItem + , menuItem + , subMenu + ) +where + +import Data.Text ( Text ) +import Data.Typeable +import Data.Vector ( Vector ) +import qualified GI.Gtk as Gtk + +import GI.Gtk.Declarative.Attributes +import GI.Gtk.Declarative.Bin +import GI.Gtk.Declarative.Container +import GI.Gtk.Declarative.Container.Patch +import GI.Gtk.Declarative.EventSource +import GI.Gtk.Declarative.Markup +import GI.Gtk.Declarative.Patch +import GI.Gtk.Declarative.State + +data MenuItem event where + MenuItem + :: (Gtk.IsMenuItem item, BinChild item Widget, Typeable item) + => Bin item Widget event + -> MenuItem event + SubMenu + :: Text -> (Container Gtk.Menu (Children MenuItem) event) -> MenuItem event + +instance Functor MenuItem where + fmap f (MenuItem item) = MenuItem (fmap f item) + fmap f (SubMenu label subMenu')= SubMenu label (fmap f subMenu') + +menuItem + :: ( Gtk.IsMenuItem item + , Typeable event + , BinChild item Widget + , Typeable item + , Gtk.IsContainer item + , Gtk.IsBin item + , Gtk.IsWidget item + ) + => (Gtk.ManagedPtr item -> item) + -> Vector (Attribute item event) + -> Widget event + -> MarkupOf MenuItem event () +menuItem item attrs = single . MenuItem . Bin item attrs + +subMenu + :: (Typeable event) + => Text + -> MarkupOf MenuItem event () + -> MarkupOf MenuItem event () +subMenu label = single . SubMenu label . container Gtk.Menu mempty + +newSubMenuItem :: Text -> IO SomeState -> IO SomeState +newSubMenuItem label createSubMenu = do + menuItem' <- Gtk.menuItemNewWithLabel label + sc <- Gtk.widgetGetStyleContext menuItem' + SomeState (subMenuState :: StateTree st subMenu children e1 cs) <- createSubMenu + case eqT @subMenu @Gtk.Menu of + Just Refl -> do + Gtk.menuItemSetSubmenu menuItem' (Just (stateTreeNodeWidget subMenuState)) + return + (SomeState + (StateTreeBin (StateTreeNode menuItem' sc mempty ()) + (SomeState subMenuState) + ) + ) + Nothing -> fail "Failed to create new sub menu item." + +instance Patchable MenuItem where + create = + \case + MenuItem item -> create item + SubMenu label subMenu' -> newSubMenuItem label (create subMenu') + patch state (MenuItem (c1 :: Bin i1 Widget e1)) (MenuItem (c2 :: Bin i2 Widget e2)) = + case eqT @i1 @i2 of + Just Refl -> patch state c1 c2 + Nothing -> Replace (create c2) + patch (SomeState st) (SubMenu l1 c1) (SubMenu l2 c2) = + case st of + StateTreeBin top childState | l1 == l2 -> + case patch childState c1 c2 of + Modify modify -> + Modify (SomeState . StateTreeBin top <$> modify) + Replace newSubMenu -> + Replace (newSubMenuItem l2 newSubMenu) + Keep -> Keep + -- TODO: case for l1 /= l2 + _ -> Replace (create (SubMenu l2 c2)) + patch _ _ b2 = Replace (create b2) + +instance EventSource MenuItem where + subscribe (MenuItem item) state cb = subscribe item state cb + subscribe (SubMenu _ children) (SomeState st) cb = + case st of + StateTreeBin _ childState -> subscribe children childState cb + _ -> error "Warning: Cannot subscribe to SubMenu events with a non-bin state tree." + +instance IsContainer Gtk.MenuShell MenuItem where + appendChild shell _ widget' = + Gtk.menuShellAppend shell =<< Gtk.unsafeCastTo Gtk.MenuItem widget' + replaceChild shell _ i old new = do + Gtk.containerRemove shell old + menuItem' <- Gtk.unsafeCastTo Gtk.MenuItem new + Gtk.menuShellInsert shell menuItem' i + Gtk.widgetShowAll shell + +instance IsContainer Gtk.MenuBar MenuItem where + appendChild menuBar d w = do + s <- Gtk.toMenuShell menuBar + appendChild s d w + replaceChild menuBar d i old new = do + s <- Gtk.toMenuShell menuBar + replaceChild s d i old new + +instance IsContainer Gtk.Menu MenuItem where + appendChild menuBar d w = do + s <- Gtk.toMenuShell menuBar + appendChild s d w + replaceChild menuBar d i old new = do + s <- Gtk.toMenuShell menuBar + replaceChild s d i old new 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 @@ -1,49 +1,36 @@ -{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors -fno-warn-orphans #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | This module implements the patch algorithm for containers. -module GI.Gtk.Declarative.Container.Patch (IsContainer(..), patchInContainer) where +module GI.Gtk.Declarative.Container.Patch + ( IsContainer(..) + , patchInContainer + ) +where -import Control.Monad (forM_) -import Data.Int (Int32) -import Data.List (zip4) -import qualified GI.Gtk as Gtk +import Data.Foldable (foldMap) +import Data.Vector (Vector, (!?)) +import qualified Data.Vector as Vector +import qualified GI.Gtk as Gtk import GI.Gtk.Declarative.Bin import GI.Gtk.Declarative.Container.Box +import GI.Gtk.Declarative.Container.Class import GI.Gtk.Declarative.Markup import GI.Gtk.Declarative.Patch - - --- | Describes supported GTK+ containers and their specialized APIs for --- appending and replacing child widgets. -class IsContainer container child | container -> child where - -- | Append a child widget to the container. - appendChild - :: container -- ^ Container widget - -> child event -- ^ Declarative child widget - -> Gtk.Widget -- ^ GTK child widget to append - -> IO () - -- | Replace the child widget at the given index in the container. - replaceChild - :: container -- ^ Container widget - -> child event -- ^ Declarative child widget - -> Int32 -- ^ Index to replace at - -> Gtk.Widget -- ^ Old GTK widget to replace - -> Gtk.Widget -- ^ New GTK widget to replace with - -> IO () +import GI.Gtk.Declarative.State -- | Patch all children in a container. This does not feature any ID checking, -- as seen in React, so reordering children in a container can produce many @@ -54,67 +41,91 @@ , Patchable child , IsContainer container child ) - => container - -> [child e1] - -> [child e2] - -> IO () -patchInContainer container os' ns' = do - cs <- Gtk.containerGetChildren container - let maxLength = maximum [length cs, length os', length ns'] - indices = [0 .. pred (fromIntegral maxLength)] - forM_ (zip4 indices (padMaybes cs) (padMaybes os') (padMaybes ns')) $ \case + => StateTree 'ContainerState container child event cs + -> container + -> Vector (child e1) + -> Vector (child e2) + -> IO (StateTree 'ContainerState container child event cs) +patchInContainer (StateTreeContainer top children) container os' ns' = do + let maxLength = maximum ([length children, length os', length ns'] :: [Int]) + indices = Vector.enumFromN 0 (fromIntegral maxLength) + newChildren <- foldMap + go + (Vector.zip4 indices + (padMaybes maxLength children) + (padMaybes maxLength os') + (padMaybes maxLength ns') + ) - -- In case we have a corresponding old and new declarative widget, we patch - -- the GTK widget. - (i, Just w, Just old, Just new) -> case patch old new of - Modify modify -> modify w - Replace createWidget -> replaceChild container new i w =<< createWidget - Keep -> return () + Gtk.widgetQueueResize container + return (StateTreeContainer top newChildren) + where + go = \case + -- In case we have a corresponding old and new declarative widget, we patch + -- the GTK widget. + (i, Just oldChildState, Just old, Just new) -> + case patch oldChildState old new of + Modify modify -> pure <$> modify + Replace createWidget -> do + newChildState <- createWidget + oldChildWidget <- someStateWidget oldChildState + newChildWidget <- someStateWidget newChildState + replaceChild container new i oldChildWidget newChildWidget + return (pure newChildState) + Keep -> return (pure oldChildState) - -- When there is a new declarative widget, but there already exists a GTK - -- widget in the corresponding place, we need to replace the GTK widget with - -- one created from the declarative widget. - (i, Just w, Nothing, Just new) -> - replaceChild container new i w =<< create new + -- When there is a new declarative widget, but there already exists a GTK + -- widget in the corresponding place, we need to replace the GTK widget with + -- one created from the declarative widget. + (i, Just oldChildState, Nothing, Just new) -> do + newChildState <- create new + oldChildWidget <- someStateWidget oldChildState + newChildWidget <- someStateWidget newChildState + replaceChild container new i oldChildWidget newChildWidget + return (Vector.singleton newChildState) - -- When there is a new declarative widget, or one that lacks a corresponding - -- GTK widget, create and add it. - (_i, Nothing, _ , Just n ) -> create n >>= appendChild container n + -- When there is a new declarative widget, or one that lacks a corresponding + -- GTK widget, create and add it. + (_i, Nothing, _, Just n) -> do + newChildState <- create n + w <- someStateWidget newChildState + appendChild container n w + return (Vector.singleton newChildState) - -- When an declarative widget has been removed, remove the GTK widget from - -- the container. - (_i, Just w , Just _ , Nothing) -> Gtk.containerRemove container w + -- When a declarative widget has been removed, remove the GTK widget from + -- the container. + (_i, Just childState, Just _, Nothing) -> do + Gtk.widgetDestroy =<< someStateWidget childState + return Vector.empty - -- When there are more old declarative widgets than GTK widgets, we can - -- safely ignore the old declarative widgets. - (_i, Nothing, Just _ , Nothing) -> return () + -- When there are more old declarative widgets than GTK widgets, we can + -- safely ignore the old declarative widgets. + (_i, Nothing , Just _ , Nothing) -> return Vector.empty - -- But, when there are stray GTK widgets without corresponding - -- declarative widgets, something has gone wrong, and we clean that up by - -- removing the GTK widgets. - (_i, Just w , Nothing, Nothing) -> Gtk.containerRemove container w + -- But, when there are stray GTK widgets without corresponding + -- declarative widgets, something has gone wrong, and we clean that up by + -- removing the GTK widgets. + (_i, Just childState, Nothing, Nothing) -> do + Gtk.widgetDestroy =<< someStateWidget childState + return Vector.empty - -- No more GTK widgets or declarative widgets, we are done. - (_i, Nothing, Nothing, Nothing) -> return () + -- No more GTK widgets or declarative widgets, we are done. + (_i, Nothing, Nothing, Nothing) -> return Vector.empty - Gtk.widgetQueueResize container +padMaybes :: Int -> Vector a -> Vector (Maybe a) +padMaybes len xs = Vector.generate len (xs !?) instance IsContainer Gtk.ListBox (Bin Gtk.ListBoxRow Widget) where - appendChild box _ widget' = Gtk.listBoxInsert box widget' (-1) + appendChild box _ widget' = + Gtk.listBoxInsert box widget' (-1) replaceChild box _ i old new = do - Gtk.containerRemove box old + Gtk.widgetDestroy old Gtk.listBoxInsert box new i - Gtk.widgetShowAll box instance IsContainer Gtk.Box BoxChild where appendChild box BoxChild {..} widget' = Gtk.boxPackStart box widget' expand fill padding - replaceChild box boxChild' i old new = do - Gtk.containerRemove box old + Gtk.widgetDestroy old appendChild box boxChild' new Gtk.boxReorderChild box new i - Gtk.widgetShowAll box - -padMaybes :: [a] -> [Maybe a] -padMaybes xs = map Just xs ++ repeat Nothing 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 @@ -1,18 +1,19 @@ -{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | Event handling for declarative widgets. module GI.Gtk.Declarative.EventSource - ( EventSource (..) + ( EventSource(..) , Subscription , fromCancellation , cancel ) where -import qualified GI.Gtk as Gtk +import Data.Vector (Vector) +import GI.Gtk.Declarative.State + -- | Cancel a 'Subscription', meaning that the callback will not be invoked on -- any subsequent signal emissions. cancel :: Subscription -> IO () @@ -23,7 +24,7 @@ class EventSource widget where subscribe :: widget event -- ^ Declarative widget with event handlers. - -> Gtk.Widget -- ^ Actual 'Gtk.Widget' that has been created or patched. + -> SomeState -- ^ State of rendered widget tree. -> (event -> IO ()) -- ^ Event callback, invoked on each emitted event until -- the 'Subscription' is cancelled, or widget is otherwise -- destroyed. @@ -33,7 +34,7 @@ -- handlers (to a tree of widgets.) When subscribing to a container widget, all -- child widgets are also subscribed to, and the 'Subscription's are combined -- using the 'Semigroup' instance. -newtype Subscription = Subscription { cancellations :: [IO ()] } +newtype Subscription = Subscription { cancellations :: Vector (IO ()) } deriving (Semigroup, Monoid) -- | Create a subscription from a cancellation IO action. diff --git a/src/GI/Gtk/Declarative/Markup.hs b/src/GI/Gtk/Declarative/Markup.hs --- a/src/GI/Gtk/Declarative/Markup.hs +++ b/src/GI/Gtk/Declarative/Markup.hs @@ -29,6 +29,7 @@ import Control.Monad.Writer import Data.Typeable +import Data.Vector (Vector) import GI.Gtk.Declarative.EventSource import GI.Gtk.Declarative.Patch @@ -54,9 +55,9 @@ -- widget instances. instance Patchable Widget where create (Widget w) = create w - patch (Widget (w1 :: t1 e1)) (Widget (w2 :: t2 e2)) = + patch s (Widget (w1 :: t1 e1)) (Widget (w2 :: t2 e2)) = case eqT @t1 @t2 of - Just Refl -> patch w1 w2 + Just Refl -> patch s w1 w2 _ -> Replace (create w2) instance EventSource Widget where @@ -74,11 +75,11 @@ -- technical necessity to have the 'Monad' instance. You can still use it if -- you need to return a value from a markup function, though. newtype MarkupOf widget event a = - MarkupOf (Writer [widget event] a) + MarkupOf (Writer (Vector (widget event)) a) deriving (Functor, Applicative, Monad) -- | Run a 'MarkupOf' builder and get its widgets. -runMarkup :: MarkupOf widget event () -> [widget event] +runMarkup :: MarkupOf widget event () -> Vector (widget event) runMarkup (MarkupOf w) = execWriter w -- | Handy type alias for the common case of markup containing 'Widget's. @@ -86,10 +87,10 @@ -- | Construct markup from a single widget. single :: widget event -> MarkupOf widget event () -single w = MarkupOf (tell [w]) +single = MarkupOf . tell . pure -- | Construct markup from multiple widgets. -multiple :: [widget event] -> MarkupOf widget event () +multiple :: Vector (widget event) -> MarkupOf widget event () multiple = MarkupOf . tell -- | Convert a widget to a target type. This is deliberately unconstrained in 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 @@ -1,21 +1,22 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} +-- | The central patching type class of this library. module GI.Gtk.Declarative.Patch ( Patch(..) , Patchable(..) ) where -import qualified GI.Gtk as Gtk +import GI.Gtk.Declarative.State -- | A possible action to take on an existing 'Gtk.Widget', decided by the -- 'patch' method when comparing declarative widgets. data Patch - = Modify (Gtk.Widget -> IO ()) + = Modify (IO SomeState) -- ^ An 'IO' action to apply to a 'Gtk.Widget' to make it reflect an updated -- declarative widget. The action to apply is calculated from the difference -- between the old and the new declarative widget. - | Replace (IO Gtk.Widget) + | Replace (IO SomeState) -- ^ Replace the current 'Gtk.Widget' by the widget returned by the IO -- action. | Keep @@ -28,7 +29,7 @@ -- | Given a declarative widget that is 'Patchable', return an IO action that -- can create a new corresponding 'Gtk.Widget'. The created widget should be -- use in corresponding patch modifications, until it is replaced. - create :: widget e -> IO Gtk.Widget + create :: widget e -> IO SomeState -- | Given two declarative widgets of the same widget type (but not -- necessarily of the same event types,) calculate a 'Patch'. - patch :: widget e1 -> widget e2 -> Patch + patch :: SomeState -> widget e1 -> widget e2 -> Patch 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,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -16,22 +17,24 @@ ) where -import Data.Maybe import Data.Typeable -import qualified GI.Gtk as Gtk +import Data.Vector (Vector) +import qualified GI.Gtk as Gtk import GI.Gtk.Declarative.Attributes +import GI.Gtk.Declarative.Attributes.Collected import GI.Gtk.Declarative.Attributes.Internal import GI.Gtk.Declarative.EventSource import GI.Gtk.Declarative.Markup import GI.Gtk.Declarative.Patch +import GI.Gtk.Declarative.State -- | Declarative version of a /leaf/ widget, i.e. a widget without any children. data SingleWidget widget event where SingleWidget :: (Typeable widget, Gtk.IsWidget widget, Functor (Attribute widget)) => (Gtk.ManagedPtr widget -> widget) - -> [Attribute widget event] + -> Vector (Attribute widget event) -> SingleWidget widget event instance Functor (SingleWidget widget) where @@ -39,35 +42,36 @@ instance Patchable (SingleWidget widget) where create = \case - (SingleWidget ctor props) -> do - let attrOps = concatMap extractAttrConstructOps props - widget' <- Gtk.new ctor attrOps - + SingleWidget ctor attrs -> do + let collected = collectAttributes attrs + widget' <- Gtk.new ctor (constructProperties collected) + Gtk.widgetShow widget' sc <- Gtk.widgetGetStyleContext widget' - mapM_ (addClass sc) props + updateClasses sc mempty (collectedClasses collected) + -- TODO: + -- mapM_ (applyAfterCreated widget') props - Gtk.widgetShowAll widget' - Gtk.toWidget widget' - patch (SingleWidget (_ :: Gtk.ManagedPtr w1 -> w1) oldAttributes) + return (SomeState (StateTreeWidget (StateTreeNode widget' sc collected ()))) + patch (SomeState (st :: StateTree stateType w child event cs)) + (SingleWidget (_ :: Gtk.ManagedPtr w1 -> w1) _) (SingleWidget (ctor :: Gtk.ManagedPtr w2 -> w2) newAttributes) = - case eqT @w1 @w2 of - Just Refl -> - Modify $ \widget' -> do - w <- Gtk.unsafeCastTo ctor widget' - Gtk.set w (concatMap extractAttrSetOps newAttributes) - - sc <- Gtk.widgetGetStyleContext widget' - mapM_ (removeClass sc) oldAttributes - mapM_ (addClass sc) newAttributes - - Gtk.widgetShowAll w - - Nothing -> Replace (create (SingleWidget ctor newAttributes)) + case (st, eqT @w @w1, eqT @w1 @w2) of + (StateTreeWidget top, Just Refl, Just Refl) -> Modify $ do + let w = stateTreeWidget top + let oldCollected = stateTreeCollectedAttributes top + newCollected = collectAttributes newAttributes + updateProperties w (collectedProperties oldCollected) (collectedProperties newCollected) + updateClasses (stateTreeStyleContext top) (collectedClasses oldCollected) (collectedClasses newCollected) + let top' = top { stateTreeCollectedAttributes = newCollected } + return (SomeState (StateTreeWidget top' { stateTreeCollectedAttributes = newCollected })) + _ -> Replace (create (SingleWidget ctor newAttributes)) instance EventSource (SingleWidget widget) where - subscribe (SingleWidget ctor props) widget' cb = do - w <- Gtk.unsafeCastTo ctor widget' - mconcat . catMaybes <$> mapM (addSignalHandler cb w) props + subscribe (SingleWidget (_ :: Gtk.ManagedPtr w1 -> w1) props) (SomeState (st :: StateTree stateType w2 child event cs)) cb = do + case (st, eqT @w1 @w2) of + (StateTreeWidget top, Just Refl) -> + foldMap (addSignalHandler cb (stateTreeWidget top)) props + _ -> fail "" instance (Typeable widget, Functor (SingleWidget widget)) => FromWidget (SingleWidget widget) event (Widget event) where @@ -81,14 +85,14 @@ fromWidget = single . Widget -- | Construct a /leaf/ widget, i.e. one without any children. -widget :: - ( Typeable widget +widget + :: ( Typeable widget , Typeable event , Functor (Attribute widget) , Gtk.IsWidget widget , FromWidget (SingleWidget widget) event target ) => (Gtk.ManagedPtr widget -> widget) -- ^ A widget constructor from the underlying gi-gtk library. - -> [Attribute widget event] -- ^ List of 'Attribute's. + -> Vector (Attribute widget event) -- ^ List of 'Attribute's. -> target -- ^ The target, whose type is decided by 'FromWidget'. widget ctor = fromWidget . SingleWidget ctor diff --git a/src/GI/Gtk/Declarative/State.hs b/src/GI/Gtk/Declarative/State.hs new file mode 100644 --- /dev/null +++ b/src/GI/Gtk/Declarative/State.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +-- | The 'StateTree' and 'SomeState' form a "shadow state" +-- representation, used in patching. Declarative widgets can return, +-- and later on reuse, its underlying GTK+ widget, collected +-- properties and classes, style context, custom internal state, and +-- child states. This reduces the need for querying GTK+ widgets +-- excessively, and recalculating/resetting, greatly improving the +-- performance of patching. +module GI.Gtk.Declarative.State where + +import Data.Typeable + +import Data.Vector (Vector) +import qualified GI.Gtk as Gtk + +import GI.Gtk.Declarative.Attributes.Collected +import GI.Gtk.Declarative.Container.Class + +-- | A 'Data.Dynamic.Dynamic'-like container of a 'StateTree' value. +data SomeState where + SomeState + :: ( Gtk.IsWidget widget + , Typeable widget + , Typeable customState + ) + => StateTree stateType widget child event customState + -> SomeState + +-- | The types of state trees that are available, matching the types +-- of GTK+ widgets (single widget, bin, and container.) +data StateType = WidgetState | BinState | ContainerState + +-- | A state tree for a specific 'widget'. This is built up recursively +-- to contain child state trees, for bin and container child widgets. +data StateTree (stateType :: StateType) widget child event customState where + StateTreeWidget + :: !(StateTreeNode widget event customState) + -> StateTree 'WidgetState widget child event customState + StateTreeBin + :: !(StateTreeNode widget event customState) + -> SomeState + -> StateTree 'BinState widget child event customState + StateTreeContainer + :: ( Gtk.IsContainer widget + , IsContainer widget child + ) + => !(StateTreeNode widget event customState) + -> Vector SomeState + -> StateTree 'ContainerState widget child event customState + +-- | The common structure for all state tree nodes. +data StateTreeNode widget event customState = StateTreeNode + { stateTreeWidget :: !widget + , stateTreeStyleContext :: !Gtk.StyleContext + , stateTreeCollectedAttributes :: !(Collected widget event) + , stateTreeCustomState :: customState + } + +-- * Convenience accessor functions + +-- | Get the common state tree node information. +stateTreeNode + :: StateTree stateType widget child event customState + -> StateTreeNode widget event customState +stateTreeNode (StateTreeWidget s ) = s +stateTreeNode (StateTreeBin s _) = s +stateTreeNode (StateTreeContainer s _) = s + +-- | Get the specific type of GTK+ widget of a state tree. +stateTreeNodeWidget :: StateTree stateType widget child event customState -> widget +stateTreeNodeWidget = stateTreeWidget . stateTreeNode + +-- | Get the GTK+ widget, cast to 'Gtk.Widget', of /some/ state tree. +someStateWidget :: SomeState -> IO Gtk.Widget +someStateWidget (SomeState st) = Gtk.toWidget (stateTreeNodeWidget st)