diff --git a/gi-gtk-declarative-app-simple.cabal b/gi-gtk-declarative-app-simple.cabal --- a/gi-gtk-declarative-app-simple.cabal +++ b/gi-gtk-declarative-app-simple.cabal @@ -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 diff --git a/src/GI/Gtk/Declarative/App/Simple.hs b/src/GI/Gtk/Declarative/App/Simple.hs --- a/src/GI/Gtk/Declarative/App/Simple.hs +++ b/src/GI/Gtk/Declarative/App/Simple.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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