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
130
131
132
133
134
135
136
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-|
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.IO.Unlift (MonadUnliftIO)
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
import Utils.Monad
#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 newtype (Functor, Applicative, Monad, MonadState InputState, MonadTrans)
deriving MonadUnliftIO via StateTUnliftIOWrapper InputState m
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
|
