1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
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
|
