Rhine and Terminal

Main.hs

{-# LANGUAGE Arrows #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RecordWildCards #-}

module IIOS where

import Prelude hiding (putString, putChar)

import Data.Time.Clock

-- transformersPreload
import Control.Monad.IO.Class ( MonadIO, liftIO )

-- rhine
import Control.Monad.Catch (MonadMask)
import Control.Monad.Schedule ()

import Data.Text (Text)
import qualified Data.Text as T
import System.Terminal
    ( withTerminal,
      awaitEvent,
      runTerminalT,
      Event(KeyEvent),
      Interrupt,
      Key(CharKey),
      MonadPrinter(flush, putText, putString),
      MonadScreen(moveCursorBackward),
      TerminalT )
import System.Terminal.Internal
import FRP.Rhine
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT)
import Data.List (singleton)
import System.IO

type App = AppT IO
type AppT = TerminalT LocalTerminal

data TerminalEventClock = TerminalEventClock

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

  initClock _ = do
    initialTime <- liftIO getCurrentTime
    return
      ( constM $ do
          event <- awaitEvent
          time <- liftIO getCurrentTime
          return (time, event)
      , initialTime
      )

instance GetClockProxy TerminalEventClock

instance Semigroup TerminalEventClock where
  _ <> _ = TerminalEventClock

type KeyClock = SelectClock TerminalEventClock String

keyClock :: KeyClock
keyClock = SelectClock { mainClock = TerminalEventClock, select = select }
  where
    select :: Tag TerminalEventClock -> Maybe String
    select = \case
      Right (KeyEvent (CharKey key) _) -> Just $ singleton key
      Right a -> Just $ show a
      Left a -> Just $ show a
      -- _ -> Nothing

type BeatClock = Millisecond 1000

-- beat :: Rhine App BeatClock () Text
beat :: Rhine
  App
  (LiftClock
     IO
     AppT
     BeatClock)
  ()
  Text
beat = ((flip T.cons " > " ) . (cycle " ." !!) <$> count) @@ liftClock waitClock

-- Rhines

key :: ClSF App KeyClock () String
key = tagS

type DisplayClock = ParClock App (LiftClock IO AppT BeatClock) KeyClock

terminalSchedule
  :: ( MonadIO m
     , MonadMask m
     , Clock (AppT m) cl1
     , Clock (AppT m) cl2
     , Time cl1 ~ Time cl2
     )
  => Schedule m
       (HoistClock (AppT m) m cl1)
       (HoistClock (AppT m) m cl2)
  -> Schedule (AppT m) cl1 cl2
terminalSchedule Schedule {..}
  = Schedule $ \cl1 cl2 -> lift $ withTerminal $ \r -> first liftTransS
  <$> initSchedule
        (HoistClock cl1 $ flip runTerminalT r)
        (HoistClock cl2 $ flip runTerminalT r)

sensor :: Rhine App DisplayClock () (Either Text String)
sensor = beat ++@ terminalSchedule concurrently @++ key @@ keyClock

display :: ClSF App cl (Maybe (Either Text String)) ()
display = arrMCl $ \case
  Just (Left prompt) -> do
    -- pos@(Position row col) <- getCursorPosition
    -- moveCursorBackward col
    moveCursorBackward 4
    putText prompt
    -- setCursorPosition pos
    flush
    pure ()
  Just (Right key) -> do
    putString "abc"
    -- putText $ T.pack key
    flush
    pure ()
  Nothing -> do
    -- putString "?"
    -- flush
    pure ()

actuate :: Rhine App (LiftClock IO AppT BeatClock) (Maybe (Either Text String)) ()
-- actuate :: Rhine App (LiftClock IO AppT BeatClock) (Either Text Char) ()
actuate = display @@ liftClock waitClock

-- mainRhine :: Rhine App (SequentialClock App DisplayClock (Millisecond 100)) () ()
mainRhine =  sensor >-- fifoUnbounded -@- terminalSchedule concurrently --> actuate

main :: IO ()
main = do
  hSetBuffering stdin NoBuffering
  hSetBuffering stdout NoBuffering
  withTerminal $ runTerminalT $ flow $ mainRhine