diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/dist/build/verify-attribute-opsStub/verify-attribute-opsStub-tmp/verify-attribute-opsStub.hs b/dist/build/verify-attribute-opsStub/verify-attribute-opsStub-tmp/verify-attribute-opsStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-attribute-opsStub/verify-attribute-opsStub-tmp/verify-attribute-opsStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyAttributeOps ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-crop-span-generationStub/verify-crop-span-generationStub-tmp/verify-crop-span-generationStub.hs b/dist/build/verify-crop-span-generationStub/verify-crop-span-generationStub-tmp/verify-crop-span-generationStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-crop-span-generationStub/verify-crop-span-generationStub-tmp/verify-crop-span-generationStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyCropSpanGeneration ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-display-attributesStub/verify-display-attributesStub-tmp/verify-display-attributesStub.hs b/dist/build/verify-display-attributesStub/verify-display-attributesStub-tmp/verify-display-attributesStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-display-attributesStub/verify-display-attributesStub-tmp/verify-display-attributesStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyDisplayAttributes ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-empty-image-propsStub/verify-empty-image-propsStub-tmp/verify-empty-image-propsStub.hs b/dist/build/verify-empty-image-propsStub/verify-empty-image-propsStub-tmp/verify-empty-image-propsStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-empty-image-propsStub/verify-empty-image-propsStub-tmp/verify-empty-image-propsStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyEmptyImageProps ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-eval-terminfo-capsStub/verify-eval-terminfo-capsStub-tmp/verify-eval-terminfo-capsStub.hs b/dist/build/verify-eval-terminfo-capsStub/verify-eval-terminfo-capsStub-tmp/verify-eval-terminfo-capsStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-eval-terminfo-capsStub/verify-eval-terminfo-capsStub-tmp/verify-eval-terminfo-capsStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyEvalTerminfoCaps ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-image-opsStub/verify-image-opsStub-tmp/verify-image-opsStub.hs b/dist/build/verify-image-opsStub/verify-image-opsStub-tmp/verify-image-opsStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-image-opsStub/verify-image-opsStub-tmp/verify-image-opsStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyImageOps ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-image-transStub/verify-image-transStub-tmp/verify-image-transStub.hs b/dist/build/verify-image-transStub/verify-image-transStub-tmp/verify-image-transStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-image-transStub/verify-image-transStub-tmp/verify-image-transStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyImageTrans ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-inlineStub/verify-inlineStub-tmp/verify-inlineStub.hs b/dist/build/verify-inlineStub/verify-inlineStub-tmp/verify-inlineStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-inlineStub/verify-inlineStub-tmp/verify-inlineStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyInline ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-layers-span-generationStub/verify-layers-span-generationStub-tmp/verify-layers-span-generationStub.hs b/dist/build/verify-layers-span-generationStub/verify-layers-span-generationStub-tmp/verify-layers-span-generationStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-layers-span-generationStub/verify-layers-span-generationStub-tmp/verify-layers-span-generationStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyLayersSpanGeneration ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-parse-terminfo-capsStub/verify-parse-terminfo-capsStub-tmp/verify-parse-terminfo-capsStub.hs b/dist/build/verify-parse-terminfo-capsStub/verify-parse-terminfo-capsStub-tmp/verify-parse-terminfo-capsStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-parse-terminfo-capsStub/verify-parse-terminfo-capsStub-tmp/verify-parse-terminfo-capsStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyParseTerminfoCaps ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-simple-span-generationStub/verify-simple-span-generationStub-tmp/verify-simple-span-generationStub.hs b/dist/build/verify-simple-span-generationStub/verify-simple-span-generationStub-tmp/verify-simple-span-generationStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-simple-span-generationStub/verify-simple-span-generationStub-tmp/verify-simple-span-generationStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifySimpleSpanGeneration ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-terminalStub/verify-terminalStub-tmp/verify-terminalStub.hs b/dist/build/verify-terminalStub/verify-terminalStub-tmp/verify-terminalStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-terminalStub/verify-terminalStub-tmp/verify-terminalStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyOutput ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-using-mock-terminalStub/verify-using-mock-terminalStub-tmp/verify-using-mock-terminalStub.hs b/dist/build/verify-using-mock-terminalStub/verify-using-mock-terminalStub-tmp/verify-using-mock-terminalStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-using-mock-terminalStub/verify-using-mock-terminalStub-tmp/verify-using-mock-terminalStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyUsingMockTerminal ( tests ) +main :: IO () +main = stubMain tests diff --git a/dist/build/verify-utf8-widthStub/verify-utf8-widthStub-tmp/verify-utf8-widthStub.hs b/dist/build/verify-utf8-widthStub/verify-utf8-widthStub-tmp/verify-utf8-widthStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/verify-utf8-widthStub/verify-utf8-widthStub-tmp/verify-utf8-widthStub.hs @@ -0,0 +1,5 @@ +module Main ( main ) where +import Distribution.Simple.Test.LibV09 ( stubMain ) +import VerifyUtf8Width ( tests ) +main :: IO () +main = stubMain tests diff --git a/src/Graphics/Vty.hs b/src/Graphics/Vty.hs --- a/src/Graphics/Vty.hs +++ b/src/Graphics/Vty.hs @@ -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 diff --git a/src/Graphics/Vty/Config.hs b/src/Graphics/Vty/Config.hs --- a/src/Graphics/Vty/Config.hs +++ b/src/Graphics/Vty/Config.hs @@ -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 diff --git a/src/Graphics/Vty/Inline/Unsafe.hs b/src/Graphics/Vty/Inline/Unsafe.hs --- a/src/Graphics/Vty/Inline/Unsafe.hs +++ b/src/Graphics/Vty/Inline/Unsafe.hs @@ -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 diff --git a/src/Graphics/Vty/Input.hs b/src/Graphics/Vty/Input.hs --- a/src/Graphics/Vty/Input.hs +++ b/src/Graphics/Vty/Input.hs @@ -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 diff --git a/src/Graphics/Vty/Input/Loop.hs b/src/Graphics/Vty/Input/Loop.hs --- a/src/Graphics/Vty/Input/Loop.hs +++ b/src/Graphics/Vty/Input/Loop.hs @@ -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 diff --git a/src/Graphics/Vty/Input/Terminfo.hs b/src/Graphics/Vty/Input/Terminfo.hs --- a/src/Graphics/Vty/Input/Terminfo.hs +++ b/src/Graphics/Vty/Input/Terminfo.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Graphics.Vty.Input.Terminfo where import Graphics.Vty.Input.Events diff --git a/src/Graphics/Vty/Output.hs b/src/Graphics/Vty/Output.hs --- a/src/Graphics/Vty/Output.hs +++ b/src/Graphics/Vty/Output.hs @@ -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. -- diff --git a/src/Graphics/Vty/Output/Interface.hs b/src/Graphics/Vty/Output/Interface.hs --- a/src/Graphics/Vty/Output/Interface.hs +++ b/src/Graphics/Vty/Output/Interface.hs @@ -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) diff --git a/src/Graphics/Vty/Output/MacOSX.hs b/src/Graphics/Vty/Output/MacOSX.hs --- a/src/Graphics/Vty/Output/MacOSX.hs +++ b/src/Graphics/Vty/Output/MacOSX.hs @@ -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 diff --git a/src/Graphics/Vty/Output/TerminfoBased.hs b/src/Graphics/Vty/Output/TerminfoBased.hs --- a/src/Graphics/Vty/Output/TerminfoBased.hs +++ b/src/Graphics/Vty/Output/TerminfoBased.hs @@ -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 diff --git a/src/Graphics/Vty/Output/XTermColor.hs b/src/Graphics/Vty/Output/XTermColor.hs --- a/src/Graphics/Vty/Output/XTermColor.hs +++ b/src/Graphics/Vty/Output/XTermColor.hs @@ -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 diff --git a/src/Graphics/Vty/PictureToSpans.hs b/src/Graphics/Vty/PictureToSpans.hs --- a/src/Graphics/Vty/PictureToSpans.hs +++ b/src/Graphics/Vty/PictureToSpans.hs @@ -1,9 +1,10 @@ -- Copyright Corey O'Connor -{-# 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) diff --git a/test/Verify.hs b/test/Verify.hs --- a/test/Verify.hs +++ b/test/Verify.hs @@ -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 diff --git a/test/VerifyConfig.hs b/test/VerifyConfig.hs --- a/test/VerifyConfig.hs +++ b/test/VerifyConfig.hs @@ -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| diff --git a/test/VerifyOutput.hs b/test/VerifyOutput.hs --- a/test/VerifyOutput.hs +++ b/test/VerifyOutput.hs @@ -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 diff --git a/test/VerifyUsingMockInput.hs b/test/VerifyUsingMockInput.hs --- a/test/VerifyUsingMockInput.hs +++ b/test/VerifyUsingMockInput.hs @@ -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 diff --git a/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -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,