summaryrefslogtreecommitdiff
path: root/src/System/IO/Terminal/Input/Posix.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/System/IO/Terminal/Input/Posix.hs')
-rw-r--r--src/System/IO/Terminal/Input/Posix.hs187
1 files changed, 187 insertions, 0 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-01 22:44:41 +0200