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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
{-|
Module : System.IO.Terminal.Input.Posix
Copyright : (c) UU, 2019
License : MIT
Maintainer : Tom Smeding
Stability : experimental
Portability : POSIX, macOS
Platform-specific submodule of "System.IO.Terminal.Input" that works on POSIX-like platforms.
-}
module System.IO.Terminal.Input.Posix
(withRawMode, getCharTimeout
,seqParser)
where
import Control.Monad
import Control.Monad.IO.Class
import Data.Char
import Data.Function
import Data.List
import Data.Maybe
import System.IO
import System.IO.Terminal.Input.Key
import System.IO.Terminal.Input.SeqParser
import System.Timeout
-- | Run an IO-monadic computation with terminal input buffering and echo
-- turned off.
withRawMode :: MonadIO m => m a -> m a
withRawMode = withNoBuffering . withNoEcho
where
withNoBuffering = with (hGetBuffering stdin `takeLeft` hSetBuffering stdin NoBuffering) (hSetBuffering stdin)
withNoEcho = with (hGetEcho stdin `takeLeft` hSetEcho stdin False) (hSetEcho stdin)
with start stop act = do
val <- liftIO start
res <- act
_ <- liftIO $ stop val
return res
takeLeft a b = a >>= \x -> b >> return x
peekIO :: Show a => IO a -> IO a
-- peekIO act = act >>= \x -> print ("peekIO", x) >> return x
peekIO = id
-- | Get a character from standard input, returning Nothing if no character
-- has appeared after the specified number of milliseconds.
getCharTimeout :: Maybe Int -> IO (Maybe Char)
getCharTimeout (Just timeoutms) = peekIO (timeout (1000 * timeoutms) getChar)
getCharTimeout Nothing = peekIO (Just <$> getChar)
-- | An ANSI escape sequence parser. Pass Nothing to the input if the time
-- between the surrounding characters was "very long", for some definition
-- of "very long" (a reasonable value is ~10ms). This timeout value is used
-- to determine whether certain characters belong together in an escape
-- sequence or are just unrelated keys.
seqParser :: SeqParser (Maybe Char) Key
seqParser = SeqParser $ \case
Nothing -> ([], seqParser)
Just '\ESC' -> ([], escParser)
Just c -> ([recogSingle c], seqParser)
where
escParser :: SeqParser (Maybe Char) Key
escParser = SeqParser $ \case
Nothing -> ([KEsc], seqParser)
Just '\ESC' -> ([], escEscParser)
Just '[' -> ([], ansiParser)
Just c -> ([addAlt (recogSingle c)], seqParser)
escEscParser :: SeqParser (Maybe Char) Key
escEscParser = SeqParser $ \case
Nothing -> ([addAlt KEsc], seqParser)
Just '[' -> ([], fmap1st addAlt ansiParser)
Just '\ESC' -> ([addAlt KEsc], escParser)
Just c -> ([addAlt KEsc, KChar c], seqParser)
ansiParser :: SeqParser (Maybe Char) Key
ansiParser = fmap recogSequence (untilRangeParser (chr 0x40, chr 0x7e) 64)
`followedBy` seqParser
where
recogSequence :: Maybe [Char] -> Key
recogSequence mstr = fromMaybe (KInvalid (show mstr)) $ do
str <- mstr
guard (not $ null str)
guard (length str < 64)
args <- parseArguments (init str)
recognise args (last str)
parseArguments :: String -> Maybe [Int]
parseArguments = collect . groupBy ((==) `on` isDigit)
where
collect :: [String] -> Maybe [Int]
collect []
= Just []
collect [num] | Just val <- parseNum num
= Just [val]
collect (num:sep:args) | Just val <- parseNum num, validSep sep
= (val:) <$> collect args
collect _
= Nothing
parseNum :: String -> Maybe Int
parseNum "" = Nothing
parseNum str
| all isDigit str = Just (read str)
| otherwise = Nothing
validSep :: String -> Bool
validSep ";" = True
validSep ":" = True
validSep _ = False
-- Terminating character is included in string
-- If a timeout occurs, returns Nothing
untilRangeParser :: (Char, Char) -> Int -> SeqParserOnce (Maybe Char) (Maybe [Char])
untilRangeParser (from, to) maxlen = SeqParserOnce (charHandler 0)
where
charHandler :: Int -> Maybe Char -> SeqParserOnce' (Maybe Char) (Maybe [Char])
charHandler _ Nothing = SeqParserVal Nothing
charHandler len (Just c)
| len >= maxlen = SeqParserVal Nothing
| from <= c && c <= to = SeqParserVal (Just [c])
| otherwise = SeqParserOnce' $ \mc' -> let rec = charHandler (len + 1) mc'
in fmap (fmap (c :)) rec
recognise :: [Int] -> Char -> Maybe Key
recognise args 'A' = Just (arrowMod args KUp)
recognise args 'B' = Just (arrowMod args KDown)
recognise args 'C' = Just (arrowMod args KRight)
recognise args 'D' = Just (arrowMod args KLeft)
recognise [] 'H' = Just KHome
recognise [1,2] 'H' = Just (addShift KHome)
recognise [1,5] 'H' = Just (addCtrl KHome)
recognise [1,6] 'H' = Just (addShift $ addCtrl KHome)
recognise [1,9] 'H' = Just (addAlt KHome)
recognise [1,13] 'H' = Just (addCtrl $ addAlt KHome)
recognise [1,10] 'H' = Just (addShift $ addAlt KHome)
recognise [1,14] 'H' = Just (addCtrl $ addShift $ addAlt KHome)
recognise [] 'F' = Just KEnd
recognise [1,2] 'F' = Just (addShift KEnd)
recognise [1,5] 'F' = Just (addCtrl KEnd)
recognise [1,6] 'F' = Just (addShift $ addCtrl KEnd)
recognise [1,9] 'F' = Just (addAlt KEnd)
recognise [1,13] 'F' = Just (addCtrl $ addAlt KEnd)
recognise [1,10] 'F' = Just (addShift $ addAlt KEnd)
recognise [1,14] 'F' = Just (addCtrl $ addShift $ addAlt KEnd)
recognise _ 'Z' = Just (addShift KTab)
recognise [] '~' = Just KDelete
recognise [1] '~' = Just KHome
recognise [3] '~' = Just KDelete
recognise [4] '~' = Just KEnd
recognise [5] '~' = Just KPageUp
recognise [6] '~' = Just KPageDown
recognise [n,2] '~' = addShift <$> recognise [n] '~'
recognise [n,5] '~' = addCtrl <$> recognise [n] '~'
recognise _ _ = Nothing
recogSingle :: Char -> Key
recogSingle '\HT' = KTab
recogSingle '\LF' = KEnter
recogSingle '\CR' = KEnter
recogSingle '\DEL' = KBackspace
recogSingle '\NUL' = addCtrl (KChar ' ')
recogSingle c
| ord c < 27 = addCtrl (KChar (chr $ ord 'a' - 1 + ord c))
| 32 <= ord c, ord c <= 126 = KChar c
| otherwise = KInvalid [c]
arrowMod :: [Int] -> Key -> Key
arrowMod [1,2] = addShift
arrowMod [1,3] = addAlt
arrowMod [1,5] = addCtrl
arrowMod [1,6] = addCtrl . addShift
arrowMod [1,7] = addCtrl . addAlt
arrowMod _ = id -- in particular, []
addCtrl, addShift, addAlt :: Key -> Key
addCtrl = kmodify (\km -> km { kCtrl = True })
addShift = kmodify (\km -> km { kShift = True })
addAlt = kmodify (\km -> km { kAlt = True })
kmodify :: (Key -> Key) -> Key -> Key
kmodify f k@(KMod {}) = f k
kmodify _ (KInvalid s) = KInvalid s
kmodify f k = f (KMod False False False k)
|
