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
|
{-|
Module : System.IO.Terminal.Input.Windows
Copyright : (c) UU, 2019
License : MIT
Maintainer : Tom Smeding
Stability : experimental
Portability : Windows
Platform-specific submodule of "System.IO.Terminal.Input" that works on Windows.
-}
module System.IO.Terminal.Input.Windows
(withRawMode, getCharTimeout
,seqParser)
where
import Control.Monad.IO.Class
import Data.Char
import System.IO.HiddenChar
import System.IO.Terminal.Input.Key
import System.IO.Terminal.Input.SeqParser
-- | Run an IO-monadic computation with terminal input buffering and echo
-- turned off.
--
-- Note: on Windows this is currently nonfunctional.
withRawMode :: MonadIO m => m a -> m a
withRawMode = id
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.
--
-- Note: on Windows the timeout is currently ineffective.
getCharTimeout :: Maybe Int -> IO (Maybe Char)
getCharTimeout _ = peekIO (Just <$> getHiddenChar)
-- | A Windows conio control 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 '\224' -> ([], escParser)
Just c -> ([recogSingle c], seqParser)
where
escParser :: SeqParser (Maybe Char) Key
escParser = SeqParser $ \case
Nothing -> ([KInvalid "timeout"], seqParser)
Just 'H' -> ([KUp], seqParser)
Just 'P' -> ([KDown], seqParser)
Just 'M' -> ([KRight], seqParser)
Just 'K' -> ([KLeft], seqParser)
Just c -> ([KInvalid ['\224', c]], seqParser)
recogSingle :: Char -> Key
recogSingle '\ESC' = KEsc
recogSingle '\HT' = KTab
recogSingle '\LF' = KEnter
recogSingle '\CR' = KEnter
recogSingle '\BS' = 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]
addCtrl :: Key -> Key
addCtrl = kmodify (\km -> km { kCtrl = True })
kmodify :: (Key -> Key) -> Key -> Key
kmodify f k@(KMod {}) = f k
kmodify f k = f (KMod False False False k)
|
