{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module GI.Gtk.Declarative.App.Simple
( App(..)
, AppView
, Transition(..)
, run
, runLoop
)
where
import Control.Concurrent
import qualified Control.Concurrent.Async as Async
import Control.Exception ( SomeException,
Exception,
catch,
finally,
throwIO)
import Control.Monad
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 qualified Pipes.Prelude as Pipes
import Pipes.Concurrent
import System.Exit
import System.IO
data App window state event =
App
{ App window state event -> state -> event -> Transition state event
update :: state -> event -> Transition state event
, App window state event -> state -> AppView window event
view :: state -> AppView window event
, App window state event -> [Producer event IO ()]
inputs :: [Producer event IO ()]
, App window state event -> state
initialState :: state
}
type AppView window event = Bin window event
data Transition state event =
Transition state (IO (Maybe event))
| Exit
data GtkMainExitedException =
GtkMainExitedException String deriving (Typeable, Int -> GtkMainExitedException -> ShowS
[GtkMainExitedException] -> ShowS
GtkMainExitedException -> String
(Int -> GtkMainExitedException -> ShowS)
-> (GtkMainExitedException -> String)
-> ([GtkMainExitedException] -> ShowS)
-> Show GtkMainExitedException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GtkMainExitedException] -> ShowS
$cshowList :: [GtkMainExitedException] -> ShowS
show :: GtkMainExitedException -> String
$cshow :: GtkMainExitedException -> String
showsPrec :: Int -> GtkMainExitedException -> ShowS
$cshowsPrec :: Int -> GtkMainExitedException -> ShowS
Show)
instance Exception GtkMainExitedException
run
:: Gtk.IsBin window
=> App window state event
-> IO state
run :: App window state event -> IO state
run app :: App window state event
app = do
IO ()
assertRuntimeSupportsBoundThreads
IO (Maybe [Text]) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe [Text]) -> IO ()) -> IO (Maybe [Text]) -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe [Text] -> IO (Maybe [Text])
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe [Text] -> m (Maybe [Text])
Gtk.init Maybe [Text]
forall a. Maybe a
Nothing
Async ()
main <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => m ()
Gtk.main
App window state event -> IO state
forall window state event.
IsBin window =>
App window state event -> IO state
runLoop App window state event
app IO state -> IO () -> IO state
forall a b. IO a -> IO b -> IO a
`finally` (IO ()
forall (m :: * -> *). (HasCallStack, MonadIO m) => m ()
Gtk.mainQuit IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Async () -> IO ()
forall a. Async a -> IO a
Async.wait Async ()
main)
runLoop :: Gtk.IsBin window => App window state event -> IO state
runLoop :: App window state event -> IO state
runLoop App {..} = do
let firstMarkup :: AppView window event
firstMarkup = state -> AppView window event
view state
initialState
Chan event
events <- IO (Chan event)
forall a. IO (Chan a)
newChan
(firstState :: SomeState
firstState, subscription :: Subscription
subscription) <- do
SomeState
firstState <- IO SomeState -> IO SomeState
forall a. IO a -> IO a
runUI (AppView window event -> IO SomeState
forall (widget :: * -> *) e.
Patchable widget =>
widget e -> IO SomeState
create AppView window event
firstMarkup)
IO () -> IO ()
forall a. IO a -> IO a
runUI (Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShowAll (Widget -> IO ()) -> IO Widget -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SomeState -> IO Widget
someStateWidget SomeState
firstState)
Subscription
sub <- AppView window event
-> SomeState -> (event -> IO ()) -> IO Subscription
forall (widget :: * -> *) event.
EventSource widget =>
widget event -> SomeState -> (event -> IO ()) -> IO Subscription
subscribe AppView window event
firstMarkup SomeState
firstState (Chan event -> event -> IO ()
forall event. Chan event -> event -> IO ()
publishEvent Chan event
events)
(SomeState, Subscription) -> IO (SomeState, Subscription)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeState
firstState, Subscription
sub)
IO () -> (Async () -> IO state) -> IO state
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (Chan event -> [Producer event IO ()] -> IO ()
forall event. Chan event -> [Producer event IO ()] -> IO ()
runProducers Chan event
events [Producer event IO ()]
inputs) ((Async () -> IO state) -> IO state)
-> (Async () -> IO state) -> IO state
forall a b. (a -> b) -> a -> b
$ \inputs' :: Async ()
inputs' -> do
IO state -> (Async state -> IO state) -> IO state
forall a b. IO a -> (Async a -> IO b) -> IO b
Async.withAsync (SomeState
-> AppView window event -> Chan event -> Subscription -> IO state
wrappedLoop SomeState
firstState AppView window event
firstMarkup Chan event
events Subscription
subscription) ((Async state -> IO state) -> IO state)
-> (Async state -> IO state) -> IO state
forall a b. (a -> b) -> a -> b
$ \loop' :: Async state
loop' -> do
Async () -> Async state -> IO (Either () state)
forall a b. Async a -> Async b -> IO (Either a b)
Async.waitEither Async ()
inputs' Async state
loop' IO (Either () state) -> (Either () state -> IO state) -> IO state
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left _ -> Async state -> IO state
forall a. Async a -> IO a
Async.wait Async state
loop'
Right state :: state
state -> state
state state -> IO () -> IO state
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Async () -> IO ()
forall a. Async a -> IO ()
Async.uninterruptibleCancel Async ()
inputs'
where
wrappedLoop :: SomeState
-> AppView window event -> Chan event -> Subscription -> IO state
wrappedLoop firstState :: SomeState
firstState firstMarkup :: AppView window event
firstMarkup events :: Chan event
events subscription :: Subscription
subscription =
SomeState
-> AppView window event
-> Chan event
-> Subscription
-> state
-> IO state
loop SomeState
firstState AppView window event
firstMarkup Chan event
events Subscription
subscription state
initialState
IO state -> (ExceptionInLinkedThread -> IO state) -> IO state
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(Async.ExceptionInLinkedThread _ e :: SomeException
e) -> SomeException -> IO state
forall e a. Exception e => e -> IO a
throwIO SomeException
e)
loop :: SomeState
-> AppView window event
-> Chan event
-> Subscription
-> state
-> IO state
loop oldState :: SomeState
oldState oldMarkup :: AppView window event
oldMarkup events :: Chan event
events oldSubscription :: Subscription
oldSubscription oldModel :: state
oldModel = do
event
event <- Chan event -> IO event
forall a. Chan a -> IO a
readChan Chan event
events
case state -> event -> Transition state event
update state
oldModel event
event of
Transition newModel :: state
newModel action :: IO (Maybe event)
action -> do
let newMarkup :: AppView window event
newMarkup = state -> AppView window event
view state
newModel
(newState :: SomeState
newState, sub :: Subscription
sub) <- case SomeState -> AppView window event -> AppView window event -> Patch
forall (widget :: * -> *) e1 e2.
Patchable widget =>
SomeState -> widget e1 -> widget e2 -> Patch
patch SomeState
oldState AppView window event
oldMarkup AppView window event
newMarkup of
Modify ma :: IO SomeState
ma -> IO (SomeState, Subscription) -> IO (SomeState, Subscription)
forall a. IO a -> IO a
runUI (IO (SomeState, Subscription) -> IO (SomeState, Subscription))
-> IO (SomeState, Subscription) -> IO (SomeState, Subscription)
forall a b. (a -> b) -> a -> b
$ do
Subscription -> IO ()
cancel Subscription
oldSubscription
SomeState
newState <- IO SomeState
ma
Subscription
sub <- AppView window event
-> SomeState -> (event -> IO ()) -> IO Subscription
forall (widget :: * -> *) event.
EventSource widget =>
widget event -> SomeState -> (event -> IO ()) -> IO Subscription
subscribe AppView window event
newMarkup SomeState
newState (Chan event -> event -> IO ()
forall event. Chan event -> event -> IO ()
publishEvent Chan event
events)
(SomeState, Subscription) -> IO (SomeState, Subscription)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeState
newState, Subscription
sub)
Replace createNew :: IO SomeState
createNew -> IO (SomeState, Subscription) -> IO (SomeState, Subscription)
forall a. IO a -> IO a
runUI (IO (SomeState, Subscription) -> IO (SomeState, Subscription))
-> IO (SomeState, Subscription) -> IO (SomeState, Subscription)
forall a b. (a -> b) -> a -> b
$ do
Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetDestroy (Widget -> IO ()) -> IO Widget -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SomeState -> IO Widget
someStateWidget SomeState
oldState
Subscription -> IO ()
cancel Subscription
oldSubscription
SomeState
newState <- IO SomeState
createNew
Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShowAll (Widget -> IO ()) -> IO Widget -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SomeState -> IO Widget
someStateWidget SomeState
newState
Subscription
sub <- AppView window event
-> SomeState -> (event -> IO ()) -> IO Subscription
forall (widget :: * -> *) event.
EventSource widget =>
widget event -> SomeState -> (event -> IO ()) -> IO Subscription
subscribe AppView window event
newMarkup SomeState
newState (Chan event -> event -> IO ()
forall event. Chan event -> event -> IO ()
publishEvent Chan event
events)
(SomeState, Subscription) -> IO (SomeState, Subscription)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeState
newState, Subscription
sub)
Keep -> (SomeState, Subscription) -> IO (SomeState, Subscription)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeState
oldState, Subscription
oldSubscription)
Async ()
a <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
IO (Maybe event)
action IO (Maybe event) -> (Maybe event -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (event -> IO ()) -> Maybe event -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Chan event -> event -> IO ()
forall event. Chan event -> event -> IO ()
writeChan Chan event
events)
Async () -> IO ()
forall a. Async a -> IO ()
Async.link Async ()
a
SomeState
-> AppView window event
-> Chan event
-> Subscription
-> state
-> IO state
loop SomeState
newState AppView window event
newMarkup Chan event
events Subscription
sub state
newModel
Exit -> state -> IO state
forall (m :: * -> *) a. Monad m => a -> m a
return state
oldModel
assertRuntimeSupportsBoundThreads :: IO ()
assertRuntimeSupportsBoundThreads :: IO ()
assertRuntimeSupportsBoundThreads = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
rtsSupportsBoundThreads (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> String -> IO ()
hPutStrLn
Handle
stderr
"GI.Gtk.Declarative.App.Simple requires the program to \
\be linked using the threaded runtime of GHC (-threaded \
\flag)."
IO ()
forall a. IO a
exitFailure
publishEvent :: Chan event -> event -> IO ()
publishEvent :: Chan event -> event -> IO ()
publishEvent mvar :: Chan event
mvar = IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> (event -> IO ()) -> event -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chan event -> event -> IO ()
forall event. Chan event -> event -> IO ()
writeChan Chan event
mvar
runProducers :: Chan event -> [Producer event IO ()] -> IO ()
runProducers :: Chan event -> [Producer event IO ()] -> IO ()
runProducers chan :: Chan event
chan producers :: [Producer event IO ()]
producers =
[Producer event IO ()] -> (Producer event IO () -> IO ()) -> IO ()
forall (f :: * -> *) a b. Foldable f => f a -> (a -> IO b) -> IO ()
Async.forConcurrently_ [Producer event IO ()]
producers ((Producer event IO () -> IO ()) -> IO ())
-> (Producer event IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \producer :: Producer event IO ()
producer -> do
Effect IO () -> IO ()
forall (m :: * -> *) r. Monad m => Effect m r -> m r
runEffect (Effect IO () -> IO ()) -> Effect IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Producer event IO ()
producer Producer event IO () -> Proxy () event () X IO () -> Effect IO ()
forall (m :: * -> *) a' a b r c' c.
Functor m =>
Proxy a' a () b m r -> Proxy () b c' c m r -> Proxy a' a c' c m r
>-> (event -> IO ()) -> Consumer' event IO ()
forall (m :: * -> *) a r. Monad m => (a -> m ()) -> Consumer' a m r
Pipes.mapM_ (Chan event -> event -> IO ()
forall event. Chan event -> event -> IO ()
publishEvent Chan event
chan)
IO ()
performGC
runUI :: IO a -> IO a
runUI :: IO a -> IO a
runUI ma :: IO a
ma = do
MVar a
r <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
IO () -> IO ()
runUI_ (IO a
ma IO a -> (a -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
r)
MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
r
runUI_ :: IO () -> IO ()
runUI_ :: IO () -> IO ()
runUI_ ma :: IO ()
ma = do
ThreadId
tId <- IO ThreadId
myThreadId
IO Word32 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Word32 -> IO ())
-> (SourceFunc -> IO Word32) -> SourceFunc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> SourceFunc -> IO Word32
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Int32 -> SourceFunc -> m Word32
Gdk.threadsAddIdle Int32
GLib.PRIORITY_DEFAULT (SourceFunc -> IO ()) -> SourceFunc -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IO ()
ma IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` ThreadId -> SomeException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo @SomeException ThreadId
tId
Bool -> SourceFunc
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False