diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# reflex-gi-gtk diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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 + ) diff --git a/reflex-gi-gtk.cabal b/reflex-gi-gtk.cabal new file mode 100644 --- /dev/null +++ b/reflex-gi-gtk.cabal @@ -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 diff --git a/src/Reflex/GI/Gtk.hs b/src/Reflex/GI/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk.hs @@ -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 diff --git a/src/Reflex/GI/Gtk/Class.hs b/src/Reflex/GI/Gtk/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk/Class.hs @@ -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) + ) diff --git a/src/Reflex/GI/Gtk/Host.hs b/src/Reflex/GI/Gtk/Host.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk/Host.hs @@ -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 diff --git a/src/Reflex/GI/Gtk/Input.hs b/src/Reflex/GI/Gtk/Input.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk/Input.hs @@ -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 diff --git a/src/Reflex/GI/Gtk/Output.hs b/src/Reflex/GI/Gtk/Output.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk/Output.hs @@ -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) diff --git a/src/Reflex/GI/Gtk/Run/Base.hs b/src/Reflex/GI/Gtk/Run/Base.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk/Run/Base.hs @@ -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 () diff --git a/src/Reflex/GI/Gtk/Run/Class.hs b/src/Reflex/GI/Gtk/Run/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk/Run/Class.hs @@ -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) diff --git a/src/Reflex/GI/Gtk/Widget/Box.hs b/src/Reflex/GI/Gtk/Widget/Box.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk/Widget/Box.hs @@ -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 diff --git a/src/Reflex/GI/Gtk/Widget/Ord.hs b/src/Reflex/GI/Gtk/Widget/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/GI/Gtk/Widget/Ord.hs @@ -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