1 files changed, 129 insertions, 0 deletions
diff --git a/src/System/IO/Terminal/Input.hs b/src/System/IO/Terminal/Input.hs
new file mode 100644
index 0000000..86db30d
--- /dev/null
+++ b/src/System/IO/Terminal/Input.hs
@@ -0,0 +1,129 @@
+{-# 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