{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- | Wrapper to write @terminal@ applications in Rhine, using concurrency.
module FRP.Rhine.Terminal (
  TerminalEventClock (..),
  flowTerminal,
  RunTerminalClock,
  runTerminalClock,
) where

-- base

import Unsafe.Coerce (unsafeCoerce)
import Prelude hiding (putChar)

-- exceptions
import Control.Monad.Catch (MonadMask)

-- time
import Data.Time.Clock (getCurrentTime)

-- terminal
import System.Terminal (Event, Interrupt, MonadInput, TerminalT, awaitEvent, runTerminalT)
import System.Terminal.Internal (Terminal)

-- transformers
import Control.Monad.Trans.Reader

-- monad-schedule
import Control.Monad.Schedule.Class

-- rhine
import FRP.Rhine

-- | A clock that ticks whenever events or interrupts on the terminal arrive.
data TerminalEventClock = TerminalEventClock

instance (MonadInput m, MonadIO m) => Clock m TerminalEventClock where
  type Time TerminalEventClock = UTCTime
  type Tag TerminalEventClock = Either Interrupt Event

  initClock :: TerminalEventClock
-> RunningClockInit
     m (Time TerminalEventClock) (Tag TerminalEventClock)
initClock TerminalEventClock
TerminalEventClock = do
    UTCTime
initialTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    (Automaton m () (UTCTime, Either Interrupt Event), UTCTime)
-> m (Automaton m () (UTCTime, Either Interrupt Event), UTCTime)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
      ( m (UTCTime, Either Interrupt Event)
-> Automaton m () (UTCTime, Either Interrupt Event)
forall (m :: * -> *) b a. Functor m => m b -> Automaton m a b
constM (m (UTCTime, Either Interrupt Event)
 -> Automaton m () (UTCTime, Either Interrupt Event))
-> m (UTCTime, Either Interrupt Event)
-> Automaton m () (UTCTime, Either Interrupt Event)
forall a b. (a -> b) -> a -> b
$ do
          Either Interrupt Event
event <- m (Either Interrupt Event)
forall (m :: * -> *). MonadInput m => m (Either Interrupt Event)
awaitEvent
          UTCTime
time <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
          (UTCTime, Either Interrupt Event)
-> m (UTCTime, Either Interrupt Event)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
time, Either Interrupt Event
event)
      , UTCTime
initialTime
      )

instance GetClockProxy TerminalEventClock

instance Semigroup TerminalEventClock where
  TerminalEventClock
t <> :: TerminalEventClock -> TerminalEventClock -> TerminalEventClock
<> TerminalEventClock
_ = TerminalEventClock
t

{- | A function wrapping `flow` to use at the top level
 in order to run a `Rhine (TerminalT t m) cl ()`

 Example:

 @
 mainRhine :: MonadIO m => Rhine (TerminalT LocalTerminal m) TerminalEventClock () ()
 mainRhine = tagS >-> arrMCl (liftIO . print) @@ TerminalEventClock

 main :: IO ()
 main = withTerminal $ \term -> `flowTerminal` term mainRhine
 @
-}
flowTerminal ::
  ( MonadIO m
  , MonadMask m
  , Terminal t
  , Clock (TerminalT t m) cl
  , GetClockProxy cl
  , Time cl ~ Time (In cl)
  , Time cl ~ Time (Out cl)
  ) =>
  t ->
  Rhine (TerminalT t m) cl () () ->
  m ()
flowTerminal :: forall (m :: * -> *) t cl.
(MonadIO m, MonadMask m, Terminal t, Clock (TerminalT t m) cl,
 GetClockProxy cl, Time cl ~ Time (In cl),
 Time cl ~ Time (Out cl)) =>
t -> Rhine (TerminalT t m) cl () () -> m ()
flowTerminal t
term Rhine (TerminalT t m) cl () ()
clsf = (TerminalT t m () -> t -> m ()) -> t -> TerminalT t m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip TerminalT t m () -> t -> m ()
forall (m :: * -> *) t a.
(MonadIO m, MonadMask m, Terminal t) =>
TerminalT t m a -> t -> m a
runTerminalT t
term (TerminalT t m () -> m ()) -> TerminalT t m () -> m ()
forall a b. (a -> b) -> a -> b
$ Rhine (TerminalT t m) cl () () -> TerminalT t m ()
forall (m :: * -> *) cl void.
(Monad m, Clock m cl, GetClockProxy cl, Time cl ~ Time (In cl),
 Time cl ~ Time (Out cl)) =>
Rhine m cl () () -> m void
flow Rhine (TerminalT t m) cl () ()
clsf

