diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,6 @@ +* 0.6.0 + - Allow dependency haskell-gi-0.23 + - Remove redundant code * 0.5.0 - New `CustomWidget` API: - easier-to-use internal state 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.5.0 +version: 0.6.0 synopsis: Declarative GTK+ programming in Haskell description: A declarative programming model for GTK+ user interfaces, implementing support for various widgets @@ -55,8 +55,8 @@ , gi-gobject >= 2 && <3 , gi-glib >= 2 && <3 , gi-gtk >= 3 && <4 - , haskell-gi >= 0.21 && <0.23 - , haskell-gi-base >= 0.21 && <0.23 + , haskell-gi >= 0.21 && <0.24 + , haskell-gi-base >= 0.21 && <0.24 , haskell-gi-overloading == 1.0 , mtl , text @@ -85,3 +85,4 @@ , unordered-containers ghc-options: -Wall -O2 -rtsopts -with-rtsopts=-N -threaded default-language: Haskell2010 + other-modules: GI.Gtk.Declarative.CustomWidgetTest 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,7 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} 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 @@ -3,7 +3,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} 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 @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -51,9 +50,7 @@ -- | Construct a /bin/ widget, i.e. a widget with exactly one child. bin - :: ( Patchable (Bin widget) - , Typeable widget - , Typeable event + :: ( Typeable widget , Gtk.IsContainer widget , Gtk.IsBin widget , Gtk.IsWidget widget 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 @@ -59,10 +59,7 @@ -- | Construct a /container/ widget, i.e. a widget with zero or more children. container - :: ( Patchable (Container widget (Children child)) - , Typeable widget - , Typeable child - , Typeable event + :: ( Typeable widget , Functor child , Gtk.IsWidget widget , Gtk.IsContainer widget @@ -117,7 +114,7 @@ -- EventSource -- -instance (Typeable child, EventSource child) => +instance EventSource child => EventSource (Container widget (Children child)) where subscribe (Container ctor props children) (SomeState st) cb = case st of @@ -138,7 +135,6 @@ , Typeable children , Patchable (Container widget children) , EventSource (Container widget children) - , Functor (Container widget children) ) => FromWidget (Container widget children) Widget where fromWidget = Widget diff --git a/src/GI/Gtk/Declarative/Container/Class.hs b/src/GI/Gtk/Declarative/Container/Class.hs --- a/src/GI/Gtk/Declarative/Container/Class.hs +++ b/src/GI/Gtk/Declarative/Container/Class.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -- | Shared interfaces for containers. 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 @@ -55,7 +55,6 @@ -- | Construct a single menu item for a 'Gtk.Menu'. menuItem :: ( Gtk.IsMenuItem item - , Typeable event , Typeable item , Gtk.IsContainer item , Gtk.IsBin item @@ -69,11 +68,7 @@ -- | Construct a sub menu for a 'Gtk.Menu', wit a text label and the -- child menu items. -subMenu - :: (Typeable event) - => Text - -> Vector (MenuItem event) - -> MenuItem event +subMenu :: Text -> Vector (MenuItem event) -> MenuItem event subMenu label = SubMenu label . container Gtk.Menu mempty newSubMenuItem :: Text -> IO SomeState -> IO SomeState 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 @@ -26,7 +26,6 @@ import Data.Coerce (coerce) import Data.Default.Class (Default (def)) -import Data.Typeable import Data.Vector (Vector) import qualified Data.Vector as Vector import GHC.Ptr (nullPtr) @@ -75,7 +74,7 @@ subscribe Pane{..} = subscribe paneChild -- | Construct a 'Gtk.Paned' based on attributes and two child 'Pane's. -paned :: Typeable event => Vector (Attribute Gtk.Paned event) -> Pane event -> Pane event -> Widget event +paned :: 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 diff --git a/src/GI/Gtk/Declarative/Container/Patch.hs b/src/GI/Gtk/Declarative/Container/Patch.hs --- a/src/GI/Gtk/Declarative/Container/Patch.hs +++ b/src/GI/Gtk/Declarative/Container/Patch.hs @@ -6,7 +6,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ScopedTypeVariables #-} 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 @@ -79,8 +79,6 @@ -- | Construct a /leaf/ widget, i.e. one without any children. widget :: ( Typeable widget - , Typeable event - , Functor (Attribute widget) , Gtk.IsWidget widget , FromWidget (SingleWidget widget) target ) diff --git a/test/GI/Gtk/Declarative/CustomWidgetTest.hs b/test/GI/Gtk/Declarative/CustomWidgetTest.hs new file mode 100644 --- /dev/null +++ b/test/GI/Gtk/Declarative/CustomWidgetTest.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module GI.Gtk.Declarative.CustomWidgetTest where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception.Safe +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 Hedgehog +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 + +prop_sets_the_button_label = property $ do + start <- forAll (Gen.int (Range.linear 0 10)) + clicks <- forAll (Gen.int (Range.linear 0 10)) + + buttonLabel <- 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 (const (pure ())) + Gtk.widgetShowAll window + replicateM_ clicks (Gtk.buttonClicked btn) + cancel sub + Gtk.get btn #label + + let expectedLabel = Text.pack (show (start + clicks)) + 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)) + + 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..] + actualValues <- liftIO (atomically (flushTBQueue values)) + expectedValues === actualValues + +prop_sets_classes = property $ do + let genClasses = + Gen.list (Range.linear 0 5) (Gen.text (Range.linear 1 5) Gen.alphaNum) + initialClasses <- forAll genClasses + finalClasses <- forAll genClasses + + (classesBefore, classesAfter) <- + runUI . bracket (Gtk.new Gtk.Window []) #destroy $ \window -> do + let markup1 = testWidget [classes initialClasses] 0 + markup2 = testWidget [classes finalClasses] 0 + first <- create markup1 + btn <- liftIO (someStateWidget first >>= Gtk.unsafeCastTo Gtk.Button) + #add window btn + Gtk.widgetShowAll window + sc <- #getStyleContext btn + beforeUpdate <- #listClasses sc + _second <- patch' first markup1 markup2 + afterUpdate <- #listClasses sc + pure (beforeUpdate, afterUpdate) + + HashSet.fromList ("text-button" : initialClasses) + === HashSet.fromList classesBefore + HashSet.fromList ("text-button" : finalClasses) + === HashSet.fromList classesAfter + +-- * Test widget and helpers + +testWidget :: Vector (Attribute Gtk.Button Int) -> Int -> Widget Int +testWidget customAttributes customParams = Widget (CustomWidget { .. }) + where + customWidget = Gtk.Button + customCreate start = do + clicks <- newMVar start + btn <- Gtk.new Gtk.Button [#label Gtk.:= Text.pack (show start)] + return (btn, clicks) + + customPatch :: Int -> Int -> MVar Int -> CustomPatch Gtk.Button (MVar Int) + customPatch _ new clicks = CustomModify $ \btn -> do + -- putMVar clicks new + Gtk.set btn [#label Gtk.:= Text.pack (show new)] + return clicks + + customSubscribe + :: Int -> MVar Int -> Gtk.Button -> (Int -> IO ()) -> IO Subscription + customSubscribe _params clicks btn cb = do + h <- Gtk.on btn #clicked $ do + current <- modifyMVar clicks $ \x -> pure (succ x, succ x) + cb current + 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)