{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances #-} {-| Module : System.IO.Terminal.Input Copyright : (c) UU, 2019 License : MIT Maintainer : Tom Smeding Stability : experimental Portability : POSIX, macOS, Windows Keyboard input for console applications. A monad transformer is defined that allows reading keys from the keyboard in symbolic form, i.e. escape sequences have already been parsed. -} module System.IO.Terminal.Input (InputT, Input, withInput, liftIO, MonadInput(..) ,Key(..) ,InfInt(..), readKey) where import Control.Monad.Trans import Control.Monad.State.Strict import Data.Maybe import Numeric.InfInt import System.IO.Terminal.Render import System.IO.Terminal.Input.Key import System.IO.Terminal.Input.SeqParser -- import qualified Utils.Debug as Debug import Utils.Time #if defined(OS_LINUX) || defined(OS_MACOS) import System.IO.Terminal.Input.Posix #else import System.IO.Terminal.Input.Windows #endif -- | Escape sequence timeout in milliseconds. gEscTimeoutMS :: Int gEscTimeoutMS = 100 -- | The keyboard input monad transformer. The contained monad must be -- a monad over 'IO'. newtype InputT m a = InputT (StateT InputState m a) deriving (Functor, Applicative, Monad, MonadState InputState, MonadTrans) deriving instance MonadIO m => MonadIO (InputT m) -- | The non-transformer variant of 'InputT'. type Input = InputT IO data InputState = InputState { sKeys :: [Key] , sParser :: SeqParser (Maybe Char) Key -- If the timeout event was already returned, Infinity , sLastKey :: InfInt } -- | Run an 'Input' computation within an IO-based monad. withInput :: MonadIO m => InputT m a -> m a withInput (InputT st) = withRawMode $ evalStateT st (InputState [] seqParser Infinity) -- | The behavior class for the 'InputT' monad transformer. class Monad m => MonadInput m where -- | Timeout in milliseconds; Infinity is no timeout. Returns Nothing -- in case the timeout was reached. readKeyTimeout :: InfInt -> m (Maybe Key) instance MonadIO m => MonadInput (InputT m) where readKeyTimeout userTimeout = get >>= \s -> case sKeys s of [] -> do let SeqParser parserFunc = sParser s beforeKey <- timestampMS <$> liftIO getSystemTime -- These timeouts are either 'Finite timeout' in milliseconds, or 'Infinity' in case -- no timeout is needed. let -- Possibly the amount of time left for the next escape sequence item escTimeout = let delta = Finite beforeKey - sLastKey s left = Finite gEscTimeoutMS - delta in if left < 0 then 0 else left -- We wait until either the user timeout or the escape timeout passes, whichever -- is earlier timeoutVal = min userTimeout escTimeout -- Debug.logIO ("readKeyTimeout", beforeKey, userTimeout, sLastKey s, escTimeout, timeoutVal) ch <- liftIO $ getCharTimeout (toFinite timeoutVal) let userTimeoutTriggered = isNothing ch && userTimeout < escTimeout -- If we hit the user timeout, return appropriately if userTimeoutTriggered then {-Debug.logIO "returning Nothing" >>-} return Nothing else do -- We either got an actual key, or we hit the escape timeout. In either -- case, we advance the escape sequence parser. let (ks, p') = parserFunc ch -- Debug.logIO ("keys", ks) -- If we got an escape timeout, we'll be reporting it so we mark the last -- key as "long ago" to not report an escape timeout twice to the parser. -- Otherwise, we "start the escape timer" by storing the time of receipt of -- this key. afterKey <- timestampMS <$> liftIO getSystemTime let newLastKey = maybe Infinity (const $ Finite afterKey) ch modify $ \s' -> s' { sKeys = ks, sParser = p', sLastKey = newLastKey } -- Either way, we stored some stuff in sKeys, so either that contains keys -- to return, or we got nothing yet and need to retry; recursing handles -- both cases nicely. let userLeft = userTimeout - Finite (afterKey - beforeKey) readKeyTimeout userLeft (k:ks) -> do put (s { sKeys = ks }) -- Debug.logIO (Just k) return (Just k) instance MonadInput (RenderT Input) where readKeyTimeout = lift . readKeyTimeout -- | Read a key from standard input without timeout. Shortcut for -- @readKeyTimeout Infinity@. readKey :: MonadInput m => m Key readKey = fromJust <$> readKeyTimeout Infinity