{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE TypeApplications #-}

-- | A simple application architecture style inspired by PureScript's Pux
-- framework.
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

-- | Describes an state reducer application.
data App window state event =
  App
    { App window state event -> 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.
    , App window state event -> state -> AppView window event
view         :: state -> AppView window event
    -- ^ The view renders a state value as a window, parameterized by the
    -- 'App's event type.
    , App window state event -> [Producer event IO ()]
inputs       :: [Producer event IO ()]
    -- ^ Inputs are pipes 'Producer's that feed events into the application.
    , App window state event -> state
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 window event = Bin window event

-- | The result of applying the 'update' function, deciding if and how to
-- transition to the next state.
data Transition state event =
  -- Transition to the given state, and with an IO action that may return a
  -- new event.
  Transition state (IO (Maybe event))
  -- | Exit the application.
  | Exit

-- | An exception thrown by the 'run' function when gtk's main loop exits
-- before event/state handling which should never happen but can be caused
-- by user code calling 'Gtk.mainQuit'
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

-- | 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
  :: Gtk.IsBin window
  => App window state event      -- ^ Application to run
  -> 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

  -- If any exception happen in `runLoop`, it will be re-thrown here
  -- and the application will be killed.
  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)

-- | 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
--     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 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
      -- Catch exception of linked thread and reraise them without the
      -- async wrapping.
      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)

        -- If the action returned by the update function produced an event, then
        -- we write that to the channel.
        -- This is done in a thread to avoid blocking the event loop.
        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
$
          -- TODO: Use prioritized queue for events returned by 'update', to take
          -- precendence over those from 'inputs'.
          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)

        -- If any exception happen in the action, it will be reraised here and
        -- catched in the thread. See the ExceptionInLinkedThread
        -- catch.
        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

-- | Assert that the program was linked using the @-threaded@ flag, to
-- enable the threaded runtime required by this module.
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
    -- 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.
    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