diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +* 0.5.0 + - New `CustomWidget` API: + - easier-to-use internal state + - pass-through attributes to top widget * 0.4.0 - Use `Vector` instead of `[]` for child widgets * 0.3.0 diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs deleted file mode 100644 --- a/bench/Benchmark.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Control.Concurrent -import Control.Monad -import Criterion.Main -import Data.Functor ((<&>)) -import Data.Text -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import qualified GI.Gdk as Gdk -import qualified GI.GLib.Constants as GLib - -import GI.Gtk (Box (..), Label (..), Window (..)) -import qualified GI.Gtk as Gtk -import GI.Gtk.Declarative -import GI.Gtk.Declarative.State - -testView :: Vector Int -> Widget () -testView ns = bin Window [] $ container Box [] $ ns <&> \n -> - BoxChild defaultBoxChildProperties { expand = True - , fill = True - , padding = 10 - } - $ widget Label [#label := pack (show n), classes ["a", "b"]] - -testPatch :: Patchable widget => SomeState -> widget e1 -> widget e2 -> IO SomeState -testPatch state oldView newView = case patch state oldView newView of - Modify ma -> do - ret <- newEmptyMVar - void . Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ do - ma >>= putMVar ret - return False - takeMVar ret - _ -> error "Expected a modification." - -main :: IO () -main = do - _ <- Gtk.init Nothing - let initialView = testView (Vector.enumFromN 1 100) - initialState <- create initialView - #showAll =<< someStateWidget initialState - _ <- forkOS $ do - defaultMain - [ bgroup - "patch" - [ bench "Modify (equal)" . whnfIO . replicateM_ 10 $ do - s1 <- testPatch initialState initialView initialView - void $ testPatch s1 initialView initialView - , bench "Modify (diff)" . whnfIO . replicateM_ 10 $ do - s1 <- testPatch initialState initialView initialView - void $ testPatch s1 initialView (testView (Vector.enumFromN 2 101)) - ] - ] - Gtk.mainQuit - Gtk.main 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.4.3 +version: 0.5.0 synopsis: Declarative GTK+ programming in Haskell description: A declarative programming model for GTK+ user interfaces, implementing support for various widgets @@ -51,6 +51,7 @@ , GI.Gtk.Declarative.Widget , GI.Gtk.Declarative.Widget.Conversions build-depends: base >=4.10 && <5 + , data-default-class >= 0.1 && <0.2 , gi-gobject >= 2 && <3 , gi-glib >= 2 && <3 , gi-gtk >= 3 && <4 @@ -65,18 +66,22 @@ default-language: Haskell2010 ghc-options: -Wall -benchmark gi-gtk-declarative-benchmark +test-suite gi-gtk-declarative-tests type: exitcode-stdio-1.0 - hs-source-dirs: bench - main-is: Benchmark.hs + hs-source-dirs: test + main-is: Main.hs build-depends: base >= 4 && < 5 - , criterion >= 1.5.3.0 + , async , gi-glib , gi-gdk + , gi-gobject , gi-gtk , gi-gtk-declarative - , random + , hedgehog >= 1 && < 2 + , safe-exceptions + , stm , text , vector + , unordered-containers ghc-options: -Wall -O2 -rtsopts -with-rtsopts=-N -threaded default-language: Haskell2010 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 @@ -124,9 +124,10 @@ -- | Update the style context's classes to only include the new set of -- classes (last argument). -updateClasses :: Gtk.StyleContext -> ClassSet -> ClassSet -> IO () -updateClasses sc old new = do +updateClasses + :: Gtk.StyleContext -> ClassSet -> ClassSet -> IO () +updateClasses ctx old new = do let toAdd = HashSet.difference new old toRemove = HashSet.difference old new - mapM_ (Gtk.styleContextAddClass sc) toAdd - mapM_ (Gtk.styleContextRemoveClass sc) toRemove + mapM_ (Gtk.styleContextAddClass ctx) toAdd + mapM_ (Gtk.styleContextRemoveClass ctx) toRemove 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 @@ -20,6 +20,7 @@ ) where +import Data.Default.Class (Default (def)) import Data.Vector (Vector) import Data.Word (Word32) import qualified GI.Gtk as Gtk @@ -48,6 +49,9 @@ defaultBoxChildProperties :: BoxChildProperties defaultBoxChildProperties = BoxChildProperties {expand = False, fill = False, padding = 0} + +instance Default BoxChildProperties where + def = defaultBoxChildProperties instance Patchable BoxChild where create = create . child 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 @@ -25,6 +25,7 @@ where import Data.Coerce (coerce) +import Data.Default.Class (Default (def)) import Data.Typeable import Data.Vector (Vector) import qualified Data.Vector as Vector @@ -57,6 +58,9 @@ -- fields. defaultPaneProperties :: PaneProperties defaultPaneProperties = PaneProperties {resize = False, shrink = True} + +instance Default PaneProperties where + def = defaultPaneProperties -- | Construct a pane to be packed with -- 'Gtk.panePack1'/'Gtk.panePack2' in a 'Gtk.Paned'. 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,4 +1,7 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | While you can instantiate 'Patchable' and 'EventSource' for your -- own data types, it's a bit complicated. The 'CustomWidget' data @@ -11,46 +14,94 @@ ) where -import qualified GI.Gtk as Gtk +import Data.Typeable +import Data.Vector (Vector) +import qualified GI.Gtk as Gtk +import GI.Gtk.Declarative.Attributes +import GI.Gtk.Declarative.Attributes.Collected import GI.Gtk.Declarative.EventSource import GI.Gtk.Declarative.Patch import GI.Gtk.Declarative.State -- | Similar to 'Patch', describing a possible action to perform on a -- 'Gtk.Widget', decided by 'customPatch'. -data CustomPatch widget customData +data CustomPatch widget internalState = CustomReplace - | CustomModify (widget -> IO SomeState) + | CustomModify (widget -> IO internalState) | CustomKeep -- | A custom widget specification, with all functions needed to --- instantiate 'Patchable' and 'EventSource'. A custom widget is based --- on a top 'widget', can use 'customData' as a way of passing --- parameters, and emits events of type 'event'. -data CustomWidget widget customData event = +-- instantiate 'Patchable' and 'EventSource'. A custom widget: +-- +-- * is based on a top 'widget' +-- * can use 'internalState' as a way of keeping an internal state +-- value threaded through updates, which is often useful for passing +-- references to child widgets used in a custom widget +-- * emits events of type 'event' +data CustomWidget widget params internalState event = CustomWidget { customWidget :: Gtk.ManagedPtr widget -> widget -- ^ The widget constructor - , customCreate :: customData -> IO SomeState + , customCreate :: params -> IO (widget, internalState) -- ^ Action that creates the initial widget - , customPatch :: SomeState -> customData -> customData -> CustomPatch widget customData + , customPatch :: params -> params -> internalState -> CustomPatch widget internalState -- ^ Patch function, calculating a 'CustomPatch' based on the state, - -- old custom data, and new custom data. - , customSubscribe :: customData -> widget -> (event -> IO ()) -> IO Subscription + -- old custom data, and new custom data + , customSubscribe :: params -> internalState -> widget -> (event -> IO ()) -> IO Subscription -- ^ Action that creates an event subscription for the custom widget - , customData :: customData - -- ^ The custom data (e.g. parameters) of the custom widget + , customAttributes :: Vector (Attribute widget event) + -- ^ Declarative 'Attribute's for the custom widget (properties and + -- classes are handled automatically in patching) + , customParams :: params + -- ^ Parameters passed when constructing the declarative custom widget } deriving (Functor) -instance Gtk.IsWidget widget => Patchable (CustomWidget widget customData) where - create custom = customCreate custom (customData custom) - patch state' old new = - case customPatch old state' (customData old) (customData new) of - CustomReplace -> Replace (customCreate new (customData new)) - CustomModify f -> Modify (f =<< Gtk.unsafeCastTo (customWidget new) =<< someStateWidget state') - CustomKeep -> Keep +instance ( Typeable widget + , Typeable internalState + , Gtk.IsWidget widget + ) + => Patchable (CustomWidget widget params internalState) where + create custom = do + (widget, internalState) <- customCreate custom (customParams custom) + Gtk.widgetShow widget -instance Gtk.GObject widget => EventSource (CustomWidget widget customData) where - subscribe custom state' cb = do - w' <- Gtk.unsafeCastTo (customWidget custom) =<< someStateWidget state' - customSubscribe custom (customData custom) w' cb + let collected = collectAttributes (customAttributes custom) + updateProperties widget mempty (collectedProperties collected) + sc <- Gtk.widgetGetStyleContext widget + updateClasses sc mempty (collectedClasses collected) + + pure (SomeState (StateTreeWidget (StateTreeNode widget sc collected internalState))) + patch (SomeState (stateTree :: StateTree st w e c cs)) old new = + case (eqT @cs @internalState, eqT @widget @w) of + (Just Refl, Just Refl) -> + case customPatch + new + (customParams old) + (customParams new) + (stateTreeCustomState (stateTreeNode stateTree)) + of + CustomReplace -> Replace (create new) + CustomModify f -> Modify $ do + let widget' = stateTreeNodeWidget stateTree + + let oldCollected = stateTreeCollectedAttributes (stateTreeNode stateTree) + newCollected = collectAttributes (customAttributes new) + updateProperties widget' (collectedProperties oldCollected) (collectedProperties newCollected) + updateClasses (stateTreeStyleContext (stateTreeNode stateTree)) (collectedClasses oldCollected) (collectedClasses newCollected) + internalState' <- + f =<< Gtk.unsafeCastTo (customWidget new) widget' + let node = stateTreeNode stateTree + return (SomeState (StateTreeWidget node { stateTreeCustomState = internalState' + , stateTreeCollectedAttributes = newCollected + })) + CustomKeep -> Keep + _ -> Replace (create new) + +instance (Typeable internalState, Gtk.GObject widget) + => EventSource (CustomWidget widget params internalState) where + subscribe custom (SomeState (stateTree :: StateTree st w e c cs)) cb = + case eqT @cs @internalState of + Just Refl -> do + w' <- Gtk.unsafeCastTo (customWidget custom) (stateTreeNodeWidget stateTree) + customSubscribe custom (customParams custom) (stateTreeCustomState (stateTreeNode stateTree)) w' cb + Nothing -> pure (fromCancellation (pure ())) 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 @@ -70,7 +70,7 @@ case (st, eqT @w1 @w2) of (StateTreeWidget top, Just Refl) -> foldMap (addSignalHandler cb (stateTreeWidget top)) props - _ -> fail "" + _ -> pure (fromCancellation (pure ())) -- instance (Typeable widget, Functor (SingleWidget widget)) -- => FromWidget (SingleWidget widget) Widget where diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,22 @@ +module Main where + +import Control.Concurrent +import Control.Monad +import qualified GI.Gtk as Gtk +import System.Exit +import System.IO + +import qualified GI.Gtk.Declarative.CustomWidgetTest as CustomWidget + + +main :: IO () +main = do + _ <- Gtk.init Nothing + _ <- forkOS $ do + results <- sequence [CustomWidget.tests] + Gtk.mainQuit + unless (and results) $ do + hPutStrLn stderr "Tests failed." + exitFailure + Gtk.main +