{-|
Module: Potato.Reflex.Vty.Host
Description: Potato version of Reflex.Vty.Host where render events are skipped to improve speed

-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

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

import Prelude

import System.IO
import Control.Concurrent (forkIO, killThread, MVar, newMVar, putMVar, readMVar, modifyMVar_)
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 Graphics.Vty (DisplayRegion)
import qualified Graphics.Vty as V





-- | 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
  { forall t. 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.
  , forall t. 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)
  , MonadSample t (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'.
-- Same as Reflex.Vty.runVtyAppWithHandle except does some bonus potato stuff
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 forall t (m :: * -> *). VtyApp t m
vtyGuest = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> IO b -> IO a
onException (Vty -> IO ()
V.shutdown Vty
vty) 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) 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.
    (Event (SpiderTimeline Global) Event
vtyEvent, IORef (Maybe (EventTrigger (SpiderTimeline Global) Event))
vtyEventTriggerRef) <- 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.
    (Event (SpiderTimeline Global) ()
postBuild, IORef (Maybe (EventTrigger (SpiderTimeline Global) ()))
postBuildTriggerRef) <- 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (Chan a)
newChan
    Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
triggerEvents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (Chan a)
newChan
    MVar Int
chanSizeVar :: MVar Int <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar Int
0

    DisplayRegion
displayRegion0 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Output -> IO DisplayRegion
V.displayBounds 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 (SpiderTimeline Global)
vtyResult, fc :: FireCommand (SpiderTimeline Global) (SpiderHost Global)
fc@(FireCommand forall a.
[DSum (EventTrigger (SpiderTimeline Global)) Identity]
-> ReadPhase (SpiderHost Global) a -> SpiderHost Global [a]
fire)) <- do
      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 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.

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

          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall t (m :: * -> *) a.
TriggerEventT t m a
-> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
runTriggerEventT Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
triggerEvents 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.

            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 =
          forall {k} (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample (forall t. VtyResult t -> Behavior t Picture
_vtyResult_picture VtyResult (SpiderTimeline Global)
vtyResult) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Picture
x -> do
            Int
n <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> IO a
readMVar forall a b. (a -> b) -> a -> b
$ MVar Int
chanSizeVar
            if Int
n forall a. Ord a => a -> a -> Bool
< Int
5
              then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vty -> Picture -> IO ()
V.update Vty
vty forall a b. (a -> b) -> a -> b
$ Picture
x
              else forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

    -- When there is a subscriber to the post-build event, fire the event.
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (EventTrigger (SpiderTimeline Global) ())
mPostBuildTrigger forall a b. (a -> b) -> a -> b
$ \EventTrigger (SpiderTimeline Global) ()
postBuildTrigger ->
      forall a.
[DSum (EventTrigger (SpiderTimeline Global)) Identity]
-> ReadPhase (SpiderHost Global) a -> SpiderHost Global [a]
fire [EventTrigger (SpiderTimeline Global) ()
postBuildTrigger forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> forall a. a -> Identity a
Identity ()] forall a b. (a -> b) -> a -> b
$ 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.
    EventHandle (SpiderTimeline Global) ()
shutdown <- forall t (m :: * -> *) a.
MonadSubscribeEvent t m =>
Event t a -> m (EventHandle t a)
subscribeEvent forall a b. (a -> b) -> a -> b
$ 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever 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 = forall t a. IORef (Maybe (EventTrigger t a)) -> EventTriggerRef t a
EventTriggerRef 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 = forall a. a -> IO () -> TriggerInvocation a
TriggerInvocation Event
ne forall a b. (a -> b) -> a -> b
$ 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.
      forall a. Chan a -> a -> IO ()
writeChan Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
events [EventTriggerRef (SpiderTimeline Global) Event
triggerRef forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> TriggerInvocation Event
triggerInvocation]
      forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Int
chanSizeVar (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Int
1))

    ThreadId
triggerEventThread <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
      [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
ev <- forall a. Chan a -> IO a
readChan Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
triggerEvents
      forall a. Chan a -> a -> IO ()
writeChan Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
events [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
ev
      forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Int
chanSizeVar (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Int
1))


    MVar Int
numFramesVar :: MVar Int <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar Int
0

    -- 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.
    forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \SpiderHost Global ()
loop -> do
      -- Read the next event (blocking).
      [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
ers <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> IO a
readChan Chan
  [DSum (EventTriggerRef (SpiderTimeline Global)) TriggerInvocation]
events
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Int
chanSizeVar (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ (-Int
1)))
      [Bool]
stop <- do
        -- Fire events that have subscribers.
        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 forall a b. (a -> b) -> a -> b
$
          -- Check if the shutdown 'Event' is firing.
          forall t (m :: * -> *) a.
MonadReadEvent t m =>
EventHandle t a -> m (Maybe (m a))
readEvent EventHandle (SpiderTimeline Global) ()
shutdown forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (ReadPhase Global ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            Just ReadPhase Global ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

      -- potato debug logging
      {-
      liftIO $ do
        nFrames <- readMVar numFramesVar
        hPutStrLn stderr $ "frame: " <> show nFrames <> " ticks: " <> show (length stop)
        hFlush stderr
        modifyMVar_ numFramesVar (return . (+1))
      -}

      if forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
stop
        then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
          ThreadId -> IO ()
killThread ThreadId
triggerEventThread
          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 :: forall (m :: * -> *) t a.
(Monad (ReadPhase m), MonadIO m) =>
FireCommand t m
-> [DSum (EventTriggerRef t) TriggerInvocation]
-> ReadPhase m a
-> m [a]
fireEventTriggerRefs (FireCommand forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire) [DSum (EventTriggerRef t) TriggerInvocation]
ers ReadPhase m a
rcb = do
      [Maybe (DSum (EventTrigger t) Identity)]
mes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DSum (EventTriggerRef t) TriggerInvocation]
ers forall a b. (a -> b) -> a -> b
$ \(EventTriggerRef IORef (Maybe (EventTrigger t a))
er :=> TriggerInvocation a
a IO ()
_) -> do
          Maybe (EventTrigger t a)
me <- forall a. IORef a -> IO a
readIORef IORef (Maybe (EventTrigger t a))
er
          return $ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\EventTrigger t a
e -> EventTrigger t a
e forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> forall a. a -> Identity a
Identity a
a) Maybe (EventTrigger t a)
me
      [a]
a <- forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire (forall a. [Maybe a] -> [a]
catMaybes [Maybe (DSum (EventTrigger t) Identity)]
mes) ReadPhase m a
rcb
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [DSum (EventTriggerRef t) TriggerInvocation]
ers forall a b. (a -> b) -> a -> b
$ \(EventTriggerRef t a
_ :=> TriggerInvocation a
_ IO ()
cb) -> IO ()
cb
      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 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 forall a b. (a -> b) -> a -> b
$ Config
cfg { mouseMode :: Maybe Bool
V.mouseMode = forall a. a -> Maybe a
Just Bool
True }