gi-gtk-declarative (empty) → 0.1.0
raw patch · 16 files changed
+1525/−0 lines, 16 filesdep +basedep +gi-gobjectdep +gi-gtksetup-changed
Dependencies added: base, gi-gobject, gi-gtk, haskell-gi, haskell-gi-base, haskell-gi-overloading, mtl, text, unordered-containers
Files
- CHANGELOG.md +5/−0
- LICENSE +373/−0
- Setup.hs +2/−0
- gi-gtk-declarative.cabal +47/−0
- src/GI/Gtk/Declarative.hs +19/−0
- src/GI/Gtk/Declarative/Attributes.hs +227/−0
- src/GI/Gtk/Declarative/Attributes/Internal.hs +59/−0
- src/GI/Gtk/Declarative/Bin.hs +167/−0
- src/GI/Gtk/Declarative/CSS.hs +35/−0
- src/GI/Gtk/Declarative/Container.hs +146/−0
- src/GI/Gtk/Declarative/Container/Box.hs +52/−0
- src/GI/Gtk/Declarative/Container/Patch.hs +120/−0
- src/GI/Gtk/Declarative/EventSource.hs +41/−0
- src/GI/Gtk/Declarative/Markup.hs +104/−0
- src/GI/Gtk/Declarative/Patch.hs +34/−0
- src/GI/Gtk/Declarative/SingleWidget.hs +94/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+* 0.1.0+ - First version of `gi-gtk-declarative`!+ - Basic widget without event handling+ - Support for `Box` and `ScrolledWindow` containers+ - Declarative CSS classes
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++ This Source Code Form is "Incompatible With Secondary Licenses", as+ defined by the Mozilla Public License, v. 2.0.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gi-gtk-declarative.cabal view
@@ -0,0 +1,47 @@+name: gi-gtk-declarative+version: 0.1.0+synopsis: Declarative GTK+ programming in Haskell+description: A declarative programming model for GTK+ user+ interfaces, implementing support for various widgets+ and generalized patching. This library aims to extend the+ gi-gtk library as transparently as possible, and to be+ a reusable library for multiple application architectures+ and styles.++ See [the project README](https://github.com/owickstrom/gi-gtk-declarative#readme)+ for more information.+license: MPL-2.0+license-file: LICENSE+author: Oskar Wickström+maintainer: oskar.wickstrom@gmail.com+copyright: Oskar Wickström+category: Graphics+build-type: Simple+cabal-version: >=1.10+extra-source-files: CHANGELOG.md++library+ exposed-modules: GI.Gtk.Declarative+ , GI.Gtk.Declarative.Attributes+ , GI.Gtk.Declarative.Attributes.Internal+ , GI.Gtk.Declarative.Bin+ , GI.Gtk.Declarative.Container+ , GI.Gtk.Declarative.Container.Box+ , 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+ build-depends: base >=4.10 && <4.12+ , gi-gobject >= 2 && <3+ , gi-gtk >= 3 && <4+ , haskell-gi >= 0.21 && <0.22+ , haskell-gi-base >= 0.21 && <0.22+ , haskell-gi-overloading == 1.0+ , mtl+ , text+ , unordered-containers >= 0.2 && < 0.3+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall
+ src/GI/Gtk/Declarative.hs view
@@ -0,0 +1,19 @@+-- | The declarative layer on top of GTK+ lets you describe your user+-- interface as a declarative hierarchy of objects, using data+-- structures and pure functions. You can leverage the declarative event+-- handling to build reusable widgets. The "Patch" typeclass, and the+-- instances provided by this library, performs minimal updates to GTK+ widgets+-- using the underlying imperative operations, so that your rendering can always+-- be a pure function your state to a "Widget".+module GI.Gtk.Declarative+ ( 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
+ src/GI/Gtk/Declarative/Attributes.hs view
@@ -0,0 +1,227 @@+{-# 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.++module GI.Gtk.Declarative.Attributes+ ( Attribute(..)+ -- *+ , classes+ -- * Event Handling+ , on+ , onM+ -- * Callbacks+ , ToGtkCallback(..)+ )+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 Data.Typeable+import GHC.TypeLits (KnownSymbol, Symbol)+import qualified GI.Gtk as Gtk++import GI.Gtk.Declarative.CSS++-- * Attributes++-- | The attribute GADT represent a supported attribute for a declarative+-- widget. This extends the regular notion of GTK+ attributes to also include+-- event handling and CSS classes.+data Attribute widget event where+ -- | An attribute/value mapping for a declarative widget. The+ -- 'GI.AttrLabelProxy' is parameterized by 'attr', which represents the+ -- GTK-defined attribute name. The underlying GI object needs to support+ -- the /construct/, /get/, and /set/ operations for the given attribute.+ (:=)+ :: (GI.AttrOpAllowed 'GI.AttrConstruct info widget+ , GI.AttrOpAllowed 'GI.AttrSet info widget+ , GI.AttrGetC info widget attr getValue+ , GI.AttrSetTypeConstraint info setValue+ , KnownSymbol attr+ , Typeable attr+ )+ => GI.AttrLabelProxy (attr :: Symbol) -> setValue -> Attribute widget event+ -- | Defines a set of CSS classes for the underlying widget's style context.+ -- Use the 'classes' function instead of this constructor directly.+ Classes+ :: Gtk.IsWidget widget+ => ClassSet+ -> Attribute widget event+ -- | Emit events using a pure callback. 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)+ )+ => Gtk.SignalProxy widget info+ -> PureCallback callback event+ -> Attribute widget event+ -- | Emit events using an impure callback. 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)+ )+ => Gtk.SignalProxy widget info+ -> ImpureCallback callback widget event+ -> Attribute widget event++-- | Attributes have a 'Functor' instance that maps events in all event+-- callbacks.+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)++-- | 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 = Classes . HashSet.fromList++-- | Emit events, using a pure callback, 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)+ )+ => Gtk.SignalProxy widget info+ -> pure+ -> Attribute widget event+on signal = OnSignalPure signal . PureCallback++-- | Emit events, using an impure callback 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)+ )+ => Gtk.SignalProxy widget info+ -> withWidget+ -> 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))++instance ToGtkCallback (ImpureCallback (IO ()) widget) where+ type CustomGtkCallback (ImpureCallback (IO ()) widget) = widget -> IO ()+ toGtkCallback (ImpureCallback cb) f w = void (cb w >>= f)
+ src/GI/Gtk/Declarative/Attributes/Internal.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}++-- | Internal helpers for applying attributes and signal handlers to GTK++-- widgets.+module GI.Gtk.Declarative.Attributes.Internal+ ( extractAttrConstructOps+ , extractAttrSetOps+ , addClass+ , removeClass+ , addSignalHandler+ ) 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 GI.Gtk.Declarative.Attributes+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 ()++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+
+ src/GI/Gtk/Declarative/Bin.hs view
@@ -0,0 +1,167 @@+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | A declarative representation of 'Gtk.Bin' in GTK.+module GI.Gtk.Declarative.Bin+ ( Bin+ , bin+ )+where++import Control.Monad ((>=>))+import Data.Maybe+import Data.Typeable+import qualified GI.GObject as GI+import qualified GI.Gtk as Gtk++import GI.Gtk.Declarative.Attributes+import GI.Gtk.Declarative.Attributes.Internal+import GI.Gtk.Declarative.EventSource+import GI.Gtk.Declarative.Markup+import GI.Gtk.Declarative.Patch+++-- | Supported 'Gtk.Bin's.+class BinChild bin (child :: * -> *) | bin -> child where+ getChild :: bin -> IO Gtk.Widget++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++-- | Declarative version of a /bin/ widget, i.e. a widget with exactly one+-- child.+data Bin widget child event where+ Bin+ :: ( Typeable widget+ , Gtk.IsContainer widget+ , Gtk.IsBin widget+ , Gtk.IsWidget widget+ , Functor child+ )+ => (Gtk.ManagedPtr widget -> widget)+ -> [Attribute widget event]+ -> child event+ -> Bin widget child event++instance Functor (Bin widget child) where+ fmap f (Bin ctor attrs child) =+ Bin ctor (fmap f <$> attrs) (fmap f child)++-- | Construct a /bin/ widget, i.e. a widget with exactly one child.+bin ::+ ( Patchable (Bin widget child)+ , Typeable widget+ , Typeable child+ , Typeable event+ , Functor child+ , Gtk.IsContainer widget+ , 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.+ -> 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++--+-- Patchable+--++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++ 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++ binWidget <- Gtk.unsafeCastTo ctor widget'+ Gtk.set binWidget (concatMap extractAttrSetOps newAttributes)++ sc <- Gtk.widgetGetStyleContext binWidget+ mapM_ (removeClass sc) oldAttributes+ mapM_ (addClass sc) newAttributes++ childWidget <- getChild binWidget++ case patch oldChild newChild of+ Modify modify -> modify childWidget+ Replace createNew -> do+ Gtk.containerRemove binWidget childWidget+ Gtk.containerAdd binWidget =<< createNew+ Keep -> return ()++--+-- EventSource+--++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++--+-- FromWidget+--++instance ( BinChild widget child+ , Typeable widget+ , Patchable child+ , EventSource child+ , Functor (Bin widget child)+ ) =>+ FromWidget (Bin widget child) event (Widget event) where+ fromWidget = Widget++instance a ~ () => FromWidget (Bin widget child) event (MarkupOf (Bin widget child) event a) where+ fromWidget = single++instance ( BinChild widget child+ , a ~ ()+ , Typeable widget+ , Patchable child+ , EventSource child+ , Functor (Bin widget child)+ ) =>+ FromWidget (Bin widget child) event (Markup event a) where+ fromWidget = single . Widget+++-- | 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
+ src/GI/Gtk/Declarative/CSS.hs view
@@ -0,0 +1,35 @@+-- | 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)
+ src/GI/Gtk/Declarative/Container.hs view
@@ -0,0 +1,146 @@+{-# 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 #-}++-- | Implementations for common "Gtk.Container".++module GI.Gtk.Declarative.Container+ ( Container+ , container+ )+where++import Control.Monad (forM_)+import Data.Maybe+import Data.Typeable+import qualified GI.Gtk as Gtk++import GI.Gtk.Declarative.Attributes+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++-- | Declarative version of a /container/ widget, i.e. a widget with zero+-- or more child widgets. The type of 'children' is parameterized, and differs+-- across the supported container widgets, as some containers require specific+-- types of child widgets. These type relations are decided by 'IsContainer',+-- and instances can found in "GI.Gtk.Declarative.Container.Patch".+data Container widget children event where+ Container+ :: ( Typeable widget+ , Gtk.IsWidget widget+ , Gtk.IsContainer widget+ , Functor children+ )+ => (Gtk.ManagedPtr widget -> widget)+ -> [Attribute widget event]+ -> children event+ -> Container widget children event++instance Functor (Container widget children) where+ fmap f (Container ctor attrs children) =+ Container ctor (fmap f <$> attrs) (fmap f children)++-- | 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+ , Functor child+ , Gtk.IsWidget widget+ , Gtk.IsContainer widget+ , 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.+ -> 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] }+ deriving (Functor)++toChildren :: MarkupOf child event () -> Children child event+toChildren = Children . runMarkup++--+-- Patchable+--++instance (Patchable 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+ 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)++--+-- 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)++--+-- FromWidget+--++instance ( Typeable widget+ , Typeable children+ , Patchable (Container widget children)+ , EventSource (Container widget children)+ , Functor (Container widget children)+ ) =>+ FromWidget (Container widget children) event (Widget event) where+ fromWidget = Widget++instance a ~ () =>+ FromWidget (Container widget children) event (MarkupOf (Container widget children) event a) where+ fromWidget = single++instance ( a ~ ()+ , Typeable widget+ , Typeable children+ , Patchable (Container widget children)+ , EventSource (Container widget children)+ , Functor (Container widget children)+ ) =>+ FromWidget (Container widget children) event (Markup event a) where+ fromWidget = single . Widget
+ src/GI/Gtk/Declarative/Container/Box.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | Implementation of 'Gtk.Box' as a declarative container.+module GI.Gtk.Declarative.Container.Box+ ( BoxChild(..)+ , boxChild+ )+where++import Data.Word (Word32)++import GI.Gtk.Declarative.EventSource+import GI.Gtk.Declarative.Patch+import GI.Gtk.Declarative.Markup++-- | Described a child widget to be added with 'boxAppend' to a 'Box'.+data BoxChild event = BoxChild+ { expand :: Bool+ , fill :: Bool+ , padding :: Word32+ , child :: Widget event+ }+ deriving (Functor)++-- | Construct a box child with the given 'boxAppend' parameters.+boxChild+ :: Bool+ -> Bool+ -> Word32+ -> Widget event+ -> MarkupOf BoxChild event ()+boxChild expand fill padding child = single BoxChild {..}++instance Patchable BoxChild where+ create = create . child+ patch b1 b2 = patch (child b1) (child b2)++instance EventSource BoxChild where+ subscribe BoxChild{..} = subscribe child
+ src/GI/Gtk/Declarative/Container/Patch.hs view
@@ -0,0 +1,120 @@+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# 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++import Control.Monad (forM_)+import Data.Int (Int32)+import Data.List (zip4)+import qualified GI.Gtk as Gtk++import GI.Gtk.Declarative.Bin+import GI.Gtk.Declarative.Container.Box+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 ()++-- | 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+-- updates.+patchInContainer+ :: ( Gtk.IsWidget container+ , Gtk.IsContainer container+ , 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++ -- 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 ()++ -- 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, or one that lacks a corresponding+ -- GTK widget, create and add it.+ (_i, Nothing, _ , Just n ) -> create n >>= appendChild container n++ -- When an declarative widget has been removed, remove the GTK widget from+ -- the container.+ (_i, Just w , Just _ , Nothing) -> Gtk.containerRemove container w++ -- When there are more old declarative widgets than GTK widgets, we can+ -- safely ignore the old declarative widgets.+ (_i, Nothing, Just _ , Nothing) -> return ()++ -- 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++ -- No more GTK widgets or declarative widgets, we are done.+ (_i, Nothing, Nothing, Nothing) -> return ()++ Gtk.widgetQueueResize container++instance IsContainer Gtk.ListBox (Bin Gtk.ListBoxRow Widget) where+ appendChild box _ widget' = Gtk.listBoxInsert box widget' (-1)+ replaceChild box _ i old new = do+ Gtk.containerRemove box 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+ appendChild box boxChild' new+ Gtk.boxReorderChild box new i+ Gtk.widgetShowAll box++padMaybes :: [a] -> [Maybe a]+padMaybes xs = map Just xs ++ repeat Nothing
+ src/GI/Gtk/Declarative/EventSource.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | Event handling for declarative widgets.+module GI.Gtk.Declarative.EventSource+ ( EventSource (..)+ , Subscription+ , fromCancellation+ , cancel+ )+where++import qualified GI.Gtk as Gtk++-- | Cancel a 'Subscription', meaning that the callback will not be invoked on+-- any subsequent signal emissions.+cancel :: Subscription -> IO ()+cancel = sequence_ . cancellations++-- | An 'EventSource' can be subscribed to, with a callback, returning a+-- 'Subscription'.+class EventSource widget where+ subscribe+ :: widget event -- ^ Declarative widget with event handlers.+ -> Gtk.Widget -- ^ Actual 'Gtk.Widget' that has been created or patched.+ -> (event -> IO ()) -- ^ Event callback, invoked on each emitted event until+ -- the 'Subscription' is cancelled, or widget is otherwise+ -- destroyed.+ -> IO Subscription -- ^ A 'Subscription' is returned, which can be cancelled.++-- | A 'Subscription' contains zero or more cancellation actions for connected+-- 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 ()] }+ deriving (Semigroup, Monoid)++-- | Create a subscription from a cancellation IO action.+fromCancellation :: IO () -> Subscription+fromCancellation = Subscription . pure
+ src/GI/Gtk/Declarative/Markup.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- | 'MarkupOf' is the common builder type for the (declarative) GTK+ markup+-- language, supporting do syntax. 'MarkupOf' wraps many widgets, usually of+-- type 'Widget', but they can be of other types.+--+-- A 'Widget' value can wrap any 'Patchable' widget, hiding the underlying+-- widget type, such that you can embed heterogeneous collections of widgets in+-- containers.+module GI.Gtk.Declarative.Markup+ ( Widget(..)+ -- * Markup+ , MarkupOf+ , Markup+ , single+ , multiple+ , runMarkup+ -- * Widget to Markup conversion+ , FromWidget(..)+ )+where++import Control.Monad.Writer+import Data.Typeable++import GI.Gtk.Declarative.EventSource+import GI.Gtk.Declarative.Patch++-- | A 'Widget' value wraps a 'Patchable' and 'EventSource' widget, providing+-- a constrained equivalent of a 'Dynamic' value. It is used to support+-- heterogeneous containers of widgets, and to support equality+-- checks on different types of widgets when calculating patches.+data Widget event where+ Widget+ :: ( Typeable widget+ , Patchable widget+ , Functor widget+ , EventSource widget+ )+ => widget event+ -> Widget event++instance Functor Widget where+ fmap f (Widget w) = Widget (fmap f w)++-- | 'Widget' is itself patchable, by delegating to the underlying+-- widget instances.+instance Patchable Widget where+ create (Widget w) = create w+ patch (Widget (w1 :: t1 e1)) (Widget (w2 :: t2 e2)) =+ case eqT @t1 @t2 of+ Just Refl -> patch w1 w2+ _ -> Replace (create w2)++instance EventSource Widget where+ subscribe (Widget w) = subscribe w++-- * Markup++-- | The declarative markup builder, primarily for using its 'Monad' instance+-- and do notation to construct adjacent widgets in containers.+--+-- It is parameterized with 'widget' and 'event', such that containers can+-- restrict the type of their children to other types than 'Widget'.+--+-- Note that the return type, 'a', is not used in this library. It's a more a+-- technical necessity to have the 'Monad' instance. You can still use it if+-- you need to return a value from a markup function, though.+newtype MarkupOf widget event a =+ MarkupOf (Writer [widget event] a)+ deriving (Functor, Applicative, Monad)++-- | Run a 'MarkupOf' builder and get its widgets.+runMarkup :: MarkupOf widget event () -> [widget event]+runMarkup (MarkupOf w) = execWriter w++-- | Handy type alias for the common case of markup containing 'Widget's.+type Markup event a = MarkupOf Widget event a++-- | Construct markup from a single widget.+single :: widget event -> MarkupOf widget event ()+single w = MarkupOf (tell [w])++-- | Construct markup from multiple widgets.+multiple :: [widget event] -> MarkupOf widget event ()+multiple = MarkupOf . tell++-- | Convert a widget to a target type. This is deliberately unconstrained in+-- it's types, and is used by smart constructors to implement return type+-- polymorphism, so that a smart contructor can return either a 'Widget', or+-- some specifically typed 'MarkupOf', depending on the context in which it's+-- used.+class FromWidget widget event target | target -> event where+ fromWidget :: (Typeable widget, Typeable event) => widget event -> target++instance FromWidget Widget event (Widget event) where+ fromWidget = id
+ src/GI/Gtk/Declarative/Patch.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++module GI.Gtk.Declarative.Patch+ ( Patch(..)+ , Patchable(..)+ ) where++import qualified GI.Gtk as Gtk++-- | 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 ())+ -- ^ 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 the current 'Gtk.Widget' by the widget returned by the IO+ -- action.+ | Keep+ -- ^ Do nothing, i.e. keep the 'Gtk.Widget' as it is.++-- | A patchable widget is one that can create an underlying GTK widget, or+-- calculate a 'Patch' to be applied to an existing GTK widget that was+-- previously created.+class Patchable widget where+ -- | 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+ -- | 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
+ src/GI/Gtk/Declarative/SingleWidget.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- | A declarative representation of 'Gtk.Widget' in GTK without children.+module GI.Gtk.Declarative.SingleWidget+ ( SingleWidget+ , widget+ )+where++import Data.Maybe+import Data.Typeable+import qualified GI.Gtk as Gtk++import GI.Gtk.Declarative.Attributes+import GI.Gtk.Declarative.Attributes.Internal+import GI.Gtk.Declarative.EventSource+import GI.Gtk.Declarative.Markup+import GI.Gtk.Declarative.Patch++-- | 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]+ -> SingleWidget widget event++instance Functor (SingleWidget widget) where+ fmap f (SingleWidget ctor attrs) = SingleWidget ctor (fmap f <$> attrs)++instance Patchable (SingleWidget widget) where+ create = \case+ (SingleWidget ctor props) -> do+ let attrOps = concatMap extractAttrConstructOps props+ widget' <- Gtk.new ctor attrOps++ sc <- Gtk.widgetGetStyleContext widget'+ mapM_ (addClass sc) props++ Gtk.widgetShowAll widget'+ Gtk.toWidget widget'+ patch (SingleWidget (_ :: Gtk.ManagedPtr w1 -> w1) oldAttributes)+ (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))++instance EventSource (SingleWidget widget) where+ subscribe (SingleWidget ctor props) widget' cb = do+ w <- Gtk.unsafeCastTo ctor widget'+ mconcat . catMaybes <$> mapM (addSignalHandler cb w) props++instance (Typeable widget, Functor (SingleWidget widget))+ => FromWidget (SingleWidget widget) event (Widget event) where+ fromWidget = Widget++instance FromWidget (SingleWidget widget) event (MarkupOf (SingleWidget widget) event ()) where+ fromWidget = single++instance (Typeable widget, Functor (SingleWidget widget))+ => FromWidget (SingleWidget widget) event (Markup event ()) where+ fromWidget = single . Widget++-- | Construct a /leaf/ widget, i.e. one without any children.+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.+ -> target -- ^ The target, whose type is decided by 'FromWidget'.+widget ctor = fromWidget . SingleWidget ctor