reflex-gi-gtk (empty) → 0.1.0.0
raw patch · 14 files changed
+1600/−0 lines, 14 filesdep +asyncdep +basedep +containerssetup-changed
Dependencies added: async, base, containers, dependent-sum, exception-transformers, gi-gdk, gi-glib, gi-gtk, haskell-gi-base, mtl, patch, primitive, ref-tf, reflex, reflex-gi-gtk, semialign, stm, text, these
Files
- LICENSE +373/−0
- README.md +1/−0
- Setup.hs +2/−0
- example/Main.hs +115/−0
- reflex-gi-gtk.cabal +63/−0
- src/Reflex/GI/Gtk.hs +34/−0
- src/Reflex/GI/Gtk/Class.hs +37/−0
- src/Reflex/GI/Gtk/Host.hs +81/−0
- src/Reflex/GI/Gtk/Input.hs +295/−0
- src/Reflex/GI/Gtk/Output.hs +143/−0
- src/Reflex/GI/Gtk/Run/Base.hs +196/−0
- src/Reflex/GI/Gtk/Run/Class.hs +55/−0
- src/Reflex/GI/Gtk/Widget/Box.hs +171/−0
- src/Reflex/GI/Gtk/Widget/Ord.hs +34/−0
+ 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.
+ README.md view
@@ -0,0 +1,1 @@+# reflex-gi-gtk
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/Main.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedLabels, FlexibleContexts, OverloadedStrings, RecursiveDo, TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Main where++import Control.Applicative (liftA2)+import Control.Monad (join)+import qualified Data.Map.Lazy as M+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import qualified GI.Gtk as Gtk+import Reflex ( Dynamic+ , Event+ , (<@>)+ , current+ , holdDyn+ , list+ , listHoldWithKey+ , mergeList+ , performEvent_+ , switch+ )+import Reflex.GI.Gtk ( ReactiveAttrOp((:==))+ , MonadGtk+ , runGtk+ , runReflexGtk+ , eventOnSignal+ , eventOnSignal0+ , sink+ , sinkBoxUniform+ )+import System.Exit ( ExitCode(ExitFailure)+ , die+ , exitSuccess+ , exitWith+ )+import System.Environment ( getArgs+ , getProgName+ )++stringInput :: (MonadGtk t m)+ => m (Gtk.Widget, Dynamic t T.Text, Event t ())+stringInput = do+ ( input+ , deleteButton+ , inputW+ ) <- runGtk $ do+ box <- Gtk.boxNew Gtk.OrientationHorizontal 0+ input <- Gtk.entryNew+ deleteButton <- Gtk.buttonNewFromIconName (Just "list-remove") $+ fromIntegral $ fromEnum Gtk.IconSizeButton+ #packStart box input True True 0+ #packStart box deleteButton False False 0+ inputW <- Gtk.toWidget box+ pure (input, deleteButton, inputW)+ newTextE <- eventOnSignal input #changed (Gtk.get input #text >>=)+ textDyn <- holdDyn T.empty newTextE+ delete <- eventOnSignal0 deleteButton #clicked+ pure (inputW, textDyn, delete)++main :: IO ()+main = do+ argv <- liftA2 (:) getProgName getArgs+ Gtk.applicationNew (Just "de.weltraumschlangen.reflex-test") []+ >>= maybe+ (die "Failed to initialize GTK")+ ( \application -> do+ ret <- runReflexGtk application (Just argv) $ do+ mainWindow <- runGtk $ Gtk.applicationWindowNew application+ activate <- eventOnSignal0 application #activate++ outerBox <- runGtk $ Gtk.boxNew Gtk.OrientationVertical 2+ inputBox <- runGtk $ Gtk.boxNew Gtk.OrientationVertical 0+ outputBox <- Gtk.boxNew Gtk.OrientationVertical 5+ addInputButton <- runGtk $ Gtk.buttonNewFromIconName (Just "list-add") $+ fromIntegral $ fromEnum Gtk.IconSizeButton+ Gtk.set addInputButton [#label Gtk.:= "Add"]+ runGtk $ do+ #add mainWindow outerBox+ #packStart outerBox inputBox False False 0+ #packStart outerBox addInputButton False False 0+ #packStart outerBox outputBox False False 0++ addInput <- eventOnSignal0 addInputButton #clicked++ rec+ let freeKey = maybe (minBound :: Word) (succ . fst) . M.lookupMax+ <$> current inputWidgets+ inputWidgetUpdates = mconcat+ [ (\k -> M.singleton k . Just) <$> freeKey <@> addInput+ , M.fromList . map (,Nothing) . NE.toList <$> delete+ ]+ inputWidgets <-+ listHoldWithKey (M.singleton 0 ()) inputWidgetUpdates $ \k () -> do+ (\(widget, text, delete') -> (widget, text, k <$ delete')) <$> stringInput++ let delete = switch $ mergeList . map (\(_, _, d) -> d) . M.elems+ <$> current inputWidgets++ sinkBoxUniform inputBox (M.map (\(w, _, _) -> w) <$> inputWidgets)+ False False 0 Gtk.PackTypeStart++ outputWidgets <- list (M.map (\(_, t, _) -> t) <$> inputWidgets) + $ \textBB -> do+ let textB = join textBB+ label <- runGtk $ Gtk.labelNew Nothing+ sink label [#label :== textB]+ pure label+ sinkBoxUniform outputBox outputWidgets True True 10 Gtk.PackTypeStart++ performEvent_ $ runGtk (#showAll mainWindow) <$ activate++ case ret of+ 0 -> exitSuccess+ n -> exitWith $ ExitFailure $ fromIntegral n+ )
+ reflex-gi-gtk.cabal view
@@ -0,0 +1,63 @@+name: reflex-gi-gtk+version: 0.1.0.0+synopsis: Helper functions to use Reflex with gi-gtk+-- description:+homepage: https://gitlab.com/Kritzefitz/reflex-gi-gtk#readme+license: MPL-2.0+license-file: LICENSE+author: Sven Bartscher+maintainer: sven.bartscher@weltraumschlangen.de+copyright: 2020 Sven Bartscher+category: FRP+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Reflex.GI.Gtk+ , Reflex.GI.Gtk.Class+ , Reflex.GI.Gtk.Host+ , Reflex.GI.Gtk.Input+ , Reflex.GI.Gtk.Output+ , Reflex.GI.Gtk.Run.Class+ , Reflex.GI.Gtk.Run.Base+ , Reflex.GI.Gtk.Widget.Box+ other-modules: Reflex.GI.Gtk.Widget.Ord+ build-depends: async >= 2.2.2 && < 2.3+ , base >= 4.7 && < 5+ , containers >= 0.6.2 && < 0.7+ , dependent-sum >= 0.7.1 && < 0.8+ , exception-transformers == 0.4.*+ , gi-gdk == 3.*+ , gi-glib == 2.*+ , gi-gtk == 3.*+ , haskell-gi-base >= 0.24 && < 1+ , mtl >= 2.2.2 && < 2.3+ , primitive == 0.7.*+ , ref-tf == 0.4.*+ , reflex == 0.8.*+ , semialign == 1.1.*+ , stm == 2.5.*+ , text >= 1.2.4 && < 1.3+ , these >= 1.1.1 && < 1.2+ default-language: Haskell2010++executable reflex-test+ hs-source-dirs: example+ main-is: Main.hs+ default-language: Haskell2010+ build-depends: reflex-gi-gtk+ , base >= 4.7 && < 5+ , containers >= 0.6.2 && < 0.7+ , dependent-sum >= 0.7.1 && < 0.8+ , gi-gtk == 3.*+ , haskell-gi-base >= 0.24.5 && < 0.25+ , mtl >= 2.2.2 && < 2.3+ , patch == 0.0.*+ , reflex == 0.8.*+ , text >= 1.2.4 && < 1.3++source-repository head+ type: git+ location: https://gitlab.com/Kritzefitz/reflex-gi-gtk
+ src/Reflex/GI/Gtk.hs view
@@ -0,0 +1,34 @@+-- 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 https://mozilla.org/MPL/2.0/.++{-# LANGUAGE DataKinds, GADTs, AllowAmbiguousTypes, RankNTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, ConstraintKinds #-}++module Reflex.GI.Gtk+ ( -- * Running+ runReflexGtk+ , MonadGtk+ -- * Executing IO in GTK context+ , MonadRunGtk+ , runGtk+ , runGtk_+ , runGtkPromise+ -- * Obtaining input from GTK sources+ , module Reflex.GI.Gtk.Input+ -- * Outputting reactive values to GTK widgets+ , module Reflex.GI.Gtk.Output+ -- * Helpers for specific widgets+ , module Reflex.GI.Gtk.Widget.Box+ ) where++import Reflex.GI.Gtk.Class (MonadGtk)+import Reflex.GI.Gtk.Host (runReflexGtk)+import Reflex.GI.Gtk.Input+import Reflex.GI.Gtk.Output+import Reflex.GI.Gtk.Run.Class ( MonadRunGtk+ , runGtk+ , runGtk_+ , runGtkPromise+ )+import Reflex.GI.Gtk.Widget.Box
+ src/Reflex/GI/Gtk/Class.hs view
@@ -0,0 +1,37 @@+-- 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 https://mozilla.org/MPL/2.0/.++{-# LANGUAGE ConstraintKinds, FlexibleContexts #-}++module Reflex.GI.Gtk.Class (MonadGtk) where++import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO)+import Reflex ( Adjustable+ , MonadHold+ , NotReady+ , PerformEvent+ , Performable+ , PostBuild+ , TriggerEvent+ )+import Reflex.Host.Class (ReflexHost)+import Reflex.GI.Gtk.Run.Class (MonadRunGtk)++-- | A set of classes available in reactive code working with GTK.+type MonadGtk t m = ( MonadIO m+ , MonadFix m+ , MonadRunGtk m+ , ReflexHost t+ , MonadHold t m+ , NotReady t m+ , TriggerEvent t m+ , PostBuild t m+ , Adjustable t m+ , PerformEvent t m+ , MonadIO (Performable m)+ , MonadRunGtk (Performable m)+ , MonadFix (Performable m)+ , MonadHold t (Performable m)+ )
+ src/Reflex/GI/Gtk/Host.hs view
@@ -0,0 +1,81 @@+-- 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 https://mozilla.org/MPL/2.0/.++{-# LANGUAGE RankNTypes, FlexibleContexts, PatternSynonyms, OverloadedLabels, RecursiveDo #-}++module Reflex.GI.Gtk.Host+ ( MonadGtk+ , runReflexGtk+ ) where++import Control.Concurrent (myThreadId)+import Control.Concurrent.Async ( async+ , waitCatchSTM+ )+import Control.Concurrent.Chan ( newChan+ , readChan+ )+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Ref (readRef)+import Data.Dependent.Sum ( DSum((:=>))+ , (==>)+ )+import Data.Function (fix)+import Data.Int (Int32)+import Data.Maybe (catMaybes)+import Data.Void (absurd)+import GI.Gtk ( Application+ , on+ )+import Reflex ( FireCommand(FireCommand)+ , TriggerInvocation(TriggerInvocation)+ , hostPerformEventT+ , runPostBuildT+ , runSpiderHostForTimeline+ , runTriggerEventT+ , unEventTriggerRef+ , withSpiderTimeline+ )+import Reflex.GI.Gtk.Class (MonadGtk)+import Reflex.GI.Gtk.Run.Base (runGtkT)+import Reflex.Host.Class (newEventWithTriggerRef)++runReflexGtk :: Application+ -> Maybe [String]+ -> (forall t m. (MonadGtk t m) => m ())+ -> IO Int32+runReflexGtk app argv a = do+ _ <- app `on` #startup $+ withSpiderTimeline+ $ \tl -> flip runSpiderHostForTimeline tl $ do+ eventChan <- liftIO newChan+ rec+ let waitForEventThreadException =+ either id absurd <$> waitCatchSTM eventThread++ (postBuildE, postBuildTriggerRef) <- newEventWithTriggerRef+ ((), FireCommand fireCommand) <-+ hostPerformEventT $+ liftIO myThreadId+ >>= runGtkT (+ runTriggerEventT ( runPostBuildT a postBuildE+ ) eventChan+ ) waitForEventThreadException++ readRef postBuildTriggerRef+ >>= mapM_ (\trigger -> fireCommand [trigger ==> ()] $ pure ())++ eventThread <- liftIO $ async $ flip runSpiderHostForTimeline tl $ fix $ \loop -> do+ invocations <- liftIO $ readChan eventChan+ triggers <-+ catMaybes <$>+ traverse (\(triggerRef :=> TriggerInvocation x _) ->+ fmap (==> x) <$> readRef (unEventTriggerRef triggerRef)+ ) invocations+ _ <- fireCommand triggers $ pure ()+ liftIO $ mapM_ (\(_ :=> (TriggerInvocation _ done)) -> done) invocations+ loop+ pure ()++ #run app argv
+ src/Reflex/GI/Gtk/Input.hs view
@@ -0,0 +1,295 @@+-- 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 https://mozilla.org/MPL/2.0/.++{-# LANGUAGE ConstraintKinds, GADTs, FlexibleContexts #-}++module Reflex.GI.Gtk.Input+ ( MonadGtkSource+ -- * Obtaining input from GI signals+ -- ** as 'Event's+ , eventOnSignal+ , eventAfterSignal+ , eventOnSignal0+ , eventAfterSignal0+ , eventOnSignal1+ , eventAfterSignal1+ , eventOnSignal0R+ , eventAfterSignal0R+ , eventOnSignal1R+ , eventAfterSignal1R+ -- ** as 'Behavior's+ , behaviorOnSignal+ , behaviorAfterSignal+ , behaviorOnSignal1+ , behaviorAfterSignal1+ , behaviorOnSignal1R+ , behaviorAfterSignal1R+ -- ** as 'Dynamic's+ , dynamicOnSignal+ , dynamicAfterSignal+ , dynamicOnSignal1+ , dynamicAfterSignal1+ , dynamicOnSignal1R+ , dynamicAfterSignal1R+ -- * Obtaining input from GI attributes+ , eventOnAttribute+ , eventAfterAttribute+ , behaviorOnAttribute+ , behaviorAfterAttribute+ , dynamicOnAttribute+ , dynamicAfterAttribute+ ) where++import Data.GI.Base (GObject)+import Data.GI.Base.Attributes ( AttrGetC+ , AttrLabel+ , AttrLabelProxy+ , get+ )+import Data.GI.Base.Signals ( HaskellCallbackType+ , SignalHandlerId+ , SignalInfo+ , SignalProxy(PropertyNotify)+ , after+ , disconnectSignalHandler+ , on+ )+import GHC.TypeLits (KnownSymbol)+import Reflex ( Behavior+ , Dynamic+ , Event+ , MonadHold+ , TriggerEvent+ , hold+ , holdDyn+ , newEventWithLazyTriggerWithOnComplete+ )+import Reflex.GI.Gtk.Run.Class ( MonadRunGtk+ , askMakeSynchronousFire+ , askRunGtk+ , askRunGtk_+ , runGtk+ )++type MonadGtkSource t m = ( MonadRunGtk m+ , TriggerEvent t m+ )++eventFromSignalWith :: ( MonadGtkSource t m+ , GObject object+ , SignalInfo info+ )+ => ( object -> SignalProxy object info ->+ HaskellCallbackType info -> IO SignalHandlerId+ )+ -> object+ -> SignalProxy object info+ -> ((a -> IO ()) -> HaskellCallbackType info)+ -> m (Event t a)+eventFromSignalWith register object signal f = do+ runGtk' <- askRunGtk+ runGtk_' <- askRunGtk_+ makeSynchronousFire <- askMakeSynchronousFire+ newEventWithLazyTriggerWithOnComplete $ \fire ->+ runGtk_' . disconnectSignalHandler object+ <$> runGtk' ( object `register` signal $+ f $ \x -> makeSynchronousFire fire x+ )++eventOnSignal, eventAfterSignal :: ( MonadGtkSource t m+ , GObject object+ , SignalInfo info+ )+ => object+ -> SignalProxy object info+ -> ((a -> IO ()) -> HaskellCallbackType info)+ -> m (Event t a)+eventOnSignal = eventFromSignalWith on+eventAfterSignal = eventFromSignalWith after++eventOnSignal0, eventAfterSignal0 :: ( MonadGtkSource t m+ , HaskellCallbackType info ~ IO ()+ , GObject object+ , SignalInfo info+ )+ => object+ -> SignalProxy object info+ -> m (Event t ())+eventOnSignal0 obj signal = eventOnSignal obj signal ($ ())+eventAfterSignal0 obj signal = eventAfterSignal obj signal ($ ())++eventOnSignal1, eventAfterSignal1 :: ( MonadGtkSource t m+ , HaskellCallbackType info ~ (a -> IO ())+ , GObject object+ , SignalInfo info+ )+ => object+ -> SignalProxy object info+ -> m (Event t a)+eventOnSignal1 obj signal = eventOnSignal obj signal id+eventAfterSignal1 obj signal = eventAfterSignal obj signal id++eventOnSignal0R, eventAfterSignal0R :: ( MonadGtkSource t m+ , HaskellCallbackType info ~ IO b+ , GObject object+ , SignalInfo info+ )+ => object+ -> SignalProxy object info+ -> b+ -> m (Event t ())+eventOnSignal0R obj signal x = eventOnSignal obj signal $ \fire -> x <$ fire ()+eventAfterSignal0R obj signal x = eventAfterSignal obj signal $ \fire -> x <$ fire ()++eventOnSignal1R, eventAfterSignal1R :: ( MonadGtkSource t m+ , HaskellCallbackType info ~ (a -> IO b)+ , GObject object+ , SignalInfo info+ )+ => object+ -> SignalProxy object info+ -> b+ -> m (Event t a)+eventOnSignal1R obj signal r = eventOnSignal obj signal $ \fire v -> r <$ fire v+eventAfterSignal1R obj signal r = eventAfterSignal obj signal $ \fire v -> r <$ fire v++behaviorOnSignal, behaviorAfterSignal :: ( MonadGtkSource t m+ , MonadHold t m+ , GObject object+ , SignalInfo info+ )+ => a+ -> object+ -> SignalProxy object info+ -> ((a -> IO ()) -> HaskellCallbackType info)+ -> m (Behavior t a)+behaviorOnSignal initial object signal f =+ eventOnSignal object signal f >>= hold initial+behaviorAfterSignal initial object signal f =+ eventAfterSignal object signal f >>= hold initial++behaviorOnSignal1, behaviorAfterSignal1 :: ( MonadGtkSource t m+ , MonadHold t m+ , HaskellCallbackType info ~ (a -> IO ())+ , GObject object+ , SignalInfo info+ )+ => a+ -> object+ -> SignalProxy object info+ -> m (Behavior t a)+behaviorOnSignal1 initial object signal =+ eventOnSignal1 object signal >>= hold initial+behaviorAfterSignal1 initial object signal =+ eventAfterSignal1 object signal >>= hold initial++behaviorOnSignal1R, behaviorAfterSignal1R :: ( MonadGtkSource t m+ , MonadHold t m+ , HaskellCallbackType info ~ (a -> IO b)+ , GObject object+ , SignalInfo info+ )+ => a+ -> object+ -> SignalProxy object info+ -> b+ -> m (Behavior t a)+behaviorOnSignal1R initial object signal result =+ eventOnSignal1R object signal result >>= hold initial+behaviorAfterSignal1R initial object signal result =+ eventAfterSignal1R object signal result >>= hold initial+++dynamicOnSignal, dynamicAfterSignal :: ( MonadGtkSource t m+ , MonadHold t m+ , GObject object+ , SignalInfo info+ )+ => a+ -> object+ -> SignalProxy object info+ -> ((a -> IO ()) -> HaskellCallbackType info)+ -> m (Dynamic t a)+dynamicOnSignal initial object signal f =+ eventOnSignal object signal f >>= holdDyn initial+dynamicAfterSignal initial object signal f =+ eventAfterSignal object signal f >>= holdDyn initial++dynamicOnSignal1, dynamicAfterSignal1 :: ( MonadGtkSource t m+ , MonadHold t m+ , HaskellCallbackType info ~ (a -> IO ())+ , GObject object+ , SignalInfo info+ )+ => a+ -> object+ -> SignalProxy object info+ -> m (Dynamic t a)+dynamicOnSignal1 initial object signal =+ eventOnSignal1 object signal >>= holdDyn initial+dynamicAfterSignal1 initial object signal =+ eventAfterSignal1 object signal >>= holdDyn initial++dynamicOnSignal1R, dynamicAfterSignal1R :: ( MonadGtkSource t m+ , MonadHold t m+ , HaskellCallbackType info ~ (a -> IO b)+ , GObject object+ , SignalInfo info+ )+ => a+ -> object+ -> SignalProxy object info+ -> b+ -> m (Dynamic t a)+dynamicOnSignal1R initial object signal result =+ eventOnSignal1R object signal result >>= holdDyn initial+dynamicAfterSignal1R initial object signal result =+ eventAfterSignal1R object signal result >>= holdDyn initial++eventOnAttribute, eventAfterAttribute :: ( MonadGtkSource t m+ , AttrGetC info object attr value+ , GObject object+ , KnownSymbol (AttrLabel info)+ )+ => object+ -> AttrLabelProxy attr+ -> m (Event t value)+eventOnAttribute object attr =+ eventOnSignal object (PropertyNotify attr) $ \fire _ ->+ get object attr >>= fire+eventAfterAttribute object attr =+ eventAfterSignal object (PropertyNotify attr) $ \fire _ ->+ get object attr >>= fire++behaviorOnAttribute, behaviorAfterAttribute :: ( MonadGtkSource t m+ , MonadHold t m+ , AttrGetC info object attr value+ , GObject object+ , KnownSymbol (AttrLabel info)+ )+ => object+ -> AttrLabelProxy attr+ -> m (Behavior t value)+behaviorOnAttribute object attr = do+ initial <- runGtk $ get object attr+ eventOnAttribute object attr >>= hold initial+behaviorAfterAttribute object attr = do+ initial <- runGtk $ get object attr+ eventAfterAttribute object attr >>= hold initial++dynamicOnAttribute, dynamicAfterAttribute :: ( MonadGtkSource t m+ , MonadHold t m+ , AttrGetC info object attr value+ , GObject object+ , KnownSymbol (AttrLabel info)+ )+ => object+ -> AttrLabelProxy attr+ -> m (Dynamic t value)+dynamicOnAttribute object attr = do+ initial <- runGtk $ get object attr+ eventOnAttribute object attr >>= holdDyn initial+dynamicAfterAttribute object attr = do+ initial <- runGtk $ get object attr+ eventAfterAttribute object attr >>= holdDyn initial
+ src/Reflex/GI/Gtk/Output.hs view
@@ -0,0 +1,143 @@+-- 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 https://mozilla.org/MPL/2.0/.++{-# LANGUAGE RankNTypes, KindSignatures, DataKinds, ConstraintKinds, FlexibleContexts, GADTs #-}+{-# LANGUAGE FunctionalDependencies, FlexibleInstances #-}++module Reflex.GI.Gtk.Output+ ( Sinkable(toSinkEvent)+ , MonadGtkSink+ , sink1+ , sink+ , ReactiveAttrOp(..)+ ) where++import Data.GI.Base.Attributes ( AttrBaseTypeConstraint+ , AttrGetType+ , AttrInfo+ , AttrLabelProxy+ , AttrOp ( (:=)+ , (:=>)+ , (:~)+ , (:~>)+ )+ , AttrOpAllowed+ , AttrOpTag( AttrGet+ , AttrSet+ )+ , AttrSetTypeConstraint+ , set+ )+import Data.GI.Base.Overloading ( HasAttributeList+ , ResolveAttribute+ )+import GHC.TypeLits (Symbol)+import Reflex ( Dynamic+ , Event+ , PerformEvent+ , Performable+ , PostBuild+ , (<@)+ , current+ , getPostBuild+ , leftmost+ , performEvent_+ , updated+ )+import Reflex.GI.Gtk.Run.Class ( MonadRunGtk+ , runGtk+ )++type MonadGtkSink t m = ( PerformEvent t m+ , PostBuild t m+ , MonadRunGtk (Performable m)+ )++class Sinkable t s | s -> t where+ toSinkEvent :: (MonadGtkSink t m) => s a -> m (Event t a)++instance Sinkable t (Event t) where+ toSinkEvent = pure++instance Sinkable t (Dynamic t) where+ toSinkEvent d = do+ postBuild <- getPostBuild+ pure $ leftmost+ [ updated d+ , current d <@ postBuild+ ]++sink1 :: (MonadGtkSink t m)+ => object+ -> ReactiveAttrOp t object 'AttrSet+ -> m ()+sink1 object reactiveOp =+ withReactiveAttrOp reactiveOp $ \plainOp updates ->+ toSinkEvent updates >>= performEvent_ . fmap (\x -> runGtk $ set object [plainOp x])++infixr 0 :==, :==>, :~~, :~~>+data ReactiveAttrOp t obj (tag :: AttrOpTag) where+ (:==) :: ( HasAttributeList obj+ , info ~ ResolveAttribute attr obj+ , AttrInfo info+ , AttrBaseTypeConstraint info obj+ , AttrOpAllowed tag info obj+ , AttrSetTypeConstraint info a+ , Sinkable t s+ )+ => AttrLabelProxy (attr :: Symbol)+ -> s a+ -> ReactiveAttrOp t obj tag+ (:==>) :: ( HasAttributeList obj+ , info ~ ResolveAttribute attr obj+ , AttrInfo info+ , AttrBaseTypeConstraint info obj+ , AttrOpAllowed tag info obj+ , AttrSetTypeConstraint info a+ , Sinkable t s+ )+ => AttrLabelProxy (attr :: Symbol)+ -> s (IO a)+ -> ReactiveAttrOp t obj tag+ (:~~) :: ( HasAttributeList obj+ , info ~ ResolveAttribute attr obj+ , AttrInfo info+ , AttrBaseTypeConstraint info obj+ , tag ~ 'AttrSet+ , AttrOpAllowed 'AttrSet info obj+ , AttrOpAllowed 'AttrGet info obj+ , AttrSetTypeConstraint info a+ , a ~ AttrGetType info+ , Sinkable t s+ )+ => AttrLabelProxy (attr :: Symbol)+ -> s (a -> a)+ -> ReactiveAttrOp t obj tag+ (:~~>) :: ( HasAttributeList obj+ , info ~ ResolveAttribute attr obj+ , AttrInfo info+ , AttrBaseTypeConstraint info obj+ , tag ~ 'AttrSet+ , AttrOpAllowed 'AttrSet info obj+ , AttrOpAllowed 'AttrGet info obj+ , AttrSetTypeConstraint info a+ , a ~ AttrGetType info+ , Sinkable t s+ )+ => AttrLabelProxy (attr :: Symbol)+ -> s (a -> IO a)+ -> ReactiveAttrOp t obj tag++withReactiveAttrOp :: ReactiveAttrOp t obj tag+ -> (forall a s. Sinkable t s => (a -> AttrOp obj tag) -> s a -> b)+ -> b+withReactiveAttrOp (attr :== updates) f = f (attr :=) updates+withReactiveAttrOp (attr :==> updates) f = f (attr :=>) updates+withReactiveAttrOp (attr :~~ updates) f = f (attr :~) updates+withReactiveAttrOp (attr :~~> updates) f = f (attr :~>) updates++sink :: ( MonadGtkSink t m+ )+ => object -> [ReactiveAttrOp t object 'AttrSet] -> m ()+sink object = mapM_ (sink1 object)
+ src/Reflex/GI/Gtk/Run/Base.hs view
@@ -0,0 +1,196 @@+-- 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 https://mozilla.org/MPL/2.0/.++{-# LANGUAGE GeneralizedNewtypeDeriving, RecordWildCards, UndecidableInstances, TypeFamilies #-}+{-# LANGUAGE StandaloneDeriving, FlexibleInstances, MultiParamTypeClasses, TypeApplications #-}+{-# LANGUAGE PatternSynonyms #-}++module Reflex.GI.Gtk.Run.Base+ ( RunGtkT+ , runGtkT+ ) where++import Control.Concurrent ( ThreadId+ , myThreadId+ , newEmptyMVar+ , putMVar+ , readMVar+ )+import Control.Concurrent.STM.TChan ( TChan+ , newTChanIO+ , readTChan+ , tryReadTChan+ , writeTChan+ )+import Control.Concurrent.STM.TVar ( newTVarIO+ , readTVar+ , writeTVar+ )+import Control.Exception ( SomeException+ , catch+ , mask_+ , throwIO+ , try+ )+import Control.Monad ( join+ , void+ )+import Control.Monad.Exception (MonadException)+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class ( MonadIO+ , liftIO+ )+import Control.Monad.Reader ( ReaderT+ , asks+ , runReaderT+ )+import Control.Monad.Ref (MonadRef)+import Control.Monad.STM ( STM+ , atomically+ , orElse+ , retry+ , throwSTM+ )+import Control.Monad.Trans (MonadTrans)+import Data.Function (fix)+import GI.GLib.Constants ( pattern PRIORITY_HIGH_IDLE+ , pattern SOURCE_REMOVE+ )+import GI.Gdk (threadsAddIdle)+import Reflex ( Adjustable( runWithReplace+ , traverseIntMapWithKeyWithAdjust+ , traverseDMapWithKeyWithAdjust+ , traverseDMapWithKeyWithAdjustWithMove+ )+ , MonadHold+ , MonadSample+ , NotReady( notReady+ , notReadyUntil+ )+ , PerformEvent( Performable+ , performEvent+ , performEvent_+ )+ , PerformEventT+ )+import Reflex.GI.Gtk.Run.Class (MonadRunGtk( askRunGtk_+ , askRunGtkPromise+ , askMakeSynchronousFire+ )+ )+import Reflex.Host.Class ( MonadReflexCreateTrigger+ , MonadReflexHost+ , MonadSubscribeEvent+ , ReflexHost+ )++data RunGtkEnv = RunGtkEnv+ { actionQueue :: TChan (IO ())+ , gtkThreadId :: ThreadId+ , waitEventThreadException :: STM SomeException+ }++newtype RunGtkT t m a = RunGtkT+ { unGtkT :: ReaderT RunGtkEnv m a+ }+ deriving ( Functor+ , Applicative+ , Monad+ , MonadTrans+ , MonadIO+ , MonadRef+ , MonadException+ , MonadFix+ )++deriving instance MonadSubscribeEvent t m => MonadSubscribeEvent t (RunGtkT t m)+deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RunGtkT t m)+deriving instance MonadReflexHost t m => MonadReflexHost t (RunGtkT t m)+deriving instance MonadSample t m => MonadSample t (RunGtkT t m)+deriving instance MonadHold t m => MonadHold t (RunGtkT t m)+deriving instance NotReady t m => NotReady t (RunGtkT t m)++instance Adjustable t m => Adjustable t (RunGtkT t m) where+ runWithReplace (RunGtkT a) e = RunGtkT $ runWithReplace a $ unGtkT <$> e+ traverseIntMapWithKeyWithAdjust f m a = RunGtkT $ traverseIntMapWithKeyWithAdjust f' m a+ where f' k v = unGtkT $ f k v+ traverseDMapWithKeyWithAdjust f m e =+ RunGtkT $ traverseDMapWithKeyWithAdjust (\k v -> unGtkT $ f k v) m e+ traverseDMapWithKeyWithAdjustWithMove f m e =+ RunGtkT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unGtkT $ f k v) m e++instance PerformEvent t m => PerformEvent t (RunGtkT t m) where+ type Performable (RunGtkT t m) = RunGtkT t (Performable m)+ performEvent = RunGtkT . performEvent . fmap unGtkT+ performEvent_ = RunGtkT . performEvent_ . fmap unGtkT++instance (MonadIO m) => MonadRunGtk (RunGtkT t m) where+ askRunGtk_ = do+ actionChan <- RunGtkT $ asks actionQueue+ gtkTId <- RunGtkT $ asks gtkThreadId+ pure $ \a -> do+ myTId <- myThreadId+ let execute = if myTId == gtkTId+ then id+ else scheduleAction actionChan+ execute $ void a+ askRunGtkPromise = do+ actionQueue <- RunGtkT $ asks actionQueue+ gtkTId <- RunGtkT $ asks gtkThreadId+ pure $ \a -> do+ myTId <- myThreadId+ if myTId == gtkTId+ then pure <$> a+ else do+ answerMVar <- newEmptyMVar+ scheduleAction actionQueue $ try @SomeException a >>= putMVar answerMVar+ pure $ readMVar answerMVar >>= either throwIO pure+ askMakeSynchronousFire = do+ actionChan <- RunGtkT $ asks actionQueue+ waitEventThreadException' <- RunGtkT $ asks waitEventThreadException+ pure $ \fireAsynchronously x -> do+ firedTVar <- newTVarIO False+ fireAsynchronously x $ atomically $ writeTVar firedTVar True+ let waitCompleted = do+ hasFired <- readTVar firedTVar+ if hasFired+ then pure ()+ else retry+ fix $ \loop -> join $ atomically $+ (pure () <$ waitCompleted)+ `orElse` ( do+ gtkAction <- readTChan actionChan+ pure $ runGtkAction gtkAction >> loop+ )+ `orElse` (waitEventThreadException' >>= throwSTM)++scheduleAction :: TChan (IO ()) -> IO () -> IO ()+scheduleAction actionChan action =+ atomically (writeTChan actionChan action)+ >> void ( threadsAddIdle PRIORITY_HIGH_IDLE $+ SOURCE_REMOVE <$ runScheduledActions actionChan+ )++runScheduledActions :: TChan (IO ()) -> IO ()+runScheduledActions actionChan =+ atomically (tryReadTChan actionChan)+ >>= mapM_ (\gtkAction -> runGtkAction gtkAction >> runScheduledActions actionChan)++runGtkAction :: IO () -> IO ()+runGtkAction a = mask_ $ catch a (const $ pure () :: SomeException -> IO ())++runGtkT :: (MonadIO m)+ => RunGtkT t m a+ -> STM SomeException+ -> ThreadId+ -> m a+runGtkT (RunGtkT a) waitEventThreadException gtkThreadId = do+ actionQueue <- liftIO newTChanIO+ runReaderT a RunGtkEnv{..}++instance ( NotReady t m+ , ReflexHost t+ ) => NotReady t (PerformEventT t (RunGtkT t m)) where+ notReady = pure ()+ notReadyUntil _ = pure ()
+ src/Reflex/GI/Gtk/Run/Class.hs view
@@ -0,0 +1,55 @@+-- 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 https://mozilla.org/MPL/2.0/.++{-# LANGUAGE TypeApplications, DefaultSignatures, StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Reflex.GI.Gtk.Run.Class+ ( MonadRunGtk( askRunGtk_+ , askRunGtk+ , askRunGtkPromise+ , askMakeSynchronousFire+ )+ , runGtk_+ , runGtk+ , runGtkPromise+ ) where++import Control.Monad (join)+import Control.Monad.IO.Class ( MonadIO+ , liftIO+ )+import Control.Monad.Reader (ReaderT(ReaderT))+import Control.Monad.Trans (lift)+import Reflex ( PostBuildT(PostBuildT)+ , TriggerEventT(TriggerEventT)+ )++class (MonadIO m) => MonadRunGtk m where+ askRunGtk :: m (IO a -> IO a)+ askRunGtk = (join .) <$> askRunGtkPromise++ askRunGtk_ :: m (IO a -> IO ())++ askRunGtkPromise :: m (IO a -> IO (IO a))++ askMakeSynchronousFire :: m ((a -> IO () -> IO ()) -> a -> IO ())++deriving instance MonadRunGtk m => MonadRunGtk (PostBuildT t m)+deriving instance MonadRunGtk m => MonadRunGtk (TriggerEventT t m)++instance MonadRunGtk m => MonadRunGtk (ReaderT r m) where+ askRunGtk = lift askRunGtk+ askRunGtk_ = lift askRunGtk_+ askRunGtkPromise = lift askRunGtkPromise+ askMakeSynchronousFire = lift askMakeSynchronousFire++runGtk :: (MonadRunGtk m) => IO a -> m a+runGtk a = askRunGtk >>= liftIO . ($a)++runGtk_ :: (MonadRunGtk m) => IO a -> m ()+runGtk_ a = askRunGtk_ >>= liftIO . ($a)++runGtkPromise :: (MonadRunGtk m) => IO a -> m (m a)+runGtkPromise a = askRunGtkPromise >>= liftIO . fmap liftIO . ($a)
+ src/Reflex/GI/Gtk/Widget/Box.hs view
@@ -0,0 +1,171 @@+-- 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 https://mozilla.org/MPL/2.0/.++{-# LANGUAGE FlexibleContexts, LambdaCase, TupleSections #-}++module Reflex.GI.Gtk.Widget.Box+ ( sinkBox+ , sinkBoxUniform+ ) where++import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO)+import Data.Align ( Semialign+ , align+ )+import Data.Foldable (foldl')+import Data.GI.Base (GObject)+import Data.GI.Base.Overloading (IsDescendantOf)+import qualified Data.Map as M+import Data.These ( These( This+ , That+ , These+ )+ )+import Data.Word (Word32)+import GI.Gtk ( Box+ , Container+ , PackType( PackTypeStart+ , PackTypeEnd+ )+ , Widget+ , boxPackEnd+ , boxPackStart+ , boxReorderChild+ , boxSetChildPacking+ , containerRemove+ , widgetShowAll+ )+import Reflex ( Dynamic+ , PerformEvent+ , Performable+ , PostBuild+ , (<@)+ , (<@>)+ , current+ , performEvent_+ , getPostBuild+ , updated+ )+import Reflex.GI.Gtk.Run.Class ( MonadRunGtk+ , runGtk+ )+import Reflex.GI.Gtk.Widget.Ord (OrdWidget(OrdWidget))++pack :: ( MonadIO m+ , GObject box+ , IsDescendantOf Box box+ , GObject child+ , IsDescendantOf Widget child+ )+ => box -> child -> Bool -> Bool -> Word32 -> PackType -> m ()+pack box child expand fill padding PackTypeStart = boxPackStart box child expand fill padding+pack box child expand fill padding PackTypeEnd = boxPackEnd box child expand fill padding+pack box child expand fill padding unknownPackType = do+ -- We don't know this packing, but boxSetChildPacking may know it,+ -- so we pack at start and then set the correct packing.+ boxPackStart box child expand fill padding+ boxSetChildPacking box child expand fill padding unknownPackType++sinkBox :: ( GObject box+ , IsDescendantOf Container box+ , IsDescendantOf Box box+ , Foldable f+ , Semialign f+ , GObject w+ , IsDescendantOf Widget w+ , Eq w+ , PerformEvent t m+ , PostBuild t m+ , MonadRunGtk m+ , MonadRunGtk (Performable m)+ )+ => box+ -> Dynamic t (f (w, Bool, Bool, Word32, PackType))+ -> m ()+sinkBox box widgets = do+ performEvent_ $ update <$> current widgets <@> updated widgets+ postBuild <- getPostBuild+ performEvent_+ $ runGtk . foldl' (\acc (w, expand, fill, padding, packType) ->+ acc >> pack box w expand fill padding packType+ ) (pure ())+ <$> current widgets <@ postBuild+ where update olds neww =+ let (reorder, _, removed) =+ foldl' (\wacc -> \case+ This old -> markOld wacc old+ That new -> otherWidget wacc new+ These+ wold@(old, oldExpand, oldFill, oldPadding, oldPackType)+ wnew@(new, newExpand, newFill, newPadding, newPackType)+ | old == new ->+ repackWidget wacc new+ (oldExpand, oldFill, oldPadding, oldPackType)+ (newExpand, newFill, newPadding, newPackType)+ | otherwise ->+ otherWidget (markOld wacc wold) wnew+ ) (pure (), 0, M.empty) $ align olds neww+ in runGtk $+ M.foldlWithKey' (\acc (OrdWidget w) _ ->+ acc >> containerRemove box w+ ) (pure ()) removed+ >> reorder+ markOld (acc, i, oldWidgets) (w, expand, fill, padding, packType) =+ ( acc+ , i+ , M.insert (OrdWidget w) (expand, fill, padding, packType) oldWidgets+ )+ otherWidget wacc@(_, _, oldWidgets) ww@(w, _, _, _, _) =+ case oldWidgets M.!? OrdWidget w of+ Nothing -> newWidget wacc ww+ Just oldPacking -> reuseWidget wacc ww oldPacking+ newWidget (acc, i, oldWidgets) (w, expand, fill, padding, packType) =+ ( do+ _ <- acc+ pack box w expand fill padding packType+ boxReorderChild box w i+ widgetShowAll w+ , succ i+ , oldWidgets+ )+ repackWidget (acc, i, oldWidgets) w oldPacking+ newPacking@(expand, fill, padding, packType) =+ ( do+ _ <- acc+ when (oldPacking /= newPacking)+ $ boxSetChildPacking box w expand fill padding packType+ , succ i+ , oldWidgets+ )+ reuseWidget (acc, i, oldWidgets) (w, expand, fill, padding, packType) oldPacking =+ repackWidget ( do+ _ <- acc+ boxReorderChild box w i+ , i -- repack widget already increases this+ , M.delete (OrdWidget w) oldWidgets+ ) w oldPacking (expand, fill, padding, packType)++sinkBoxUniform :: ( GObject box+ , IsDescendantOf Container box+ , IsDescendantOf Box box+ , Foldable f+ , Semialign f+ , GObject w+ , IsDescendantOf Widget w+ , Eq w+ , PerformEvent t m+ , PostBuild t m+ , MonadRunGtk m+ , MonadRunGtk (Performable m)+ )+ => box+ -> Dynamic t (f w)+ -> Bool+ -> Bool+ -> Word32+ -> PackType+ -> m ()+sinkBoxUniform box widgets expand fill padding packType =+ sinkBox box $ fmap (, expand, fill, padding, packType) <$> widgets
+ src/Reflex/GI/Gtk/Widget/Ord.hs view
@@ -0,0 +1,34 @@+-- 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 https://mozilla.org/MPL/2.0/.++{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}++module Reflex.GI.Gtk.Widget.Ord+ ( OrdWidget(..)+ ) where++import Data.Coerce (coerce)+import Data.Function (on)+import Data.GI.Base ( GObject+ , ManagedPtr(managedForeignPtr)+ )+import Foreign.ForeignPtr (ForeignPtr)++newtype OrdWidget w = OrdWidget+ { fromOrdWidget :: w+ }+ deriving (Eq)++foreignPtrFromWidget :: (GObject w) => w -> ForeignPtr ()+foreignPtrFromWidget = managedForeignPtr . coerce++foreignPtrFromOrdWidget :: (GObject w) => OrdWidget w -> ForeignPtr ()+foreignPtrFromOrdWidget (OrdWidget w) = foreignPtrFromWidget w++instance (GObject w, Eq w) => Ord (OrdWidget w) where+ compare = compare `on` foreignPtrFromOrdWidget+ (<) = (<) `on` foreignPtrFromOrdWidget+ (<=) = (<=) `on` foreignPtrFromOrdWidget+ (>) = (>) `on` foreignPtrFromOrdWidget+ (>=) = (>=) `on` foreignPtrFromOrdWidget