vty-unix-0.2.0.0/0000755000000000000000000000000007346545000011643 5ustar0000000000000000vty-unix-0.2.0.0/CHANGELOG.md0000644000000000000000000000053507346545000013457 0ustar0000000000000000 0.2.0.0 ======= API changes: * The `settingColorMode` field of `UnixSettings` was removed in favor of Vty 6.1's new `configPreferredColorMode` field of the `VtyUserConfig` type. This package now uses that setting if present; otherwise it does the same color mode detection that it did before this release. 0.1.0.0 ======= Initial release. vty-unix-0.2.0.0/LICENSE0000644000000000000000000000277607346545000012664 0ustar0000000000000000Copyright (c) 2023, Jonathan Daugherty All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Jonathan Daugherty nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. vty-unix-0.2.0.0/cbits/0000755000000000000000000000000007346545000012747 5ustar0000000000000000vty-unix-0.2.0.0/cbits/gwinsz.c0000644000000000000000000000067007346545000014437 0ustar0000000000000000#include unsigned long vty_c_get_window_size(int fd) { struct winsize w; if (ioctl (fd, TIOCGWINSZ, &w) >= 0) return (w.ws_row << 16) + w.ws_col; else return 0x190050; } void vty_c_set_window_size(int fd, unsigned long val) { struct winsize w; if (ioctl(fd, TIOCGWINSZ, &w) >= 0) { w.ws_row = val >> 16; w.ws_col = val & 0xFFFF; ioctl(fd, TIOCSWINSZ, &w); } } vty-unix-0.2.0.0/cbits/gwinsz.h0000644000000000000000000000015507346545000014442 0ustar0000000000000000unsigned long vty_c_get_window_size(int fd); unsigned long vty_c_set_window_size(int fd, unsigned long val); vty-unix-0.2.0.0/cbits/set_term_timing.c0000644000000000000000000000042607346545000016306 0ustar0000000000000000#include #include #include #include void vty_set_term_timing(int fd, int vmin, int vtime) { struct termios trm; tcgetattr(fd, &trm); trm.c_cc[VMIN] = vmin; trm.c_cc[VTIME] = vtime; tcsetattr(fd, TCSANOW, &trm); } vty-unix-0.2.0.0/src/Data/Terminfo/0000755000000000000000000000000007346545000015066 5ustar0000000000000000vty-unix-0.2.0.0/src/Data/Terminfo/Eval.hs0000644000000000000000000000703107346545000016312 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} -- | Evaluates the paramaterized terminfo string capability with the -- given parameters. module Data.Terminfo.Eval ( writeCapExpr ) where import Blaze.ByteString.Builder.Word import Blaze.ByteString.Builder import Data.Terminfo.Parse import Control.Monad import Control.Monad.State.Strict import Control.Monad.Writer import Data.Bits ((.|.), (.&.), xor) import Data.List import qualified Data.Vector.Unboxed as Vector -- | capability evaluator state data EvalState = EvalState { evalStack :: ![CapParam] , evalExpression :: !CapExpression , evalParams :: ![CapParam] } type Eval a = StateT EvalState (Writer Write) a pop :: Eval CapParam pop = do s <- get (v, stack') <- case evalStack s of [] -> error "BUG: Data.Terminfo.Eval.pop: failed to pop from empty stack" v:s' -> return (v, s') put $ s { evalStack = stack' } return v readParam :: Word -> Eval CapParam readParam pn = do !params <- evalParams <$> get return $! genericIndex params pn push :: CapParam -> Eval () push !v = do s <- get let s' = s { evalStack = v : evalStack s } put s' applyParamOps :: CapExpression -> [CapParam] -> [CapParam] applyParamOps cap params = foldl applyParamOp params (paramOps cap) applyParamOp :: [CapParam] -> ParamOp -> [CapParam] applyParamOp params IncFirstTwo = map (+ 1) params writeCapExpr :: CapExpression -> [CapParam] -> Write writeCapExpr cap params = let params' = applyParamOps cap params s0 = EvalState [] cap params' in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0) writeCapOps :: CapOps -> Eval () writeCapOps = mapM_ writeCapOp writeCapOp :: CapOp -> Eval () writeCapOp (Bytes !offset !count) = do !cap <- evalExpression <$> get let bytes = Vector.take count $ Vector.drop offset (capBytes cap) Vector.forM_ bytes $ tell.writeWord8 writeCapOp DecOut = do p <- pop forM_ (show p) $ tell.writeWord8.toEnum.fromEnum writeCapOp CharOut = do pop >>= tell.writeWord8.toEnum.fromEnum writeCapOp (PushParam pn) = do readParam pn >>= push writeCapOp (PushValue v) = do push v writeCapOp (Conditional expr parts) = do writeCapOps expr writeContitionalParts parts where writeContitionalParts [] = return () writeContitionalParts ((trueOps, falseOps) : falseParts) = do -- (man 5 terminfo) -- Usually the %? expr part pushes a value onto the stack, -- and %t pops it from the stack, testing if it is nonzero -- (true). If it is zero (false), control passes to the %e -- (else) part. v <- pop if v /= 0 then writeCapOps trueOps else do writeCapOps falseOps writeContitionalParts falseParts writeCapOp BitwiseOr = do v0 <- pop v1 <- pop push $ v0 .|. v1 writeCapOp BitwiseAnd = do v0 <- pop v1 <- pop push $ v0 .&. v1 writeCapOp BitwiseXOr = do v1 <- pop v0 <- pop push $ v0 `xor` v1 writeCapOp ArithPlus = do v1 <- pop v0 <- pop push $ v0 + v1 writeCapOp ArithMinus = do v1 <- pop v0 <- pop push $ v0 - v1 writeCapOp CompareEq = do v1 <- pop v0 <- pop push $ if v0 == v1 then 1 else 0 writeCapOp CompareLt = do v1 <- pop v0 <- pop push $ if v0 < v1 then 1 else 0 writeCapOp CompareGt = do v1 <- pop v0 <- pop push $ if v0 > v1 then 1 else 0 vty-unix-0.2.0.0/src/Data/Terminfo/Parse.hs0000644000000000000000000002305007346545000016474 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -funbox-strict-fields -O #-} {-# OPTIONS_HADDOCK hide #-} module Data.Terminfo.Parse ( module Data.Terminfo.Parse , Text.Parsec.ParseError ) where import Control.Monad ( liftM ) import Control.DeepSeq #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif import Data.Word import qualified Data.Vector.Unboxed as Vector import Numeric (showHex) import Text.Parsec data CapExpression = CapExpression { capOps :: !CapOps , capBytes :: !(Vector.Vector Word8) , sourceString :: !String , paramCount :: !Int , paramOps :: !ParamOps } deriving (Eq) instance Show CapExpression where show c = "CapExpression { " ++ show (capOps c) ++ " }" ++ " <- [" ++ hexDump ( map ( toEnum . fromEnum ) $! sourceString c ) ++ "]" ++ " <= " ++ show (sourceString c) where hexDump :: [Word8] -> String hexDump = foldr showHex "" instance NFData CapExpression where rnf (CapExpression ops !_bytes !str !c !pOps) = rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps type CapParam = Word type CapOps = [CapOp] data CapOp = Bytes !Int !Int -- offset count | DecOut | CharOut -- This stores a 0-based index to the parameter. However the -- operation that implies this op is 1-based | PushParam !Word | PushValue !Word -- The conditional parts are the sequence of (%t expression, %e -- The expression) pairs. %e expression may be NOP | Conditional { conditionalExpr :: !CapOps , conditionalParts :: ![(CapOps, CapOps)] } | BitwiseOr | BitwiseXOr | BitwiseAnd | ArithPlus | ArithMinus | CompareEq | CompareLt | CompareGt deriving (Show, Eq) instance NFData CapOp where rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount rnf (PushParam pn) = rnf pn rnf (PushValue v) = rnf v rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts rnf BitwiseOr = () rnf BitwiseXOr = () rnf BitwiseAnd = () rnf ArithPlus = () rnf ArithMinus = () rnf CompareEq = () rnf CompareLt = () rnf CompareGt = () rnf DecOut = () rnf CharOut = () type ParamOps = [ParamOp] data ParamOp = IncFirstTwo deriving (Show, Eq) instance NFData ParamOp where rnf IncFirstTwo = () parseCapExpression :: String -> Either ParseError CapExpression parseCapExpression capString = let v = runParser capExpressionParser initialBuildState "terminfo cap" capString in case v of Left e -> Left e Right buildResults -> Right $ constructCapExpression capString buildResults constructCapExpression :: String -> BuildResults -> CapExpression constructCapExpression capString buildResults = let expr = CapExpression { capOps = outCapOps buildResults -- The cap bytes are the lower 8 bits of the input -- string's characters. , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString , sourceString = capString , paramCount = outParamCount buildResults , paramOps = outParamOps buildResults } in rnf expr `seq` expr type CapParser a = Parsec String BuildState a capExpressionParser :: CapParser BuildResults capExpressionParser = do rs <- many $ paramEscapeParser <|> bytesOpParser return $ mconcat rs paramEscapeParser :: CapParser BuildResults paramEscapeParser = do _ <- char '%' incOffset 1 literalPercentParser <|> paramOpParser literalPercentParser :: CapParser BuildResults literalPercentParser = do _ <- char '%' startOffset <- nextOffset <$> getState incOffset 1 return $ BuildResults 0 [Bytes startOffset 1] [] paramOpParser :: CapParser BuildResults paramOpParser = incrementOpParser <|> pushOpParser <|> decOutParser <|> charOutParser <|> conditionalOpParser <|> bitwiseOpParser <|> arithOpParser <|> literalIntOpParser <|> compareOpParser <|> charConstParser incrementOpParser :: CapParser BuildResults incrementOpParser = do _ <- char 'i' incOffset 1 return $ BuildResults 0 [] [ IncFirstTwo ] pushOpParser :: CapParser BuildResults pushOpParser = do _ <- char 'p' paramN <- read . pure <$> digit incOffset 2 return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] [] decOutParser :: CapParser BuildResults decOutParser = do _ <- char 'd' incOffset 1 return $ BuildResults 0 [ DecOut ] [] charOutParser :: CapParser BuildResults charOutParser = do _ <- char 'c' incOffset 1 return $ BuildResults 0 [ CharOut ] [] conditionalOpParser :: CapParser BuildResults conditionalOpParser = do _ <- char '?' incOffset 1 condPart <- manyExpr conditionalTrueParser parts <- manyP ( do truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser , conditionalFalseParser ] falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser , conditionalTrueParser ] return ( truePart, falsePart ) ) conditionalEndParser let trueParts = map fst parts falseParts = map snd parts BuildResults n cond condParamOps = condPart let n' = maximum $ n : map outParamCount trueParts n'' = maximum $ n' : map outParamCount falseParts let trueOps = map outCapOps trueParts falseOps = map outCapOps falseParts condParts = zip trueOps falseOps let trueParamOps = mconcat $ map outParamOps trueParts falseParamOps = mconcat $ map outParamOps falseParts pOps = mconcat [condParamOps, trueParamOps, falseParamOps] return $ BuildResults n'' [ Conditional cond condParts ] pOps where manyP !p !end = choice [ try end >> return [] , do !v <- p !vs <- manyP p end return $! v : vs ] manyExpr end = liftM mconcat $ manyP ( paramEscapeParser <|> bytesOpParser ) end conditionalTrueParser :: CapParser () conditionalTrueParser = do _ <- string "%t" incOffset 2 conditionalFalseParser :: CapParser () conditionalFalseParser = do _ <- string "%e" incOffset 2 conditionalEndParser :: CapParser () conditionalEndParser = do _ <- string "%;" incOffset 2 bitwiseOpParser :: CapParser BuildResults bitwiseOpParser = bitwiseOrParser <|> bitwiseAndParser <|> bitwiseXorParser bitwiseOrParser :: CapParser BuildResults bitwiseOrParser = do _ <- char '|' incOffset 1 return $ BuildResults 0 [ BitwiseOr ] [ ] bitwiseAndParser :: CapParser BuildResults bitwiseAndParser = do _ <- char '&' incOffset 1 return $ BuildResults 0 [ BitwiseAnd ] [ ] bitwiseXorParser :: CapParser BuildResults bitwiseXorParser = do _ <- char '^' incOffset 1 return $ BuildResults 0 [ BitwiseXOr ] [ ] arithOpParser :: CapParser BuildResults arithOpParser = plusOp <|> minusOp where plusOp = do _ <- char '+' incOffset 1 return $ BuildResults 0 [ ArithPlus ] [ ] minusOp = do _ <- char '-' incOffset 1 return $ BuildResults 0 [ ArithMinus ] [ ] literalIntOpParser :: CapParser BuildResults literalIntOpParser = do _ <- char '{' incOffset 1 nStr <- many1 digit incOffset $ toEnum $ length nStr let n :: Word = read nStr _ <- char '}' incOffset 1 return $ BuildResults 0 [ PushValue n ] [ ] compareOpParser :: CapParser BuildResults compareOpParser = compareEqOp <|> compareLtOp <|> compareGtOp where compareEqOp = do _ <- char '=' incOffset 1 return $ BuildResults 0 [ CompareEq ] [ ] compareLtOp = do _ <- char '<' incOffset 1 return $ BuildResults 0 [ CompareLt ] [ ] compareGtOp = do _ <- char '>' incOffset 1 return $ BuildResults 0 [ CompareGt ] [ ] bytesOpParser :: CapParser BuildResults bytesOpParser = do bytes <- many1 $ satisfy (/= '%') startOffset <- nextOffset <$> getState let !c = length bytes !s <- getState let s' = s { nextOffset = startOffset + c } setState s' return $ BuildResults 0 [Bytes startOffset c] [] charConstParser :: CapParser BuildResults charConstParser = do _ <- char '\'' charValue <- liftM (toEnum . fromEnum) anyChar _ <- char '\'' incOffset 3 return $ BuildResults 0 [ PushValue charValue ] [ ] data BuildState = BuildState { nextOffset :: Int } incOffset :: Int -> CapParser () incOffset n = do s <- getState let s' = s { nextOffset = nextOffset s + n } setState s' initialBuildState :: BuildState initialBuildState = BuildState 0 data BuildResults = BuildResults { outParamCount :: !Int , outCapOps :: !CapOps , outParamOps :: !ParamOps } instance Semigroup BuildResults where v0 <> v1 = BuildResults { outParamCount = outParamCount v0 `max` outParamCount v1 , outCapOps = outCapOps v0 <> outCapOps v1 , outParamOps = outParamOps v0 <> outParamOps v1 } instance Monoid BuildResults where mempty = BuildResults 0 [] [] #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif vty-unix-0.2.0.0/src/Graphics/Vty/Platform/0000755000000000000000000000000007346545000016540 5ustar0000000000000000vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix.hs0000644000000000000000000000447207346545000020026 0ustar0000000000000000-- | The Unix implementation entry point for Vty. This module and -- @Graphics.Vty.Platform.Unix.Settings@ are the only modules you should -- ever need to import from this package; the rest is exported for -- testing purposes only. -- -- This module provides 'mkVty' to create Vty handles for Unix -- terminals. Once a 'Vty' handle has been created, the rest of Vty's -- API can be used it with as usual; see the @vty@ package for details. module Graphics.Vty.Platform.Unix ( mkVty , mkVtyWithSettings ) where import Control.Monad (when) import Graphics.Vty (Vty, installCustomWidthTable, mkVtyFromPair) import Graphics.Vty.Config (VtyUserConfig(..)) import Graphics.Vty.Platform.Unix.Settings import Graphics.Vty.Platform.Unix.Output import Graphics.Vty.Platform.Unix.Input -- | Create a Vty handle. At most one handle should be created -- at a time for a given terminal device. Uses the default -- values for 'UnixSettings'. If you need to override those, use -- 'mkVtyWithSettings'. -- -- This may raise -- 'Graphics.Vty.Platform.Unix.Settings.VtyUnixConfigurationError'. mkVty :: VtyUserConfig -- ^ The user's Vty configuration or the result of -- 'Graphics.Vty.Config.defaultConfig'. -> IO Vty mkVty userConfig = mkVtyWithSettings userConfig =<< defaultSettings -- | Create a Vty handle. At most one handle should be created -- at a time for a given terminal device. -- -- This also uses the value of @TERM@ to attempt to load and -- install a Unicode character width table map. For details, see -- 'Graphics.Vty.UnicodeWidthTable.Install.installUnicodeWidthTable'. -- -- This may raise -- 'Graphics.Vty.Platform.Unix.Settings.VtyUnixConfigurationError'. mkVtyWithSettings :: VtyUserConfig -- ^ The user's Vty configuration or the result of -- 'defaultConfig'. -> UnixSettings -- ^ Runtime settings. -> IO Vty mkVtyWithSettings userConfig settings = do when (configAllowCustomUnicodeWidthTables userConfig /= Just False) $ installCustomWidthTable (configDebugLog userConfig) (Just $ settingTermName settings) (configTermWidthMaps userConfig) input <- buildInput userConfig settings out <- buildOutput userConfig settings mkVtyFromPair input out vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/0000755000000000000000000000000007346545000017463 5ustar0000000000000000vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input.hs0000644000000000000000000001730007346545000021117 0ustar0000000000000000{-# LANGUAGE RecordWildCards, CPP #-} -- | This module provides a function to build an 'Input' for Unix -- terminal devices. -- -- This module is exposed for testing purposes only; applications should -- never need to import this directly. -- -- Note that due to the evolution of terminal emulators, some keys -- and combinations will not reliably map to the expected events by -- any terminal program. There is no 1:1 mapping from key events to -- bytes read from the terminal input device. In very limited cases the -- terminal and vty's input process can be customized to resolve these -- issues; see "Graphics.Vty.Config" to learn how to configure Vty's -- input processing. -- -- = @vty-unix@ Implementation -- -- There are two input modes: -- -- 1. 7-bit -- -- 2. 8-bit -- -- The 7-bit input mode is the default and the expected mode in most use -- cases. This is what Vty uses. -- -- == 7-bit input encoding -- -- Control key combinations are represented by masking the two high bits -- of the 7-bit input. Historically the control key actually grounded -- the two high bit wires: 6 and 7. This is why control key combos -- map to single character events: the input bytes are identical. The -- input byte is the bit encoding of the character with bits 6 and 7 -- masked. Bit 6 is set by shift. Bit 6 and 7 are masked by control. For -- example, -- -- * Control-I is 'i', `01101001`, and has bit 6 and 7 masked to become -- `00001001`, which is the ASCII and UTF-8 encoding of the Tab key. -- -- * Control+Shift-C is 'C', `01000011`, with bit 6 and 7 set to zero -- which is `0000011` and is the "End of Text" code. -- -- * Hypothesis: This is why capital-A, 'A', has value 65 in ASCII: this -- is the value 1 with bit 7 set and 6 unset. -- -- * Hypothesis: Bit 6 is unset by upper case letters because, -- initially, there were only upper case letters used and a 5 bit -- encoding. -- -- == 8-bit encoding -- -- The 8th bit was originally used for parity checking which is useless -- for terminal emulators. Some terminal emulators support an 8-bit -- input encoding. While this provides some advantages, the actual usage -- is low. Most systems use 7-bit mode but recognize 8-bit control -- characters when escaped. This is what Vty does. -- -- == Escaped Control Keys -- -- Using 7-bit input encoding, the @ESC@ byte can signal the start of -- an encoded control key. To differentiate a single @ESC@ event from a -- control key, the timing of the input is used. -- -- 1. @ESC@ individually: @ESC@ byte; no bytes following for a period of -- 'VMIN' milliseconds. -- -- 2. Control keys that contain @ESC@ in their encoding: The @ESC byte -- is followed by more bytes read within 'VMIN' milliseconds. All bytes -- up until the next valid input block are passed to the classifier. -- -- If the current runtime is the threaded runtime then the terminal's -- @VMIN@ and @VTIME@ behavior reliably implement the above rules. If -- the current runtime does not support 'forkOS' then there is currently -- no implementation. -- -- == Unicode Input and Escaped Control Key Sequences -- -- The input encoding determines how UTF-8 encoded characters are -- recognized. -- -- * 7-bit mode: UTF-8 can be input unambiguously. UTF-8 input is -- a superset of ASCII. UTF-8 does not overlap escaped control key -- sequences. However, the escape key must be differentiated from -- escaped control key sequences by the timing of the input bytes. -- -- * 8-bit mode: UTF-8 cannot be input unambiguously. This does not -- require using the timing of input bytes to differentiate the escape -- key. Many terminals do not support 8-bit mode. -- -- == Terminfo -- -- The terminfo system is used to determine how some keys are encoded. -- Terminfo is incomplete and in some cases terminfo is incorrect. Vty -- assumes terminfo is correct but provides a mechanism to override -- terminfo; see "Graphics.Vty.Config", specifically 'inputOverrides'. -- -- == Terminal Input is Broken -- -- Clearly terminal input has fundamental issues. There is no easy way -- to reliably resolve these issues. -- -- One resolution would be to ditch standard terminal interfaces -- entirely and just go directly to scancodes. This would be a -- reasonable option for Vty if everybody used the linux kernel console -- but for obvious reasons this is not possible. -- -- The "Graphics.Vty.Config" module supports customizing the -- input-byte-to-event mapping and xterm supports customizing the -- scancode-to-input-byte mapping. With a lot of work a user's system -- can be set up to encode all the key combos in an almost-sane manner. -- -- == See also -- -- * http://www.leonerd.org.uk/hacks/fixterms/ module Graphics.Vty.Platform.Unix.Input ( buildInput , attributeControl ) where import Control.Concurrent.STM #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif import qualified System.Console.Terminfo as Terminfo import System.Posix.Signals.Exts import System.Posix.Terminal import System.Posix.Types (Fd(..)) import Graphics.Vty.Input import Graphics.Vty.Config (VtyUserConfig(..)) import Graphics.Vty.Platform.Unix.Settings import Graphics.Vty.Platform.Unix.Input.Loop import Graphics.Vty.Platform.Unix.Input.Terminfo (classifyMapForTerm) buildInput :: VtyUserConfig -> UnixSettings -> IO Input buildInput userConfig settings = do let tName = settingTermName settings fd = settingInputFd settings terminal <- Terminfo.setupTerm tName let inputOverrides = [(s,e) | (t,s,e) <- configInputMap userConfig, t == Nothing || t == Just tName] activeInputMap = classifyMapForTerm tName terminal `mappend` inputOverrides (setAttrs, unsetAttrs) <- attributeControl fd setAttrs input <- initInput settings activeInputMap let pokeIO = Catch $ do setAttrs atomically $ writeTChan (eventChannel input) ResumeAfterInterrupt _ <- installHandler windowChange pokeIO Nothing _ <- installHandler continueProcess pokeIO Nothing let restore = unsetAttrs return $ input { shutdownInput = do shutdownInput input _ <- installHandler windowChange Ignore Nothing _ <- installHandler continueProcess Ignore Nothing restore , restoreInputState = restoreInputState input >> restore } -- | Construct two IO actions: one to configure the terminal for Vty and -- one to restore the terminal mode flags to the values they had at the -- time this function was called. -- -- This function constructs a configuration action to clear the -- following terminal mode flags: -- -- * IXON disabled: disables software flow control on outgoing data. -- This stops the process from being suspended if the output terminal -- cannot keep up. -- -- * Raw mode is used for input. -- -- * ISIG (enables keyboard combinations that result in -- signals) -- -- * ECHO (input is not echoed to the output) -- -- * ICANON (canonical mode (line mode) input is not used) -- -- * IEXTEN (extended functions are disabled) -- -- The configuration action also explicitly sets these flags: -- -- * ICRNL (input carriage returns are mapped to newlines) attributeControl :: Fd -> IO (IO (), IO ()) attributeControl fd = do original <- getTerminalAttributes fd let vtyMode = foldl withMode clearedFlags flagsToSet clearedFlags = foldl withoutMode original flagsToUnset flagsToSet = [ MapCRtoLF -- ICRNL ] flagsToUnset = [ StartStopOutput -- IXON , KeyboardInterrupts -- ISIG , EnableEcho -- ECHO , ProcessInput -- ICANON , ExtendedFunctions -- IEXTEN ] let setAttrs = setTerminalAttributes fd vtyMode Immediately unsetAttrs = setTerminalAttributes fd original Immediately return (setAttrs, unsetAttrs) vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input/0000755000000000000000000000000007346545000020562 5ustar0000000000000000vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input/Classify.hs0000644000000000000000000000747707346545000022712 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} -- This makes a kind of trie. Has space efficiency issues with large -- input blocks. Likely building a parser and just applying that would -- be better. module Graphics.Vty.Platform.Unix.Input.Classify ( classify ) where import Graphics.Vty.Input.Events import Graphics.Vty.Platform.Unix.Input.Classify.Types import Graphics.Vty.Platform.Unix.Input.Mouse import Graphics.Vty.Platform.Unix.Input.Focus import Graphics.Vty.Platform.Unix.Input.Paste import Codec.Binary.UTF8.Generic (decode) import Control.Arrow (first) import qualified Data.Map as M( fromList, lookup ) import Data.Maybe ( mapMaybe ) import qualified Data.Set as S( fromList, member ) import Data.Word import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.ByteString.Char8 (ByteString) compile :: ClassifyMap -> ByteString -> KClass compile table = cl' where -- take all prefixes and create a set of these prefixSet = S.fromList $ concatMap (init . BS.inits . BS8.pack . fst) table maxValidInputLength = maximum (map (length . fst) table) eventForInput = M.fromList $ map (first BS8.pack) table cl' inputBlock | BS8.null inputBlock = Prefix cl' inputBlock = case M.lookup inputBlock eventForInput of -- if the inputBlock is exactly what is expected for an -- event then consume the whole block and return the event Just e -> Valid e BS8.empty Nothing -> case S.member inputBlock prefixSet of True -> Prefix -- look up progressively smaller tails of the input -- block until an event is found The assumption is that -- the event that consumes the most input bytes should -- be produced. -- The test verifyFullSynInputToEvent2x verifies this. -- H: There will always be one match. The prefixSet -- contains, by definition, all prefixes of an event. False -> let inputPrefixes = reverse . take maxValidInputLength . tail . BS8.inits $ inputBlock in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of (s,e) : _ -> Valid e (BS8.drop (BS8.length s) inputBlock) -- neither a prefix or a full event. [] -> Invalid classify :: ClassifyMap -> ClassifierState -> ByteString -> KClass classify table = process where standardClassifier = compile table process ClassifierStart s = case BS.uncons s of _ | bracketedPasteStarted s -> if bracketedPasteFinished s then parseBracketedPaste s else Chunk _ | isMouseEvent s -> classifyMouseEvent s _ | isFocusEvent s -> classifyFocusEvent s Just (c,cs) | c >= 0xC2 -> classifyUtf8 c cs _ -> standardClassifier s process (ClassifierInChunk p ps) s | bracketedPasteStarted p = if bracketedPasteFinished s then parseBracketedPaste $ BS.concat $ p:reverse (s:ps) else Chunk process ClassifierInChunk{} _ = Invalid classifyUtf8 :: Word8 -> ByteString -> KClass classifyUtf8 c cs = let n = utf8Length c (codepoint,rest) = BS8.splitAt (n - 1) cs codepoint8 :: [Word8] codepoint8 = c:BS.unpack codepoint in case decode codepoint8 of _ | n < BS.length codepoint + 1 -> Prefix Just (unicodeChar, _) -> Valid (EvKey (KChar unicodeChar) []) rest -- something bad happened; just ignore and continue. Nothing -> Invalid utf8Length :: Word8 -> Int utf8Length c | c < 0x80 = 1 | c < 0xE0 = 2 | c < 0xF0 = 3 | otherwise = 4 vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input/Classify/0000755000000000000000000000000007346545000022337 5ustar0000000000000000vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input/Classify/Parse.hs0000644000000000000000000000362407346545000023752 0ustar0000000000000000-- | This module provides a simple parser for parsing input event -- control sequences. -- -- This module is exposed for testing purposes only; applications should -- never need to import this directly. module Graphics.Vty.Platform.Unix.Input.Classify.Parse ( Parser , runParser , failParse , readInt , readChar , expectChar ) where import Graphics.Vty.Input.Events import Graphics.Vty.Platform.Unix.Input.Classify.Types import Control.Monad.Trans.Maybe import Control.Monad.State import qualified Data.ByteString.Char8 as BS8 import Data.ByteString.Char8 (ByteString) type Parser a = MaybeT (State ByteString) a -- | Run a parser on a given input string. If the parser fails, return -- 'Invalid'. Otherwise return the valid event ('Valid') and the -- remaining unparsed characters. runParser :: ByteString -> Parser Event -> KClass runParser s parser = case runState (runMaybeT parser) s of (Nothing, _) -> Invalid (Just e, remaining) -> Valid e remaining -- | Fail a parsing operation. failParse :: Parser a failParse = fail "invalid parse" -- | Read an integer from the input stream. If an integer cannot be -- read, fail parsing. E.g. calling readInt on an input of "123abc" will -- return '123' and consume those characters. readInt :: Parser Int readInt = do s <- BS8.unpack <$> get case (reads :: ReadS Int) s of [(i, rest)] -> put (BS8.pack rest) >> return i _ -> failParse -- | Read a character from the input stream. If one cannot be read (e.g. -- we are out of characters), fail parsing. readChar :: Parser Char readChar = do s <- get case BS8.uncons s of Just (c,rest) -> put rest >> return c Nothing -> failParse -- | Read a character from the input stream and fail parsing if it is -- not the specified character. expectChar :: Char -> Parser () expectChar c = do c' <- readChar if c' == c then return () else failParse vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input/Classify/Types.hs0000644000000000000000000000254507346545000024005 0ustar0000000000000000-- | Data types for the input parser. -- -- This module is exposed for testing purposes only; applications should -- never need to import this directly. {-# LANGUAGE StrictData #-} module Graphics.Vty.Platform.Unix.Input.Classify.Types ( KClass(..) , ClassifierState(..) ) where import Graphics.Vty.Input.Events import Data.ByteString.Char8 (ByteString) -- | Whether the classifier is currently processing a chunked format. -- Currently, only bracketed pastes use this. data ClassifierState = ClassifierStart -- ^ Not processing a chunked format. | ClassifierInChunk ByteString [ByteString] -- ^ Currently processing a chunked format. The initial chunk is in the -- first argument and a reversed remainder of the chunks is collected in -- the second argument. At the end of the processing, the chunks are -- reversed and concatenated with the final chunk. data KClass = Valid Event ByteString -- ^ A valid event was parsed. Any unused characters from the input -- stream are also provided. | Invalid -- ^ The input characters did not represent a valid event. | Prefix -- ^ The input characters form the prefix of a valid event character -- sequence. | Chunk -- ^ The input characters are either start of a bracketed paste chunk -- or in the middle of a bracketed paste chunk. deriving(Show, Eq) vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input/Focus.hs0000644000000000000000000000267107346545000022203 0ustar0000000000000000-- | Focus mode implementation. -- -- This module is exposed for testing purposes only; applications should -- never need to import this directly. module Graphics.Vty.Platform.Unix.Input.Focus ( requestFocusEvents , disableFocusEvents , isFocusEvent , classifyFocusEvent ) where import Graphics.Vty.Input.Events import Graphics.Vty.Platform.Unix.Input.Classify.Types import Graphics.Vty.Platform.Unix.Input.Classify.Parse import Control.Monad import qualified Data.ByteString.Char8 as BS8 import Data.ByteString.Char8 (ByteString) -- | These sequences set xterm-based terminals to send focus event -- sequences. requestFocusEvents :: ByteString requestFocusEvents = BS8.pack "\ESC[?1004h" -- | These sequences disable focus events. disableFocusEvents :: ByteString disableFocusEvents = BS8.pack "\ESC[?1004l" -- | Does the specified string begin with a focus event? isFocusEvent :: ByteString -> Bool isFocusEvent s = BS8.isPrefixOf focusIn s || BS8.isPrefixOf focusOut s focusIn :: ByteString focusIn = BS8.pack "\ESC[I" focusOut :: ByteString focusOut = BS8.pack "\ESC[O" -- | Attempt to classify an input string as a focus event. classifyFocusEvent :: ByteString -> KClass classifyFocusEvent s = runParser s $ do when (not $ isFocusEvent s) failParse expectChar '\ESC' expectChar '[' ty <- readChar case ty of 'I' -> return EvGainedFocus 'O' -> return EvLostFocus _ -> failParse vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input/Loop.hs0000644000000000000000000001513307346545000022032 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_HADDOCK hide #-} -- | The input layer used to be a single function that correctly -- accounted for the non-threaded runtime by emulating the terminal -- VMIN adn VTIME handling. This has been removed and replace with a -- more straightforward parser. The non-threaded runtime is no longer -- supported. -- -- This is an example of an algorithm where code coverage could be high, -- even 100%, but the behavior is still under tested. I should collect -- more of these examples... -- -- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html module Graphics.Vty.Platform.Unix.Input.Loop ( initInput ) where import Graphics.Vty.Input import Graphics.Vty.Platform.Unix.Settings import Graphics.Vty.Platform.Unix.Input.Classify import Graphics.Vty.Platform.Unix.Input.Classify.Types import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception (mask, try, SomeException) import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString as BS import Data.ByteString.Char8 (ByteString) import Data.Word (Word8) import Foreign (allocaArray) import Foreign.C.Types (CInt(..)) import Foreign.Ptr (Ptr, castPtr) import Lens.Micro hiding ((<>~)) import Lens.Micro.TH import Lens.Micro.Mtl import Control.Monad (when, mzero, forM_, forever) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans (lift) import Control.Monad.Trans.State (StateT(..), evalStateT) import Control.Monad.State.Class (MonadState, modify) import Control.Monad.Trans.Reader (ReaderT(..), asks) import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..)) import System.Posix.Types (Fd(..)) data InputBuffer = InputBuffer { _ptr :: Ptr Word8 , _size :: Int } makeLenses ''InputBuffer data InputState = InputState { _unprocessedBytes :: ByteString , _classifierState :: ClassifierState , _deviceFd :: Fd , _originalInput :: Input , _inputBuffer :: InputBuffer , _classifier :: ClassifierState -> ByteString -> KClass } makeLenses ''InputState type InputM a = StateT InputState (ReaderT Input IO) a logMsg :: String -> InputM () logMsg msg = do i <- use originalInput liftIO $ inputLogMsg i msg -- this must be run on an OS thread dedicated to this input handling. -- otherwise the terminal timing read behavior will block the execution -- of the lightweight threads. loopInputProcessor :: InputM () loopInputProcessor = forever $ do readFromDevice >>= addBytesToProcess validEvents <- many parseEvent forM_ validEvents emit dropInvalid addBytesToProcess :: ByteString -> InputM () addBytesToProcess block = unprocessedBytes <>= block emit :: Event -> InputM () emit event = do logMsg $ "parsed event: " ++ show event (lift $ asks eventChannel) >>= liftIO . atomically . flip writeTChan (InputEvent event) -- The timing requirements are assured by the VMIN and VTIME set for the -- device. -- -- Precondition: Under the threaded runtime. Only current use is from a -- forkOS thread. That case satisfies precondition. readFromDevice :: InputM ByteString readFromDevice = do fd <- use deviceFd bufferPtr <- use $ inputBuffer.ptr maxBytes <- use $ inputBuffer.size stringRep <- liftIO $ do -- The killThread used in shutdownInput will not interrupt the -- foreign call fdReadBuf uses this provides a location to be -- interrupted prior to the foreign call. If there is input on -- the FD then the fdReadBuf will return in a finite amount of -- time due to the vtime terminal setting. threadWaitRead fd bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes) if bytesRead > 0 then BS.packCStringLen (castPtr bufferPtr, fromIntegral bytesRead) else return BS.empty when (not $ BS.null stringRep) $ logMsg $ "input bytes: " ++ show (BS8.unpack stringRep) return stringRep parseEvent :: InputM Event parseEvent = do c <- use classifier s <- use classifierState b <- use unprocessedBytes case c s b of Valid e remaining -> do logMsg $ "valid parse: " ++ show e logMsg $ "remaining: " ++ show remaining classifierState .= ClassifierStart unprocessedBytes .= remaining return e _ -> mzero dropInvalid :: InputM () dropInvalid = do c <- use classifier s <- use classifierState b <- use unprocessedBytes case c s b of Chunk -> do classifierState .= case s of ClassifierStart -> ClassifierInChunk b [] ClassifierInChunk p bs -> ClassifierInChunk p (b:bs) unprocessedBytes .= BS8.empty Invalid -> do logMsg "dropping input bytes" classifierState .= ClassifierStart unprocessedBytes .= BS8.empty _ -> return () runInputProcessorLoop :: ClassifyMap -> Input -> Fd -> IO () runInputProcessorLoop classifyTable input devFd = do let bufferSize = 1024 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do let s0 = InputState BS8.empty ClassifierStart devFd input (InputBuffer bufferPtr bufferSize) (classify classifyTable) runReaderT (evalStateT loopInputProcessor s0) input initInput :: UnixSettings -> ClassifyMap -> IO Input initInput settings classifyTable = do let devFd = settingInputFd settings theVmin = settingVmin settings theVtime = settingVtime settings setFdOption devFd NonBlockingRead False setTermTiming devFd theVmin (theVtime `div` 100) stopSync <- newEmptyMVar input <- Input <$> atomically newTChan <*> pure (return ()) <*> pure (return ()) <*> pure (const $ return ()) inputThread <- forkOSFinally (runInputProcessorLoop classifyTable input devFd) (\_ -> putMVar stopSync ()) let killAndWait = do killThread inputThread takeMVar stopSync return $ input { shutdownInput = killAndWait } foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO () forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId forkOSFinally action and_then = mask $ \restore -> forkOS $ try (restore action) >>= and_then (<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m () l <>= a = modify (l <>~ a) (<>~) :: Monoid a => ASetter s t a a -> a -> s -> t l <>~ n = over l (`mappend` n) vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input/Mouse.hs0000644000000000000000000001133007346545000022204 0ustar0000000000000000-- | This module provides parsers for mouse events for both "normal" and -- "extended" modes. This implementation was informed by -- -- http://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking -- -- This module is exposed for testing purposes only; applications should -- never need to import this directly. module Graphics.Vty.Platform.Unix.Input.Mouse ( requestMouseEvents , disableMouseEvents , isMouseEvent , classifyMouseEvent ) where import Graphics.Vty.Input.Events import Graphics.Vty.Platform.Unix.Input.Classify.Types import Graphics.Vty.Platform.Unix.Input.Classify.Parse import Control.Monad import Data.Maybe (catMaybes) import Data.Bits ((.&.)) import qualified Data.ByteString.Char8 as BS8 import Data.ByteString.Char8 (ByteString) -- A mouse event in SGR extended mode is -- -- '\ESC' '[' '<' B ';' X ';' Y ';' ('M'|'m') -- -- where -- -- * B is the number with button and modifier bits set, -- * X is the X coordinate of the event starting at 1 -- * Y is the Y coordinate of the event starting at 1 -- * the final character is 'M' for a press, 'm' for a release -- | These sequences set xterm-based terminals to send mouse event -- sequences. requestMouseEvents :: ByteString requestMouseEvents = BS8.pack "\ESC[?1000h\ESC[?1002h\ESC[?1006h" -- | These sequences disable mouse events. disableMouseEvents :: ByteString disableMouseEvents = BS8.pack "\ESC[?1000l\ESC[?1002l\ESC[?1006l" -- | Does the specified string begin with a mouse event? isMouseEvent :: ByteString -> Bool isMouseEvent s = isSGREvent s || isNormalEvent s isSGREvent :: ByteString -> Bool isSGREvent = BS8.isPrefixOf sgrPrefix sgrPrefix :: ByteString sgrPrefix = BS8.pack "\ESC[M" isNormalEvent :: ByteString -> Bool isNormalEvent = BS8.isPrefixOf normalPrefix normalPrefix :: ByteString normalPrefix = BS8.pack "\ESC[<" -- Modifier bits: shiftBit :: Int shiftBit = 4 metaBit :: Int metaBit = 8 ctrlBit :: Int ctrlBit = 16 -- These bits indicate the buttons involved: buttonMask :: Int buttonMask = 67 leftButton :: Int leftButton = 0 middleButton :: Int middleButton = 1 rightButton :: Int rightButton = 2 scrollUp :: Int scrollUp = 64 scrollDown :: Int scrollDown = 65 hasBitSet :: Int -> Int -> Bool hasBitSet val bit = val .&. bit > 0 -- | Attempt to classify an input string as a mouse event. classifyMouseEvent :: ByteString -> KClass classifyMouseEvent s = runParser s $ do when (not $ isMouseEvent s) failParse expectChar '\ESC' expectChar '[' ty <- readChar case ty of '<' -> classifySGRMouseEvent 'M' -> classifyNormalMouseEvent _ -> failParse -- Given a modifier/button value, determine which button was indicated getSGRButton :: Int -> Parser Button getSGRButton mods = let buttonMap = [ (leftButton, BLeft) , (middleButton, BMiddle) , (rightButton, BRight) , (scrollUp, BScrollUp) , (scrollDown, BScrollDown) ] in case lookup (mods .&. buttonMask) buttonMap of Nothing -> failParse Just b -> return b getModifiers :: Int -> [Modifier] getModifiers mods = catMaybes [ if mods `hasBitSet` shiftBit then Just MShift else Nothing , if mods `hasBitSet` metaBit then Just MMeta else Nothing , if mods `hasBitSet` ctrlBit then Just MCtrl else Nothing ] -- Attempt to classify a control sequence as a "normal" mouse event. To -- get here we should have already read "\ESC[M" so that will not be -- included in the string to be parsed. classifyNormalMouseEvent :: Parser Event classifyNormalMouseEvent = do statusChar <- readChar xCoordChar <- readChar yCoordChar <- readChar let xCoord = fromEnum xCoordChar - 32 yCoord = fromEnum yCoordChar - 32 status = fromEnum statusChar modifiers = getModifiers status let press = status .&. buttonMask /= 3 case press of True -> do button <- getSGRButton status return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers False -> return $ EvMouseUp (xCoord-1) (yCoord-1) Nothing -- Attempt to classify a control sequence as an SGR mouse event. To -- get here we should have already read "\ESC[<" so that will not be -- included in the string to be parsed. classifySGRMouseEvent :: Parser Event classifySGRMouseEvent = do mods <- readInt expectChar ';' xCoord <- readInt expectChar ';' yCoord <- readInt final <- readChar let modifiers = getModifiers mods button <- getSGRButton mods case final of 'M' -> return $ EvMouseDown (xCoord-1) (yCoord-1) button modifiers 'm' -> return $ EvMouseUp (xCoord-1) (yCoord-1) (Just button) _ -> failParse vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input/Paste.hs0000644000000000000000000000275307346545000022201 0ustar0000000000000000-- | This module provides bracketed paste support as described at -- -- http://cirw.in/blog/bracketed-paste -- -- This module is exposed for testing purposes only; applications should -- never need to import this directly. module Graphics.Vty.Platform.Unix.Input.Paste ( parseBracketedPaste , bracketedPasteStarted , bracketedPasteFinished ) where import qualified Data.ByteString.Char8 as BS8 import Data.ByteString.Char8 (ByteString) import Graphics.Vty.Input.Events import Graphics.Vty.Platform.Unix.Input.Classify.Types bracketedPasteStart :: ByteString bracketedPasteStart = BS8.pack "\ESC[200~" bracketedPasteEnd :: ByteString bracketedPasteEnd = BS8.pack "\ESC[201~" -- | Does the input start a bracketed paste? bracketedPasteStarted :: ByteString -> Bool bracketedPasteStarted = BS8.isPrefixOf bracketedPasteStart -- | Does the input contain a complete bracketed paste? bracketedPasteFinished :: ByteString -> Bool bracketedPasteFinished = BS8.isInfixOf bracketedPasteEnd -- | Parse a bracketed paste. This should only be called on a string if -- both 'bracketedPasteStarted' and 'bracketedPasteFinished' return -- 'True'. parseBracketedPaste :: ByteString -> KClass parseBracketedPaste s = Valid (EvPaste p) (BS8.drop endLen rest') where startLen = BS8.length bracketedPasteStart endLen = BS8.length bracketedPasteEnd (_, rest ) = BS8.breakSubstring bracketedPasteStart s (p, rest') = BS8.breakSubstring bracketedPasteEnd . BS8.drop startLen $ rest vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input/Terminfo.hs0000644000000000000000000001324507346545000022706 0ustar0000000000000000-- | Terminfo-oriented terminal input parser. -- -- This module is exposed for testing purposes only; applications should -- never need to import this directly. module Graphics.Vty.Platform.Unix.Input.Terminfo ( classifyMapForTerm , specialSupportKeys , capsClassifyMap , keysFromCapsTable , universalTable , visibleChars ) where import Data.Maybe (mapMaybe) import Graphics.Vty.Input.Events import qualified Graphics.Vty.Platform.Unix.Input.Terminfo.ANSIVT as ANSIVT import Control.Arrow import System.Console.Terminfo -- | Queries the terminal for all capability-based input sequences and -- then adds on a terminal-dependent input sequence mapping. -- -- For reference see: -- -- * http://vimdoc.sourceforge.net/htmldoc/term.html -- -- * vim74/src/term.c -- -- * http://invisible-island.net/vttest/ -- -- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html -- -- Terminfo is incomplete. The vim source implies that terminfo is also -- incorrect. Vty assumes that the internal terminfo table added to the -- system-provided terminfo table is correct. -- -- The procedure used here is: -- -- 1. Build terminfo table for all caps. Missing caps are not added. -- -- 2. Add tables for visible chars, esc, del, ctrl, and meta. -- -- 3. Add internally-defined table for given terminal type. -- -- Precedence is currently implicit in the 'compile' algorithm. classifyMapForTerm :: String -> Terminal -> ClassifyMap classifyMapForTerm termName term = concat $ capsClassifyMap term keysFromCapsTable : universalTable : termSpecificTables termName -- | The key table applicable to all terminals. -- -- Note that some of these entries are probably only applicable to -- ANSI/VT100 terminals. universalTable :: ClassifyMap universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys] capsClassifyMap :: Terminal -> [(String,Event)] -> ClassifyMap capsClassifyMap terminal table = [(x,y) | (Just x,y) <- map extractCap table] where extractCap = first (getCapability terminal . tiGetOutput1) -- | Tables specific to a given terminal that are not derivable from -- terminfo. -- -- Note that this adds the ANSI/VT100/VT50 tables regardless of term -- identifier. termSpecificTables :: String -> [ClassifyMap] termSpecificTables _termName = ANSIVT.classifyTable -- | Visible characters in the ISO-8859-1 and UTF-8 common set. -- -- We limit to < 0xC1. The UTF8 sequence detector will catch all values -- 0xC2 and above before this classify table is reached. visibleChars :: ClassifyMap visibleChars = [ ([x], EvKey (KChar x) []) | x <- [' ' .. toEnum 0xC1] ] -- | Non-printable characters in the ISO-8859-1 and UTF-8 common set -- translated to ctrl + char. -- -- This treats CTRL-i the same as tab. ctrlChars :: ClassifyMap ctrlChars = [ ([toEnum x],EvKey (KChar y) [MCtrl]) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) , y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB. , y /= 'h' -- CTRL-h should not hide BS ] -- | Ctrl+Meta+Char ctrlMetaChars :: ClassifyMap ctrlMetaChars = mapMaybe f ctrlChars where f (s, EvKey c m) = Just ('\ESC':s, EvKey c (MMeta:m)) f _ = Nothing -- | Esc, meta-esc, delete, meta-delete, enter, meta-enter. specialSupportKeys :: ClassifyMap specialSupportKeys = [ ("\ESC\ESC[5~",EvKey KPageUp [MMeta]) , ("\ESC\ESC[6~",EvKey KPageDown [MMeta]) -- special support for ESC , ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta]) -- Special support for backspace , ("\DEL",EvKey KBS []), ("\ESC\DEL",EvKey KBS [MMeta]), ("\b",EvKey KBS []) -- Special support for Enter , ("\ESC\^J",EvKey KEnter [MMeta]), ("\^J",EvKey KEnter []) -- explicit support for tab , ("\t", EvKey (KChar '\t') []) ] -- | A classification table directly generated from terminfo cap -- strings. These are: -- -- * ka1 - keypad up-left -- -- * ka3 - keypad up-right -- -- * kb2 - keypad center -- -- * kbs - keypad backspace -- -- * kbeg - begin -- -- * kcbt - back tab -- -- * kc1 - keypad left-down -- -- * kc3 - keypad right-down -- -- * kdch1 - delete -- -- * kcud1 - down -- -- * kend - end -- -- * kent - enter -- -- * kf0 - kf63 - function keys -- -- * khome - KHome -- -- * kich1 - insert -- -- * kcub1 - left -- -- * knp - next page (page down) -- -- * kpp - previous page (page up) -- -- * kcuf1 - right -- -- * kDC - shift delete -- -- * kEND - shift end -- -- * kHOM - shift home -- -- * kIC - shift insert -- -- * kLFT - shift left -- -- * kRIT - shift right -- -- * kcuu1 - up keysFromCapsTable :: ClassifyMap keysFromCapsTable = [ ("ka1", EvKey KUpLeft []) , ("ka3", EvKey KUpRight []) , ("kb2", EvKey KCenter []) , ("kbs", EvKey KBS []) , ("kbeg", EvKey KBegin []) , ("kcbt", EvKey KBackTab []) , ("kc1", EvKey KDownLeft []) , ("kc3", EvKey KDownRight []) , ("kdch1", EvKey KDel []) , ("kcud1", EvKey KDown []) , ("kend", EvKey KEnd []) , ("kent", EvKey KEnter []) , ("khome", EvKey KHome []) , ("kich1", EvKey KIns []) , ("kcub1", EvKey KLeft []) , ("knp", EvKey KPageDown []) , ("kpp", EvKey KPageUp []) , ("kcuf1", EvKey KRight []) , ("kDC", EvKey KDel [MShift]) , ("kEND", EvKey KEnd [MShift]) , ("kHOM", EvKey KHome [MShift]) , ("kIC", EvKey KIns [MShift]) , ("kLFT", EvKey KLeft [MShift]) , ("kRIT", EvKey KRight [MShift]) , ("kcuu1", EvKey KUp []) ] ++ functionKeyCapsTable -- | Cap names for function keys. functionKeyCapsTable :: ClassifyMap functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) []) vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input/Terminfo/0000755000000000000000000000000007346545000022345 5ustar0000000000000000vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Input/Terminfo/ANSIVT.hs0000644000000000000000000000562207346545000023712 0ustar0000000000000000-- | Input mappings for ANSI, VT100, and VT50 terminals that are missing -- from terminfo or that are sent regardless of terminfo by terminal -- emulators. For example, terminal emulators will often use VT50 -- input bytes regardless of declared terminal type. This provides -- compatibility with programs that don't follow terminfo. -- -- This module is exposed for testing purposes only; applications should -- never need to import this directly. module Graphics.Vty.Platform.Unix.Input.Terminfo.ANSIVT ( classifyTable ) where import Graphics.Vty.Input.Events -- | Encoding for navigation keys. navKeys0 :: ClassifyMap navKeys0 = [ k "G" KCenter , k "P" KPause , k "A" KUp , k "B" KDown , k "C" KRight , k "D" KLeft , k "H" KHome , k "F" KEnd , k "E" KBegin ] where k c s = ("\ESC["++c,EvKey s []) -- | encoding for shift, meta and ctrl plus arrows/home/end navKeys1 :: ClassifyMap navKeys1 = [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m) | charCnt <- ["1;", ""], -- we can have a count or not (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3), -- modifiers and their codes ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- directions and their codes (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] ] -- | encoding for ins, del, pageup, pagedown, home, end navKeys2 :: ClassifyMap navKeys2 = let k n s = ("\ESC["++show n++"~",EvKey s []) in zipWith k [2::Int,3,5,6,1,4] [KIns,KDel,KPageUp,KPageDown,KHome,KEnd] -- | encoding for ctrl + ins, del, pageup, pagedown, home, end navKeys3 :: ClassifyMap navKeys3 = let k n s = ("\ESC["++show n++";5~",EvKey s [MCtrl]) in zipWith k [2::Int,3,5,6,1,4] [KIns,KDel,KPageUp,KPageDown,KHome,KEnd] -- | encoding for shift plus function keys -- -- According to -- -- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html -- -- This encoding depends on the terminal. functionKeys1 :: ClassifyMap functionKeys1 = let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-head nrs+ff) m) | n <- nrs ] in concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ] -- | encoding for meta plus char -- -- 1. removed 'ESC' from second list due to duplication with -- "special_support_keys". -- 2. removed '[' from second list due to conflict with 7-bit encoding -- for ESC. Whether meta+[ is the same as ESC should examine km and -- current encoding. -- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped -- to KBS by special_support_keys. functionKeys2 :: ClassifyMap functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta]) | x <- '\t':[' ' .. '~'] , x /= '[' ] classifyTable :: [ClassifyMap] classifyTable = [ navKeys0 , navKeys1 , navKeys2 , navKeys3 , functionKeys1 , functionKeys2 ] vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Output.hs0000644000000000000000000000377507346545000021333 0ustar0000000000000000{-# LANGUAGE RecordWildCards, CPP #-} -- | This module provides a function to build an 'Output' for Unix -- terminal devices. -- -- This module is exposed for testing purposes only; applications should -- never need to import this directly. module Graphics.Vty.Platform.Unix.Output ( buildOutput ) where import Graphics.Vty.Config import Graphics.Vty.Output import Graphics.Vty.Platform.Unix.Settings import Graphics.Vty.Platform.Unix.Output.Color (detectColorMode) import Graphics.Vty.Platform.Unix.Output.XTermColor as XTermColor import Graphics.Vty.Platform.Unix.Output.TerminfoBased as TerminfoBased import Data.List (isPrefixOf) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif -- | Returns an 'Output' for the terminal specified in 'UnixSettings'. -- -- The specific output implementation chosen is based -- on the @TERM@ environment variable and ultimately -- uses @Graphics.Vty.Platform.Unix.Output.XTermColor@ -- for terminals that look @xterm@-like or -- @Graphics.Vty.Platform.Unix.Output.TerminfoBased@ as a fallback -- otherwise. -- -- * If @TERM@ starts with @xterm@, @screen@, @rxvt@, or @tmux@, this -- will the @xterm@-based implementation. -- * Otherwise this will use the 'TerminfoBased' implementation. buildOutput :: VtyUserConfig -> UnixSettings -> IO Output buildOutput config settings = do let termName = settingTermName settings fd = settingOutputFd settings colorMode <- case configPreferredColorMode config of Nothing -> detectColorMode termName Just m -> return m t <- if isXtermLike termName then XTermColor.reserveTerminal termName fd colorMode -- Not an xterm-like terminal. try for generic terminfo. else TerminfoBased.reserveTerminal termName fd colorMode return t isXtermLike :: String -> Bool isXtermLike termName = any (`isPrefixOf` termName) xtermLikeTerminalNamePrefixes xtermLikeTerminalNamePrefixes :: [String] xtermLikeTerminalNamePrefixes = [ "xterm" , "screen" , "tmux" , "rxvt" ] vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Output/0000755000000000000000000000000007346545000020763 5ustar0000000000000000vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Output/Color.hs0000644000000000000000000000242307346545000022376 0ustar0000000000000000{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Best-effort terminfo-based color mode detection. -- -- This module is exposed for testing purposes only; applications should -- never need to import this directly. module Graphics.Vty.Platform.Unix.Output.Color ( detectColorMode ) where import System.Environment (lookupEnv) import qualified System.Console.Terminfo as Terminfo import Control.Exception (catch) import Data.Maybe import Graphics.Vty.Attributes.Color detectColorMode :: String -> IO ColorMode detectColorMode termName' = do term <- catch (Just <$> Terminfo.setupTerm termName') (\(_ :: Terminfo.SetupTermError) -> return Nothing) let getCap cap = term >>= \t -> Terminfo.getCapability t cap termColors = fromMaybe 0 $ getCap (Terminfo.tiGetNum "colors") colorterm <- lookupEnv "COLORTERM" return $ if | termColors < 8 -> NoColor | termColors < 16 -> ColorMode8 | termColors == 16 -> ColorMode16 | termColors < 256 -> ColorMode240 (fromIntegral termColors - 16) | colorterm == Just "truecolor" -> FullColor | colorterm == Just "24bit" -> FullColor | otherwise -> ColorMode240 240 vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Output/TerminfoBased.hs0000644000000000000000000006230707346545000024051 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- | Terminfo-based terminal output implementation. -- -- This module is exposed for testing purposes only; applications should -- never need to import this directly. module Graphics.Vty.Platform.Unix.Output.TerminfoBased ( reserveTerminal , setWindowSize ) where import Control.Monad (when) import Data.Bits (shiftL, (.&.)) import qualified Data.ByteString as BS import Data.ByteString.Internal (toForeignPtr) import Data.Terminfo.Parse import Data.Terminfo.Eval import Graphics.Vty.Attributes import Graphics.Vty.Image (DisplayRegion) import Graphics.Vty.DisplayAttributes import Graphics.Vty.Output import Blaze.ByteString.Builder (Write, writeToByteString, writeStorable, writeWord8) import Data.IORef import Data.Maybe (isJust, isNothing, fromJust) import Data.Word #if !MIN_VERSION_base(4,8,0) import Data.Foldable (foldMap) #endif import Foreign.C.Types ( CInt(..), CLong(..) ) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr) import qualified System.Console.Terminfo as Terminfo import System.Posix.IO (fdWriteBuf) import System.Posix.Types (Fd(..)) data TerminfoCaps = TerminfoCaps { smcup :: Maybe CapExpression , rmcup :: Maybe CapExpression , cup :: CapExpression , cnorm :: Maybe CapExpression , civis :: Maybe CapExpression , useAltColorMap :: Bool , setForeColor :: CapExpression , setBackColor :: CapExpression , setDefaultAttr :: CapExpression , clearScreen :: CapExpression , clearEol :: CapExpression , displayAttrCaps :: DisplayAttrCaps , ringBellAudio :: Maybe CapExpression } data DisplayAttrCaps = DisplayAttrCaps { setAttrStates :: Maybe CapExpression , enterStandout :: Maybe CapExpression , exitStandout :: Maybe CapExpression , enterItalic :: Maybe CapExpression , exitItalic :: Maybe CapExpression , enterStrikethrough :: Maybe CapExpression , exitStrikethrough :: Maybe CapExpression , enterUnderline :: Maybe CapExpression , exitUnderline :: Maybe CapExpression , enterReverseVideo :: Maybe CapExpression , enterDimMode :: Maybe CapExpression , enterBoldMode :: Maybe CapExpression } -- kinda like: -- https://code.google.com/p/vim/source/browse/src/fileio.c#10422 -- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR -- the write will be retried. fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int fdWriteAll outFd ptr len count | len < 0 = fail "fdWriteAll: len is less than 0" | len == 0 = return count | otherwise = do writeCount <- fromEnum <$> fdWriteBuf outFd ptr (toEnum len) let len' = len - writeCount ptr' = ptr `plusPtr` writeCount count' = count + writeCount fdWriteAll outFd ptr' len' count' sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO () sendCapToTerminal t cap capParams = do outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams -- | Constructs an output driver that uses terminfo for all control -- codes. While this should provide the most compatible terminal, -- terminfo does not support some features that would increase -- efficiency and improve compatibility: -- -- * determining the character encoding supported by the terminal. -- Should this be taken from the LANG environment variable? -- -- * Providing independent string capabilities for all display -- attributes. reserveTerminal :: String -> Fd -> ColorMode -> IO Output reserveTerminal termName outFd colorMode = do ti <- Terminfo.setupTerm termName -- assumes set foreground always implies set background exists. -- if set foreground is not set then all color changing style -- attributes are filtered. msetaf <- probeCap ti "setaf" msetf <- probeCap ti "setf" let (useAlt, setForeCap) = case msetaf of Just setaf -> (False, setaf) Nothing -> case msetf of Just setf -> (True, setf) Nothing -> (True, error $ "no fore color support for terminal " ++ termName) msetab <- probeCap ti "setab" msetb <- probeCap ti "setb" let setBackCap = case msetab of Just setab -> setab Nothing -> case msetb of Just setb -> setb Nothing -> error $ "no back color support for terminal " ++ termName hyperlinkModeStatus <- newIORef False newAssumedStateRef <- newIORef initialAssumedState let terminfoSetMode m newStatus = do curStatus <- terminfoModeStatus m when (newStatus /= curStatus) $ case m of Hyperlink -> do writeIORef hyperlinkModeStatus newStatus writeIORef newAssumedStateRef initialAssumedState _ -> return () terminfoModeStatus m = case m of Hyperlink -> readIORef hyperlinkModeStatus _ -> return False terminfoModeSupported Hyperlink = True terminfoModeSupported _ = False terminfoCaps <- pure TerminfoCaps <*> probeCap ti "smcup" <*> probeCap ti "rmcup" <*> requireCap ti "cup" <*> probeCap ti "cnorm" <*> probeCap ti "civis" <*> pure useAlt <*> pure setForeCap <*> pure setBackCap <*> requireCap ti "sgr0" <*> requireCap ti "clear" <*> requireCap ti "el" <*> currentDisplayAttrCaps ti <*> probeCap ti "bel" let t = Output { terminalID = termName , releaseTerminal = do sendCap setDefaultAttr [] maybeSendCap cnorm [] , supportsBell = return $ isJust $ ringBellAudio terminfoCaps , supportsItalics = return $ (isJust $ enterItalic (displayAttrCaps terminfoCaps)) && (isJust $ exitItalic (displayAttrCaps terminfoCaps)) , supportsStrikethrough = return $ (isJust $ enterStrikethrough (displayAttrCaps terminfoCaps)) && (isJust $ exitStrikethrough (displayAttrCaps terminfoCaps)) , ringTerminalBell = maybeSendCap ringBellAudio [] , reserveDisplay = do -- If there is no support for smcup: Clear the screen -- and then move the mouse to the home position to -- approximate the behavior. maybeSendCap smcup [] sendCap clearScreen [] , releaseDisplay = do maybeSendCap rmcup [] maybeSendCap cnorm [] , setDisplayBounds = \(w, h) -> setWindowSize outFd (w, h) , displayBounds = do rawSize <- getWindowSize outFd case rawSize of (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize | otherwise -> return (w,h) , outputByteBuffer = \outBytes -> do let (fptr, offset, len) = toForeignPtr outBytes actualLen <- withForeignPtr fptr $ \ptr -> fdWriteAll outFd (ptr `plusPtr` offset) len 0 when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer " ++ "length mismatch. " ++ show len ++ " /= " ++ show actualLen ++ " Please report this bug to vty project." , supportsCursorVisibility = isJust $ civis terminfoCaps , supportsMode = terminfoModeSupported , setMode = terminfoSetMode , getModeStatus = terminfoModeStatus , assumedStateRef = newAssumedStateRef , outputColorMode = colorMode -- I think fix would help assure tActual is the only -- reference. I was having issues tho. , mkDisplayContext = (`terminfoDisplayContext` terminfoCaps) , setOutputWindowTitle = const $ return () } sendCap s = sendCapToTerminal t (s terminfoCaps) maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s) return t requireCap :: Terminfo.Terminal -> String -> IO CapExpression requireCap ti capName = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\"" Just capStr -> parseCap capStr probeCap :: Terminfo.Terminal -> String -> IO (Maybe CapExpression) probeCap ti capName = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of Nothing -> return Nothing Just capStr -> Just <$> parseCap capStr parseCap :: String -> IO CapExpression parseCap capStr = do case parseCapExpression capStr of Left e -> fail $ show e Right cap -> return cap currentDisplayAttrCaps :: Terminfo.Terminal -> IO DisplayAttrCaps currentDisplayAttrCaps ti = pure DisplayAttrCaps <*> probeCap ti "sgr" <*> probeCap ti "smso" <*> probeCap ti "rmso" <*> probeCap ti "sitm" <*> probeCap ti "ritm" <*> probeCap ti "smxx" <*> probeCap ti "rmxx" <*> probeCap ti "smul" <*> probeCap ti "rmul" <*> probeCap ti "rev" <*> probeCap ti "dim" <*> probeCap ti "bold" foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong getWindowSize :: Fd -> IO (Int,Int) getWindowSize fd = do (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd return (fromIntegral b, fromIntegral a) foreign import ccall "gwinsz.h vty_c_set_window_size" c_setWindowSize :: Fd -> CLong -> IO () setWindowSize :: Fd -> (Int, Int) -> IO () setWindowSize fd (w, h) = do let val = (h `shiftL` 16) + w c_setWindowSize fd $ fromIntegral val terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext terminfoDisplayContext tActual terminfoCaps r = return dc where dc = DisplayContext { contextDevice = tActual , contextRegion = r , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x] , writeShowCursor = case cnorm terminfoCaps of Nothing -> error "this terminal does not support show cursor" Just c -> writeCapExpr c [] , writeHideCursor = case civis terminfoCaps of Nothing -> error "this terminal does not support hide cursor" Just c -> writeCapExpr c [] , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps , writeDefaultAttr = \urlsEnabled -> writeCapExpr (setDefaultAttr terminfoCaps) [] `mappend` (if urlsEnabled then writeURLEscapes EndLink else mempty) `mappend` (case exitStrikethrough $ displayAttrCaps terminfoCaps of Just cap -> writeCapExpr cap [] Nothing -> mempty ) , writeRowEnd = writeCapExpr (clearEol terminfoCaps) [] , inlineHack = return () } -- | Write the escape sequences that are used in some terminals to -- include embedded hyperlinks. As of yet, this information isn't -- included in termcap or terminfo, so this writes them directly -- instead of looking up the appropriate capabilities. writeURLEscapes :: URLDiff -> Write writeURLEscapes (LinkTo url) = foldMap writeStorable (BS.unpack "\x1b]8;;") `mappend` foldMap writeStorable (BS.unpack url) `mappend` writeStorable (0x07 :: Word8) writeURLEscapes EndLink = foldMap writeStorable (BS.unpack "\x1b]8;;\a") writeURLEscapes NoLinkChange = mempty -- | Portably setting the display attributes is a giant pain in the ass. -- -- If the terminal supports the sgr capability (which sets the on/off -- state of each style directly; and, for no good reason, resets the -- colors to the default) this procedure is used: -- -- 0. set the style attributes. This resets the fore and back color. -- -- 1, If a foreground color is to be set then set the foreground color -- -- 2. likewise with the background color -- -- If the terminal does not support the sgr cap then: if there is a -- change from an applied color to the default (in either the fore or -- back color) then: -- -- 0. reset all display attributes (sgr0) -- -- 1. enter required style modes -- -- 2. set the fore color if required -- -- 3. set the back color if required -- -- Entering the required style modes could require a reset of the -- display attributes. If this is the case then the back and fore colors -- always need to be set if not default. -- -- This equation implements the above logic. -- -- Note that this assumes the removal of color changes in the -- display attributes is done as expected with noColors == True. See -- `limitAttrForDisplay`. -- -- Note that this optimizes for fewer state changes followed by fewer -- bytes. terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> Bool -> FixedAttr -> Attr -> DisplayAttrDiff -> Write terminfoWriteSetAttr dc terminfoCaps urlsEnabled prevAttr reqAttr diffs = urlAttrs urlsEnabled `mappend` case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of -- The only way to reset either color, portably, to the default -- is to use either the set state capability or the set default -- capability. True -> do case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps) (fixedStyle attr) (styleToApplySeq $ fixedStyle attr) of -- only way to reset a color to the defaults EnterExitSeq caps -> writeDefaultAttr dc urlsEnabled `mappend` foldMap (\cap -> writeCapExpr cap []) caps `mappend` setColors -- implicitly resets the colors to the defaults SetState state -> writeCapExpr (fromJust $ setAttrStates $ displayAttrCaps terminfoCaps ) (sgrArgsForState state) `mappend` setItalics `mappend` setStrikethrough `mappend` setColors -- Otherwise the display colors are not changing or changing -- between two non-default points. False -> do -- Still, it could be the case that the change in display -- attributes requires the colors to be reset because the -- required capability was not available. case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps) (fixedStyle attr) (styleDiffs diffs) of -- Really, if terminals were re-implemented with modern -- concepts instead of bowing down to 40 yr old dumb -- terminal requirements this would be the only case -- ever reached! Changes the style and color states -- according to the differences with the currently -- applied states. EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps `mappend` writeColorDiff Foreground (foreColorDiff diffs) `mappend` writeColorDiff Background (backColorDiff diffs) -- implicitly resets the colors to the defaults SetState state -> writeCapExpr (fromJust $ setAttrStates $ displayAttrCaps terminfoCaps ) (sgrArgsForState state) `mappend` setItalics `mappend` setStrikethrough `mappend` setColors where urlAttrs True = writeURLEscapes (urlDiff diffs) urlAttrs False = mempty colorMap = case useAltColorMap terminfoCaps of False -> ansiColorIndex True -> altColorIndex attr = fixDisplayAttr prevAttr reqAttr -- italics can't be set via SGR, so here we manually -- apply the enter and exit sequences as needed after -- changing the SGR setItalics | hasStyle (fixedStyle attr) italic , Just sitm <- enterItalic (displayAttrCaps terminfoCaps) = writeCapExpr sitm [] | otherwise = mempty setStrikethrough | hasStyle (fixedStyle attr) strikethrough , Just smxx <- enterStrikethrough (displayAttrCaps terminfoCaps) = writeCapExpr smxx [] | otherwise = mempty setColors = (case fixedForeColor attr of Just c -> writeColor Foreground c Nothing -> mempty) `mappend` (case fixedBackColor attr of Just c -> writeColor Background c Nothing -> mempty) writeColorDiff _side NoColorChange = mempty writeColorDiff _side ColorToDefault = error "ColorToDefault is not a possible case for applyColorDiffs" writeColorDiff side (SetColor c) = writeColor side c writeColor side (RGBColor r g b) = case outputColorMode (contextDevice dc) of FullColor -> hardcodeColor side (r, g, b) _ -> error "clampColor should remove rgb colors in standard mode" writeColor side c = writeCapExpr (setSideColor side terminfoCaps) [toEnum $ colorMap c] -- a color can either be in the foreground or the background data ColorSide = Foreground | Background -- get the capability for drawing a color on a specific side setSideColor :: ColorSide -> TerminfoCaps -> CapExpression setSideColor Foreground = setForeColor setSideColor Background = setBackColor hardcodeColor :: ColorSide -> (Word8, Word8, Word8) -> Write hardcodeColor side (r, g, b) = -- hardcoded color codes are formatted as "\x1b[{side};2;{r};{g};{b}m" mconcat [ writeStr "\x1b[", sideCode, delimiter, writeChar '2', delimiter , writeColor r, delimiter, writeColor g, delimiter, writeColor b , writeChar 'm'] where writeChar = writeWord8 . fromIntegral . fromEnum writeStr = mconcat . map writeChar writeColor = writeStr . show delimiter = writeChar ';' -- 38/48 are used to set whether we should write to the -- foreground/background. I really don't want to know why. sideCode = case side of Foreground -> writeStr "38" Background -> writeStr "48" -- | The color table used by a terminal is a 16 color set followed by a -- 240 color set that might not be supported by the terminal. -- -- This takes a Color which clearly identifies which palette to use and -- computes the index into the full 256 color palette. ansiColorIndex :: Color -> Int ansiColorIndex (ISOColor v) = fromEnum v ansiColorIndex (Color240 v) = 16 + fromEnum v ansiColorIndex (RGBColor _ _ _) = error $ unlines [ "Attempted to create color index from rgb color." , "This is currently unsupported, and shouldn't ever happen" ] -- | For terminals without setaf/setab -- -- See table in `man terminfo` -- Will error if not in table. altColorIndex :: Color -> Int altColorIndex (ISOColor 0) = 0 altColorIndex (ISOColor 1) = 4 altColorIndex (ISOColor 2) = 2 altColorIndex (ISOColor 3) = 6 altColorIndex (ISOColor 4) = 1 altColorIndex (ISOColor 5) = 5 altColorIndex (ISOColor 6) = 3 altColorIndex (ISOColor 7) = 7 altColorIndex (ISOColor v) = fromEnum v altColorIndex (Color240 v) = 16 + fromEnum v altColorIndex (RGBColor _ _ _) = error $ unlines [ "Attempted to create color index from rgb color." , "This is currently unsupported, and shouldn't ever happen" ] {- | The sequence of terminfo caps to apply a given style are determined - according to these rules. - - 1. The assumption is that it's preferable to use the simpler - enter/exit mode capabilities than the full set display attribute - state capability. - - 2. If a mode is supposed to be removed but there is not an exit - capability defined then the display attributes are reset to defaults - then the display attribute state is set. - - 3. If a mode is supposed to be applied but there is not an enter - capability defined then then display attribute state is set if - possible. Otherwise the mode is not applied. - - 4. If the display attribute state is being set then just update the - arguments to that for any apply/remove. -} data DisplayAttrSeq = EnterExitSeq [CapExpression] | SetState DisplayAttrState data DisplayAttrState = DisplayAttrState { applyStandout :: Bool , applyUnderline :: Bool , applyItalic :: Bool , applyStrikethrough :: Bool , applyReverseVideo :: Bool , applyBlink :: Bool , applyDim :: Bool , applyBold :: Bool } sgrArgsForState :: DisplayAttrState -> [CapParam] sgrArgsForState attrState = map (\b -> if b then 1 else 0) [ applyStandout attrState , applyUnderline attrState , applyReverseVideo attrState , applyBlink attrState , applyDim attrState , applyBold attrState , False -- invis , False -- protect , False -- alt char set ] reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq reqDisplayCapSeqFor caps s diffs -- if the state transition implied by any diff cannot be supported -- with an enter/exit mode cap then either the state needs to be set -- or the attribute change ignored. = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of -- If all the diffs have an enter-exit cap then just use those ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs -- If not all the diffs have an enter-exit cap and there is no -- set state cap then filter out all unsupported diffs and just -- apply the rest ( True, False ) -> EnterExitSeq $ map enterExitCap $ filter (not . noEnterExitCap) diffs -- if not all the diffs have an enter-exit can and there is a -- set state cap then just use the set state cap. ( True, True ) -> SetState $ stateForStyle s where noEnterExitCap ApplyStrikethrough = isNothing $ enterStrikethrough caps noEnterExitCap RemoveStrikethrough = isNothing $ exitStrikethrough caps noEnterExitCap ApplyItalic = isNothing $ enterItalic caps noEnterExitCap RemoveItalic = isNothing $ exitItalic caps noEnterExitCap ApplyStandout = isNothing $ enterStandout caps noEnterExitCap RemoveStandout = isNothing $ exitStandout caps noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps noEnterExitCap RemoveReverseVideo = True noEnterExitCap ApplyBlink = True noEnterExitCap RemoveBlink = True noEnterExitCap ApplyDim = isNothing $ enterDimMode caps noEnterExitCap RemoveDim = True noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps noEnterExitCap RemoveBold = True enterExitCap ApplyStrikethrough = fromJust $ enterStrikethrough caps enterExitCap RemoveStrikethrough = fromJust $ exitStrikethrough caps enterExitCap ApplyItalic = fromJust $ enterItalic caps enterExitCap RemoveItalic = fromJust $ exitItalic caps enterExitCap ApplyStandout = fromJust $ enterStandout caps enterExitCap RemoveStandout = fromJust $ exitStandout caps enterExitCap ApplyUnderline = fromJust $ enterUnderline caps enterExitCap RemoveUnderline = fromJust $ exitUnderline caps enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps enterExitCap ApplyDim = fromJust $ enterDimMode caps enterExitCap ApplyBold = fromJust $ enterBoldMode caps enterExitCap _ = error "enterExitCap applied to diff that was known not to have one." stateForStyle :: Style -> DisplayAttrState stateForStyle s = DisplayAttrState { applyStandout = isStyleSet standout , applyUnderline = isStyleSet underline , applyItalic = isStyleSet italic , applyStrikethrough = isStyleSet strikethrough , applyReverseVideo = isStyleSet reverseVideo , applyBlink = isStyleSet blink , applyDim = isStyleSet dim , applyBold = isStyleSet bold } where isStyleSet = hasStyle s styleToApplySeq :: Style -> [StyleStateChange] styleToApplySeq s = concat [ applyIfRequired ApplyStandout standout , applyIfRequired ApplyUnderline underline , applyIfRequired ApplyItalic italic , applyIfRequired ApplyStrikethrough strikethrough , applyIfRequired ApplyReverseVideo reverseVideo , applyIfRequired ApplyBlink blink , applyIfRequired ApplyDim dim , applyIfRequired ApplyBold bold ] where applyIfRequired op flag = if 0 == (flag .&. s) then [] else [op] vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Output/XTermColor.hs0000644000000000000000000001327007346545000023360 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Output implementation for xterm-like terminals. -- -- This module is exposed for testing purposes only; applications should -- never need to import this directly. module Graphics.Vty.Platform.Unix.Output.XTermColor ( reserveTerminal ) where import Graphics.Vty.Output import Graphics.Vty.Platform.Unix.Input.Mouse import Graphics.Vty.Platform.Unix.Input.Focus import Graphics.Vty.Attributes.Color (ColorMode) import qualified Graphics.Vty.Platform.Unix.Output.TerminfoBased as TerminfoBased import Blaze.ByteString.Builder (writeToByteString) import Blaze.ByteString.Builder.Word (writeWord8) import qualified Data.ByteString.Char8 as BS8 import Data.ByteString.Char8 (ByteString) import Foreign.Ptr (castPtr) import Control.Monad (void, when) import Control.Monad.Trans import Data.Char (toLower, isPrint, showLitChar) import Data.IORef import System.Posix.IO (fdWriteBuf) import System.Posix.Types (ByteCount, Fd) import System.Posix.Env (getEnv) import Data.List (isInfixOf) import Data.Maybe (catMaybes) #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif -- | Write a 'ByteString' to an 'Fd'. fdWrite :: Fd -> ByteString -> IO ByteCount fdWrite fd s = BS8.useAsCStringLen s $ \(buf,len) -> do fdWriteBuf fd (castPtr buf) (fromIntegral len) -- | Construct an Xterm output driver. Initialize the display to UTF-8. reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> ColorMode -> m Output reserveTerminal variant outFd colorMode = liftIO $ do let flushedPut = void . fdWrite outFd -- If the terminal variant is xterm-color use xterm instead since, -- more often than not, xterm-color is broken. let variant' = if variant == "xterm-color" then "xterm" else variant utf8a <- utf8Active when (not utf8a) $ flushedPut setUtf8CharSet t <- TerminfoBased.reserveTerminal variant' outFd colorMode mouseModeStatus <- newIORef False focusModeStatus <- newIORef False pasteModeStatus <- newIORef False let xtermSetMode t' m newStatus = do curStatus <- getModeStatus t' m when (newStatus /= curStatus) $ case m of Focus -> liftIO $ do case newStatus of True -> flushedPut requestFocusEvents False -> flushedPut disableFocusEvents writeIORef focusModeStatus newStatus Mouse -> liftIO $ do case newStatus of True -> flushedPut requestMouseEvents False -> flushedPut disableMouseEvents writeIORef mouseModeStatus newStatus BracketedPaste -> liftIO $ do case newStatus of True -> flushedPut enableBracketedPastes False -> flushedPut disableBracketedPastes writeIORef pasteModeStatus newStatus Hyperlink -> setMode t Hyperlink newStatus xtermGetMode Mouse = liftIO $ readIORef mouseModeStatus xtermGetMode Focus = liftIO $ readIORef focusModeStatus xtermGetMode BracketedPaste = liftIO $ readIORef pasteModeStatus xtermGetMode Hyperlink = getModeStatus t Hyperlink let t' = t { terminalID = terminalID t ++ " (xterm-color)" , releaseTerminal = do when (not utf8a) $ liftIO $ flushedPut setDefaultCharSet setMode t' BracketedPaste False setMode t' Mouse False setMode t' Focus False releaseTerminal t , mkDisplayContext = \tActual r -> do dc <- mkDisplayContext t tActual r return $ dc { inlineHack = xtermInlineHack t' } , supportsMode = const True , getModeStatus = xtermGetMode , setMode = xtermSetMode t' , setOutputWindowTitle = setWindowTitle t } return t' utf8Active :: IO Bool utf8Active = do let vars = ["LC_ALL", "LANG", "LC_CTYPE"] results <- map (toLower <$>) . catMaybes <$> mapM getEnv vars let matches = filter ("utf8" `isInfixOf`) results <> filter ("utf-8" `isInfixOf`) results return $ not $ null matches -- | Enable bracketed paste mode: -- http://cirw.in/blog/bracketed-paste enableBracketedPastes :: ByteString enableBracketedPastes = BS8.pack "\ESC[?2004h" -- | Disable bracketed paste mode: disableBracketedPastes :: ByteString disableBracketedPastes = BS8.pack "\ESC[?2004l" -- | These sequences set xterm based terminals to UTF-8 output. -- -- There is no known terminfo capability equivalent to this. setUtf8CharSet, setDefaultCharSet :: ByteString setUtf8CharSet = BS8.pack "\ESC%G" setDefaultCharSet = BS8.pack "\ESC%@" xtermInlineHack :: Output -> IO () xtermInlineHack t = do let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K" outputByteBuffer t $ writeToByteString writeReset -- This function emits an Xterm-compatible escape sequence that we -- anticipate will work for essentially all modern terminal emulators. -- Ideally we'd use a terminal capability for this, but there does not -- seem to exist a termcap for setting window titles. If you find that -- this function does not work for a given terminal emulator, please -- report the issue. -- -- For details, see: -- -- https://tldp.org/HOWTO/Xterm-Title-3.html setWindowTitle :: Output -> String -> IO () setWindowTitle o title = do let sanitize :: String -> String sanitize = concatMap sanitizeChar sanitizeChar c | not (isPrint c) = showLitChar c "" | otherwise = [c] let buf = BS8.pack $ "\ESC]2;" <> sanitize title <> "\007" outputByteBuffer o buf vty-unix-0.2.0.0/src/Graphics/Vty/Platform/Unix/Settings.hs0000644000000000000000000000567107346545000021630 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -- | Runtime settings for @vty-unix@. Most applications will not need to -- change any of these settings. module Graphics.Vty.Platform.Unix.Settings ( VtyUnixConfigurationError(..) , UnixSettings(..) , currentTerminalName , defaultSettings ) where import Control.Exception (Exception(..), throwIO) import Control.Monad (when, void) #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(..)) #endif #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif import Data.Typeable (Typeable) import System.Environment (lookupEnv) import System.IO (Handle, BufferMode(..), hReady, hSetBuffering, hGetChar, stdin) import System.Posix.IO (stdInput, stdOutput) import System.Posix.Types (Fd(..)) -- | Type of exceptions that can be raised when configuring Vty on a -- Unix system. data VtyUnixConfigurationError = MissingTermEnvVar -- ^ The @TERM@ environment variable is not set. deriving (Show, Eq, Typeable) instance Exception VtyUnixConfigurationError where displayException MissingTermEnvVar = "TERM environment variable not set" -- | Runtime library settings for interacting with Unix terminals. -- -- See this page for details on @VTIME@ and @VMIN@: -- -- http://unixwiz.net/techtips/termios-vmin-vtime.html data UnixSettings = UnixSettings { settingVmin :: Int -- ^ VMIN character count. , settingVtime :: Int -- ^ VTIME setting in tenths of a second. , settingInputFd :: Fd -- ^ The input file descriptor to use. , settingOutputFd :: Fd -- ^ The output file descriptor to use. , settingTermName :: String -- ^ The terminal name used to look up terminfo capabilities. } deriving (Show, Eq) -- | Default runtime settings used by the library. defaultSettings :: IO UnixSettings defaultSettings = do mb <- lookupEnv termVariable case mb of Nothing -> throwIO MissingTermEnvVar Just t -> do flushStdin return $ UnixSettings { settingVmin = 1 , settingVtime = 100 , settingInputFd = stdInput , settingOutputFd = stdOutput , settingTermName = t } termVariable :: String termVariable = "TERM" currentTerminalName :: IO (Maybe String) currentTerminalName = lookupEnv termVariable flushStdin :: IO () flushStdin = do hSetBuffering stdin NoBuffering whileM $ consume stdin whileM :: (Monad m) => m Bool -> m () whileM act = do continue <- act when continue $ whileM act consume :: Handle -> IO Bool consume h = do avail <- hReady h when avail $ void $ hGetChar h return avail vty-unix-0.2.0.0/tools/0000755000000000000000000000000007346545000013003 5ustar0000000000000000vty-unix-0.2.0.0/tools/BuildWidthTable.hs0000644000000000000000000000060007346545000016342 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Main where import System.Console.ANSI (getCursorPosition) import Text.Printf (printf) import Graphics.Vty.UnicodeWidthTable.Main (defaultMain) charWidth :: Char -> IO Int charWidth c = do printf "\r" putChar c Just (_, col) <- getCursorPosition return col main :: IO () main = defaultMain charWidth vty-unix-0.2.0.0/vty-unix.cabal0000644000000000000000000000556407346545000014444 0ustar0000000000000000cabal-version: 3.0 name: vty-unix version: 0.2.0.0 synopsis: Unix backend for Vty description: This package provides Unix terminal support for Vty. license: BSD-3-Clause license-file: LICENSE author: Jonathan Daugherty maintainer: cygnus@foobox.com category: User Interfaces copyright: (c) 2023 Jonathan Daugherty build-type: Simple extra-doc-files: CHANGELOG.md extra-source-files: cbits/gwinsz.h cbits/gwinsz.c cbits/set_term_timing.c source-repository head type: git location: https://github.com/jtdaugherty/vty-unix.git common warnings ghc-options: -Wall library import: warnings hs-source-dirs: src default-language: Haskell2010 includes: cbits/gwinsz.h c-sources: cbits/set_term_timing.c cbits/gwinsz.c exposed-modules: Data.Terminfo.Eval Data.Terminfo.Parse Graphics.Vty.Platform.Unix Graphics.Vty.Platform.Unix.Input Graphics.Vty.Platform.Unix.Input.Classify Graphics.Vty.Platform.Unix.Input.Classify.Parse Graphics.Vty.Platform.Unix.Input.Classify.Types Graphics.Vty.Platform.Unix.Input.Focus Graphics.Vty.Platform.Unix.Input.Loop Graphics.Vty.Platform.Unix.Input.Mouse Graphics.Vty.Platform.Unix.Input.Paste Graphics.Vty.Platform.Unix.Input.Terminfo Graphics.Vty.Platform.Unix.Input.Terminfo.ANSIVT Graphics.Vty.Platform.Unix.Output Graphics.Vty.Platform.Unix.Output.Color Graphics.Vty.Platform.Unix.Output.TerminfoBased Graphics.Vty.Platform.Unix.Output.XTermColor Graphics.Vty.Platform.Unix.Settings build-depends: base >= 4.8 && < 5, blaze-builder, bytestring, mtl, unix, terminfo, vty >= 6.1, deepseq, vector, parsec, containers, utf8-string, transformers, stm, microlens, microlens-mtl, microlens-th executable vty-unix-build-width-table main-is: BuildWidthTable.hs hs-source-dirs: tools default-language: Haskell2010 ghc-options: -threaded -Wall if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16 build-depends: base, vty, ansi-terminal