gi-gtk-declarative-app-simple 0.6.3 → 0.7.0
raw patch · 3 files changed
+142/−49 lines, 3 filesdep +gi-gtk-declarative-app-simpledep +hspecdep ~basedep ~gi-gtkdep ~gi-gtk-declarativePVP ok
version bump matches the API change (PVP)
Dependencies added: gi-gtk-declarative-app-simple, hspec
Dependency ranges changed: base, gi-gtk, gi-gtk-declarative, haskell-gi, haskell-gi-base, haskell-gi-overloading, pipes
API changes (from Hackage documentation)
Files
- gi-gtk-declarative-app-simple.cabal +24/−10
- src/GI/Gtk/Declarative/App/Simple.hs +50/−39
- test/Main.hs +68/−0
gi-gtk-declarative-app-simple.cabal view
@@ -1,5 +1,5 @@ name: gi-gtk-declarative-app-simple-version: 0.6.3+version: 0.7.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.@@ -21,19 +21,33 @@ library exposed-modules: GI.Gtk.Declarative.App.Simple- build-depends: base >=4.10 && <5+ build-depends: base >=4.10 && <5 , async- , gi-gobject >= 2 && <3+ , gi-gobject >=2 && <3 , gi-glib- , gi-gtk >= 3 && <4+ , gi-gtk >=3 && <4 , gi-gdk- , haskell-gi >= 0.21 && <0.24- , haskell-gi-base >= 0.21 && <0.24- , haskell-gi-overloading == 1.0- , pipes >= 4 && <5- , pipes-concurrency >= 2 && <3+ , haskell-gi >=0.24 && <0.25+ , haskell-gi-base >=0.24 && <0.25+ , haskell-gi-overloading >=1.0 && <1.1+ , pipes >=4 && <5+ , pipes-concurrency >=2 && <3 , text- , gi-gtk-declarative >= 0.4 && <0.7+ , gi-gtk-declarative >=0.4 && <0.8 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall++test-suite gi-gtk-declarative-app-simple-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: async+ , base >= 4 && < 5+ , gi-gtk <4+ , gi-gtk-declarative+ , gi-gtk-declarative-app-simple+ , hspec+ , pipes+ default-language: Haskell2010+ ghc-options: -Wall -O2 -rtsopts -with-rtsopts=-N -threaded
src/GI/Gtk/Declarative/App/Simple.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-} -- | A simple application architecture style inspired by PureScript's Pux -- framework.@@ -15,9 +16,11 @@ import Control.Concurrent import qualified Control.Concurrent.Async as Async-import Control.Exception ( Exception- , throw- )+import Control.Exception ( SomeException,+ Exception,+ catch,+ finally,+ throwIO) import Control.Monad import Data.Typeable import qualified GI.Gdk as Gdk@@ -27,6 +30,7 @@ import GI.Gtk.Declarative.EventSource import GI.Gtk.Declarative.State import Pipes+import qualified Pipes.Prelude as Pipes import Pipes.Concurrent import System.Exit import System.IO@@ -78,39 +82,45 @@ run app = do assertRuntimeSupportsBoundThreads void $ Gtk.init Nothing- Async.withAsync (runLoop app <* Gtk.mainQuit) $ \lastState -> do- Gtk.main- Async.poll lastState >>= \case- Nothing ->- throw $ GtkMainExitedException "gtk's main loop exited unexpectedly"- Just (Right state ) -> return state- Just (Left exception) -> throw exception + -- If any exception happen in `runLoop`, it will be re-thrown here+ -- and the application will be killed.+ main <- Async.async Gtk.main+ runLoop app `finally` (Gtk.mainQuit >> Async.wait main)+ -- | 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.+-- Note: the following example take care of exception raised in 'runLoop'. -- -- @ -- void $ Gtk.init Nothing--- void . async $ do--- runLoop app--- -- In case the run loop exits, quit the main GTK loop.--- Gtk.mainQuit--- Gtk.main+-- main <- Async.async Gtk.main+-- runLoop app `finally` (Gtk.mainQuit >> Async.wait main) -- @ runLoop :: Gtk.IsBin window => App window state event -> IO state 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 + Async.withAsync (runProducers events inputs) $ \inputs' -> do+ Async.withAsync (wrappedLoop firstState firstMarkup events subscription) $ \loop' -> do+ Async.waitEither inputs' loop' >>= \case+ Left _ -> Async.wait loop'+ Right state -> state <$ Async.uninterruptibleCancel inputs'+ where+ wrappedLoop firstState firstMarkup events subscription =+ loop firstState firstMarkup events subscription initialState+ -- Catch exception of linked thread and reraise them without the+ -- async wrapping.+ `catch` (\(Async.ExceptionInLinkedThread _ e) -> throwIO e)+ loop oldState oldMarkup events oldSubscription oldModel = do event <- readChan events case update oldModel event of@@ -134,12 +144,17 @@ -- 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)+ -- This is done in a thread to avoid blocking the event loop.+ a <- Async.async $+ -- TODO: Use prioritized queue for events returned by 'update', to take+ -- precendence over those from 'inputs'.+ action >>= maybe (return ()) (writeChan events) - -- Finally, we loop.+ -- If any exception happen in the action, it will be reraised here and+ -- catched in the thread. See the ExceptionInLinkedThread+ -- catch.+ Async.link a+ loop newState newMarkup events sub newModel Exit -> return oldModel @@ -154,24 +169,15 @@ \flag)." exitFailure - 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- _ <- liftIO $ mapM (fork output) producers- fromInput input- where- fork :: Output a -> Producer a IO () -> IO ()- fork output producer = void $ forkIO $ do- runEffect $ producer >-> toOutput output+runProducers :: Chan event -> [Producer event IO ()] -> IO ()+runProducers chan producers =+ Async.forConcurrently_ producers $ \producer -> do+ runEffect $ producer >-> Pipes.mapM_ (publishEvent chan) performGC -publishInputEvents :: Chan event -> Consumer event IO ()-publishInputEvents events = forever (await >>= liftIO . writeChan events)- runUI :: IO a -> IO a runUI ma = do r <- newEmptyMVar@@ -179,6 +185,11 @@ takeMVar r runUI_ :: IO () -> IO ()-runUI_ ma = void . Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ do- ma- return False+runUI_ ma = do+ tId <- myThreadId++ void . Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $ do+ -- Any exception in the gtk ui thread will be rethrown in the calling thread.+ -- This ensure that this exception won't terminate the application without any control.+ ma `catch` throwTo @SomeException tId+ return False
+ test/Main.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+module Main where++import Control.Concurrent (threadDelay)+import qualified GI.Gtk as Gtk+import GI.Gtk.Declarative+import GI.Gtk.Declarative.App.Simple+import Pipes+import System.Timeout+import Test.Hspec++main :: IO ()+main = hspec $+ describe "run" $ do+ it "processes events from inputs" $+ runApp app { inputs = [yield IncState >> yield Close]} >>= (`shouldBe` Just 1)+ it "finishes app on Exit when input still going" $ do+ runApp app { inputs = [closeLoop] } >>= (`shouldBe` Just 0)+ -- Propagating exception from the view/update/inputs even is+ -- important to crash the application instead of keeping it in a+ -- weird state.+ it "propagates exceptions from view function" $+ runApp app {view = const (error "oh no")} `shouldThrow` errorCall "oh no"+ it "propagates exceptions from update handler itself" $+ runApp app {inputs = [yield ThrowError]} `shouldThrow` errorCall "oh no"+ it "propagates exceptions from the pipeline itself" $+ runApp app {inputs = [error "oh no"]} `shouldThrow` errorCall "oh no"+ describe "propagates exceptions from the Transition" $ do+ it "when the maybe is an exception" $+ runApp app { update = \s _ -> Transition s (pure $ error "oh no")+ , inputs = [yield ThrowError]+ } `shouldThrow` errorCall "oh no"+ it "when the io is an exception" $+ runApp app { update = \s _ -> Transition s (error "oh no")+ , inputs = [yield ThrowError]+ } `shouldThrow` errorCall "oh no"+ it "when the newly generated event is an exception" $+ -- Note: forcing the event by pattern matching is important to raise the exception+ runApp app { update = \s ThrowError -> Transition s (pure $ Just (error "oh no"))+ , inputs = [yield ThrowError]+ } `shouldThrow` errorCall "oh no"+ where+ app = App+ { update = update'+ , view = view'+ , inputs = []+ , initialState = 0+ }+ runApp = timeout 1000000 . run+ closeLoop = do+ yield Close+ liftIO (threadDelay 1000000)+ closeLoop++type AppState = Int++data AppEvent = IncState | ThrowError | Close++view' :: AppState -> AppView Gtk.Window AppEvent+view' _ = bin Gtk.Window [] (widget Gtk.Label [])++update' :: AppState -> AppEvent -> Transition AppState AppEvent+update' state = \case+ IncState -> Transition (state + 1) (pure Nothing)+ ThrowError -> error "oh no"+ Close -> Exit