ddd61dd · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

add input and output file descriptor to Config

ddd61ddCorey O'Connor12 years ago

CHANGELOG+10

compare with master

unifiedsplit

@@ -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!

15.1.4

115.1.4

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

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

src/Graphics/Vty.hs+3−3

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

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

109mkVty :: Config -> IO Vty

110mkVty appConfig = do

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

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

112− input <- inputForCurrentTerminal config

112+ input <- inputForConfig config

113− out <- outputForCurrentTerminal config

113+ out <- outputForConfig config

114 intMkVty input out

115

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

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

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE NoMonomorphismRestriction #-}

3{-# LANGUAGE NoMonomorphismRestriction #-}

3{-# LANGUAGE KindSignatures #-}

4{-# LANGUAGE KindSignatures #-}

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

66module Graphics.Vty.Config where

67module Graphics.Vty.Config where

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

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

70+#if __GLASGOW_HASKELL__ >= 704

71+import Prelude

72+#else

69import Prelude hiding (catch)

73import Prelude hiding (catch)

74+#endif

71import Control.Applicative hiding (many)

76import Control.Applicative hiding (many)

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

82import Graphics.Vty.Input.Events

87import Graphics.Vty.Input.Events

84import System.Directory (getAppUserDataDirectory)

89import System.Directory (getAppUserDataDirectory)

85−import System.Environment (getEnv)

86import System.IO.Error (isDoesNotExistError)

90import System.IO.Error (isDoesNotExistError)

91+import System.Posix.Env (getEnv)

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

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

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

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

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

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

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

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

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

102

96data Config = Config

103data Config = Config

104+ {

105+ -- | The default is 1 character.

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

106+ vmin :: Maybe Int

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

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

108+ , vtime :: Maybe Int

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

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

100 , debugLog :: Maybe FilePath

110 , debugLog :: Maybe FilePath

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

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

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

103 --

113 --

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

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

105 , inputMap :: InputMap

115 , 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

106 } deriving (Show, Eq)

123 } deriving (Show, Eq)

107

124

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−

118instance Default Config where

125instance Default Config where

119 def = mempty

126 def = mempty

120

127

121instance Monoid Config where

128instance Monoid Config where

122 mempty = Config

129 mempty = Config

123− { vmin = Nothing

130+ { vmin = Nothing

124− , vtime = Nothing

131+ , vtime = Nothing

125− , debugLog = mempty

132+ , debugLog = mempty

126− , inputMap = mempty

133+ , inputMap = mempty

134+ , inputFd = Nothing

135+ , outputFd = Nothing

136+ , termName = Nothing

127 }

137 }

128 mappend c0 c1 = Config

138 mappend c0 c1 = Config

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

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

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

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

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

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

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

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

133− , inputMap = inputMap c0 <> inputMap c1

143+ , inputMap = inputMap c0 <> inputMap c1

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

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

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

134 }

147 }

135

148

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

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

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

139userConfig :: IO Config

152userConfig :: IO Config

140userConfig = do

153userConfig = do

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

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

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

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

143− overridePath <- maybeEnv "VTY_CONFIG_FILE"

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

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

157+ (mappend base) <$> overrideEnvConfig

158+

159+overrideEnvConfig :: IO Config

160+overrideEnvConfig = do

145− debugLogPath <- maybeEnv "VTY_DEBUG_LOG"

161+ d <- getEnv "VTY_DEBUG_LOG"

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

162+ return $ def { debugLog = d }

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

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+ }

148

173

149parseConfigFile :: FilePath -> IO Config

174parseConfigFile :: FilePath -> IO Config

150parseConfigFile path = do

175parseConfigFile path = do

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

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

4import Graphics.Vty

6+import Control.Applicative

6import Data.Default

8import Data.Default

9+import Data.Monoid

7import Data.IORef

10import Data.IORef

12+import GHC.IO.Handle (hDuplicate)

13+

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

9import System.IO.Unsafe

15import System.IO.Unsafe

