gi-gtk-declarative-app-simple 0.1.0 → 0.2.0
raw patch · 3 files changed
+94/−95 lines, 3 files
Files
- CHANGELOG.md +2/−0
- gi-gtk-declarative-app-simple.cabal +5/−4
- src/GI/Gtk/Declarative/App/Simple.hs +87/−91
CHANGELOG.md view
@@ -1,3 +1,5 @@+* 0.2.0+ - Require GTK+ windows as top-level widget * 0.1.0 - First version of `gi-gtk-declarative`! - Basic widget without event handling
gi-gtk-declarative-app-simple.cabal view
@@ -1,8 +1,9 @@ name: gi-gtk-declarative-app-simple-version: 0.1.0-synopsis: Declarative GTK+ programming in Haskell in the style of- [Pux](https://github.com/alexmingoia/purescript-pux).--- description:+version: 0.2.0+synopsis: Declarative GTK+ programming in Haskell in the style of Pux.+description: Experimental application architecture in the style of+ PureScript Pux, built on top of gi-gtk-declarative. Learn+ more in the README below. license: MPL-2.0 license-file: LICENSE author: Oskar Wickström
src/GI/Gtk/Declarative/App/Simple.hs view
@@ -1,45 +1,49 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -- | A simple application architecture style inspired by PureScript's Pux -- framework. module GI.Gtk.Declarative.App.Simple ( App(..)+ , AppView , Transition(..)- , runInWindow , run+ , runLoop ) where import Control.Concurrent+import Control.Concurrent.Async (async) import Control.Monad-import Data.Int-import Data.Text (Text) import Data.Typeable import qualified GI.Gdk as Gdk import qualified GI.GLib.Constants as GLib import qualified GI.Gtk as Gtk import GI.Gtk.Declarative import GI.Gtk.Declarative.EventSource+import GI.Gtk.Declarative.State import Pipes import Pipes.Concurrent -- | Describes an state reducer application. data App state event = App- { update :: state -> event -> Transition state event+ { update :: state -> event -> Transition state event -- ^ The update function of an application reduces the current state and -- a new event to a 'Transition', which decides if and how to transition -- to the next state.- , view :: state -> Widget event- -- ^ The view renders a state value as a 'Widget', parameterized by the+ , view :: state -> AppView event+ -- ^ The view renders a state value as a window, parameterized by the -- 'App's event type.- , inputs :: [Producer event IO ()]+ , inputs :: [Producer event IO ()] -- ^ Inputs are pipes 'Producer's that feed events into the application. , initialState :: state -- ^ The initial state value of the state reduction loop. } +-- | The top-level widget for the 'view' function of an 'App',+-- requiring a GTK+ 'Window'.+type AppView event = Bin Gtk.Window Widget event+ -- | The result of applying the 'update' function, deciding if and how to -- transition to the next state. data Transition state event =@@ -49,93 +53,82 @@ -- | Exit the application. | Exit --- | Run an 'App' in a 'Gtk.Window' that has already been set up. This IO action--- will loop, so run it in a separate thread using 'forkIO' if you're calling--- it before the GTK main loop.-runInWindow :: Typeable event => Gtk.Window -> App state event -> IO ()-runInWindow window App {..} = do- let firstMarkup = view initialState- nextEvent <- newEmptyMVar- subscription <- runUI $ do- widget' <- Gtk.toWidget =<< create firstMarkup- Gtk.containerAdd window widget'- Gtk.widgetShowAll window- subscribe firstMarkup widget' (publishEvent nextEvent)- void . forkIO $- runEffect (mergeProducers inputs >-> publishInputEvents nextEvent)- loop firstMarkup nextEvent subscription initialState- where- loop oldMarkup nextEvent oldSubscription oldModel = do- event <- takeMVar nextEvent- case update oldModel event of- Transition newModel action -> do- let newMarkup = view newModel-- sub <- runUI (patchContainer window oldMarkup newMarkup nextEvent) >>= \case- Just newSubscription -> cancel oldSubscription *> pure newSubscription- Nothing -> pure oldSubscription-- -- Make sure the MVar is empty.- void (tryTakeMVar nextEvent)-- -- If the action returned by the update function produced an event, then- -- we write that as the nextEvent to use directly.- void . forkIO $ action >>= maybe (return ()) (putMVar nextEvent)-- -- Finally, we loop.- loop newMarkup nextEvent sub newModel- Exit ->- return ()---- | Initialize GTK, set up a new window, and run the application in it. This--- is a convenience function. If you need more flexibility, you should use--- 'runInWindow' instead.+-- | Initialize GTK and run the application in it. This is a+-- convenience function that is highly recommended. If you need more+-- flexibility, e.g. to set up GTK+ yourself, use 'runLoop' instead. run :: Typeable event- => Text -- ^ Window title- -> Maybe (Int32, Int32) -- ^ Optional window size- -> App state event -- ^ Application to run+ => App state event -- ^ Application to run -> IO ()-run title size app = do+run app = do void $ Gtk.init Nothing- window <- Gtk.windowNew Gtk.WindowTypeToplevel- void (Gtk.onWidgetDestroy window Gtk.mainQuit)- Gtk.windowSetTitle window title- case size of- Just (width, height) -> Gtk.windowResize window width height- Nothing -> return ()- void . forkIO $ do- runInWindow window app+ void . async $ do+ runLoop app -- In case the run loop exits, quit the main GTK loop. Gtk.mainQuit Gtk.main -patchContainer- :: Typeable event- => Gtk.Window- -> Widget event- -> Widget event- -> MVar event- -> IO (Maybe Subscription)-patchContainer w o1 o2 nextEvent = case patch o1 o2 of- Modify f -> Gtk.containerGetChildren w >>= \case- [] -> return Nothing- (c : _) -> do- widget' <- Gtk.toWidget c- f widget'- Gtk.widgetShowAll w- Just <$> subscribe o2 widget' (publishEvent nextEvent)- Replace createNew -> do- Gtk.containerForall w (Gtk.containerRemove w)- newWidget <- createNew- Gtk.containerAdd w newWidget- Gtk.widgetShowAll w- Just <$> subscribe o2 newWidget (publishEvent nextEvent)- Keep -> return Nothing+-- | Run an 'App'. This IO action will loop, so run it in a separate thread+-- using 'async' if you're calling it before the GTK main loop.+--+-- @+-- void $ Gtk.init Nothing+-- void . async $ do+-- runLoop app+-- -- In case the run loop exits, quit the main GTK loop.+-- Gtk.mainQuit+-- Gtk.main+-- @+runLoop :: Typeable event => App state event -> IO ()+runLoop App {..} = do+ let firstMarkup = view initialState+ events <- newChan+ (firstState, subscription) <- do+ firstState <- runUI (create firstMarkup)+ runUI (Gtk.widgetShowAll =<< someStateWidget firstState)+ sub <- subscribe firstMarkup firstState (publishEvent events)+ return (firstState, sub)+ void . forkIO $ runEffect+ (mergeProducers inputs >-> publishInputEvents events)+ loop firstState firstMarkup events subscription initialState -publishEvent :: MVar event -> event -> IO ()-publishEvent mvar = void . tryPutMVar mvar+ where+ loop oldState oldMarkup events oldSubscription oldModel = do+ event <- readChan events+ case update oldModel event of+ Transition newModel action -> do+ let newMarkup = view newModel + (newState, sub) <-+ case patch oldState oldMarkup newMarkup of+ Modify ma -> runUI $ do+ cancel oldSubscription+ newState <- ma+ sub <- subscribe newMarkup newState (publishEvent events)+ return (newState, sub)+ Replace createNew -> runUI $ do+ Gtk.widgetDestroy =<< someStateWidget oldState+ cancel oldSubscription+ newState <- createNew+ Gtk.widgetShowAll =<< someStateWidget newState+ sub <- subscribe newMarkup newState (publishEvent events)+ return (newState, sub)+ Keep -> return (oldState, oldSubscription)++ -- If the action returned by the update function produced an event, then+ -- we write that to the channel.+ --+ -- TODO: Use prioritized queue for events returned by 'update', to take+ -- precendence over those from 'inputs'.+ void . forkIO $ action >>= maybe (return ()) (writeChan events)++ -- Finally, we loop.+ loop newState newMarkup events sub newModel+ Exit -> return ()++publishEvent :: Chan event -> event -> IO ()+publishEvent mvar = void . writeChan mvar+ mergeProducers :: [Producer a IO ()] -> Producer a IO () mergeProducers producers = do (output, input) <- liftIO $ spawn unbounded@@ -147,14 +140,17 @@ runEffect $ producer >-> toOutput output performGC -publishInputEvents :: MVar event -> Consumer event IO ()-publishInputEvents nextEvent =- forever (await >>= liftIO . (putMVar nextEvent))+publishInputEvents :: Chan event -> Consumer event IO ()+publishInputEvents events = forever (await >>= liftIO . writeChan events) runUI :: IO a -> IO a-runUI f = do+runUI ma = do r <- newEmptyMVar+ runUI_ (ma >>= putMVar r)+ takeMVar r++runUI_ :: IO () -> IO ()+runUI_ ma = void . Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ do- f >>= putMVar r+ ma return False- takeMVar r