diff options
Diffstat (limited to 'src/System/IO')
| -rw-r--r-- | src/System/IO/Terminal.hs | 31 | ||||
| -rw-r--r-- | src/System/IO/Terminal/Characters.hs | 140 | ||||
| -rw-r--r-- | src/System/IO/Terminal/IO.hs | 57 | ||||
| -rw-r--r-- | src/System/IO/Terminal/Input.hs | 129 | ||||
| -rw-r--r-- | src/System/IO/Terminal/Input/Key.hs | 27 | ||||
| -rw-r--r-- | src/System/IO/Terminal/Input/Posix.hs | 187 | ||||
| -rw-r--r-- | src/System/IO/Terminal/Input/SeqParser.hs | 49 | ||||
| -rw-r--r-- | src/System/IO/Terminal/Input/Windows.hs | 80 | ||||
| -rw-r--r-- | src/System/IO/Terminal/Render.hs | 312 |
9 files changed, 1012 insertions, 0 deletions
diff --git a/src/System/IO/Terminal.hs b/src/System/IO/Terminal.hs new file mode 100644 index 0000000..0846d9f --- /dev/null +++ b/src/System/IO/Terminal.hs @@ -0,0 +1,31 @@ +{-| +Module : System.IO.Terminal +Copyright : (c) UU, 2019 +License : MIT +Maintainer : Tom Smeding +Stability : experimental +Portability : POSIX, macOS, Windows + +Top-level module for building an application using terminal I/O. + +The library is loosely modelled after the [termio](https://github.com/tomsmeding/termio) +library for C. See the documentation of the re-exported modules for more +information. +-} +module System.IO.Terminal + (module System.IO.Terminal.Input + ,module System.IO.Terminal.Render + ,TUI, withTUI) + where + +import Control.Monad.Trans +import System.IO.Terminal.Input +import System.IO.Terminal.Render + + +-- | The monad for doing terminal I/O operations. +type TUI = RenderT Input + +-- | Run a 'TUI' computation in the 'IO' monad. +withTUI :: TUI a -> IO a +withTUI = withInput . withRender diff --git a/src/System/IO/Terminal/Characters.hs b/src/System/IO/Terminal/Characters.hs new file mode 100644 index 0000000..85f8b5f --- /dev/null +++ b/src/System/IO/Terminal/Characters.hs @@ -0,0 +1,140 @@ +{-| +Module : System.IO.Terminal.Characters +Copyright : (c) UU, 2019 +License : MIT +Maintainer : Tom Smeding +Stability : experimental +Portability : POSIX, macOS, Windows + +Access to a small database of box-drawing characters. +-} +module System.IO.Terminal.Characters + (boxChar, BoxChar, BoxWeight(..)) + where + +import qualified Data.Map.Strict as Map + + +-- | Description of a box-drawing character: (up, right, down, left) +type BoxChar = (BoxWeight, BoxWeight, BoxWeight, BoxWeight) + +-- | Description of one arm of a box-drawing character. +data BoxWeight = BoxNone | BoxSingle | BoxHeavy | BoxDouble + deriving (Eq, Ord, Show) + +-- | Look up a box drawing character in the unicode table. Note that not +-- all combinations are valid; currently, the function throws an error if +-- the character doesn't exist. +boxChar :: BoxChar -> Char +boxChar tup = mapping Map.! tup + where + mapping = Map.fromList + [((BoxNone, BoxNone, BoxNone, BoxSingle), '╴') + ,((BoxNone, BoxNone, BoxNone, BoxHeavy), '╸') + ,((BoxSingle, BoxNone, BoxNone, BoxNone), '╵') + ,((BoxHeavy, BoxNone, BoxNone, BoxNone), '╹') + ,((BoxNone, BoxSingle, BoxNone, BoxNone), '╶') + ,((BoxNone, BoxHeavy, BoxNone, BoxNone), '╺') + ,((BoxNone, BoxNone, BoxSingle, BoxNone), '╷') + ,((BoxNone, BoxNone, BoxHeavy, BoxNone), '╻') + ,((BoxNone, BoxSingle, BoxNone, BoxSingle), '─') + ,((BoxNone, BoxHeavy, BoxNone, BoxHeavy), '━') + ,((BoxNone, BoxHeavy, BoxNone, BoxSingle), '╼') + ,((BoxNone, BoxSingle, BoxNone, BoxHeavy), '╾') + ,((BoxSingle, BoxNone, BoxSingle, BoxNone), '│') + ,((BoxHeavy, BoxNone, BoxHeavy, BoxNone), '┃') + ,((BoxSingle, BoxNone, BoxHeavy, BoxNone), '╽') + ,((BoxHeavy, BoxNone, BoxSingle, BoxNone), '╿') + ,((BoxNone, BoxSingle, BoxSingle, BoxNone), '┌') + ,((BoxNone, BoxHeavy, BoxSingle, BoxNone), '┍') + ,((BoxNone, BoxSingle, BoxHeavy, BoxNone), '┎') + ,((BoxNone, BoxHeavy, BoxHeavy, BoxNone), '┏') + ,((BoxNone, BoxNone, BoxSingle, BoxSingle), '┐') + ,((BoxNone, BoxNone, BoxSingle, BoxHeavy), '┑') + ,((BoxNone, BoxNone, BoxHeavy, BoxSingle), '┒') + ,((BoxNone, BoxNone, BoxHeavy, BoxHeavy), '┓') + ,((BoxSingle, BoxSingle, BoxNone, BoxNone), '└') + ,((BoxSingle, BoxHeavy, BoxNone, BoxNone), '┕') + ,((BoxHeavy, BoxSingle, BoxNone, BoxNone), '┖') + ,((BoxHeavy, BoxHeavy, BoxNone, BoxNone), '┗') + ,((BoxSingle, BoxNone, BoxNone, BoxSingle), '┘') + ,((BoxSingle, BoxNone, BoxNone, BoxHeavy), '┙') + ,((BoxHeavy, BoxNone, BoxNone, BoxSingle), '┚') + ,((BoxHeavy, BoxNone, BoxNone, BoxHeavy), '┛') + ,((BoxSingle, BoxSingle, BoxSingle, BoxNone), '├') + ,((BoxSingle, BoxHeavy, BoxSingle, BoxNone), '┝') + ,((BoxHeavy, BoxSingle, BoxSingle, BoxNone), '┞') + ,((BoxSingle, BoxSingle, BoxHeavy, BoxNone), '┟') + ,((BoxHeavy, BoxSingle, BoxHeavy, BoxNone), '┠') + ,((BoxHeavy, BoxHeavy, BoxSingle, BoxNone), '┡') + ,((BoxSingle, BoxHeavy, BoxHeavy, BoxNone), '┢') + ,((BoxHeavy, BoxHeavy, BoxHeavy, BoxNone), '┣') + ,((BoxSingle, BoxNone, BoxSingle, BoxSingle), '┤') + ,((BoxSingle, BoxNone, BoxSingle, BoxHeavy), '┥') + ,((BoxHeavy, BoxNone, BoxSingle, BoxSingle), '┦') + ,((BoxSingle, BoxNone, BoxHeavy, BoxSingle), '┧') + ,((BoxHeavy, BoxNone, BoxHeavy, BoxSingle), '┨') + ,((BoxHeavy, BoxNone, BoxSingle, BoxHeavy), '┩') + ,((BoxSingle, BoxNone, BoxHeavy, BoxHeavy), '┪') + ,((BoxHeavy, BoxNone, BoxHeavy, BoxHeavy), '┫') + ,((BoxNone, BoxSingle, BoxSingle, BoxSingle), '┬') + ,((BoxNone, BoxSingle, BoxSingle, BoxHeavy), '┭') + ,((BoxNone, BoxHeavy, BoxSingle, BoxSingle), '┮') + ,((BoxNone, BoxHeavy, BoxSingle, BoxHeavy), '┯') + ,((BoxNone, BoxSingle, BoxHeavy, BoxSingle), '┰') + ,((BoxNone, BoxSingle, BoxHeavy, BoxHeavy), '┱') + ,((BoxNone, BoxHeavy, BoxHeavy, BoxSingle), '┲') + ,((BoxNone, BoxHeavy, BoxHeavy, BoxHeavy), '┳') + ,((BoxSingle, BoxSingle, BoxNone, BoxSingle), '┴') + ,((BoxSingle, BoxSingle, BoxNone, BoxHeavy), '┵') + ,((BoxSingle, BoxHeavy, BoxNone, BoxSingle), '┶') + ,((BoxSingle, BoxHeavy, BoxNone, BoxHeavy), '┷') + ,((BoxHeavy, BoxSingle, BoxNone, BoxSingle), '┸') + ,((BoxHeavy, BoxSingle, BoxNone, BoxHeavy), '┹') + ,((BoxHeavy, BoxHeavy, BoxNone, BoxSingle), '┺') + ,((BoxHeavy, BoxHeavy, BoxNone, BoxHeavy), '┻') + ,((BoxSingle, BoxSingle, BoxSingle, BoxSingle), '┼') + ,((BoxSingle, BoxSingle, BoxSingle, BoxHeavy), '┽') + ,((BoxSingle, BoxHeavy, BoxSingle, BoxSingle), '┾') + ,((BoxSingle, BoxHeavy, BoxSingle, BoxHeavy), '┿') + ,((BoxHeavy, BoxSingle, BoxSingle, BoxSingle), '╀') + ,((BoxSingle, BoxSingle, BoxHeavy, BoxSingle), '╁') + ,((BoxHeavy, BoxSingle, BoxHeavy, BoxSingle), '╂') + ,((BoxHeavy, BoxSingle, BoxSingle, BoxHeavy), '╃') + ,((BoxHeavy, BoxHeavy, BoxSingle, BoxSingle), '╄') + ,((BoxSingle, BoxSingle, BoxHeavy, BoxHeavy), '╅') + ,((BoxSingle, BoxHeavy, BoxHeavy, BoxSingle), '╆') + ,((BoxHeavy, BoxHeavy, BoxSingle, BoxHeavy), '╇') + ,((BoxSingle, BoxHeavy, BoxHeavy, BoxHeavy), '╈') + ,((BoxHeavy, BoxSingle, BoxHeavy, BoxHeavy), '╉') + ,((BoxHeavy, BoxHeavy, BoxHeavy, BoxSingle), '╊') + ,((BoxHeavy, BoxHeavy, BoxHeavy, BoxHeavy), '╋') + ,((BoxNone, BoxDouble, BoxNone, BoxDouble), '═') + ,((BoxDouble, BoxNone, BoxDouble, BoxNone), '║') + ,((BoxNone, BoxDouble, BoxSingle, BoxNone), '╒') + ,((BoxNone, BoxSingle, BoxDouble, BoxNone), '╓') + ,((BoxNone, BoxDouble, BoxDouble, BoxNone), '╔') + ,((BoxNone, BoxNone, BoxSingle, BoxDouble), '╕') + ,((BoxNone, BoxNone, BoxDouble, BoxSingle), '╖') + ,((BoxNone, BoxNone, BoxDouble, BoxDouble), '╗') + ,((BoxSingle, BoxDouble, BoxNone, BoxNone), '╘') + ,((BoxDouble, BoxSingle, BoxNone, BoxNone), '╙') + ,((BoxDouble, BoxDouble, BoxNone, BoxNone), '╚') + ,((BoxSingle, BoxNone, BoxNone, BoxDouble), '╛') + ,((BoxDouble, BoxNone, BoxNone, BoxSingle), '╜') + ,((BoxDouble, BoxNone, BoxNone, BoxDouble), '╝') + ,((BoxSingle, BoxDouble, BoxSingle, BoxNone), '╞') + ,((BoxDouble, BoxSingle, BoxDouble, BoxNone), '╟') + ,((BoxDouble, BoxDouble, BoxDouble, BoxNone), '╠') + ,((BoxSingle, BoxNone, BoxSingle, BoxDouble), '╡') + ,((BoxDouble, BoxNone, BoxDouble, BoxSingle), '╢') + ,((BoxDouble, BoxNone, BoxDouble, BoxDouble), '╣') + ,((BoxNone, BoxDouble, BoxSingle, BoxDouble), '╤') + ,((BoxNone, BoxSingle, BoxDouble, BoxSingle), '╥') + ,((BoxNone, BoxDouble, BoxDouble, BoxDouble), '╦') + ,((BoxSingle, BoxDouble, BoxNone, BoxDouble), '╧') + ,((BoxDouble, BoxSingle, BoxNone, BoxSingle), '╨') + ,((BoxDouble, BoxDouble, BoxNone, BoxDouble), '╩') + ,((BoxSingle, BoxDouble, BoxSingle, BoxDouble), '╪') + ,((BoxDouble, BoxSingle, BoxDouble, BoxSingle), '╫') + ,((BoxDouble, BoxDouble, BoxDouble, BoxDouble), '╬')] diff --git a/src/System/IO/Terminal/IO.hs b/src/System/IO/Terminal/IO.hs new file mode 100644 index 0000000..fb0f1c2 --- /dev/null +++ b/src/System/IO/Terminal/IO.hs @@ -0,0 +1,57 @@ +{-| +Module : System.IO.Terminal.IO +Copyright : (c) UU, 2019 +License : MIT +Maintainer : Tom Smeding +Stability : experimental +Portability : POSIX, macOS, Windows + +Extra terminal management utility functions. This module basically extends +the @ansi-terminal@ package. +-} +module System.IO.Terminal.IO + (queryTermSize + -- ,withWinchHandler + ,toAlternateScreen + ,fromAlternateScreen) + where + +-- import Foreign.C.Types +import qualified System.Console.Terminal.Size as TS +-- import System.Exit +import System.IO +-- import System.Posix.Signals + + +-- sigWINCH :: CInt +-- sigWINCH = 28 + + +-- | Request the current terminal size from the terminal. Probably not very +-- fast. +queryTermSize :: IO (Int, Int) +queryTermSize = TS.size >>= \case + Just win -> return (TS.width win, TS.height win) + Nothing -> error "Cannot get terminal size" + +-- withWinchHandler :: IO () -> IO a -> IO a +-- withWinchHandler h act = do +-- prevh <- installHandler sigWINCH (Catch h) Nothing +-- case prevh of +-- Default -> return () +-- Ignore -> return () +-- _ -> die "ERROR: A signal handler was already installed for the WINCH signal!" + +-- res <- act + +-- _ <- installHandler sigWINCH prevh Nothing +-- return res + +-- | Switch to the \"alternate screen\", if the terminal supports it. +toAlternateScreen :: IO () +toAlternateScreen = putStr "\x1B[?1049h" >> hFlush stdout + +-- | Switch from the \"alternate screen\" back to the normal buffer, if the +-- terminal supports it. +fromAlternateScreen :: IO () +fromAlternateScreen = putStr "\x1B[?1049l" >> hFlush stdout diff --git a/src/System/IO/Terminal/Input.hs b/src/System/IO/Terminal/Input.hs new file mode 100644 index 0000000..86db30d --- /dev/null +++ b/src/System/IO/Terminal/Input.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances #-} +{-| +Module : System.IO.Terminal.Input +Copyright : (c) UU, 2019 +License : MIT +Maintainer : Tom Smeding +Stability : experimental +Portability : POSIX, macOS, Windows + +Keyboard input for console applications. + +A monad transformer is defined that allows reading keys from the +keyboard in symbolic form, i.e. escape sequences have already been +parsed. +-} +module System.IO.Terminal.Input + (InputT, Input, withInput, liftIO, MonadInput(..) + ,Key(..) + ,InfInt(..), readKey) + where + +import Control.Monad.Trans +import Control.Monad.State.Strict +import Data.Maybe +import Numeric.InfInt +import System.IO.Terminal.Render +import System.IO.Terminal.Input.Key +import System.IO.Terminal.Input.SeqParser +-- import qualified Utils.Debug as Debug +import Utils.Time + +#if defined(OS_LINUX) || defined(OS_MACOS) +import System.IO.Terminal.Input.Posix +#else +import System.IO.Terminal.Input.Windows +#endif + + +-- | Escape sequence timeout in milliseconds. +gEscTimeoutMS :: Int +gEscTimeoutMS = 100 + + +-- | The keyboard input monad transformer. The contained monad must be +-- a monad over 'IO'. +newtype InputT m a = InputT (StateT InputState m a) + deriving (Functor, Applicative, Monad, MonadState InputState, MonadTrans) + +deriving instance MonadIO m => MonadIO (InputT m) + +-- | The non-transformer variant of 'InputT'. +type Input = InputT IO + +data InputState = InputState { sKeys :: [Key] + , sParser :: SeqParser (Maybe Char) Key + -- If the timeout event was already returned, Infinity + , sLastKey :: InfInt } + +-- | Run an 'Input' computation within an IO-based monad. +withInput :: MonadIO m => InputT m a -> m a +withInput (InputT st) = + withRawMode $ evalStateT st (InputState [] seqParser Infinity) + + +-- | The behavior class for the 'InputT' monad transformer. +class Monad m => MonadInput m where + -- | Timeout in milliseconds; Infinity is no timeout. Returns Nothing + -- in case the timeout was reached. + readKeyTimeout :: InfInt -> m (Maybe Key) + +instance MonadIO m => MonadInput (InputT m) where + readKeyTimeout userTimeout = + get >>= \s -> case sKeys s of + [] -> do + let SeqParser parserFunc = sParser s + + beforeKey <- timestampMS <$> liftIO getSystemTime + + -- These timeouts are either 'Finite timeout' in milliseconds, or 'Infinity' in case + -- no timeout is needed. + let -- Possibly the amount of time left for the next escape sequence item + escTimeout = let delta = Finite beforeKey - sLastKey s + left = Finite gEscTimeoutMS - delta + in if left < 0 then 0 else left + -- We wait until either the user timeout or the escape timeout passes, whichever + -- is earlier + timeoutVal = min userTimeout escTimeout + + -- Debug.logIO ("readKeyTimeout", beforeKey, userTimeout, sLastKey s, escTimeout, timeoutVal) + + ch <- liftIO $ getCharTimeout (toFinite timeoutVal) + + let userTimeoutTriggered = isNothing ch && userTimeout < escTimeout + -- If we hit the user timeout, return appropriately + if userTimeoutTriggered + then {-Debug.logIO "returning Nothing" >>-} return Nothing + else do + -- We either got an actual key, or we hit the escape timeout. In either + -- case, we advance the escape sequence parser. + let (ks, p') = parserFunc ch + -- Debug.logIO ("keys", ks) + + -- If we got an escape timeout, we'll be reporting it so we mark the last + -- key as "long ago" to not report an escape timeout twice to the parser. + -- Otherwise, we "start the escape timer" by storing the time of receipt of + -- this key. + afterKey <- timestampMS <$> liftIO getSystemTime + let newLastKey = maybe Infinity (const $ Finite afterKey) ch + modify $ \s' -> s' { sKeys = ks, sParser = p', sLastKey = newLastKey } + + -- Either way, we stored some stuff in sKeys, so either that contains keys + -- to return, or we got nothing yet and need to retry; recursing handles + -- both cases nicely. + let userLeft = userTimeout - Finite (afterKey - beforeKey) + readKeyTimeout userLeft + + (k:ks) -> do + put (s { sKeys = ks }) + -- Debug.logIO (Just k) + return (Just k) + +instance MonadInput (RenderT Input) where + readKeyTimeout = lift . readKeyTimeout + +-- | Read a key from standard input without timeout. Shortcut for +-- @readKeyTimeout Infinity@. +readKey :: MonadInput m => m Key +readKey = fromJust <$> readKeyTimeout Infinity 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) diff --git a/src/System/IO/Terminal/Render.hs b/src/System/IO/Terminal/Render.hs new file mode 100644 index 0000000..6939c9f --- /dev/null +++ b/src/System/IO/Terminal/Render.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-| +Module : System.IO.Terminal.Render +Copyright : (c) UU, 2019 +License : MIT +Maintainer : Tom Smeding +Stability : experimental +Portability : POSIX, macOS, Windows + +Double-buffering terminal UI library. + +This library was inspired by [ncurses](https://www.gnu.org/software/ncurses/ncurses.html) +in type of functionality and by [termio](https://github.com/tomsmeding/termio) +in featureset and API. It offers a double-buffered interface for writing +text on the terminal without being bound to the classical sequential-output +model that one gets when just printing text without regard for the extra +features of the terminal. + +The API is an imperative DSL that runs in the 'RenderT' monad +transformer. Because the draw buffer (on which the drawing commands +operate) is separate from the screen buffer (in which the actual screen +contents live) (hence "double-buffered"), the user needs to +__explicitly__ commit their changes to the screen using the 'redraw' +function. The upside of this is that only the parts of the interface +that actually changed since the last update are committed to the +screen. + +Functions that write text to the draw buffer generally take the text +position as an argument, so there is no "current cursor position" in +the API. On the other hand, the drawing style /is/ stateful, in that +the current foreground/background color and text formatting rules apply +for all subsequent writes until the current style is changed to +something else. + +All positions in the terminal are in (x, y) format, where the top-left +corner is (0, 0). +-} +module System.IO.Terminal.Render + (Style(..), RGB, defaultStyle + ,RenderT, Render, withRender, liftIO + ,getTermSize + ,redraw, redrawFull + ,write, putc + ,readPixel + ,setStyle, setFg, setBg, setBold, setUnderline + ,savingStyle + ,fillRect, clearScreen + ,bel + ,module System.IO.Terminal.Characters) + where + +import Control.Concurrent +import Control.Monad.State.Strict +import Data.Array.IO +import Data.Colour.SRGB hiding (RGB) +import Data.Foldable (toList) +import Data.Word +import qualified System.Console.ANSI as A +import System.Exit +import System.IO +import System.IO.Terminal.Characters +import qualified System.IO.Terminal.IO as IO +import Utils.Monad + + +-- NOTE ON COORDINATES +-- Friendly coordinates are in the form (x, y), but the world is not +-- friendly. +-- * Function arguments: (x, y) +-- * Array indices: (y, x) +-- * A.setCursorPosition: (y, x) +-- Unless explicitly indicated otherwise. + +-- Other notes +-- - For box-drawing characters, it _may_ be necessary to write the C0 +-- codes SO and SI; see https://stackoverflow.com/a/4499628 + + +-- | A color in red-green-blue format. (255, 255, 255) is white. +type RGB = (Word8, Word8, Word8) + +-- | The monad transformer on which the drawing commands operate. The +-- wrapped monad should be a monad over 'IO' (i.e. needs to be an instance +-- of 'MonadIO'). +newtype RenderT m a = RenderT { unRenderT :: StateT RState m a } + deriving (Functor, Applicative, Monad, MonadState RState, MonadTrans) + +deriving instance MonadIO m => MonadIO (RenderT m) + +-- | A convenience type alias for if 'Render' is the bottom-most monad in +-- the stack. +type Render = RenderT IO + +data RState = RState { rDrawBuffer :: !(IOArray (Int, Int) Cell) + , rScreenBuffer :: !(IOArray (Int, Int) Cell) + , rCurrentStyle :: !Style } + +data Cell = Cell { cChar :: !Char + , cStyle :: !Style } + deriving (Eq, Show) + +-- | A drawing style. If a color is 'Nothing', it is the color that the +-- terminal uses by default. +data Style = Style { sFg :: !(Maybe RGB) + , sBg :: !(Maybe RGB) + , sBold :: !Bool + , sUnderline :: !Bool } + deriving (Eq, Show) + +-- | The default style of the terminal, i.e. the style that one would get +-- without explicit styling in the terminal. Note in particular that the +-- foreground and background colors may be anything: dark-on-light or +-- light-on-dark are both possible. +defaultStyle :: Style +defaultStyle = Style { sFg = Nothing, sBg = Nothing, sBold = False, sUnderline = False } + +initRState :: IO RState +initRState = do + (wid, hei) <- IO.queryTermSize + let emptyCell = Cell { cChar = ' ', cStyle = defaultStyle } + bufferConstructor = newArray ((0, 0), (hei - 1, wid - 1)) emptyCell + drawBuffer <- bufferConstructor + screenBuffer <- bufferConstructor + return $ RState { rDrawBuffer = drawBuffer + , rScreenBuffer = screenBuffer + , rCurrentStyle = defaultStyle } + +-- | Run a 'Render' computation in an IO-monad. +withRender :: MonadIO m => RenderT m a -> m a +withRender act = do + whenM (liftIO $ not <$> hIsTerminalDevice stdout) $ + liftIO $ die "ERROR: Stdout is not connected to a terminal!" + + liftIO $ A.hSupportsANSIWithoutEmulation stdout >>= \case + Just True -> return () + Just False -> die "ERROR: Terminal is not capable of interpreting ANSI escape sequences!" + Nothing -> do + hPutStrLn stderr "WARNING: Cannot determine terminal capabilities; continuing anyway..." + threadDelay 1000000 + + liftIO IO.toAlternateScreen + liftIO A.clearScreen + liftIO A.hideCursor + st <- liftIO initRState + res <- evalStateT (unRenderT act) st + liftIO A.showCursor + liftIO IO.fromAlternateScreen + return res + +-- | Commit the changes from the draw buffer to the screen buffer. +redraw :: MonadIO m => RenderT m () +redraw = redrawGen False + +-- | Commit the draw buffer to the screen buffer, disabling the caching +-- mechanism: this unconditionally redraws the whole screen. This would +-- normally be bound to e.g. a ctrl-L keyboard shortcut in a terminal +-- application. +redrawFull :: MonadIO m => RenderT m () +redrawFull = redrawGen True + +redrawGen :: MonadIO m => Bool -> RenderT m () +redrawGen full = do + drawBuffer <- gets rDrawBuffer + screenBuffer <- gets rScreenBuffer + size@(wid, hei) <- getTermSize + let indices = range ((0, 0), (hei - 1, wid - 1)) + + liftIO $ do + A.setSGR (styleToSGR defaultStyle) + foldM_ (applyCell drawBuffer screenBuffer size) (defaultStyle, (-1, -1)) indices + hFlush stdout + + liftIO $ copyArray screenBuffer drawBuffer + where + applyCell :: IOArray (Int, Int) Cell -- drawbuf + -> IOArray (Int, Int) Cell -- screenbuf + -> (Int, Int) -- screen size@(y, x) + -> (Style, (Int, Int)) -- current (style, curpos@(y, x)) + -> (Int, Int) -- index@(y, x) + -> IO (Style, (Int, Int)) -- new (style, curpos@(y, x)) + applyCell drawbuf screenbuf size (style, curpos) idx = do + dcell <- readArray drawbuf idx + scell <- readArray screenbuf idx + if dcell /= scell || full + then do + when (cStyle dcell /= style) $ A.setSGR (styleToSGR (cStyle dcell)) + when (curpos /= idx) $ uncurry A.setCursorPosition idx + putChar (cChar dcell) + return (cStyle dcell, incrCursorYX size idx) + else do + return (style, curpos) + +-- | Get the current terminal size. This is a cheap operation. +getTermSize :: MonadIO m => RenderT m (Int, Int) +getTermSize = do + drawBuffer <- gets rDrawBuffer + (_, (maxy, maxx)) <- liftIO (getBounds drawBuffer) + return (maxx + 1, maxy + 1) + +-- | Write some text to the draw buffer at the given position. +write :: MonadIO m => (Int, Int) -> String -> RenderT m () +write (x, y1) str = do + (wid, hei) <- getTermSize + let writeLine y line = sequence_ [putc' (x', y) c | (x', c) <- zip [x..] line] + sequence_ [writeLine y (take (wid - x) line) + | (y, line) <- take (hei - y1) $ zip [y1..] (lines str)] + +-- | Write one character to the draw buffer at the given position. +putc :: MonadIO m => (Int, Int) -> Char -> RenderT m () +putc (x, y) c = whenM (inBounds (x, y)) $ putc' (x, y) c + +putc' :: MonadIO m => (Int, Int) -> Char -> RenderT m () +putc' (x, y) c = do + drawBuffer <- gets rDrawBuffer + style <- gets rCurrentStyle + let cell = Cell { cChar = c, cStyle = style } + liftIO $ writeArray drawBuffer (y, x) cell + +-- | Obtain the current character and style in the draw buffer at the given +-- position. +readPixel :: MonadIO m => (Int, Int) -> RenderT m (Style, Char) +readPixel (x, y) = + ifM (inBounds (x, y)) + (do buf <- gets rDrawBuffer + Cell ch sty <- liftIO $ readArray buf (y, x) + return (sty, ch)) + (return (defaultStyle, ' ')) + +incrCursorYX :: (Int, Int) -> (Int, Int) -> (Int, Int) +incrCursorYX (hei, wid) (y, x) + | x + 1 == wid = if y + 1 == hei then (y, 0) else (y + 1, 0) + | otherwise = (y, x + 1) + +-- | Set the current style. +setStyle :: Monad m => Style -> RenderT m () +setStyle style = modify' $ \s -> s { rCurrentStyle = style } + +modifyCurrentStyle :: Monad m => (Style -> Style) -> RenderT m () +modifyCurrentStyle f = modify' $ \s -> s { rCurrentStyle = f (rCurrentStyle s)} + +-- | Set the foreground color component of the current style. +setFg :: Monad m => Maybe RGB -> RenderT m () +setFg clr = modifyCurrentStyle (\s -> s { sFg = clr }) + +-- | Set the background color component of the current style. +setBg :: Monad m => Maybe RGB -> RenderT m () +setBg clr = modifyCurrentStyle (\s -> s { sBg = clr }) + +-- | Set the boldface component of the current style. +setBold :: Monad m => Bool -> RenderT m () +setBold bold = modifyCurrentStyle (\s -> s { sBold = bold }) + +-- | Set the text-underline component of the current style. +setUnderline :: Monad m => Bool -> RenderT m () +setUnderline ul = modifyCurrentStyle (\s -> s { sUnderline = ul }) + +-- | Fill a rectangle, specified using its top-left and bottom-right +-- corners, with a particular character. Calling this function with a space +-- character allows clearing a subregion of the screen. +fillRect :: MonadIO m => (Int, Int) -> (Int, Int) -> Char -> RenderT m () +fillRect (fromx, fromy) (tox, toy) ch = + forM_ [(x, y) | y <- [fromy..toy], x <- [fromx..tox]] $ \(x, y) -> do + putc' (x, y) ch + +-- | Clear the whole screen. This may also be accomplished using 'fillRect' +-- with appropriate bounds. +clearScreen :: MonadIO m => RenderT m () +clearScreen = savingStyle $ do + (w, h) <- getTermSize + setStyle defaultStyle + fillRect (0, 0) (w-1, h-1) ' ' + +-- | After running the computation, restore the current style as it was +-- before running the computation. +savingStyle :: MonadIO m => RenderT m a -> RenderT m a +savingStyle act = do + st <- gets rCurrentStyle + res <- act + setStyle st + return res + +styleToSGR :: Style -> [A.SGR] +styleToSGR style = + [A.Reset] ++ + toList (A.SetRGBColor A.Foreground . fromRGB <$> sFg style) ++ + toList (A.SetRGBColor A.Background . fromRGB <$> sBg style) ++ + (if sBold style then [A.SetConsoleIntensity A.BoldIntensity] else []) ++ + (if sUnderline style then [A.SetUnderlining A.SingleUnderline] else []) + +fromRGB :: RGB -> Colour Float +fromRGB (r, g, b) = sRGB24 r g b + +-- | Sound the terminal bell (plonk, dong, BEEP). This bypasses the buffer +-- model, i.e. it happens immediately. +bel :: MonadIO m => RenderT m () +bel = liftIO $ putChar '\BEL' >> hFlush stdout + +inBounds :: MonadIO m => (Int, Int) -> RenderT m Bool +inBounds (x, y) = do + (wid, hei) <- getTermSize + return $ x >= 0 && x < wid && y >= 0 && y < hei + + +-- Bounds of dest and src should be equal! +copyArray :: (MArray a e m, Ix i) => a i e -> a i e -> m () +copyArray dest src = do + destbounds <- getBounds dest + srcbounds <- getBounds src + when (srcbounds /= destbounds) $ error "Logic error: incompatible array bounds in copyArray" + + forM_ (range destbounds) $ \idx -> + readArray src idx >>= writeArray dest idx |