{- | To escape the 'TerminalT' transformer,
  you can apply this operator to your clock type,
  where @cl@ is a clock in 'TerminalT'.
  The resulting clock is then in @m@.
-}
type RunTerminalClock m t cl = HoistClock (TerminalT t m) m cl

-- | See 'RunTerminalClock'. Apply this to your clock value to remove a 'TerminalT' layer.
runTerminalClock ::
  (Terminal t) =>
  t ->
  cl ->
  RunTerminalClock IO t cl
runTerminalClock :: forall t cl. Terminal t => t -> cl -> RunTerminalClock IO t cl
runTerminalClock t
term cl
unhoistedClock =
  HoistClock
    { monadMorphism :: forall a. TerminalT t IO a -> IO a
monadMorphism = (TerminalT t IO a -> t -> IO a) -> t -> TerminalT t IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip TerminalT t IO a -> t -> IO a
forall (m :: * -> *) t a.
(MonadIO m, MonadMask m, Terminal t) =>
TerminalT t m a -> t -> m a
runTerminalT t
term
    , cl
unhoistedClock :: cl
unhoistedClock :: cl
..
    }

-- Workaround TerminalT constructor not being exported. Should be safe in practice.
-- See PR upstream https://github.com/lpeterse/haskell-terminal/pull/18
terminalT :: ReaderT t m a -> TerminalT t m a
terminalT :: forall t (m :: * -> *) a. ReaderT t m a -> TerminalT t m a
terminalT = ReaderT t m a -> TerminalT t m a
forall a b. a -> b
unsafeCoerce

unTerminalT :: TerminalT t m a -> ReaderT t m a
unTerminalT :: forall t (m :: * -> *) a. TerminalT t m a -> ReaderT t m a
unTerminalT = TerminalT t m a -> ReaderT t m a
forall a b. a -> b
unsafeCoerce

instance (Monad m, MonadSchedule m) => MonadSchedule (TerminalT t m) where
  schedule :: forall a.
NonEmpty (TerminalT t m a)
-> TerminalT t m (NonEmpty a, [TerminalT t m a])
schedule = ReaderT t m (NonEmpty a, [TerminalT t m a])
-> TerminalT t m (NonEmpty a, [TerminalT t m a])
forall t (m :: * -> *) a. ReaderT t m a -> TerminalT t m a
terminalT (ReaderT t m (NonEmpty a, [TerminalT t m a])
 -> TerminalT t m (NonEmpty a, [TerminalT t m a]))
-> (NonEmpty (TerminalT t m a)
    -> ReaderT t m (NonEmpty a, [TerminalT t m a]))
-> NonEmpty (TerminalT t m a)
-> TerminalT t m (NonEmpty a, [TerminalT t m a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((NonEmpty a, [ReaderT t m a]) -> (NonEmpty a, [TerminalT t m a]))
-> ReaderT t m (NonEmpty a, [ReaderT t m a])
-> ReaderT t m (NonEmpty a, [TerminalT t m a])
forall a b. (a -> b) -> ReaderT t m a -> ReaderT t m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([ReaderT t m a] -> [TerminalT t m a])
-> (NonEmpty a, [ReaderT t m a]) -> (NonEmpty a, [TerminalT t m a])
forall a b. (a -> b) -> (NonEmpty a, a) -> (NonEmpty a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ReaderT t m a -> TerminalT t m a)
-> [ReaderT t m a] -> [TerminalT t m a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ReaderT t m a -> TerminalT t m a
forall t (m :: * -> *) a. ReaderT t m a -> TerminalT t m a
terminalT)) (ReaderT t m (NonEmpty a, [ReaderT t m a])
 -> ReaderT t m (NonEmpty a, [TerminalT t m a]))
-> (NonEmpty (TerminalT t m a)
    -> ReaderT t m (NonEmpty a, [ReaderT t m a]))
-> NonEmpty (TerminalT t m a)
-> ReaderT t m (NonEmpty a, [TerminalT t m a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ReaderT t m a)
-> ReaderT t m (NonEmpty a, [ReaderT t m a])
forall a.
NonEmpty (ReaderT t m a)
-> ReaderT t m (NonEmpty a, [ReaderT t m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule (NonEmpty (ReaderT t m a)
 -> ReaderT t m (NonEmpty a, [ReaderT t m a]))
-> (NonEmpty (TerminalT t m a) -> NonEmpty (ReaderT t m a))
-> NonEmpty (TerminalT t m a)
-> ReaderT t m (NonEmpty a, [ReaderT t m a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerminalT t m a -> ReaderT t m a)
-> NonEmpty (TerminalT t m a) -> NonEmpty (ReaderT t m a)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TerminalT t m a -> ReaderT t m a
forall t (m :: * -> *) a. TerminalT t m a -> ReaderT t m a
unTerminalT