packages feed

vty 5.1.4 → 5.2.0

raw patch · 32 files changed

+315/−216 lines, 32 filesdep ~Cabal

Dependency ranges changed: Cabal

Files

CHANGELOG view
@@ -1,3 +1,16 @@+5.2.0+  - Config structure now specifies file descriptor to use. The default is stdInput and stdOutput+    file descriptors. Previously Vty used stdInput for input and the follow code for output:+      - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering` NoBuffering)+      - the difference was required by Vty.Inline. Now, Vty.Inline uses the Config structure options+        to acheive the same effect.+  - removed: derivedVtime, derivedVmin, inputForCurrentTerminal, inputForNameAndIO,+    outputForCurrentTerminal, outputForNameAndIO+  - added: inputForConfig, outputForConfig+  - updates to vty-rogue from jtdaugherty. Thanks! +  - the oldest version of GHC tested to support vty is 7.6.2.+  - the oldest version of GHC that vty compiles under is 7.4.2+ 5.1.4   - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi! @@ -65,9 +78,9 @@     - vty-event-echo       - view a input event log for vty. Example of interacting with user.       - test/EventEcho.hs-    - vty-rouge-      - The start of a rouge-like game. Example of layers and image build operations.-      - test/Rouge.hs+    - vty-rogue+      - The start of a rogue-like game. Example of layers and image build operations.+      - test/Rogue.hs     - vty-benchmark       - benchmarks vty. A series of tests that push random pictures to the terminal. The         random pictures are generated using QuickCheck. The same generators used in the
+ dist/build/verify-attribute-opsStub/verify-attribute-opsStub-tmp/verify-attribute-opsStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyAttributeOps ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-crop-span-generationStub/verify-crop-span-generationStub-tmp/verify-crop-span-generationStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyCropSpanGeneration ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-display-attributesStub/verify-display-attributesStub-tmp/verify-display-attributesStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyDisplayAttributes ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-empty-image-propsStub/verify-empty-image-propsStub-tmp/verify-empty-image-propsStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyEmptyImageProps ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-eval-terminfo-capsStub/verify-eval-terminfo-capsStub-tmp/verify-eval-terminfo-capsStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyEvalTerminfoCaps ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-image-opsStub/verify-image-opsStub-tmp/verify-image-opsStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyImageOps ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-image-transStub/verify-image-transStub-tmp/verify-image-transStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyImageTrans ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-inlineStub/verify-inlineStub-tmp/verify-inlineStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyInline ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-layers-span-generationStub/verify-layers-span-generationStub-tmp/verify-layers-span-generationStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyLayersSpanGeneration ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-parse-terminfo-capsStub/verify-parse-terminfo-capsStub-tmp/verify-parse-terminfo-capsStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyParseTerminfoCaps ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-simple-span-generationStub/verify-simple-span-generationStub-tmp/verify-simple-span-generationStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifySimpleSpanGeneration ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-terminalStub/verify-terminalStub-tmp/verify-terminalStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyOutput ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-using-mock-terminalStub/verify-using-mock-terminalStub-tmp/verify-using-mock-terminalStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyUsingMockTerminal ( tests )+main :: IO ()+main = stubMain tests
+ dist/build/verify-utf8-widthStub/verify-utf8-widthStub-tmp/verify-utf8-widthStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import VerifyUtf8Width ( tests )+main :: IO ()+main = stubMain tests
src/Graphics/Vty.hs view
@@ -108,9 +108,9 @@ -- For most applications @mkVty def@ is sufficient. mkVty :: Config -> IO Vty mkVty appConfig = do-    config <- mappend <$> pure appConfig <*> userConfig-    input  <- inputForCurrentTerminal config-    out    <- outputForCurrentTerminal config+    config <- (<> appConfig) <$> userConfig+    input  <- inputForConfig config+    out    <- outputForConfig config     intMkVty input out  intMkVty :: Input -> Output -> IO Vty
src/Graphics/Vty/Config.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE KindSignatures #-}@@ -65,13 +66,16 @@ -- module Graphics.Vty.Config where --- ignore warning on GHC 7.6+. Required for GHC 7.4+#if __GLASGOW_HASKELL__ > 704+import Prelude+#else import Prelude hiding (catch)+#endif  import Control.Applicative hiding (many) -import Control.Exception (tryJust, catch, IOException)-import Control.Monad (void, guard)+import Control.Exception (catch, IOException)+import Control.Monad (void) import Control.Monad.Trans.Class import Control.Monad.Trans.Writer @@ -82,8 +86,9 @@ import Graphics.Vty.Input.Events  import System.Directory (getAppUserDataDirectory)-import System.Environment (getEnv)-import System.IO.Error (isDoesNotExistError)+import System.Posix.Env (getEnv)+import System.Posix.IO (stdInput, stdOutput)+import System.Posix.Types (Fd(..))  import Text.Parsec hiding ((<|>)) import Text.Parsec.Token ( GenLanguageDef(..) )@@ -94,8 +99,11 @@ type InputMap = [(Maybe String, String, Event)]  data Config = Config-    { vmin  :: Maybe Int -- < See 'derivedVmin'-    , vtime :: Maybe Int -- < See 'derivedVtime'+    {+    -- | The default is 1 character.+      vmin  :: Maybe Int+    -- | The default is 100 milliseconds, 0.1 seconds.+    , vtime :: Maybe Int     -- | Debug information is appended to this file if not Nothing.     , debugLog           :: Maybe FilePath     -- | The (input byte, output event) pairs extend the internal input table of VTY and the table@@ -103,34 +111,37 @@     --     -- See "Graphics.Vty.Config" module documentation for documentation of the @map@ directive.     , inputMap           :: InputMap+    -- | The input file descriptor to use. The default is 'System.Posix.IO.stdInput'+    , inputFd           :: Maybe Fd+    -- | The output file descriptor to use. The default is 'System.Posix.IO.stdOutput'+    , outputFd          :: Maybe Fd+    -- | The terminal name used to look up terminfo capabilities.+    -- The default is the value of the TERM environment variable.+    , termName           :: Maybe String     } deriving (Show, Eq) --- | The default is 100 milliseconds, 0.1 seconds.--- Set using the 'vtime' field of 'Config'-derivedVtime :: Config -> Int-derivedVtime = maybe 100 id . vtime---- | The default is 1 character.--- Set using the 'vmin' field of 'Config'-derivedVmin :: Config -> Int-derivedVmin = maybe 1 id . vmin- instance Default Config where     def = mempty  instance Monoid Config where     mempty = Config-        { vmin      = Nothing-        , vtime     = Nothing-        , debugLog  = mempty-        , inputMap  = mempty+        { vmin         = Nothing+        , vtime        = Nothing+        , debugLog     = mempty+        , inputMap     = mempty+        , inputFd     = Nothing+        , outputFd    = Nothing+        , termName     = Nothing         }     mappend c0 c1 = Config-        -- latter config takes priority in vmin, vtime, debugInputLog-        { vmin      = vmin c1     <|> vmin c0-        , vtime     = vtime c1    <|> vtime c0-        , debugLog  = debugLog c1 <|> debugLog c0-        , inputMap  = inputMap c0 <>  inputMap c1+        -- latter config takes priority for everything but inputMap+        { vmin          = vmin c1     <|> vmin c0+        , vtime         = vtime c1    <|> vtime c0+        , debugLog      = debugLog c1 <|> debugLog c0+        , inputMap      = inputMap c0 <>  inputMap c1+        , inputFd      = inputFd c1 <|> inputFd c1+        , outputFd     = outputFd c1 <|> outputFd c1+        , termName      = termName c1 <|> termName c0         }  type ConfigParser s a = ParsecT s () (Writer Config) a@@ -139,12 +150,24 @@ userConfig :: IO Config userConfig = do     configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile-    let maybeEnv = tryJust (guard . isDoesNotExistError) . getEnv-    overridePath <- maybeEnv "VTY_CONFIG_FILE"-    overrideConfig <- either (const $ return def) parseConfigFile overridePath-    debugLogPath <- maybeEnv "VTY_DEBUG_LOG"-    let debugLogConfig = either (const def) (\p -> def { debugLog = Just p }) debugLogPath-    return $ mconcat [configFile, overrideConfig, debugLogConfig]+    overrideConfig <- maybe (return def) parseConfigFile =<< getEnv "VTY_CONFIG_FILE"+    base <- (<> configFile <> overrideConfig) <$> standardIOConfig+    (mappend base) <$> overrideEnvConfig++overrideEnvConfig :: IO Config+overrideEnvConfig = do+    d <- getEnv "VTY_DEBUG_LOG"+    return $ def { debugLog = d }++standardIOConfig :: IO Config+standardIOConfig = do+    Just t <- getEnv "TERM"+    return $ def { vmin = Just 1+                 , vtime = Just 100+                 , inputFd = Just stdInput+                 , outputFd = Just stdOutput+                 , termName = Just t+                 }  parseConfigFile :: FilePath -> IO Config parseConfigFile path = do
src/Graphics/Vty/Inline/Unsafe.hs view
@@ -1,13 +1,23 @@+{-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} module Graphics.Vty.Inline.Unsafe where  import Graphics.Vty +import Control.Applicative+ import Data.Default+import Data.Monoid import Data.IORef +import GHC.IO.Handle (hDuplicate)++import System.IO (stdin, stdout, hSetBuffering, BufferMode(NoBuffering))+ import System.IO.Unsafe +import System.Posix.IO (handleToFd)+ globalVty :: IORef (Maybe Vty) {-# NOINLINE globalVty #-} globalVty = unsafePerformIO $ newIORef Nothing@@ -16,14 +26,24 @@ {-# NOINLINE globalOutput #-} globalOutput = unsafePerformIO $ newIORef Nothing +mkDupeConfig :: IO Config+mkDupeConfig = do+    hSetBuffering stdout NoBuffering+    hSetBuffering stdin NoBuffering+    stdinDupe <- hDuplicate stdin >>= handleToFd+    stdoutDupe <- hDuplicate stdout >>= handleToFd+    return $ def { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }+ -- | This will create a Vty instance using 'mkVty' and execute an IO action provided that instance. -- The created Vty instance will be stored to the unsafe 'IORef' 'globalVty'.+--+-- This instance will use duplicates of the stdin and stdout Handles. withVty :: (Vty -> IO b) -> IO b withVty f = do     mvty <- readIORef globalVty     vty <- case mvty of         Nothing -> do-            vty <- mkVty $ def+            vty <- mkDupeConfig >>= mkVty             writeIORef globalVty (Just vty)             return vty         Just vty -> return vty@@ -34,8 +54,8 @@     mout <- readIORef globalOutput     out <- case mout of         Nothing -> do-            config <- userConfig-            out <- outputForCurrentTerminal config+            config <- (<>) <$> userConfig <*> mkDupeConfig+            out <- outputForConfig config             writeIORef globalOutput (Just out)             return out         Just out -> return out
src/Graphics/Vty/Input.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} -- | The input layer for VTY. This provides methods for initializing an 'Input' structure which can -- then be used to read 'Event's from the terminal. --@@ -120,8 +121,7 @@                           , Button(..)                           , Event(..)                           , Input(..)-                          , inputForCurrentTerminal-                          , inputForNameAndIO+                          , inputForConfig                           )     where @@ -133,22 +133,13 @@ import Control.Concurrent import Control.Lens +import Data.Functor ((<$>)) import Data.Monoid  import qualified System.Console.Terminfo as Terminfo-import System.Environment import System.Posix.Signals.Exts-import System.Posix.IO (stdInput)-import System.Posix.Types (Fd) --- | Set up the current terminal for input.--- This determines the current terminal then invokes 'inputForNameAndIO'-inputForCurrentTerminal :: Config -> IO Input-inputForCurrentTerminal config = do-    termName <- getEnv "TERM"-    inputForNameAndIO config termName stdInput---- | Set up the terminal attached to the given Fd for input.  Returns a 'Input'.+-- | Set up the terminal with file descriptor `inputFd` for input.  Returns a 'Input'. -- -- The table used to determine the 'Events' to produce for the input bytes comes from -- 'classifyMapForTerm'. Which is then overridden by the the applicable entries from@@ -175,16 +166,20 @@ --      - canonical mode (line mode) input is not used. TODO: should be a dynamic option. -- -- * IEXTEN disabled---      - extended functions are disabled. TODO: Uh. Whatever these are.+--      - extended functions are disabled. TODO: I don't know what those are. ---inputForNameAndIO :: Config -> String -> Fd -> IO Input-inputForNameAndIO config termName termFd = do+inputForConfig :: Config -> IO Input+inputForConfig config@Config{ termName = Just termName+                            , inputFd = Just termFd+                            , vmin = Just _+                            , vtime = Just _+                            , .. } = do     terminal <- Terminfo.setupTerm termName-    let inputOverrides = [(s,e) | (t,s,e) <- inputMap config, t == Nothing || t == Just termName]+    let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]         activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides     (setAttrs,unsetAttrs) <- attributeControl termFd     setAttrs-    input <- initInputForFd config termName activeInputMap termFd +    input <- initInput config activeInputMap     let pokeIO = Catch $ do             let e = error "vty internal failure: this value should not propagate to users"             setAttrs@@ -198,3 +193,4 @@             _ <- installHandler continueProcess Ignore Nothing             unsetAttrs         }+inputForConfig config = mappend config <$> standardIOConfig >>= inputForConfig
src/Graphics/Vty/Input/Loop.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE TemplateHaskell #-}@@ -47,8 +48,6 @@     , shutdownInput :: IO ()       -- | Changes to this value are reflected after the next event.     , _configRef :: IORef Config-      -- | File descriptor used for input.-    , _inputFd :: Fd       -- | input debug log     , _inputDebug :: Maybe Handle     }@@ -108,10 +107,10 @@ readFromDevice = do     newConfig <- view configRef >>= liftIO . readIORef     oldConfig <- use appliedConfig-    fd <- view inputFd+    let Just fd = inputFd newConfig     when (newConfig /= oldConfig) $ do         logMsg $ "new config: " ++ show newConfig-        liftIO $ applyTimingConfig fd newConfig+        liftIO $ applyConfig fd newConfig         appliedConfig .= newConfig     bufferPtr <- use $ inputBuffer.ptr     maxBytes  <- use $ inputBuffer.size@@ -123,9 +122,10 @@     when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep     return stringRep -applyTimingConfig :: Fd -> Config -> IO ()-applyTimingConfig fd config = setTermTiming fd (derivedVmin config)-                                               (derivedVtime config `div` 100)+applyConfig :: Fd -> Config -> IO ()+applyConfig fd (Config{ vmin = Just theVmin, vtime = Just theVtime })+    = setTermTiming fd theVmin (theVtime `div` 100)+applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configuration"  parseEvent :: InputM Event parseEvent = do@@ -172,32 +172,34 @@         unsetAttrs = setTerminalAttributes fd original Immediately     return (setAttrs,unsetAttrs) -logInitialInputState :: Input -> String -> ClassifyMap -> IO()-logInitialInputState input termName classifyTable = case _inputDebug input of+logInitialInputState :: Input -> ClassifyMap -> IO()+logInitialInputState input classifyTable = case _inputDebug input of     Nothing -> return ()     Just h  -> do-        config <- readIORef $ _configRef input-        _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (vmin config, vtime config))+        Config{ vmin = Just theVmin+              , vtime = Just theVtime+              , termName = Just theTerm, .. } <- readIORef $ _configRef input+        _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))         forM_ classifyTable $ \i -> case i of-            (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show termName)+            (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)                                                                      (show inBytes)                                                                      (show k)                                                                      (show mods)             _ -> return () -initInputForFd :: Config -> String -> ClassifyMap -> Fd -> IO Input-initInputForFd config termName classifyTable inFd = do-    setFdOption inFd NonBlockingRead False-    applyTimingConfig inFd config+initInput :: Config -> ClassifyMap -> IO Input+initInput config classifyTable = do+    let Just fd = inputFd config+    setFdOption fd NonBlockingRead False+    applyConfig fd config     stopFlag <- newIORef False     input <- Input <$> newChan                    <*> pure (writeIORef stopFlag True)                    <*> newIORef config-                   <*> pure inFd                    <*> maybe (return Nothing)                              (\f -> Just <$> openFile f AppendMode)                              (debugLog config)-    logInitialInputState input termName classifyTable+    logInitialInputState input classifyTable     _ <- forkOS $ runInputProcessorLoop classifyTable input stopFlag     return input
src/Graphics/Vty/Input/Terminfo.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Graphics.Vty.Input.Terminfo where  import Graphics.Vty.Input.Events
src/Graphics/Vty/Output.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-} --  | Output interface. -- --  Access to the current terminal or a specific terminal device.@@ -37,25 +39,23 @@  import Blaze.ByteString.Builder (writeToByteString) -import Control.Exception ( SomeException, try ) import Control.Monad.Trans -import Data.List ( isPrefixOf )--import GHC.IO.Handle+import Data.Monoid (mappend)+import Data.List (isPrefixOf) -import System.Environment-import System.IO+import System.Posix.Env (getEnv) --- | Returns a `Output` for the current terminal as determined by TERM.+-- | Returns a `Output` for the terminal specified in `Config` -- -- The specific Output implementation used is hidden from the API user. All terminal implementations--- are assumed to perform more, or less, the same. Currently all implementations use terminfo for at--- least some terminal specific information. This is why platforms without terminfo are not--- supported. However, as mentioned before, any specifics about it being based on terminfo are--- hidden from the API user.  If a terminal implementation is developed for a terminal for a--- platform without terminfo support then Vty should work as expected on that terminal.+-- are assumed to perform more, or less, the same. Currently, all implementations use terminfo for at+-- least some terminal specific information. --+-- Specifics about it being based on terminfo are hidden from the API user. If a terminal+-- implementation is developed for a terminal without terminfo support then Vty should work as+-- expected on that terminal.+-- -- Selection of a terminal is done as follows: -- --      * If TERM == xterm@@ -72,43 +72,30 @@ -- environment variables (I think?) this assumes that XTERM_VERSION will never be set for a true -- Terminal.app or iTerm.app session. ----- The file descriptor used for output will a be a duplicate of the current stdout file descriptor.--- -- \todo add an implementation for windows that does not depend on terminfo. Should be installable -- with only what is provided in the haskell platform. Use ansi-terminal-outputForCurrentTerminal :: ( Applicative m, MonadIO m ) => Config -> m Output-outputForCurrentTerminal _config = do-    termType <- liftIO $ getEnv "TERM"-    outHandle <- liftIO $ hDuplicate stdout-    outputForNameAndIO termType outHandle---- | gives an output method structure for a terminal with the given name and the given 'Handle'.-outputForNameAndIO :: (Applicative m, MonadIO m) => String -> Handle -> m Output-outputForNameAndIO termType outHandle = do-    t <- if "xterm" `isPrefixOf` termType+outputForConfig :: Config -> IO Output+outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do+    t <- if "xterm" `isPrefixOf` termName         then do-            maybeTerminalApp <- mGetEnv "TERM_PROGRAM"+            -- the explicit nature of the code below was nice for development, not needed anymore.+            maybeTerminalApp <- getEnv "TERM_PROGRAM"             case maybeTerminalApp of                 Nothing-                    -> XTermColor.reserveTerminal termType outHandle+                    -> XTermColor.reserveTerminal termName fd                 Just v | v == "Apple_Terminal" || v == "iTerm.app"                      -> do-                        maybeXterm <- mGetEnv "XTERM_VERSION"+                        maybeXterm <- getEnv "XTERM_VERSION"                         case maybeXterm of-                            Nothing -> MacOSX.reserveTerminal v outHandle-                            Just _  -> XTermColor.reserveTerminal termType outHandle+                            Nothing -> MacOSX.reserveTerminal v fd+                            Just _  -> XTermColor.reserveTerminal termName fd                 -- Assume any other terminal that sets TERM_PROGRAM to not be an OS X terminal.app                 -- like terminal?-                _   -> XTermColor.reserveTerminal termType outHandle+                _   -> XTermColor.reserveTerminal termName fd         -- Not an xterm-like terminal. try for generic terminfo.-        else TerminfoBased.reserveTerminal termType outHandle+        else TerminfoBased.reserveTerminal termName fd     return t-    where-        mGetEnv var = do-            mv <- liftIO $ try $ getEnv var-            case mv of-                Left (_e :: SomeException)  -> return $ Nothing-                Right v -> return $ Just v+outputForConfig config = mappend config <$> standardIOConfig >>= outputForConfig  -- | Sets the cursor position to the given output column and row.  --
src/Graphics/Vty/Output/Interface.hs view
@@ -247,9 +247,9 @@             | otherwise                          = SetTo $ ISOColor v         clampColor' (Color240 v)             -- TODO: Choose closes ISO color?-            | contextColorCount t < 8            = Default-            | contextColorCount t < 16           = Default-            | contextColorCount t == 240         = SetTo $ Color240 v+            | contextColorCount t <  8           = Default+            | contextColorCount t <  16          = Default+            | contextColorCount t <= 256         = SetTo $ Color240 v             | otherwise                  = let p :: Double = fromIntegral v / 240.0                        v' = floor $ p * (fromIntegral $ contextColorCount t)
src/Graphics/Vty/Output/MacOSX.hs view
@@ -15,23 +15,23 @@ import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased  import Control.Applicative+import Control.Monad (void) import Control.Monad.Trans -import System.IO+import System.Posix.IO (fdWrite)+import System.Posix.Types (Fd)  -- | for Terminal.app the terminal identifier "xterm" is used. For iTerm.app the terminal identifier -- "xterm-256color" is used. -- -- This effects the terminfo lookup.-reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output-reserveTerminal v outHandle = do+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output+reserveTerminal v outFd = do     let remapTerm "iTerm.app" = "xterm-256color"         remapTerm _ = "xterm"         flushedPut :: String -> IO ()-        flushedPut str = do-            hPutStr outHandle str-            hFlush outHandle-    t <- TerminfoBased.reserveTerminal (remapTerm v) outHandle+        flushedPut = void . fdWrite outFd+    t <- TerminfoBased.reserveTerminal (remapTerm v) outFd     return $ t { terminalID = terminalID t ++ " (Mac)"                , reserveDisplay = terminalAppReserveDisplay flushedPut                , releaseDisplay = terminalAppReleaseDisplay flushedPut
src/Graphics/Vty/Output/TerminfoBased.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-}+{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 -fno-warn-warnings-deprecations #-} {-# CFILES gwinsz.c #-} -- |  Terminfo based terminal handling. --@@ -15,7 +15,7 @@  import Graphics.Vty.Prelude -import qualified Data.ByteString as BS+import Data.ByteString.Internal (toForeignPtr) import Data.Terminfo.Parse import Data.Terminfo.Eval @@ -32,31 +32,14 @@ import Data.IORef import Data.Maybe (isJust, isNothing, fromJust) import Data.Monoid+import Data.Word  import Foreign.C.Types ( CInt(..), CLong(..) )--import GHC.IO.Handle-#ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ >= 611-import GHC.IO.Handle.Internals (withHandle_)-import GHC.IO.Handle.Types (Handle__(..))-import qualified GHC.IO.FD as FD--- import qualified GHC.IO.Handle.FD as FD-import GHC.IO.Exception-import Data.Typeable (cast)-#else-import GHC.IOBase-import GHC.Handle hiding (fdToHandle)-import qualified GHC.Handle-#endif-#endif+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr)  import qualified System.Console.Terminfo as Terminfo-#ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ >= 611-import System.IO.Error-#endif-#endif +import System.Posix.IO (fdWriteBuf) import System.Posix.Types (Fd(..))  data TerminfoCaps = TerminfoCaps @@ -86,6 +69,19 @@     , 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@@ -101,9 +97,9 @@  - todo: Some display attributes like underline and bold have independent string capabilities that  - should be used instead of the generic "sgr" string capability.  -}-reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output-reserveTerminal inID outHandle = liftIO $ do-    ti <- Terminfo.setupTerm inID+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output+reserveTerminal termName outFd = liftIO $ 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"@@ -113,14 +109,14 @@                 Just setaf -> (False, False, setaf)                 Nothing -> case msetf of                     Just setf -> (False, True, setf)-                    Nothing -> (True, True, error $ "no fore color support for terminal " ++ inID)+                    Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)     msetab <- probeCap ti "setab"     msetb <- probeCap ti "setb"     let set_back_cap              = case msetab of                 Nothing -> case msetb of                     Just setb -> setb-                    Nothing -> error $ "no back color support for terminal " ++ inID+                    Nothing -> error $ "no back color support for terminal " ++ termName                 Just setab -> setab     terminfoCaps <- pure TerminfoCaps         <*> probeCap ti "smcup"@@ -138,28 +134,30 @@         <*> currentDisplayAttrCaps ti     newAssumedStateRef <- newIORef initialAssumedState     let t = Output-            { terminalID = inID+            { terminalID = termName             , releaseTerminal = liftIO $ do                 sendCap setDefaultAttr []                 maybeSendCap cnorm []-                hClose outHandle             , reserveDisplay = liftIO $ 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 []-                hFlush outHandle                 sendCap clearScreen []             , releaseDisplay = liftIO $ do                 maybeSendCap rmcup []                 maybeSendCap cnorm []             , displayBounds = do-                rawSize <- liftIO $ withFd outHandle getWindowSize+                rawSize <- liftIO $ getWindowSize outFd                 case rawSize of                     (w, h)  | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize                             | otherwise      -> return (w,h)             , outputByteBuffer = \outBytes -> do-                BS.hPut outHandle outBytes-                hFlush outHandle+                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."             , contextColorCount                 = case supportsNoColors terminfoCaps of                     False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of@@ -262,7 +260,7 @@ -- This equation implements the above logic. -- -- \todo This assumes the removal of color changes in the display attributes is done as expected--- with noColors == True. See `limit_attr_for_display`+-- with noColors == True. See `limitAttrForDisplay` -- -- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I -- haven't measured this or even examined terminal implementations. *shrug*@@ -462,22 +460,3 @@                 then []                 else [op] --- from https://patch-tag.com/r/mae/sendfile/snapshot/current/content/pretty/src/Network/Socket/SendFile/Internal.hs--- The Fd should not be used after the action returns because the--- Handler may be garbage collected and than will cause the finalizer--- to close the fd.-withFd :: Handle -> (Fd -> IO a) -> IO a-#ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ >= 611-withFd h f = withHandle_ "withFd" h $ \ Handle__{..} -> do-  case cast haDevice of-    Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation-                                           "withFd" (Just h) Nothing)-                        "handle is not a file descriptor")-    Just fd -> f (Fd (fromIntegral (FD.fdFD fd)))-#else-withFd h f =-    withHandle_ "withFd" h $ \ h_ ->-      f (Fd (fromIntegral (haFD h_)))-#endif-#endif
src/Graphics/Vty/Output/XTermColor.hs view
@@ -9,23 +9,23 @@ import Blaze.ByteString.Builder.Word (writeWord8)  import Control.Applicative+import Control.Monad (void) import Control.Monad.Trans  import Data.Foldable (foldMap) -import System.IO+import System.Posix.IO (fdWrite)+import System.Posix.Types (Fd)  -- | Initialize the display to UTF-8. -reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output-reserveTerminal variant outHandle = liftIO $ do-    let flushedPut str = do-            hPutStr outHandle str-            hFlush outHandle+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output+reserveTerminal variant outFd = 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     flushedPut setUtf8CharSet-    t <- TerminfoBased.reserveTerminal variant' outHandle+    t <- TerminfoBased.reserveTerminal variant' outFd     let t' = t              { terminalID = terminalID t ++ " (xterm-color)"              , releaseTerminal = do
src/Graphics/Vty/PictureToSpans.hs view
@@ -1,9 +1,10 @@ -- Copyright Corey O'Connor<coreyoconnor@gmail.com>-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-} {- | Transforms an image into rows of operations.  -} module Graphics.Vty.PictureToSpans where@@ -18,7 +19,12 @@ import Control.Lens hiding ( op ) import Control.Monad.Reader import Control.Monad.State.Strict hiding ( state )++#if __GLASGOW_HASKELL__ < 708 import Control.Monad.ST.Strict hiding ( unsafeIOToST )+#else+import Control.Monad.ST.Strict+#endif  import qualified Data.Vector as Vector hiding ( take, replicate ) import Data.Monoid (mappend)
test/Verify.hs view
@@ -84,7 +84,7 @@         ++ [ toEnum 0x309B .. toEnum 0xA4CF ]  liftIOResult :: Testable prop => IO prop -> Property-liftIOResult = morallyDubiousIOProperty+liftIOResult = ioProperty  #if __GLASGOW_HASKELL__ <= 701 instance Random Word where
test/VerifyConfig.hs view
@@ -4,19 +4,12 @@ import Graphics.Vty.Config import Graphics.Vty.Input.Events -import Control.Applicative-import Control.Exception-import Control.Lens ((^.))-import Control.Monad- import Data.Default import Data.String.QQ  import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit hiding (Test)--import Text.Printf  exampleConfig :: String exampleConfig = [s|
test/VerifyOutput.hs view
@@ -12,9 +12,11 @@  import Control.Monad +import Data.Default+ import qualified System.Console.Terminfo as Terminfo import System.Posix.Env-import System.IO+import System.Posix.IO  tests :: IO [Test] tests = concat <$> forM terminalsOfInterest (\termName -> do@@ -45,8 +47,8 @@  smokeTestTerm :: String -> Image -> IO Result smokeTestTerm termName i = do-    nullOut <- openFile "/dev/null" WriteMode-    t <- outputForNameAndIO termName nullOut+    nullOut <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags+    t <- outputForConfig $ def { outputFd = Just nullOut, termName = Just termName }     -- putStrLn $ "context color count: " ++ show (contextColorCount t)     reserveDisplay t     dc <- displayContext t (100,100)@@ -59,5 +61,6 @@         showCursor t     releaseDisplay t     releaseTerminal t+    closeFd nullOut     return succeeded
test/VerifyUsingMockInput.hs view
@@ -110,7 +110,12 @@     (writeFd, readFd) <- openPseudoTerminal     (setTermAttr,_) <- attributeControl readFd     setTermAttr-    input <- initInputForFd def "dummy" table readFd+    let testConfig = def { inputFd = Just readFd+                         , termName = Just "dummy"+                         , vmin = Just 1+                         , vtime = Just 100+                         }+    input <- initInput testConfig table     eventsRef <- newIORef []     let writeWaitClose = do             synthesizeInput inputSpec writeFd
vty.cabal view
@@ -1,5 +1,5 @@ name:                vty-version:             5.1.4+version:             5.2.0 license:             BSD3 license-file:        LICENSE author:              AUTHORS@@ -137,7 +137,7 @@   hs-source-dirs:      test   test-module:         VerifyAttributeOps   build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -169,7 +169,7 @@                        Verify.Graphics.Vty.Output    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -202,12 +202,13 @@                        Verify.Graphics.Vty.Output    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,                        bytestring,                        containers,+                       data-default >= 0.5.3,                        deepseq >= 1.1 && < 1.4,                        mtl >= 1.1.1.0 && < 2.3,                        terminfo >= 0.3 && < 0.5,@@ -235,7 +236,7 @@                        Verify.Graphics.Vty.Span    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -261,7 +262,7 @@   other-modules:       Verify    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -288,7 +289,7 @@                        Verify.Graphics.Vty.Output    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -318,7 +319,7 @@                        Verify.Graphics.Vty.Image    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -346,7 +347,7 @@                        Verify.Graphics.Vty.Image    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -373,7 +374,7 @@                        Verify.Graphics.Vty.Output    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -401,7 +402,7 @@                        Verify.Graphics.Vty.Output    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -433,7 +434,7 @@                        Verify.Graphics.Vty.Span    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -465,7 +466,7 @@                        Verify.Graphics.Vty.Span    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -497,7 +498,7 @@                        Verify.Graphics.Vty.Span    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -523,7 +524,7 @@   other-modules:       Verify    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        QuickCheck >= 2.4,                        random == 1.0.*,                        base >= 4 && < 5,@@ -547,7 +548,7 @@   main-is:             VerifyUsingMockInput.hs    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        data-default >= 0.5.3,                        QuickCheck >= 2.4,                        smallcheck == 1.*,@@ -580,7 +581,7 @@   main-is:             VerifyConfig.hs    build-depends:       vty,-                       Cabal == 1.20.*,+                       Cabal >= 1.18,                        data-default >= 0.5.3,                        HUnit,                        QuickCheck >= 2.4,