summaryrefslogtreecommitdiff
path: root/src/System/IO/Terminal/Input
diff options
context:
space:
mode:
Diffstat (limited to 'src/System/IO/Terminal/Input')
-rw-r--r--src/System/IO/Terminal/Input/Key.hs27
-rw-r--r--src/System/IO/Terminal/Input/Posix.hs187
-rw-r--r--src/System/IO/Terminal/Input/SeqParser.hs49
-rw-r--r--src/System/IO/Terminal/Input/Windows.hs80
4 files changed, 343 insertions, 0 deletions
diff --git a/src/System/IO/Terminal/Input/Key.hs b/src/System/IO/Terminal/Input/Key.hs
new file mode 100644
index 0000000..40b52c3
--- /dev/null
+++ b/src/System/IO/Terminal/Input/Key.hs
@@ -0,0 +1,27 @@
+{-|
+Module : System.IO.Terminal.Input.Key
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS, Windows
+-}
+module System.IO.Terminal.Input.Key where
+
+
+-- | A keypress. This does not attempt to model all possible keypresses
+-- that the user may enter, since not all can be recognised in the terminal
+-- anyway. The argument to 'KInvalid' contains some description of the
+-- unknown key.
+data Key = KChar Char
+ | KUp | KDown | KRight | KLeft
+ | KEnter | KDelete | KBackspace
+ | KPageDown | KPageUp | KHome | KEnd
+ | KTab
+ | KEsc
+ | KMod { kShift :: Bool
+ , kCtrl :: Bool
+ , kAlt :: Bool
+ , kKey :: Key }
+ | KInvalid String
+ deriving (Eq, Ord, Show)
diff --git a/src/System/IO/Terminal/Input/Posix.hs b/src/System/IO/Terminal/Input/Posix.hs
new file mode 100644
index 0000000..85f0268
--- /dev/null
+++ b/src/System/IO/Terminal/Input/Posix.hs
@@ -0,0 +1,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)
diff --git a/src/System/IO/Terminal/Input/SeqParser.hs b/src/System/IO/Terminal/Input/SeqParser.hs
new file mode 100644
index 0000000..8dfdafc
--- /dev/null
+++ b/src/System/IO/Terminal/Input/SeqParser.hs
@@ -0,0 +1,49 @@
+{-|
+Module : System.IO.Terminal.Input.SeqParser
+Copyright : (c) UU, 2019
+License : MIT
+Maintainer : Tom Smeding
+Stability : experimental
+Portability : POSIX, macOS, Windows
+
+This module defines a coroutine-like, finite-state-machine-like type,
+'SeqParser'. Sequence parsers consume an infinite stream of values,
+producing zero or more output values after each input value read. The
+described parser is explicitly lazy to have full and explicit control over
+the amount of input necessary to produce an output value.
+-}
+module System.IO.Terminal.Input.SeqParser where
+
+
+-- | Consumes an explicitly lazy stream of @a@\'s, producing a staggered
+-- infinite stream of @b@\'s.
+newtype SeqParser a b = SeqParser (a -> ([b], SeqParser a b))
+
+-- | Consumes an explicitly lazy stream of @a@\'s, and after some nonzero
+-- number of such values, produces a @b@.
+data SeqParserOnce a b = SeqParserOnce (a -> SeqParserOnce' a b)
+-- | A 'SeqParserOnce' that does not guarantee to consume at least one
+-- @a@.
+data SeqParserOnce' a b = SeqParserOnce' (a -> SeqParserOnce' a b) | SeqParserVal b
+
+-- | Modify the next result from the 'SeqParser'.
+fmap1st :: (b -> b) -> SeqParser a b -> SeqParser a b
+fmap1st f (SeqParser g) =
+ SeqParser $ \a -> case g a of
+ ([], p) -> ([], fmap1st f p)
+ (b : bs, p) -> (f b : bs, p)
+
+instance Functor (SeqParserOnce a) where
+ fmap f (SeqParserOnce g) = SeqParserOnce (fmap f . g)
+
+instance Functor (SeqParserOnce' a) where
+ fmap f (SeqParserVal x) = SeqParserVal (f x)
+ fmap f (SeqParserOnce' g) = SeqParserOnce' (fmap f . g)
+
+-- | After the 'SeqParserOnce' is done, continue processing input with the
+-- 'SeqParser'.
+followedBy :: SeqParserOnce a b -> SeqParser a b -> SeqParser a b
+followedBy (SeqParserOnce g) p =
+ SeqParser $ \a -> case g a of
+ SeqParserVal b -> ([b], p)
+ SeqParserOnce' g' -> ([], SeqParserOnce g' `followedBy` p)
diff --git a/src/System/IO/Terminal/Input/Windows.hs b/src/System/IO/Terminal/Input/Windows.hs
new file mode 100644
index 0000000..0ac4122
--- /dev/null
+++ b/src/System/IO/Terminal/Input/Windows.hs
@@ -0,0 +1,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)
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-22 13:03:10 +0100