ddd61dd · vty · git.iko.soy

CHANGELOG+10

@@ -1,3 +1,13 @@

1+5.2.0

2+ - Config structure now specifies file descriptor to use. The default is stdInput and stdOutput

3+ file descriptors. Previously Vty used stdInput for input and the follow code for output:

4+ - hDuplicate stdout >>= handleToFd >>= (`hSetBuffering` NoBuffering)

5+ - the difference was required by Vty.Inline. Now, Vty.Inline uses the Config structure options

6+ to acheive the same effect.

7+ - removed: derivedVtime, derivedVmin, inputForCurrentTerminal, inputForNameAndIO,

8+ outputForCurrentTerminal, outputForNameAndIO

9+ - added: inputForConfig, outputForConfig

10+ - updates to vty-rogue from jtdaugherty. Thanks!

1115.1.4

212 - merged https://github.com/coreyoconnor/vty/pull/51 thanks trofi!

313

src/Graphics/Vty.hs+3−3

@@ -108,9 +108,9 @@ data Vty = Vty

108108-- For most applications @mkVty def@ is sufficient.

109109mkVty :: Config -> IO Vty

110110mkVty appConfig = do

111− config <- mappend <$> pure appConfig <*> userConfig

112− input <- inputForCurrentTerminal config

113− out <- outputForCurrentTerminal config

111+ config <- (<> appConfig) <$> userConfig

112+ input <- inputForConfig config

113+ out <- outputForConfig config

114114 intMkVty input out

115115

116116intMkVty :: Input -> Output -> IO Vty

src/Graphics/Vty/Config.hs+53−28

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE FlexibleContexts #-}