17+import System.Posix.IO (handleToFd)

18+

11globalVty :: IORef (Maybe Vty)

19globalVty :: IORef (Maybe Vty)

12{-# NOINLINE globalVty #-}

20{-# NOINLINE globalVty #-}

13globalVty = unsafePerformIO $ newIORef Nothing

21globalVty = unsafePerformIO $ newIORef Nothing

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

16{-# NOINLINE globalOutput #-}

24{-# NOINLINE globalOutput #-}

17globalOutput = unsafePerformIO $ newIORef Nothing

25globalOutput = unsafePerformIO $ newIORef Nothing

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+

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

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

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

36-- 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.

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

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

22withVty f = do

40withVty f = do

23 mvty <- readIORef globalVty

41 mvty <- readIORef globalVty

24 vty <- case mvty of

42 vty <- case mvty of

25 Nothing -> do

43 Nothing -> do

26− vty <- mkVty $ def

44+ vty <- mkDupeConfig >>= mkVty

27 writeIORef globalVty (Just vty)

45 writeIORef globalVty (Just vty)

28 return vty

46 return vty

29 Just vty -> return vty

47 Just vty -> return vty

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

34 mout <- readIORef globalOutput

52 mout <- readIORef globalOutput

35 out <- case mout of

53 out <- case mout of

36 Nothing -> do

54 Nothing -> do

37− config <- userConfig

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

38− out <- outputForCurrentTerminal config

56+ out <- outputForConfig config

39 writeIORef globalOutput (Just out)

57 writeIORef globalOutput (Just out)

40 return out

58 return out

41 Just out -> return out

59 Just out -> return out

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

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

1+{-# LANGUAGE RecordWildCards #-}

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

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

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

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

3--

4--

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

120 , Button(..)

121 , Button(..)

121 , Event(..)

122 , Event(..)

122 , Input(..)

123 , Input(..)

123− , inputForCurrentTerminal

124+ , inputForConfig

124− , inputForNameAndIO

125 )

126 where

127

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

133import Control.Concurrent

134import Control.Lens

135

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

136import Data.Monoid

137import Data.Monoid

137

138

138import qualified System.Console.Terminfo as Terminfo

139import qualified System.Console.Terminfo as Terminfo

139−import System.Environment

140import System.Posix.Signals.Exts

141−import System.Posix.IO (stdInput)

142−import System.Posix.Types (Fd)

143

141

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

142+-- | Set up the terminal with file descriptor `inputFd` for input. Returns a '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'.

152--

143--

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

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

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

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

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

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

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

176--

167--

177-- * IEXTEN disabled

168-- * IEXTEN disabled

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

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

179−--

170+--

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

171+inputForConfig :: Config -> IO Input

181−inputForNameAndIO config termName termFd = do

172+inputForConfig config@Config{ termName = Just termName

173+ , inputFd = Just termFd

174+ , vmin = Just _

175+ , vtime = Just _

176+ , .. } = do

182 terminal <- Terminfo.setupTerm termName

177 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]

184 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides

179 activeInputMap = classifyMapForTerm termName terminal `mappend` inputOverrides

185 (setAttrs,unsetAttrs) <- attributeControl termFd

180 (setAttrs,unsetAttrs) <- attributeControl termFd

186 setAttrs

181 setAttrs

187− input <- initInputForFd config termName activeInputMap termFd

182+ input <- initInput config activeInputMap

188 let pokeIO = Catch $ do

183 let pokeIO = Catch $ do

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

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

190 setAttrs

185 setAttrs

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

198 _ <- installHandler continueProcess Ignore Nothing

193 _ <- installHandler continueProcess Ignore Nothing

199 unsetAttrs

194 unsetAttrs

200 }

195 }

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

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

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

1+{-# LANGUAGE RecordWildCards #-}

1{-# OPTIONS_HADDOCK hide #-}

2{-# OPTIONS_HADDOCK hide #-}

2{-# LANGUAGE NoMonomorphismRestriction #-}

3{-# LANGUAGE NoMonomorphismRestriction #-}

3{-# LANGUAGE TemplateHaskell #-}

4{-# LANGUAGE TemplateHaskell #-}

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

47 , shutdownInput :: IO ()

48 , shutdownInput :: IO ()

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

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

49 , _configRef :: IORef Config

50 , _configRef :: IORef Config

50− -- | File descriptor used for input.

51− , _inputFd :: Fd

52 -- | input debug log

51 -- | input debug log

53 , _inputDebug :: Maybe Handle

52 , _inputDebug :: Maybe Handle

54 }

53 }

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

108readFromDevice = do

107readFromDevice = do

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

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

110 oldConfig <- use appliedConfig

109 oldConfig <- use appliedConfig

111− fd <- view inputFd

110+ let Just fd = inputFd newConfig

112 when (newConfig /= oldConfig) $ do

111 when (newConfig /= oldConfig) $ do

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

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

114− liftIO $ applyTimingConfig fd newConfig

113+ liftIO $ applyConfig fd newConfig

115 appliedConfig .= newConfig

114 appliedConfig .= newConfig

116 bufferPtr <- use $ inputBuffer.ptr

115 bufferPtr <- use $ inputBuffer.ptr

117 maxBytes <- use $ inputBuffer.size

116 maxBytes <- use $ inputBuffer.size

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

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

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

124 return stringRep

123 return stringRep

125

124

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

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

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

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

128− (derivedVtime config `div` 100)

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

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

129

130parseEvent :: InputM Event

131parseEvent = do

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

172 unsetAttrs = setTerminalAttributes fd original Immediately

173 return (setAttrs,unsetAttrs)

174

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

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

176−logInitialInputState input termName classifyTable = case _inputDebug input of

176+logInitialInputState input classifyTable = case _inputDebug input of

177 Nothing -> return ()

178 Just h -> do

179+ Config{ vmin = Just theVmin

180+ , vtime = Just theVtime

179− config <- readIORef $ _configRef input

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

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

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

181 forM_ classifyTable $ \i -> case i of

183 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)

183 (show inBytes)

185 (show inBytes)

184 (show k)

186 (show k)

185 (show mods)

187 (show mods)

186 _ -> return ()

188 _ -> return ()

187

189

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

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

189−initInputForFd config termName classifyTable inFd = do

191+initInput config classifyTable = do

192+ let Just fd = inputFd config

190− setFdOption inFd NonBlockingRead False

193+ setFdOption fd NonBlockingRead False

191− applyTimingConfig inFd config

194+ applyConfig fd config

192 stopFlag <- newIORef False

195 stopFlag <- newIORef False

193 input <- Input <$> newChan

196 input <- Input <$> newChan

194 <*> pure (writeIORef stopFlag True)

197 <*> pure (writeIORef stopFlag True)

195 <*> newIORef config

198 <*> newIORef config

196− <*> pure inFd

197 <*> maybe (return Nothing)

199 <*> maybe (return Nothing)

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

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

199 (debugLog config)

201 (debugLog config)

200− logInitialInputState input termName classifyTable

202+ logInitialInputState input classifyTable

201 _ <- forkOS $ runInputProcessorLoop classifyTable input stopFlag

203 _ <- forkOS $ runInputProcessorLoop classifyTable input stopFlag

202 return input

204 return input

203

205

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

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

1+{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE NamedFieldPuns #-}

1-- | Output interface.

3-- | Output interface.

2--

4--

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

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

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

38import Blaze.ByteString.Builder (writeToByteString)

40import Blaze.ByteString.Builder (writeToByteString)

40−import Control.Exception ( SomeException, try )

41import Control.Monad.Trans

42import Control.Monad.Trans

44+import Data.Monoid (mappend)

43−import Data.List ( isPrefixOf )

45+import Data.List (isPrefixOf)

45−import GHC.IO.Handle

47+import System.Posix.Env (getEnv)

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`

51--

50--

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

51-- 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

52+-- 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

53+-- least some terminal specific information.

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

54+--

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

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

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

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

57+-- expected on that terminal.

58--

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

60--

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

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

73-- Terminal.app or iTerm.app session.

74--

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

76−--

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

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

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

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

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

77+outputForConfig :: Config -> IO Output

80−outputForCurrentTerminal _config = do

78+outputForConfig Config{ outputFd = Just fd, termName = Just termName, .. } = 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

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

89 then do

80 then do

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

90− maybeTerminalApp <- mGetEnv "TERM_PROGRAM"

82+ maybeTerminalApp <- getEnv "TERM_PROGRAM"

91 case maybeTerminalApp of

83 case maybeTerminalApp of

92 Nothing

84 Nothing

93− -> XTermColor.reserveTerminal termType outHandle

85+ -> XTermColor.reserveTerminal termName fd

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

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

95 -> do

87 -> do

96− maybeXterm <- mGetEnv "XTERM_VERSION"

88+ maybeXterm <- getEnv "XTERM_VERSION"

97 case maybeXterm of

89 case maybeXterm of

98− Nothing -> MacOSX.reserveTerminal v outHandle

90+ Nothing -> MacOSX.reserveTerminal v fd

99− Just _ -> XTermColor.reserveTerminal termType outHandle

91+ Just _ -> XTermColor.reserveTerminal termName fd

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

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

101 -- like terminal?

93 -- like terminal?

102− _ -> XTermColor.reserveTerminal termType outHandle

94+ _ -> XTermColor.reserveTerminal termName fd

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

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

104− else TerminfoBased.reserveTerminal termType outHandle

96+ else TerminfoBased.reserveTerminal termName fd

105 return t

97 return t

106− where

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

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

112

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

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

114--

101--

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

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

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

17import Control.Applicative

18+import Control.Monad (void)

18import Control.Monad.Trans

19import Control.Monad.Trans

20−import System.IO

21+import System.Posix.IO (fdWrite)

22+import System.Posix.Types (Fd)

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

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

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

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

24--

26--

25-- This effects the terminfo lookup.

27-- This effects the terminfo lookup.

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

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

27−reserveTerminal v outHandle = do

29+reserveTerminal v outFd = do

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

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

29 remapTerm _ = "xterm"

31 remapTerm _ = "xterm"

30 flushedPut :: String -> IO ()

32 flushedPut :: String -> IO ()

31− flushedPut str = do

33+ flushedPut = void . fdWrite outFd

32− hPutStr outHandle str

33− hFlush outHandle

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

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

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

36 , reserveDisplay = terminalAppReserveDisplay flushedPut

37 , releaseDisplay = terminalAppReleaseDisplay flushedPut

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

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

16import Graphics.Vty.Prelude

18−import qualified Data.ByteString as BS

18+import Data.ByteString.Internal (toForeignPtr)

19import Data.Terminfo.Parse

20import Data.Terminfo.Eval

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

34import Data.Monoid

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

37−

37+import Foreign.ForeignPtr (withForeignPtr)

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

54import qualified System.Console.Terminfo as Terminfo

39import qualified System.Console.Terminfo as Terminfo

55−#ifdef __GLASGOW_HASKELL__

56−#if __GLASGOW_HASKELL__ >= 611

57−import System.IO.Error

40+import System.Posix.IO (fdWriteBuf)

58−#endif

59−#endif

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

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

62data TerminfoCaps = TerminfoCaps

43data TerminfoCaps = TerminfoCaps

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

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

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

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

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

103 -}

84 -}

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

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

105−reserveTerminal inID outHandle = liftIO $ do

86+reserveTerminal termName outFd = liftIO $ do

106− ti <- Terminfo.setupTerm inID

87+ ti <- Terminfo.setupTerm termName

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

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

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

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

109 msetaf <- probeCap ti "setaf"

90 msetaf <- probeCap ti "setaf"

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

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

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

114 Nothing -> case msetf of

95 Nothing -> case msetf of

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

96 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)

117 msetab <- probeCap ti "setab"

98 msetab <- probeCap ti "setab"

118 msetb <- probeCap ti "setb"

99 msetb <- probeCap ti "setb"

119 let set_back_cap

100 let set_back_cap

120 = case msetab of

101 = case msetab of

121 Nothing -> case msetb of

102 Nothing -> case msetb of

122 Just setb -> setb

103 Just setb -> setb

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

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

124 Just setab -> setab

105 Just setab -> setab

125 terminfoCaps <- pure TerminfoCaps

106 terminfoCaps <- pure TerminfoCaps

126 <*> probeCap ti "smcup"

107 <*> probeCap ti "smcup"

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

138 <*> currentDisplayAttrCaps ti

119 <*> currentDisplayAttrCaps ti

139 newAssumedStateRef <- newIORef initialAssumedState

120 newAssumedStateRef <- newIORef initialAssumedState

140 let t = Output

121 let t = Output

141− { terminalID = inID

122+ { terminalID = termName

142 , releaseTerminal = liftIO $ do

123 , releaseTerminal = liftIO $ do

143 sendCap setDefaultAttr []

124 sendCap setDefaultAttr []

144 maybeSendCap cnorm []

125 maybeSendCap cnorm []

145− hClose outHandle

146 , reserveDisplay = liftIO $ do

126 , reserveDisplay = liftIO $ do

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

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

148 -- home position to approximate the behavior.

128 -- home position to approximate the behavior.

149 maybeSendCap smcup []

129 maybeSendCap smcup []

150− hFlush outHandle

151 sendCap clearScreen []

130 sendCap clearScreen []

152 , releaseDisplay = liftIO $ do

131 , releaseDisplay = liftIO $ do

153 maybeSendCap rmcup []

132 maybeSendCap rmcup []

154 maybeSendCap cnorm []

133 maybeSendCap cnorm []

155 , displayBounds = do

134 , displayBounds = do

156− rawSize <- liftIO $ withFd outHandle getWindowSize

135+ rawSize <- liftIO $ getWindowSize outFd

157 case rawSize of

136 case rawSize of

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

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

159 | otherwise -> return (w,h)

138 | otherwise -> return (w,h)

160 , outputByteBuffer = \outBytes -> do

139 , outputByteBuffer = \outBytes -> do

161− BS.hPut outHandle outBytes

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

162− hFlush outHandle

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."

163 , contextColorCount

144 , contextColorCount

164 = case supportsNoColors terminfoCaps of

145 = case supportsNoColors terminfoCaps of

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

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

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

462 then []

443 then []

463 else [op]

444 else [op]

464

445

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)

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

11import Control.Applicative

12+import Control.Monad (void)

12import Control.Monad.Trans

13import Control.Monad.Trans

14import Data.Foldable (foldMap)

15import Data.Foldable (foldMap)

16−import System.IO

17+import System.Posix.IO (fdWrite)

18+import System.Posix.Types (Fd)

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

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

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

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

20−reserveTerminal variant outHandle = liftIO $ do

22+reserveTerminal variant outFd = liftIO $ do

21− let flushedPut str = do

23+ let flushedPut = void . fdWrite outFd

22− hPutStr outHandle str

23− hFlush outHandle

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

25 -- xterm-color is broken.

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

27 flushedPut setUtf8CharSet

28− t <- TerminfoBased.reserveTerminal variant' outHandle

28+ t <- TerminfoBased.reserveTerminal variant' outFd

29 let t' = t

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

31 , releaseTerminal = do

vty.cabal+17−17

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

1name: vty

2−version: 5.1.4

2+version: 5.2.0

3license: BSD3

4license-file: LICENSE

5author: AUTHORS

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

137 hs-source-dirs: test

138 test-module: VerifyAttributeOps

139 build-depends: vty,

140− Cabal == 1.20.*,

140+ Cabal == 1.18.*,

141 QuickCheck >= 2.4,

142 random == 1.0.*,

143 base >= 4 && < 5,

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

169 Verify.Graphics.Vty.Output

170

171 build-depends: vty,

172− Cabal == 1.20.*,

172+ Cabal == 1.18.*,

173 QuickCheck >= 2.4,

174 random == 1.0.*,

175 base >= 4 && < 5,

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

202 Verify.Graphics.Vty.Output

203

204 build-depends: vty,

205− Cabal == 1.20.*,

205+ Cabal == 1.18.*,

206 QuickCheck >= 2.4,

207 random == 1.0.*,

208 base >= 4 && < 5,

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

235 Verify.Graphics.Vty.Span

236

237 build-depends: vty,

238− Cabal == 1.20.*,

238+ Cabal == 1.18.*,

239 QuickCheck >= 2.4,

240 random == 1.0.*,

241 base >= 4 && < 5,

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

261 other-modules: Verify

262

263 build-depends: vty,

264− Cabal == 1.20.*,

264+ Cabal == 1.18.*,

265 QuickCheck >= 2.4,

266 random == 1.0.*,

267 base >= 4 && < 5,

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

288 Verify.Graphics.Vty.Output

289

290 build-depends: vty,

291− Cabal == 1.20.*,

291+ Cabal == 1.18.*,

292 QuickCheck >= 2.4,

293 random == 1.0.*,

294 base >= 4 && < 5,

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

318 Verify.Graphics.Vty.Image

319

320 build-depends: vty,

321− Cabal == 1.20.*,

321+ Cabal == 1.18.*,

322 QuickCheck >= 2.4,

323 random == 1.0.*,

324 base >= 4 && < 5,

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

346 Verify.Graphics.Vty.Image

347

348 build-depends: vty,

349− Cabal == 1.20.*,

349+ Cabal == 1.18.*,

350 QuickCheck >= 2.4,

351 random == 1.0.*,

352 base >= 4 && < 5,

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

373 Verify.Graphics.Vty.Output

374

375 build-depends: vty,

376− Cabal == 1.20.*,

376+ Cabal == 1.18.*,

377 QuickCheck >= 2.4,

378 random == 1.0.*,

379 base >= 4 && < 5,

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

401 Verify.Graphics.Vty.Output

402

403 build-depends: vty,

404− Cabal == 1.20.*,

404+ Cabal == 1.18.*,

405 QuickCheck >= 2.4,

406 random == 1.0.*,

407 base >= 4 && < 5,

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

433 Verify.Graphics.Vty.Span

434

435 build-depends: vty,

436− Cabal == 1.20.*,

436+ Cabal == 1.18.*,

437 QuickCheck >= 2.4,

438 random == 1.0.*,

439 base >= 4 && < 5,

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

465 Verify.Graphics.Vty.Span

466

467 build-depends: vty,

468− Cabal == 1.20.*,

468+ Cabal == 1.18.*,

469 QuickCheck >= 2.4,

470 random == 1.0.*,

471 base >= 4 && < 5,

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

497 Verify.Graphics.Vty.Span

498

499 build-depends: vty,

500− Cabal == 1.20.*,

500+ Cabal == 1.18.*,

501 QuickCheck >= 2.4,

502 random == 1.0.*,

503 base >= 4 && < 5,

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

523 other-modules: Verify

524

525 build-depends: vty,

526− Cabal == 1.20.*,

526+ Cabal == 1.18.*,

527 QuickCheck >= 2.4,

528 random == 1.0.*,

529 base >= 4 && < 5,

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

547 main-is: VerifyUsingMockInput.hs

548

549 build-depends: vty,

550− Cabal == 1.20.*,

550+ Cabal == 1.18.*,

551 data-default >= 0.5.3,

552 QuickCheck >= 2.4,

553 smallcheck == 1.*,

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

580 main-is: VerifyConfig.hs

581

582 build-depends: vty,

583− Cabal == 1.20.*,

583+ Cabal == 1.18.*,

584 data-default >= 0.5.3,

585 HUnit,

586 QuickCheck >= 2.4,