{-|
Module: Reflex.Vty.Host
Description: Scaffolding for running a reflex-vty application
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

module Reflex.Vty.Host
  ( VtyApp
  , VtyResult(..)
  , getDefaultVty
  , runVtyApp
  , runVtyAppWithHandle
  , MonadVtyApp
  , VtyEvent
  ) where

import Control.Concurrent (forkIO, killThread)
import Control.Concurrent.Chan (newChan, readChan, writeChan)
import Control.Exception (onException)
import Control.Monad (forM, forM_, forever)
import Control.Monad.Fix (MonadFix, fix)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Identity (Identity(..))
import Control.Monad.Primitive (PrimMonad)
import Control.Monad.Ref (MonadRef, Ref, readRef)
import Data.Dependent.Sum (DSum ((:=>)))
import Data.IORef (IORef, readIORef)
import Data.Maybe (catMaybes)

import Reflex
import Reflex.Host.Class
import Reflex.Spider.Orphans ()
import qualified Graphics.Vty as V
import Graphics.Vty (DisplayRegion)

-- | A synonym for the underlying vty event type from 'Graphics.Vty'. This should
-- probably ultimately be replaced by something defined in this library.
type VtyEvent = V.Event

-- | The output of a 'VtyApp'.
data VtyResult t = VtyResult
  { VtyResult t -> Behavior t Picture
_vtyResult_picture :: Behavior t V.Picture
  -- ^ The current vty output. 'runVtyAppWithHandle' samples this value every time an
  -- event fires and updates the display.
  , VtyResult t -> Event t ()
_vtyResult_shutdown :: Event t ()
  -- ^ An event that requests application termination.
  }

-- | The constraints necessary to run a 'VtyApp'. See 'runVtyAppWithHandle' for more
-- on why each of these are necessary and how they can be fulfilled.
type MonadVtyApp t m =
  ( Reflex t
  , MonadHold t m
  , MonadFix m
  , PrimMonad (HostFrame t)
  , ReflexHost t
  , MonadIO (HostFrame t)
  , Ref m ~ IORef
  , Ref (HostFrame t) ~ IORef
  , MonadRef (HostFrame t)
  , NotReady t m
  , TriggerEvent t m
  , PostBuild t m
  , PerformEvent t m
  , MonadIO m
  , MonadIO (Performable m)
  , Adjustable t m
  )

-- | A functional reactive vty application.
type VtyApp t m = MonadVtyApp t m
  => DisplayRegion
  -- ^ The initial display size (updates to this come as events)
  -> Event t V.Event
  -- ^ Vty input events.
  -> m (VtyResult t)
  -- ^ The output of the 'VtyApp'. The application runs in a context that,
  -- among other things, allows new events to be created and triggered
  -- ('TriggerEvent'), provides access to an event that fires immediately upon
  -- app instantiation ('PostBuild'), and allows actions to be run upon
  -- occurrences of events ('PerformEvent').

-- | Runs a 'VtyApp' in a given 'Graphics.Vty.Vty'.
runVtyAppWithHandle
  :: V.Vty
  -- ^ A 'Graphics.Vty.Vty' handle.
  -> (forall t m. VtyApp t m)
  -- ^ A functional reactive vty application.
  -> IO ()
runVtyAppWithHandle :: Vty -> (forall t (m :: * -> *). VtyApp t m) -> IO ()
runVtyAppWithHandle vty :: Vty
vty vtyGuest :: forall t (m :: * -> *). VtyApp t m
vtyGuest = (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
onException (Vty -> IO ()
V.shutdown Vty
vty) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$

  -- We are using the 'Spider' implementation of reflex. Running the host
  -- allows us to take actions on the FRP timeline. The scoped type signature
  -- specifies that our host runs on the Global timeline.
  -- For more information, see 'Reflex.Spider.Internal.runSpiderHost'.
  (forall a. SpiderHost Global a -> IO a
runSpiderHost :: SpiderHost Global a -> IO a) (SpiderHost Global () -> IO ()) -> SpiderHost Global () -> IO ()
forall a b. (a -> b) -> a -> b
$ do

    -- Create an 'Event' and a "trigger" reference for that event. The trigger
    -- reference can be used to determine whether anyone is "subscribed" to
    -- that 'Event' and, therefore, whether we need to bother performing any
    -- updates when the 'Event' fires.
    -- The 'Event' below will be used to convey vty input events.
    (vtyEvent :: Event (SpiderTimeline Global) Event
vtyEvent, vtyEventTriggerRef :: IORef (Maybe (RootTrigger Global Event))
vtyEventTriggerRef) <- SpiderHost
  Global
  (Event (SpiderTimeline Global) Event,
   IORef (Maybe (RootTrigger Global Event)))
forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
newEventWithTriggerRef

    -- Create the "post-build" event and associated trigger. This event fires
    -- once, when the application starts.
    (postBuild :: Event (SpiderTimeline Global) ()
postBuild, postBuildTriggerRef :: IORef (Maybe (RootTrigger Global ()))
postBuildTriggerRef) <- SpiderHost
  Global
  (Event (SpiderTimeline Global) (),
   IORef (Maybe (RootTrigger Global ())))
forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
newEventWithTriggerRef

    -- Create a queue to which we will write 'Event's that need to be
    -- processed.
    Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
events <- IO
  (Chan
     [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation])
-> SpiderHost
     Global
     (Chan
        [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO
  (Chan
     [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation])
forall a. IO (Chan a)
newChan

    DisplayRegion
displayRegion0 <- IO DisplayRegion -> SpiderHost Global DisplayRegion
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DisplayRegion -> SpiderHost Global DisplayRegion)
-> IO DisplayRegion -> SpiderHost Global DisplayRegion
forall a b. (a -> b) -> a -> b
$ Output -> IO DisplayRegion
V.displayBounds (Output -> IO DisplayRegion) -> Output -> IO DisplayRegion
forall a b. (a -> b) -> a -> b
$ Vty -> Output
V.outputIface Vty
vty

    -- Run the vty "guest" application, providing the appropriate context. The
    -- result is a 'VtyResult', and a 'FireCommand' that will be used to
    -- trigger events.
    (vtyResult :: VtyResult (SpiderTimeline Global)
vtyResult, fc :: FireCommand (SpiderTimeline Global) (SpiderHost Global)
fc@(FireCommand fire :: forall a.
[DSum (EventTrigger (SpiderTimeline Global)) Identity]
-> ReadPhase (SpiderHost Global) a -> SpiderHost Global [a]
fire)) <- do
      PerformEventT
  (SpiderTimeline Global)
  (SpiderHost Global)
  (VtyResult (SpiderTimeline Global))
-> SpiderHost
     Global
     (VtyResult (SpiderTimeline Global),
      FireCommand (SpiderTimeline Global) (SpiderHost Global))
forall t (m :: * -> *) a.
(Monad m, MonadSubscribeEvent t m, MonadReflexHost t m, MonadRef m,
 Ref m ~ Ref IO) =>
PerformEventT t m a -> m (a, FireCommand t m)
hostPerformEventT (PerformEventT
   (SpiderTimeline Global)
   (SpiderHost Global)
   (VtyResult (SpiderTimeline Global))
 -> SpiderHost
      Global
      (VtyResult (SpiderTimeline Global),
       FireCommand (SpiderTimeline Global) (SpiderHost Global)))
-> PerformEventT
     (SpiderTimeline Global)
     (SpiderHost Global)
     (VtyResult (SpiderTimeline Global))
-> SpiderHost
     Global
     (VtyResult (SpiderTimeline Global),
      FireCommand (SpiderTimeline Global) (SpiderHost Global))
forall a b. (a -> b) -> a -> b
$                 -- Allows the guest app to run
                                          -- 'performEvent', so that actions
                                          -- (e.g., IO actions) can be run when
                                          -- 'Event's fire.

        (PostBuildT
   (SpiderTimeline Global)
   (PerformEventT (SpiderTimeline Global) (SpiderHost Global))
   (VtyResult (SpiderTimeline Global))
 -> Event (SpiderTimeline Global) ()
 -> PerformEventT
      (SpiderTimeline Global)
      (SpiderHost Global)
      (VtyResult (SpiderTimeline Global)))
-> Event (SpiderTimeline Global) ()
-> PostBuildT
     (SpiderTimeline Global)
     (PerformEventT (SpiderTimeline Global) (SpiderHost Global))
     (VtyResult (SpiderTimeline Global))
-> PerformEventT
     (SpiderTimeline Global)
     (SpiderHost Global)
     (VtyResult (SpiderTimeline Global))
forall a b c. (a -> b -> c) -> b -> a -> c
flip PostBuildT
  (SpiderTimeline Global)
  (PerformEventT (SpiderTimeline Global) (SpiderHost Global))
  (VtyResult (SpiderTimeline Global))
-> Event (SpiderTimeline Global) ()
-> PerformEventT
     (SpiderTimeline Global)
     (SpiderHost Global)
     (VtyResult (SpiderTimeline Global))
forall t (m :: * -> *) a. PostBuildT t m a -> Event t () -> m a
runPostBuildT Event (SpiderTimeline Global) ()
postBuild (PostBuildT
   (SpiderTimeline Global)
   (PerformEventT (SpiderTimeline Global) (SpiderHost Global))
   (VtyResult (SpiderTimeline Global))
 -> PerformEventT
      (SpiderTimeline Global)
      (SpiderHost Global)
      (VtyResult (SpiderTimeline Global)))
-> PostBuildT
     (SpiderTimeline Global)
     (PerformEventT (SpiderTimeline Global) (SpiderHost Global))
     (VtyResult (SpiderTimeline Global))
-> PerformEventT
     (SpiderTimeline Global)
     (SpiderHost Global)
     (VtyResult (SpiderTimeline Global))
forall a b. (a -> b) -> a -> b
$    -- Allows the guest app to access to
                                          -- a "post-build" 'Event'

          (TriggerEventT
   (SpiderTimeline Global)
   (PostBuildT
      (SpiderTimeline Global)
      (PerformEventT (SpiderTimeline Global) (SpiderHost Global)))
   (VtyResult (SpiderTimeline Global))
 -> Chan
      [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
 -> PostBuildT
      (SpiderTimeline Global)
      (PerformEventT (SpiderTimeline Global) (SpiderHost Global))
      (VtyResult (SpiderTimeline Global)))
-> Chan
     [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
-> TriggerEventT
     (SpiderTimeline Global)
     (PostBuildT
        (SpiderTimeline Global)
        (PerformEventT (SpiderTimeline Global) (SpiderHost Global)))
     (VtyResult (SpiderTimeline Global))
-> PostBuildT
     (SpiderTimeline Global)
     (PerformEventT (SpiderTimeline Global) (SpiderHost Global))
     (VtyResult (SpiderTimeline Global))
forall a b c. (a -> b -> c) -> b -> a -> c
flip TriggerEventT
  (SpiderTimeline Global)
  (PostBuildT
     (SpiderTimeline Global)
     (PerformEventT (SpiderTimeline Global) (SpiderHost Global)))
  (VtyResult (SpiderTimeline Global))
-> Chan
     [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
-> PostBuildT
     (SpiderTimeline Global)
     (PerformEventT (SpiderTimeline Global) (SpiderHost Global))
     (VtyResult (SpiderTimeline Global))
forall t (m :: * -> *) a.
TriggerEventT t m a
-> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
runTriggerEventT Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
events (TriggerEventT
   (SpiderTimeline Global)
   (PostBuildT
      (SpiderTimeline Global)
      (PerformEventT (SpiderTimeline Global) (SpiderHost Global)))
   (VtyResult (SpiderTimeline Global))
 -> PostBuildT
      (SpiderTimeline Global)
      (PerformEventT (SpiderTimeline Global) (SpiderHost Global))
      (VtyResult (SpiderTimeline Global)))
-> TriggerEventT
     (SpiderTimeline Global)
     (PostBuildT
        (SpiderTimeline Global)
        (PerformEventT (SpiderTimeline Global) (SpiderHost Global)))
     (VtyResult (SpiderTimeline Global))
-> PostBuildT
     (SpiderTimeline Global)
     (PerformEventT (SpiderTimeline Global) (SpiderHost Global))
     (VtyResult (SpiderTimeline Global))
forall a b. (a -> b) -> a -> b
$  -- Allows the guest app to create new
                                          -- events and triggers and writes
                                          -- those triggers to a channel from
                                          -- which they will be read and
                                          -- processed.

            DisplayRegion
-> Event (SpiderTimeline Global) Event
-> TriggerEventT
     (SpiderTimeline Global)
     (PostBuildT
        (SpiderTimeline Global)
        (PerformEventT (SpiderTimeline Global) (SpiderHost Global)))
     (VtyResult (SpiderTimeline Global))
forall t (m :: * -> *). VtyApp t m
vtyGuest DisplayRegion
displayRegion0 Event (SpiderTimeline Global) Event
vtyEvent
                                          -- The guest app is provided the
                                          -- initial display region and an
                                          -- 'Event' of vty inputs.

    -- Reads the current value of the 'Picture' behavior and updates the
    -- display with it. This will be called whenever we determine that a
    -- display update is necessary. In this implementation that is when various
    -- events occur.
    let updateVty :: SpiderHost Global ()
updateVty =
          Behavior (SpiderTimeline Global) Picture
-> SpiderHost Global Picture
forall k (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample (VtyResult (SpiderTimeline Global)
-> Behavior (SpiderTimeline Global) Picture
forall t. VtyResult t -> Behavior t Picture
_vtyResult_picture VtyResult (SpiderTimeline Global)
vtyResult) SpiderHost Global Picture
-> (Picture -> SpiderHost Global ()) -> SpiderHost Global ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> SpiderHost Global ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SpiderHost Global ())
-> (Picture -> IO ()) -> Picture -> SpiderHost Global ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vty -> Picture -> IO ()
V.update Vty
vty

    -- Read the trigger reference for the post-build event. This will be
    -- 'Nothing' if the guest application hasn't subscribed to this event.
    Maybe (RootTrigger Global ())
mPostBuildTrigger <- Ref (SpiderHost Global) (Maybe (RootTrigger Global ()))
-> SpiderHost Global (Maybe (RootTrigger Global ()))
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef IORef (Maybe (RootTrigger Global ()))
Ref (SpiderHost Global) (Maybe (RootTrigger Global ()))
postBuildTriggerRef

    -- When there is a subscriber to the post-build event, fire the event.
    Maybe (RootTrigger Global ())
-> (RootTrigger Global () -> SpiderHost Global [()])
-> SpiderHost Global ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (RootTrigger Global ())
mPostBuildTrigger ((RootTrigger Global () -> SpiderHost Global [()])
 -> SpiderHost Global ())
-> (RootTrigger Global () -> SpiderHost Global [()])
-> SpiderHost Global ()
forall a b. (a -> b) -> a -> b
$ \postBuildTrigger :: RootTrigger Global ()
postBuildTrigger ->
      [DSum (EventTrigger (SpiderTimeline Global)) Identity]
-> ReadPhase (SpiderHost Global) () -> SpiderHost Global [()]
forall a.
[DSum (EventTrigger (SpiderTimeline Global)) Identity]
-> ReadPhase (SpiderHost Global) a -> SpiderHost Global [a]
fire [RootTrigger Global ()
postBuildTrigger RootTrigger Global ()
-> Identity () -> DSum (RootTrigger Global) Identity
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> () -> Identity ()
forall a. a -> Identity a
Identity ()] (ReadPhase (SpiderHost Global) () -> SpiderHost Global [()])
-> ReadPhase (SpiderHost Global) () -> SpiderHost Global [()]
forall a b. (a -> b) -> a -> b
$ () -> ReadPhase Global ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- After firing the post-build event, sample the vty result and update
    -- the display.
    SpiderHost Global ()
updateVty

    -- Subscribe to an 'Event' of that the guest application can use to
    -- request application shutdown. We'll check whether this 'Event' is firing
    -- to determine whether to terminate.
    SpiderEventHandle Global ()
shutdown <- Event (SpiderTimeline Global) ()
-> SpiderHost Global (SpiderEventHandle Global ())
forall t (m :: * -> *) a.
MonadSubscribeEvent t m =>
Event t a -> m (EventHandle t a)
subscribeEvent (Event (SpiderTimeline Global) ()
 -> SpiderHost Global (SpiderEventHandle Global ()))
-> Event (SpiderTimeline Global) ()
-> SpiderHost Global (SpiderEventHandle Global ())
forall a b. (a -> b) -> a -> b
$ VtyResult (SpiderTimeline Global)
-> Event (SpiderTimeline Global) ()
forall t. VtyResult t -> Event t ()
_vtyResult_shutdown VtyResult (SpiderTimeline Global)
vtyResult

    -- Fork a thread and continuously get the next vty input event, and then
    -- write the input event to our channel of FRP 'Event' triggers.
    -- The thread is forked here because 'nextEvent' blocks.
    ThreadId
nextEventThread <- IO ThreadId -> SpiderHost Global ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> SpiderHost Global ThreadId)
-> IO ThreadId -> SpiderHost Global ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      -- Retrieve the next input event.
      Event
ne <- Vty -> IO Event
V.nextEvent Vty
vty
      let -- The reference to the vty input 'EventTrigger'. This is the trigger
          -- we'd like to associate the input event value with.
          triggerRef :: EventTriggerRef (SpiderTimeline Global) Event
triggerRef = IORef (Maybe (EventTrigger (SpiderTimeline Global) Event))
-> EventTriggerRef (SpiderTimeline Global) Event
forall t a. IORef (Maybe (EventTrigger t a)) -> EventTriggerRef t a
EventTriggerRef IORef (Maybe (RootTrigger Global Event))
IORef (Maybe (EventTrigger (SpiderTimeline Global) Event))
vtyEventTriggerRef
          -- Create an event 'TriggerInvocation' with the value that we'd like
          -- the event to have if it is fired. It may not fire with this value
          -- if nobody is subscribed to the 'Event'.
          triggerInvocation :: TriggerInvocation Event
triggerInvocation = Event -> IO () -> TriggerInvocation Event
forall a. a -> IO () -> TriggerInvocation a
TriggerInvocation Event
ne (IO () -> TriggerInvocation Event)
-> IO () -> TriggerInvocation Event
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      -- Write our input event's 'EventTrigger' with the newly created
      -- 'TriggerInvocation' value to the queue of events.
      Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
-> [DSum
      (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
-> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
events [EventTriggerRef (SpiderTimeline Global) Event
triggerRef EventTriggerRef (SpiderTimeline Global) Event
-> TriggerInvocation Event
-> DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> TriggerInvocation Event
triggerInvocation]

    -- The main application loop. We wait for new events, fire those that
    -- have subscribers, and update the display. If we detect a shutdown
    -- request, the application terminates.
    (SpiderHost Global () -> SpiderHost Global ())
-> SpiderHost Global ()
forall a. (a -> a) -> a
fix ((SpiderHost Global () -> SpiderHost Global ())
 -> SpiderHost Global ())
-> (SpiderHost Global () -> SpiderHost Global ())
-> SpiderHost Global ()
forall a b. (a -> b) -> a -> b
$ \loop :: SpiderHost Global ()
loop -> do
      -- Read the next event (blocking).
      [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
ers <- IO
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
-> SpiderHost
     Global
     [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
 -> SpiderHost
      Global
      [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation])
-> IO
     [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
-> SpiderHost
     Global
     [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
forall a b. (a -> b) -> a -> b
$ Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
-> IO
     [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
forall a. Chan a -> IO a
readChan Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
events
      [Bool]
stop <- do
        -- Fire events that have subscribers.
        FireCommand (SpiderTimeline Global) (SpiderHost Global)
-> [DSum
      (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
-> ReadPhase (SpiderHost Global) Bool
-> SpiderHost Global [Bool]
forall (m :: * -> *) t a.
(Monad (ReadPhase m), MonadIO m) =>
FireCommand t m
-> [DSum (EventTriggerRef t) TriggerInvocation]
-> ReadPhase m a
-> m [a]
fireEventTriggerRefs FireCommand (SpiderTimeline Global) (SpiderHost Global)
fc [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
ers (ReadPhase (SpiderHost Global) Bool -> SpiderHost Global [Bool])
-> ReadPhase (SpiderHost Global) Bool -> SpiderHost Global [Bool]
forall a b. (a -> b) -> a -> b
$
          -- Check if the shutdown 'Event' is firing.
          EventHandle (SpiderTimeline Global) ()
-> ReadPhase Global (Maybe (ReadPhase Global ()))
forall t (m :: * -> *) a.
MonadReadEvent t m =>
EventHandle t a -> m (Maybe (m a))
readEvent SpiderEventHandle Global ()
EventHandle (SpiderTimeline Global) ()
shutdown ReadPhase Global (Maybe (ReadPhase Global ()))
-> (Maybe (ReadPhase Global ()) -> ReadPhase Global Bool)
-> ReadPhase Global Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Nothing -> Bool -> ReadPhase Global Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            Just _ -> Bool -> ReadPhase Global Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
stop
        then IO () -> SpiderHost Global ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SpiderHost Global ()) -> IO () -> SpiderHost Global ()
forall a b. (a -> b) -> a -> b
$ do             -- If we received a shutdown 'Event'
          ThreadId -> IO ()
killThread ThreadId
nextEventThread -- then stop reading input events and
          Vty -> IO ()
V.shutdown Vty
vty             -- call the 'Graphics.Vty.Vty's shutdown command.

        else do                      -- Otherwise, update the display and loop.
          SpiderHost Global ()
updateVty
          SpiderHost Global ()
loop
  where
    -- TODO Some part of this is probably general enough to belong in reflex
    -- | Use the given 'FireCommand' to fire events that have subscribers
    -- and call the callback for the 'TriggerInvocation' of each.
    fireEventTriggerRefs
      :: (Monad (ReadPhase m), MonadIO m)
      => FireCommand t m
      -> [DSum (EventTriggerRef t) TriggerInvocation]
      -> ReadPhase m a
      -> m [a]
    fireEventTriggerRefs :: FireCommand t m
-> [DSum (EventTriggerRef t) TriggerInvocation]
-> ReadPhase m a
-> m [a]
fireEventTriggerRefs (FireCommand fire :: forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire) ers :: [DSum (EventTriggerRef t) TriggerInvocation]
ers rcb :: ReadPhase m a
rcb = do
      [Maybe (DSum (EventTrigger t) Identity)]
mes <- IO [Maybe (DSum (EventTrigger t) Identity)]
-> m [Maybe (DSum (EventTrigger t) Identity)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Maybe (DSum (EventTrigger t) Identity)]
 -> m [Maybe (DSum (EventTrigger t) Identity)])
-> IO [Maybe (DSum (EventTrigger t) Identity)]
-> m [Maybe (DSum (EventTrigger t) Identity)]
forall a b. (a -> b) -> a -> b
$
        [DSum (EventTriggerRef t) TriggerInvocation]
-> (DSum (EventTriggerRef t) TriggerInvocation
    -> IO (Maybe (DSum (EventTrigger t) Identity)))
-> IO [Maybe (DSum (EventTrigger t) Identity)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DSum (EventTriggerRef t) TriggerInvocation]
ers ((DSum (EventTriggerRef t) TriggerInvocation
  -> IO (Maybe (DSum (EventTrigger t) Identity)))
 -> IO [Maybe (DSum (EventTrigger t) Identity)])
-> (DSum (EventTriggerRef t) TriggerInvocation
    -> IO (Maybe (DSum (EventTrigger t) Identity)))
-> IO [Maybe (DSum (EventTrigger t) Identity)]
forall a b. (a -> b) -> a -> b
$ \(EventTriggerRef er :: IORef (Maybe (EventTrigger t a))
er :=> TriggerInvocation a :: a
a _) -> do
          Maybe (EventTrigger t a)
me <- IORef (Maybe (EventTrigger t a)) -> IO (Maybe (EventTrigger t a))
forall a. IORef a -> IO a
readIORef IORef (Maybe (EventTrigger t a))
er
          Maybe (DSum (EventTrigger t) Identity)
-> IO (Maybe (DSum (EventTrigger t) Identity))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (DSum (EventTrigger t) Identity)
 -> IO (Maybe (DSum (EventTrigger t) Identity)))
-> Maybe (DSum (EventTrigger t) Identity)
-> IO (Maybe (DSum (EventTrigger t) Identity))
forall a b. (a -> b) -> a -> b
$ (EventTrigger t a -> DSum (EventTrigger t) Identity)
-> Maybe (EventTrigger t a)
-> Maybe (DSum (EventTrigger t) Identity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\e :: EventTrigger t a
e -> EventTrigger t a
e EventTrigger t a -> Identity a -> DSum (EventTrigger t) Identity
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> a -> Identity a
forall a. a -> Identity a
Identity a
a) Maybe (EventTrigger t a)
me
      [a]
a <- [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire ([Maybe (DSum (EventTrigger t) Identity)]
-> [DSum (EventTrigger t) Identity]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (DSum (EventTrigger t) Identity)]
mes) ReadPhase m a
rcb
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [DSum (EventTriggerRef t) TriggerInvocation]
-> (DSum (EventTriggerRef t) TriggerInvocation -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DSum (EventTriggerRef t) TriggerInvocation]
ers ((DSum (EventTriggerRef t) TriggerInvocation -> IO ()) -> IO ())
-> (DSum (EventTriggerRef t) TriggerInvocation -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(_ :=> TriggerInvocation _ cb :: IO ()
cb) -> IO ()
cb
      [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
a

-- | Run a 'VtyApp' with a 'Graphics.Vty.Vty' handle with a standard configuration.
runVtyApp
  :: (forall t m. VtyApp t m)
  -> IO ()
runVtyApp :: (forall t (m :: * -> *). VtyApp t m) -> IO ()
runVtyApp app :: forall t (m :: * -> *). VtyApp t m
app = do
  Vty
vty <- IO Vty
getDefaultVty
  Vty -> (forall t (m :: * -> *). VtyApp t m) -> IO ()
runVtyAppWithHandle Vty
vty forall t (m :: * -> *). VtyApp t m
app

-- | Returns the standard vty configuration with mouse mode enabled.
getDefaultVty :: IO V.Vty
getDefaultVty :: IO Vty
getDefaultVty = do
  Config
cfg <- IO Config
V.standardIOConfig
  Config -> IO Vty
V.mkVty (Config -> IO Vty) -> Config -> IO Vty
forall a b. (a -> b) -> a -> b
$ Config
cfg { mouseMode :: Maybe Bool
V.mouseMode = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True }