23{-# LANGUAGE NoMonomorphismRestriction #-}

34{-# LANGUAGE KindSignatures #-}

@@ -66,7 +67,11 @@

6667module Graphics.Vty.Config where

6768

6869-- ignore warning on GHC 7.6+. Required for GHC 7.4

70+#if __GLASGOW_HASKELL__ >= 704

71+import Prelude

72+#else

6973import Prelude hiding (catch)

74+#endif

7075

7176import Control.Applicative hiding (many)

7277

@@ -82,8 +87,10 @@ import Data.Monoid

8287import Graphics.Vty.Input.Events

8388

8489import System.Directory (getAppUserDataDirectory)

85−import System.Environment (getEnv)

8690import System.IO.Error (isDoesNotExistError)

91+import System.Posix.Env (getEnv)

92+import System.Posix.IO (stdInput, stdOutput)

93+import System.Posix.Types (Fd(..))

8794

8895import Text.Parsec hiding ((<|>))

8996import Text.Parsec.Token ( GenLanguageDef(..) )

@@ -94,8 +101,11 @@ import qualified Text.Parsec.Token as P

94101type InputMap = [(Maybe String, String, Event)]

95102

96103data Config = Config

97− { vmin :: Maybe Int -- < See 'derivedVmin'

98− , vtime :: Maybe Int -- < See 'derivedVtime'

104+ {

105+ -- | The default is 1 character.

106+ vmin :: Maybe Int

107+ -- | The default is 100 milliseconds, 0.1 seconds.

108+ , vtime :: Maybe Int

99109 -- | Debug information is appended to this file if not Nothing.

100110 , debugLog :: Maybe FilePath

101111 -- | The (input byte, output event) pairs extend the internal input table of VTY and the table

@@ -103,34 +113,37 @@ data Config = Config

103113 --

104114 -- See "Graphics.Vty.Config" module documentation for documentation of the @map@ directive.

105115 , inputMap :: InputMap

116+ -- | The input file descriptor to use. The default is 'System.Posix.IO.stdInput'

117+ , inputFd :: Maybe Fd

118+ -- | The output file descriptor to use. The default is 'System.Posix.IO.stdOutput'

119+ , outputFd :: Maybe Fd

120+ -- | The terminal name used to look up terminfo capabilities.

121+ -- The default is the value of the TERM environment variable.

122+ , termName :: Maybe String

106123 } deriving (Show, Eq)

107124

108−-- | The default is 100 milliseconds, 0.1 seconds.

109−-- Set using the 'vtime' field of 'Config'

110−derivedVtime :: Config -> Int

111−derivedVtime = maybe 100 id . vtime

112−

113−-- | The default is 1 character.

114−-- Set using the 'vmin' field of 'Config'

115−derivedVmin :: Config -> Int

116−derivedVmin = maybe 1 id . vmin

117−

118125instance Default Config where

119126 def = mempty

120127

121128instance Monoid Config where

122129 mempty = Config

123− { vmin = Nothing

124− , vtime = Nothing

125− , debugLog = mempty

126− , inputMap = mempty

130+ { vmin = Nothing

131+ , vtime = Nothing

132+ , debugLog = mempty

133+ , inputMap = mempty

134+ , inputFd = Nothing

135+ , outputFd = Nothing

136+ , termName = Nothing

127137 }

128138 mappend c0 c1 = Config

129− -- latter config takes priority in vmin, vtime, debugInputLog

130− { vmin = vmin c1 <|> vmin c0

131− , vtime = vtime c1 <|> vtime c0

132− , debugLog = debugLog c1 <|> debugLog c0

133− , inputMap = inputMap c0 <> inputMap c1

139+ -- latter config takes priority for everything but inputMap

140+ { vmin = vmin c1 <|> vmin c0

141+ , vtime = vtime c1 <|> vtime c0

142+ , debugLog = debugLog c1 <|> debugLog c0

143+ , inputMap = inputMap c0 <> inputMap c1

144+ , inputFd = inputFd c1 <|> inputFd c1

145+ , outputFd = outputFd c1 <|> outputFd c1

146+ , termName = termName c1 <|> termName c0

134147 }

135148

136149type ConfigParser s a = ParsecT s () (Writer Config) a

@@ -139,12 +152,24 @@ type ConfigParser s a = ParsecT s () (Writer Config) a

139152userConfig :: IO Config

140153userConfig = do

141154 configFile <- (mappend <$> getAppUserDataDirectory "vty" <*> pure "/config") >>= parseConfigFile

142− let maybeEnv = tryJust (guard . isDoesNotExistError) . getEnv

143− overridePath <- maybeEnv "VTY_CONFIG_FILE"

144− overrideConfig <- either (const $ return def) parseConfigFile overridePath

145− debugLogPath <- maybeEnv "VTY_DEBUG_LOG"

146− let debugLogConfig = either (const def) (\p -> def { debugLog = Just p }) debugLogPath

147− return $ mconcat [configFile, overrideConfig, debugLogConfig]

155+ overrideConfig <- maybe (return def) parseConfigFile =<< getEnv "VTY_CONFIG_FILE"

156+ base <- (<> configFile <> overrideConfig) <$> standardIOConfig

157+ (mappend base) <$> overrideEnvConfig

158+

159+overrideEnvConfig :: IO Config

160+overrideEnvConfig = do

161+ d <- getEnv "VTY_DEBUG_LOG"

162+ return $ def { debugLog = d }

163+

164+standardIOConfig :: IO Config

165+standardIOConfig = do

166+ Just t <- getEnv "TERM"

167+ return $ def { vmin = Just 1

168+ , vtime = Just 100

169+ , inputFd = Just stdInput

170+ , outputFd = Just stdOutput

171+ , termName = Just t

172+ }

148173

149174parseConfigFile :: FilePath -> IO Config

150175parseConfigFile path = do

src/Graphics/Vty/Inline/Unsafe.hs+21−3

@@ -3,11 +3,19 @@ module Graphics.Vty.Inline.Unsafe where

33

44import Graphics.Vty

55

6+import Control.Applicative

7+

68import Data.Default

9+import Data.Monoid

710import Data.IORef

811

12+import GHC.IO.Handle (hDuplicate)

13+

14+import System.IO (Handle, stdin, stdout, hSetBuffering, BufferMode(NoBuffering))

915import System.IO.Unsafe

1016

17+import System.Posix.IO (handleToFd)

18+

1119globalVty :: IORef (Maybe Vty)

1220{-# NOINLINE globalVty #-}

1321globalVty = unsafePerformIO $ newIORef Nothing

@@ -16,14 +24,24 @@ globalOutput :: IORef (Maybe Output)

1624{-# NOINLINE globalOutput #-}

1725globalOutput = unsafePerformIO $ newIORef Nothing

1826

27+mkDupeConfig :: IO Config

28+mkDupeConfig = do

29+ hSetBuffering stdout NoBuffering

30+ hSetBuffering stdin NoBuffering

31+ stdinDupe <- hDuplicate stdin >>= handleToFd

32+ stdoutDupe <- hDuplicate stdout >>= handleToFd

33+ return $ def { inputFd = Just stdinDupe, outputFd = Just stdoutDupe }

34+

1935-- | This will create a Vty instance using 'mkVty' and execute an IO action provided that instance.

2036-- The created Vty instance will be stored to the unsafe 'IORef' 'globalVty'.

37+--

38+-- This instance will use duplicates of the stdin and stdout Handles.

2139withVty :: (Vty -> IO b) -> IO b

2240withVty f = do

2341 mvty <- readIORef globalVty

2442 vty <- case mvty of

2543 Nothing -> do

26− vty <- mkVty $ def

44+ vty <- mkDupeConfig >>= mkVty

2745 writeIORef globalVty (Just vty)

2846 return vty

2947 Just vty -> return vty

@@ -34,8 +52,8 @@ withOutput f = do

3452 mout <- readIORef globalOutput

3553 out <- case mout of

3654 Nothing -> do

37− config <- userConfig

38− out <- outputForCurrentTerminal config

55+ config <- (<>) <$> userConfig <*> mkDupeConfig

56+ out <- outputForConfig config

3957 writeIORef globalOutput (Just out)

4058 return out

4159 Just out -> return out

src/Graphics/Vty/Input.hs+15−19

@@ -1,3 +1,4 @@

1+{-# LANGUAGE RecordWildCards #-}

12-- | The input layer for VTY. This provides methods for initializing an 'Input' structure which can

23-- then be used to read 'Event's from the terminal.

34--

@@ -120,8 +121,7 @@ module Graphics.Vty.Input ( Key(..)

120121 , Button(..)

121122 , Event(..)

122123 , Input(..)

123− , inputForCurrentTerminal

124− , inputForNameAndIO

124+ , inputForConfig

125125 )

126126 where

127127

@@ -133,22 +133,13 @@ import Graphics.Vty.Input.Terminfo

133133import Control.Concurrent

134134import Control.Lens

135135

136+import Data.Functor ((<$>))

136137import Data.Monoid

137138

138139import qualified System.Console.Terminfo as Terminfo

139−import System.Environment

140140import System.Posix.Signals.Exts

141−import System.Posix.IO (stdInput)

142−import System.Posix.Types (Fd)

143141

144−-- | Set up the current terminal for input.

145−-- This determines the current terminal then invokes 'inputForNameAndIO'

146−inputForCurrentTerminal :: Config -> IO Input

147−inputForCurrentTerminal config = do

148− termName <- getEnv "TERM"

149− inputForNameAndIO config termName stdInput

150−

151−-- | Set up the terminal attached to the given Fd for input. Returns a 'Input'.

142+-- | Set up the terminal with file descriptor `inputFd` for input. Returns a 'Input'.

152143--

153144-- The table used to determine the 'Events' to produce for the input bytes comes from

154145-- 'classifyMapForTerm'. Which is then overridden by the the applicable entries from

@@ -175,16 +166,20 @@ inputForCurrentTerminal config = do

175166-- - canonical mode (line mode) input is not used. TODO: should be a dynamic option.

176167--

177168-- * IEXTEN disabled

178−-- - extended functions are disabled. TODO: Uh. Whatever these are.

179−--

180−inputForNameAndIO :: Config -> String -> Fd -> IO Input

181−inputForNameAndIO config termName termFd = do

169+-- - extended functions are disabled. TODO: I don't know what those are.

170+--

171+inputForConfig :: Config -> IO Input

172+inputForConfig config@Config{ termName = Just termName

173+ , inputFd = Just termFd

174+ , vmin = Just _

175+ , vtime = Just _

176+ , .. } = do

182177 terminal <- Terminfo.setupTerm termName

183− let inputOverrides = [(s,e) | (t,s,e) <- inputMap config, t == Nothing || t == Just termName]

178+ let inputOverrides = [(s,e) | (t,s,e) <- inputMap, t == Nothing || t == Just termName]

184179 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides

185180 (setAttrs,unsetAttrs) <- attributeControl termFd

186181 setAttrs

187− input <- initInputForFd config termName activeInputMap termFd

182+ input <- initInput config activeInputMap

188183 let pokeIO = Catch $ do

189184 let e = error "vty internal failure: this value should not propagate to users"

190185 setAttrs

@@ -198,3 +193,4 @@ inputForNameAndIO config termName termFd = do

198193 _ <- installHandler continueProcess Ignore Nothing

199194 unsetAttrs

200195 }

196+inputForConfig config = mappend config <$> standardIOConfig >>= inputForConfig

src/Graphics/Vty/Input/Loop.hs+20−18

@@ -1,3 +1,4 @@

1+{-# LANGUAGE RecordWildCards #-}

12{-# OPTIONS_HADDOCK hide #-}

23{-# LANGUAGE NoMonomorphismRestriction #-}

34{-# LANGUAGE TemplateHaskell #-}

@@ -47,8 +48,6 @@ data Input = Input

4748 , shutdownInput :: IO ()

4849 -- | Changes to this value are reflected after the next event.

4950 , _configRef :: IORef Config

50− -- | File descriptor used for input.

51− , _inputFd :: Fd

5251 -- | input debug log

5352 , _inputDebug :: Maybe Handle

5453 }

@@ -108,10 +107,10 @@ readFromDevice :: InputM String

108107readFromDevice = do

109108 newConfig <- view configRef >>= liftIO . readIORef

110109 oldConfig <- use appliedConfig

111− fd <- view inputFd

110+ let Just fd = inputFd newConfig

112111 when (newConfig /= oldConfig) $ do

113112 logMsg $ "new config: " ++ show newConfig

114− liftIO $ applyTimingConfig fd newConfig

113+ liftIO $ applyConfig fd newConfig

115114 appliedConfig .= newConfig

116115 bufferPtr <- use $ inputBuffer.ptr

117116 maxBytes <- use $ inputBuffer.size

@@ -123,9 +122,10 @@ readFromDevice = do

123122 when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep

124123 return stringRep

125124

126−applyTimingConfig :: Fd -> Config -> IO ()

127−applyTimingConfig fd config = setTermTiming fd (derivedVmin config)

128− (derivedVtime config `div` 100)

125+applyConfig :: Fd -> Config -> IO ()

126+applyConfig fd (Config{ vmin = Just theVmin, vtime = Just theVtime })

127+ = setTermTiming fd theVmin (theVtime `div` 100)

128+applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configuration"

129129

130130parseEvent :: InputM Event

131131parseEvent = do

@@ -172,32 +172,34 @@ attributeControl fd = do

172172 unsetAttrs = setTerminalAttributes fd original Immediately

173173 return (setAttrs,unsetAttrs)

174174

175−logInitialInputState :: Input -> String -> ClassifyMap -> IO()

176−logInitialInputState input termName classifyTable = case _inputDebug input of

175+logInitialInputState :: Input -> ClassifyMap -> IO()

176+logInitialInputState input classifyTable = case _inputDebug input of

177177 Nothing -> return ()

178178 Just h -> do

179− config <- readIORef $ _configRef input

180− _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (vmin config, vtime config))

179+ Config{ vmin = Just theVmin

180+ , vtime = Just theVtime

181+ , termName = Just theTerm, .. } <- readIORef $ _configRef input

182+ _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))

181183 forM_ classifyTable $ \i -> case i of

182− (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show termName)

184+ (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)

183185 (show inBytes)

184186 (show k)

185187 (show mods)

186188 _ -> return ()

187189

188−initInputForFd :: Config -> String -> ClassifyMap -> Fd -> IO Input

189−initInputForFd config termName classifyTable inFd = do

190− setFdOption inFd NonBlockingRead False

191− applyTimingConfig inFd config

190+initInput :: Config -> ClassifyMap -> IO Input

191+initInput config classifyTable = do

192+ let Just fd = inputFd config

193+ setFdOption fd NonBlockingRead False

194+ applyConfig fd config

192195 stopFlag <- newIORef False

193196 input <- Input <$> newChan

194197 <*> pure (writeIORef stopFlag True)

195198 <*> newIORef config

196− <*> pure inFd

197199 <*> maybe (return Nothing)

198200 (\f -> Just <$> openFile f AppendMode)

199201 (debugLog config)

200− logInitialInputState input termName classifyTable

202+ logInitialInputState input classifyTable

201203 _ <- forkOS $ runInputProcessorLoop classifyTable input stopFlag

202204 return input

203205

src/Graphics/Vty/Output.hs+24−37

@@ -1,3 +1,5 @@

1+{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE NamedFieldPuns #-}

13-- | Output interface.

24--

35-- Access to the current terminal or a specific terminal device.

@@ -37,24 +39,22 @@ import Graphics.Vty.Output.TerminfoBased as TerminfoBased

3739

3840import Blaze.ByteString.Builder (writeToByteString)

3941

40−import Control.Exception ( SomeException, try )

4142import Control.Monad.Trans

4243

43−import Data.List ( isPrefixOf )

44+import Data.Monoid (mappend)

45+import Data.List (isPrefixOf)

4446

45−import GHC.IO.Handle

47+import System.Posix.Env (getEnv)

4648

47−import System.Environment

48−import System.IO

49−

50−-- | Returns a `Output` for the current terminal as determined by TERM.

49+-- | Returns a `Output` for the terminal specified in `Config`

5150--

5251-- The specific Output implementation used is hidden from the API user. All terminal implementations

53−-- are assumed to perform more, or less, the same. Currently all implementations use terminfo for at

54−-- least some terminal specific information. This is why platforms without terminfo are not

55−-- supported. However, as mentioned before, any specifics about it being based on terminfo are

56−-- hidden from the API user. If a terminal implementation is developed for a terminal for a

57−-- platform without terminfo support then Vty should work as expected on that terminal.

52+-- are assumed to perform more, or less, the same. Currently, all implementations use terminfo for at

53+-- least some terminal specific information.

54+--

55+-- Specifics about it being based on terminfo are hidden from the API user. If a terminal

56+-- implementation is developed for a terminal without terminfo support then Vty should work as

57+-- expected on that terminal.

5858--

5959-- Selection of a terminal is done as follows:

6060--

@@ -72,43 +72,30 @@ import System.IO

7272-- environment variables (I think?) this assumes that XTERM_VERSION will never be set for a true

7373-- Terminal.app or iTerm.app session.

7474--

75−-- The file descriptor used for output will a be a duplicate of the current stdout file descriptor.

76−--

7775-- \todo add an implementation for windows that does not depend on terminfo. Should be installable

7876-- with only what is provided in the haskell platform. Use ansi-terminal

79−outputForCurrentTerminal :: ( Applicative m, MonadIO m ) => Config -> m Output

80−outputForCurrentTerminal _config = do

81− termType <- liftIO $ getEnv "TERM"

82− outHandle <- liftIO $ hDuplicate stdout

83− outputForNameAndIO termType outHandle

84−

85−-- | gives an output method structure for a terminal with the given name and the given 'Handle'.

86−outputForNameAndIO :: (Applicative m, MonadIO m) => String -> Handle -> m Output

87−outputForNameAndIO termType outHandle = do

88− t <- if "xterm" `isPrefixOf` termType

77+outputForConfig :: Config -> IO Output

78+outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = do

79+ t <- if "xterm" `isPrefixOf` termName

8980 then do

90− maybeTerminalApp <- mGetEnv "TERM_PROGRAM"

81+ -- the explicit nature of the code below was nice for development, not needed anymore.

82+ maybeTerminalApp <- getEnv "TERM_PROGRAM"

9183 case maybeTerminalApp of

9284 Nothing

93− -> XTermColor.reserveTerminal termType outHandle

85+ -> XTermColor.reserveTerminal termName fd

9486 Just v | v == "Apple_Terminal" || v == "iTerm.app"

9587 -> do

96− maybeXterm <- mGetEnv "XTERM_VERSION"

88+ maybeXterm <- getEnv "XTERM_VERSION"

9789 case maybeXterm of

98− Nothing -> MacOSX.reserveTerminal v outHandle

99− Just _ -> XTermColor.reserveTerminal termType outHandle

90+ Nothing -> MacOSX.reserveTerminal v fd

91+ Just _ -> XTermColor.reserveTerminal termName fd

10092 -- Assume any other terminal that sets TERM_PROGRAM to not be an OS X terminal.app

10193 -- like terminal?

102− _ -> XTermColor.reserveTerminal termType outHandle

94+ _ -> XTermColor.reserveTerminal termName fd

10395 -- Not an xterm-like terminal. try for generic terminfo.

104− else TerminfoBased.reserveTerminal termType outHandle

96+ else TerminfoBased.reserveTerminal termName fd

10597 return t

106− where

107− mGetEnv var = do

108− mv <- liftIO $ try $ getEnv var

109− case mv of

110− Left (_e :: SomeException) -> return $ Nothing

111− Right v -> return $ Just v

98+outputForConfig config = mappend config <$> standardIOConfig >>= outputForConfig

11299

113100-- | Sets the cursor position to the given output column and row.

114101--

src/Graphics/Vty/Output/MacOSX.hs+7−7

@@ -15,23 +15,23 @@ import Graphics.Vty.Output.Interface

1515import qualified Graphics.Vty.Output.TerminfoBased as TerminfoBased

1616

1717import Control.Applicative

18+import Control.Monad (void)

1819import Control.Monad.Trans

1920

20−import System.IO

21+import System.Posix.IO (fdWrite)

22+import System.Posix.Types (Fd)

2123

2224-- | for Terminal.app the terminal identifier "xterm" is used. For iTerm.app the terminal identifier

2325-- "xterm-256color" is used.

2426--

2527-- This effects the terminfo lookup.

26−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output

27−reserveTerminal v outHandle = do

28+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output

29+reserveTerminal v outFd = do

2830 let remapTerm "iTerm.app" = "xterm-256color"

2931 remapTerm _ = "xterm"

3032 flushedPut :: String -> IO ()

31− flushedPut str = do

32− hPutStr outHandle str

33− hFlush outHandle

34− t <- TerminfoBased.reserveTerminal (remapTerm v) outHandle

33+ flushedPut = void . fdWrite outFd

34+ t <- TerminfoBased.reserveTerminal (remapTerm v) outFd

3535 return $ t { terminalID = terminalID t ++ " (Mac)"

3636 , reserveDisplay = terminalAppReserveDisplay flushedPut

3737 , releaseDisplay = terminalAppReleaseDisplay flushedPut

src/Graphics/Vty/Output/TerminfoBased.hs+14−52

@@ -15,7 +15,7 @@ module Graphics.Vty.Output.TerminfoBased ( reserveTerminal )

1515

1616import Graphics.Vty.Prelude

1717

18−import qualified Data.ByteString as BS

18+import Data.ByteString.Internal (toForeignPtr)

1919import Data.Terminfo.Parse

2020import Data.Terminfo.Eval

2121

@@ -34,29 +34,10 @@ import Data.Maybe (isJust, isNothing, fromJust)

3434import Data.Monoid

3535

3636import Foreign.C.Types ( CInt(..), CLong(..) )

37−

38−import GHC.IO.Handle

39−#ifdef __GLASGOW_HASKELL__

40−#if __GLASGOW_HASKELL__ >= 611

41−import GHC.IO.Handle.Internals (withHandle_)

42−import GHC.IO.Handle.Types (Handle__(..))

43−import qualified GHC.IO.FD as FD

44−-- import qualified GHC.IO.Handle.FD as FD

45−import GHC.IO.Exception

46−import Data.Typeable (cast)

47−#else

48−import GHC.IOBase

49−import GHC.Handle hiding (fdToHandle)

50−import qualified GHC.Handle

51−#endif

52−#endif

37+import Foreign.ForeignPtr (withForeignPtr)

5338

5439import qualified System.Console.Terminfo as Terminfo

55−#ifdef __GLASGOW_HASKELL__

56−#if __GLASGOW_HASKELL__ >= 611

57−import System.IO.Error

58−#endif

59−#endif

40+import System.Posix.IO (fdWriteBuf)

6041import System.Posix.Types (Fd(..))

6142

6243data TerminfoCaps = TerminfoCaps

@@ -101,9 +82,9 @@ sendCapToTerminal t cap capParams = do

10182 - todo: Some display attributes like underline and bold have independent string capabilities that

10283 - should be used instead of the generic "sgr" string capability.

10384 -}

104−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output

105−reserveTerminal inID outHandle = liftIO $ do

106− ti <- Terminfo.setupTerm inID

85+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output

86+reserveTerminal termName outFd = liftIO $ do

87+ ti <- Terminfo.setupTerm termName

10788 -- assumes set foreground always implies set background exists.

10889 -- if set foreground is not set then all color changing style attributes are filtered.

10990 msetaf <- probeCap ti "setaf"

@@ -113,14 +94,14 @@ reserveTerminal inID outHandle = liftIO $ do

11394 Just setaf -> (False, False, setaf)

11495 Nothing -> case msetf of

11596 Just setf -> (False, True, setf)

116− Nothing -> (True, True, error $ "no fore color support for terminal " ++ inID)

97+ Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)

11798 msetab <- probeCap ti "setab"

11899 msetb <- probeCap ti "setb"

119100 let set_back_cap

120101 = case msetab of

121102 Nothing -> case msetb of

122103 Just setb -> setb

123− Nothing -> error $ "no back color support for terminal " ++ inID

104+ Nothing -> error $ "no back color support for terminal " ++ termName

124105 Just setab -> setab

125106 terminfoCaps <- pure TerminfoCaps

126107 <*> probeCap ti "smcup"

@@ -138,28 +119,28 @@ reserveTerminal inID outHandle = liftIO $ do

138119 <*> currentDisplayAttrCaps ti

139120 newAssumedStateRef <- newIORef initialAssumedState

140121 let t = Output

141− { terminalID = inID

122+ { terminalID = termName

142123 , releaseTerminal = liftIO $ do

143124 sendCap setDefaultAttr []

144125 maybeSendCap cnorm []

145− hClose outHandle

146126 , reserveDisplay = liftIO $ do

147127 -- If there is no support for smcup: Clear the screen and then move the mouse to the

148128 -- home position to approximate the behavior.

149129 maybeSendCap smcup []

150− hFlush outHandle

151130 sendCap clearScreen []

152131 , releaseDisplay = liftIO $ do

153132 maybeSendCap rmcup []

154133 maybeSendCap cnorm []

155134 , displayBounds = do

156− rawSize <- liftIO $ withFd outHandle getWindowSize

135+ rawSize <- liftIO $ getWindowSize outFd

157136 case rawSize of

158137 (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize

159138 | otherwise -> return (w,h)

160139 , outputByteBuffer = \outBytes -> do

161− BS.hPut outHandle outBytes

162− hFlush outHandle

140+ let (fptr, _offset, len) = toForeignPtr outBytes

141+ actualLen <- withForeignPtr fptr $ \ptr -> fdWriteBuf outFd ptr (toEnum len)

142+ when (toEnum len /= actualLen) $ fail $ "Graphics.Vty.Output: outputByteBuffer length "

143+ ++ "mismatch. Please report a bug to vty project."

163144 , contextColorCount

164145 = case supportsNoColors terminfoCaps of

165146 False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of

@@ -462,22 +443,3 @@ styleToApplySeq s = concat

462443 then []

463444 else [op]

464445

465−-- from https://patch-tag.com/r/mae/sendfile/snapshot/current/content/pretty/src/Network/Socket/SendFile/Internal.hs

466−-- The Fd should not be used after the action returns because the

467−-- Handler may be garbage collected and than will cause the finalizer

468−-- to close the fd.

469−withFd :: Handle -> (Fd -> IO a) -> IO a

470−#ifdef __GLASGOW_HASKELL__

471−#if __GLASGOW_HASKELL__ >= 611

472−withFd h f = withHandle_ "withFd" h $ \ Handle__{..} -> do

473− case cast haDevice of

474− Nothing -> ioError (ioeSetErrorString (mkIOError IllegalOperation

475− "withFd" (Just h) Nothing)

476− "handle is not a file descriptor")

477− Just fd -> f (Fd (fromIntegral (FD.fdFD fd)))

478−#else

479−withFd h f =

480− withHandle_ "withFd" h $ \ h_ ->

481− f (Fd (fromIntegral (haFD h_)))

482−#endif

483−#endif

src/Graphics/Vty/Output/XTermColor.hs+7−7

@@ -9,23 +9,23 @@ import Blaze.ByteString.Builder (writeToByteString)

99import Blaze.ByteString.Builder.Word (writeWord8)

1010

1111import Control.Applicative

12+import Control.Monad (void)

1213import Control.Monad.Trans

1314

1415import Data.Foldable (foldMap)

1516

16−import System.IO

17+import System.Posix.IO (fdWrite)

18+import System.Posix.Types (Fd)

1719

1820-- | Initialize the display to UTF-8.

19−reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output

20−reserveTerminal variant outHandle = liftIO $ do

21− let flushedPut str = do

22− hPutStr outHandle str

23− hFlush outHandle

21+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output

22+reserveTerminal variant outFd = liftIO $ do

23+ let flushedPut = void . fdWrite outFd

2424 -- If the terminal variant is xterm-color use xterm instead since, more often than not,

2525 -- xterm-color is broken.

2626 let variant' = if variant == "xterm-color" then "xterm" else variant

2727 flushedPut setUtf8CharSet

28− t <- TerminfoBased.reserveTerminal variant' outHandle

28+ t <- TerminfoBased.reserveTerminal variant' outFd

2929 let t' = t

3030 { terminalID = terminalID t ++ " (xterm-color)"

3131 , releaseTerminal = do

vty.cabal+17−17

@@ -1,5 +1,5 @@

11name: vty

2−version: 5.1.4

2+version: 5.2.0

33license: BSD3

44license-file: LICENSE

55author: AUTHORS

@@ -137,7 +137,7 @@ test-suite verify-attribute-ops

137137 hs-source-dirs: test

138138 test-module: VerifyAttributeOps

139139 build-depends: vty,

140− Cabal == 1.20.*,

140+ Cabal == 1.18.*,

141141 QuickCheck >= 2.4,

142142 random == 1.0.*,

143143 base >= 4 && < 5,

@@ -169,7 +169,7 @@ test-suite verify-using-mock-terminal

169169 Verify.Graphics.Vty.Output

170170

171171 build-depends: vty,

172− Cabal == 1.20.*,

172+ Cabal == 1.18.*,

173173 QuickCheck >= 2.4,

174174 random == 1.0.*,

175175 base >= 4 && < 5,

@@ -202,7 +202,7 @@ test-suite verify-terminal

202202 Verify.Graphics.Vty.Output

203203

204204 build-depends: vty,

205− Cabal == 1.20.*,

205+ Cabal == 1.18.*,

206206 QuickCheck >= 2.4,

207207 random == 1.0.*,

208208 base >= 4 && < 5,

@@ -235,7 +235,7 @@ test-suite verify-display-attributes

235235 Verify.Graphics.Vty.Span

236236

237237 build-depends: vty,

238− Cabal == 1.20.*,

238+ Cabal == 1.18.*,

239239 QuickCheck >= 2.4,

240240 random == 1.0.*,

241241 base >= 4 && < 5,

@@ -261,7 +261,7 @@ test-suite verify-empty-image-props

261261 other-modules: Verify

262262

263263 build-depends: vty,

264− Cabal == 1.20.*,

264+ Cabal == 1.18.*,

265265 QuickCheck >= 2.4,

266266 random == 1.0.*,

267267 base >= 4 && < 5,

@@ -288,7 +288,7 @@ test-suite verify-eval-terminfo-caps

288288 Verify.Graphics.Vty.Output

289289

290290 build-depends: vty,

291− Cabal == 1.20.*,

291+ Cabal == 1.18.*,

292292 QuickCheck >= 2.4,

293293 random == 1.0.*,

294294 base >= 4 && < 5,

@@ -318,7 +318,7 @@ test-suite verify-image-ops

318318 Verify.Graphics.Vty.Image

319319

320320 build-depends: vty,

321− Cabal == 1.20.*,

321+ Cabal == 1.18.*,

322322 QuickCheck >= 2.4,

323323 random == 1.0.*,

324324 base >= 4 && < 5,

@@ -346,7 +346,7 @@ test-suite verify-image-trans

346346 Verify.Graphics.Vty.Image

347347

348348 build-depends: vty,

349− Cabal == 1.20.*,

349+ Cabal == 1.18.*,

350350 QuickCheck >= 2.4,

351351 random == 1.0.*,

352352 base >= 4 && < 5,

@@ -373,7 +373,7 @@ test-suite verify-inline

373373 Verify.Graphics.Vty.Output

374374

375375 build-depends: vty,

376− Cabal == 1.20.*,

376+ Cabal == 1.18.*,

377377 QuickCheck >= 2.4,

378378 random == 1.0.*,

379379 base >= 4 && < 5,

@@ -401,7 +401,7 @@ test-suite verify-parse-terminfo-caps

401401 Verify.Graphics.Vty.Output

402402

403403 build-depends: vty,

404− Cabal == 1.20.*,

404+ Cabal == 1.18.*,

405405 QuickCheck >= 2.4,

406406 random == 1.0.*,

407407 base >= 4 && < 5,

@@ -433,7 +433,7 @@ test-suite verify-simple-span-generation

433433 Verify.Graphics.Vty.Span

434434

435435 build-depends: vty,

436− Cabal == 1.20.*,

436+ Cabal == 1.18.*,

437437 QuickCheck >= 2.4,

438438 random == 1.0.*,

439439 base >= 4 && < 5,

@@ -465,7 +465,7 @@ test-suite verify-crop-span-generation

465465 Verify.Graphics.Vty.Span

466466

467467 build-depends: vty,

468− Cabal == 1.20.*,

468+ Cabal == 1.18.*,

469469 QuickCheck >= 2.4,

470470 random == 1.0.*,

471471 base >= 4 && < 5,

@@ -497,7 +497,7 @@ test-suite verify-layers-span-generation

497497 Verify.Graphics.Vty.Span

498498

499499 build-depends: vty,

500− Cabal == 1.20.*,

500+ Cabal == 1.18.*,

501501 QuickCheck >= 2.4,

502502 random == 1.0.*,

503503 base >= 4 && < 5,

@@ -523,7 +523,7 @@ test-suite verify-utf8-width

523523 other-modules: Verify

524524

525525 build-depends: vty,

526− Cabal == 1.20.*,

526+ Cabal == 1.18.*,

527527 QuickCheck >= 2.4,

528528 random == 1.0.*,

529529 base >= 4 && < 5,

@@ -547,7 +547,7 @@ test-suite verify-using-mock-input

547547 main-is: VerifyUsingMockInput.hs

548548

549549 build-depends: vty,

550− Cabal == 1.20.*,

550+ Cabal == 1.18.*,

551551 data-default >= 0.5.3,

552552 QuickCheck >= 2.4,

553553 smallcheck == 1.*,

@@ -580,7 +580,7 @@ test-suite verify-config

580580 main-is: VerifyConfig.hs

581581

582582 build-depends: vty,

583− Cabal == 1.20.*,

583+ Cabal == 1.18.*,

584584 data-default >= 0.5.3,

585585 HUnit,

586586 QuickCheck >= 2.4,