{-| 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)