Terminal.hs

{- | Wrapper to write @terminal@ applications in Rhine, using concurrency.
-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
module FRP.Rhine.Terminal
  ( TerminalEventClock (..)
  , flowTerminal
  , terminalConcurrently
  ) where

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

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

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

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

-- transformers
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class (lift)

-- 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 = do
      initialTime <- liftIO getCurrentTime
      return
        ( constM $ do
            event <- awaitEvent
            time <- liftIO getCurrentTime
            return (time, event)
        , initialTime
        )

instance GetClockProxy TerminalEventClock

instance Semigroup TerminalEventClock where
  t <> _ = 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 term clsf = flip runTerminalT term $ flow clsf

-- | A schedule in the 'TerminalT LocalTerminal' transformer,
--   supplying the same backend connection to its scheduled clocks.
terminalConcurrently
  :: forall t cl1 cl2. (
       Terminal t
     , Clock (TerminalT t IO) cl1
     , Clock (TerminalT t IO) cl2
     , Time cl1 ~ Time cl2
     )
  => Schedule (TerminalT t IO) cl1 cl2
terminalConcurrently
  = Schedule $ \cl1 cl2 -> do
      term <- terminalT ask
      lift $ first liftTransS <$>
        initSchedule concurrently (runTerminalClock term cl1) (runTerminalClock term cl2)

-- 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 = unsafeCoerce

type RunTerminalClock m t cl = HoistClock (TerminalT t m) m cl

runTerminalClock
  :: Terminal t
  => t
  -> cl
  -> RunTerminalClock IO t cl
runTerminalClock term unhoistedClock = HoistClock
  { monadMorphism = flip runTerminalT term
  , ..
  }