packages feed

vty-unix (empty) → 0.1.0.0

raw patch · 25 files changed

+2815/−0 lines, 25 filesdep +ansi-terminaldep +basedep +blaze-builder

Dependencies added: ansi-terminal, base, blaze-builder, bytestring, containers, deepseq, microlens, microlens-mtl, microlens-th, mtl, parsec, semigroups, stm, terminfo, transformers, unix, utf8-string, vector, vty

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@++0.1.0.0+=======++Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (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.
+ cbits/gwinsz.c view
@@ -0,0 +1,18 @@+#include <sys/ioctl.h>++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);+    }+}
+ cbits/gwinsz.h view
@@ -0,0 +1,2 @@+unsigned long vty_c_get_window_size(int fd);+unsigned long vty_c_set_window_size(int fd, unsigned long val);
+ cbits/set_term_timing.c view
@@ -0,0 +1,13 @@+#include <termios.h>+#include <stdio.h>+#include <unistd.h>+#include <stdlib.h>++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);+}
+ src/Data/Terminfo/Eval.hs view
@@ -0,0 +1,134 @@+{-# 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
+ src/Data/Terminfo/Parse.hs view
@@ -0,0 +1,348 @@+{-# 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
+ src/Graphics/Vty/Platform/Unix.hs view
@@ -0,0 +1,61 @@+-- | 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 settings+    mkVtyFromPair input out
+ src/Graphics/Vty/Platform/Unix/Input.hs view
@@ -0,0 +1,205 @@+{-# 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)
+ src/Graphics/Vty/Platform/Unix/Input/Classify.hs view
@@ -0,0 +1,98 @@+{-# 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
+ src/Graphics/Vty/Platform/Unix/Input/Classify/Parse.hs view
@@ -0,0 +1,64 @@+-- | 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
+ src/Graphics/Vty/Platform/Unix/Input/Classify/Types.hs view
@@ -0,0 +1,39 @@+-- | 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)
+ src/Graphics/Vty/Platform/Unix/Input/Focus.hs view
@@ -0,0 +1,53 @@+-- | 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
+ src/Graphics/Vty/Platform/Unix/Input/Loop.hs view
@@ -0,0 +1,194 @@+{-# 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)
+ src/Graphics/Vty/Platform/Unix/Input/Mouse.hs view
@@ -0,0 +1,166 @@+-- | 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
+ src/Graphics/Vty/Platform/Unix/Input/Paste.hs view
@@ -0,0 +1,44 @@+-- | 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
+ src/Graphics/Vty/Platform/Unix/Input/Terminfo.hs view
@@ -0,0 +1,201 @@+-- | 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) [])
+ src/Graphics/Vty/Platform/Unix/Input/Terminfo/ANSIVT.hs view
@@ -0,0 +1,92 @@+-- | 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+    ]
+ src/Graphics/Vty/Platform/Unix/Output.hs view
@@ -0,0 +1,59 @@+{-# 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.Output++import Graphics.Vty.Platform.Unix.Settings+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 :: UnixSettings -> IO Output+buildOutput settings = do+    let termName = settingTermName settings+        fd = settingOutputFd settings+        colorMode = settingColorMode settings++    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"+    ]
+ src/Graphics/Vty/Platform/Unix/Output/Color.hs view
@@ -0,0 +1,34 @@+{-# 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
+ src/Graphics/Vty/Platform/Unix/Output/TerminfoBased.hs view
@@ -0,0 +1,604 @@+{-# 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]
+ src/Graphics/Vty/Platform/Unix/Output/XTermColor.hs view
@@ -0,0 +1,152 @@+{-# 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
+ src/Graphics/Vty/Platform/Unix/Settings.hs view
@@ -0,0 +1,102 @@+{-# 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(..))++import Graphics.Vty.Attributes.Color+import Graphics.Vty.Platform.Unix.Output.Color (detectColorMode)++-- | 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.+                 , settingColorMode :: ColorMode+                 -- ^ The color mode used to know how many colors the terminal+                 -- supports.+                 }+                 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+        mcolorMode <- detectColorMode t+        flushStdin+        return $ UnixSettings { settingVmin      = 1+                              , settingVtime     = 100+                              , settingInputFd   = stdInput+                              , settingOutputFd  = stdOutput+                              , settingTermName  = t+                              , settingColorMode = mcolorMode+                              }++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
+ tools/BuildWidthTable.hs view
@@ -0,0 +1,18 @@+{-# 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.cabal view
@@ -0,0 +1,79 @@+cabal-version:      3.0+name:               vty-unix+version:            0.1.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.0,+                      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