From 4e5590d148a7f2b517dce18c231b9d4cb0b1d19f Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Mon, 19 Aug 2019 13:00:05 +0200 Subject: Import of source files --- src/System/IO/Terminal/Input/Key.hs | 27 +++++ src/System/IO/Terminal/Input/Posix.hs | 187 ++++++++++++++++++++++++++++++ src/System/IO/Terminal/Input/SeqParser.hs | 49 ++++++++ src/System/IO/Terminal/Input/Windows.hs | 80 +++++++++++++ 4 files changed, 343 insertions(+) create mode 100644 src/System/IO/Terminal/Input/Key.hs create mode 100644 src/System/IO/Terminal/Input/Posix.hs create mode 100644 src/System/IO/Terminal/Input/SeqParser.hs create mode 100644 src/System/IO/Terminal/Input/Windows.hs (limited to 'src/System/IO/Terminal/Input') 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) -- cgit v1.2.3-70-g09d2