diff --git a/ChangeLog.md b/ChangeLog.md index 0ba781cda0..d0541843fa 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -39,6 +39,12 @@ Behavior changes: * Addition of `stack build --copy-compiler-tool`, to allow tools like intero to be installed globally for a particular compiler. [#2643](https://github.com/commercialhaskell/stack/issues/2643) +* Stack will now try to detect the width of the running terminal + (only on POSIX for the moment) and use that to better display + output messages. Work is ongoing, so some messages will not + be optimal yet. The terminal width can be overriden with the + new `--terminal-width` command-line option (this works even on + non-POSIX). Other enhancements: diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index 8f66db4e0f..eb14e1477a 100644 --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -28,6 +28,9 @@ module Stack.Constants ,platformVariantEnvVar ,compilerOptionsCabalFlag ,ghcColorForceFlag + ,minTerminalWidth + ,maxTerminalWidth + ,defaultTerminalWidth ) where @@ -214,5 +217,20 @@ compilerOptionsCabalFlag :: WhichCompiler -> String compilerOptionsCabalFlag Ghc = "--ghc-options" compilerOptionsCabalFlag Ghcjs = "--ghcjs-options" +-- | The flag to pass to GHC when we want to force its output to be +-- colorized. ghcColorForceFlag :: String ghcColorForceFlag = "-fdiagnostics-color=always" + +-- | The minimum allowed terminal width. Used for pretty-printing. +minTerminalWidth :: Int +minTerminalWidth = 40 + +-- | The maximum allowed terminal width. Used for pretty-printing. +maxTerminalWidth :: Int +maxTerminalWidth = 200 + +-- | The default terminal width. Used for pretty-printing when we can't +-- automatically detect it and when the user doesn't supply one. +defaultTerminalWidth :: Int +defaultTerminalWidth = 100 diff --git a/src/Stack/Options/GlobalParser.hs b/src/Stack/Options/GlobalParser.hs index e329b56d88..0f96239412 100644 --- a/src/Stack/Options/GlobalParser.hs +++ b/src/Stack/Options/GlobalParser.hs @@ -40,6 +40,10 @@ globalOptsParser currentDir kind defLogLevel = completeWith ["always", "never", "auto"] <> help "Specify when to use color in output; WHEN is 'always', 'never', or 'auto'" <> hide)) <*> + optionalFirst (option auto + (long "terminal-width" <> + metavar "INT" <> + help "Specify the width of the terminal, used for pretty-print messages")) <*> optionalFirst (strOption (long "stack-yaml" <> @@ -64,6 +68,7 @@ globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts , globalCompiler = getFirst globalMonoidCompiler , globalTerminal = fromFirst defaultTerminal globalMonoidTerminal , globalColorWhen = fromFirst ColorAuto globalMonoidColorWhen + , globalTermWidth = getFirst globalMonoidTermWidth , globalStackYaml = maybe SYLDefault SYLOverride $ getFirst globalMonoidStackYaml } initOptsParser :: Parser InitOpts diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs index e2a51db7a9..3b308f72a2 100644 --- a/src/Stack/PrettyPrint.hs +++ b/src/Stack/PrettyPrint.hs @@ -51,7 +51,8 @@ displayWithColor => a -> m T.Text displayWithColor x = do useAnsi <- liftM logUseColor $ view logOptionsL - return $ if useAnsi then displayAnsi x else displayPlain x + termWidth <- liftM logTermWidth $ view logOptionsL + return $ (if useAnsi then displayAnsi else displayPlain) termWidth x -- TODO: switch to using implicit callstacks once 7.8 support is dropped diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index 6628bf4215..b7711d91bc 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -214,6 +214,7 @@ withRunnerGlobal GlobalOpts{..} = withRunner globalTimeInLog globalTerminal globalColorWhen + globalTermWidth (isJust globalReExecVersion) withMiniConfigAndLock diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 51bd8576e4..1f233b984f 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -442,6 +442,7 @@ data GlobalOpts = GlobalOpts , globalCompiler :: !(Maybe (CompilerVersion 'CVWanted)) -- ^ Compiler override , globalTerminal :: !Bool -- ^ We're in a terminal? , globalColorWhen :: !ColorWhen -- ^ When to use ansi terminal colors + , globalTermWidth :: !(Maybe Int) -- ^ Terminal width override , globalStackYaml :: !(StackYamlLoc FilePath) -- ^ Override project stack.yaml } deriving (Show) @@ -465,6 +466,7 @@ data GlobalOptsMonoid = GlobalOptsMonoid , globalMonoidCompiler :: !(First (CompilerVersion 'CVWanted)) -- ^ Compiler override , globalMonoidTerminal :: !(First Bool) -- ^ We're in a terminal? , globalMonoidColorWhen :: !(First ColorWhen) -- ^ When to use ansi colors + , globalMonoidTermWidth :: !(First Int) -- ^ Terminal width override , globalMonoidStackYaml :: !(First FilePath) -- ^ Override project stack.yaml } deriving (Show, Generic) diff --git a/src/Stack/Types/Runner.hs b/src/Stack/Types/Runner.hs index bd5ec43725..2bb74639f0 100644 --- a/src/Stack/Types/Runner.hs +++ b/src/Stack/Types/Runner.hs @@ -41,10 +41,14 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax (lift) import Lens.Micro import Stack.Prelude hiding (lift) +import Stack.Constants import System.Console.ANSI import System.FilePath import System.IO import System.Log.FastLogger +#ifndef WINDOWS +import System.Terminal +#endif -- | Monadic environment. data Runner = Runner @@ -77,6 +81,7 @@ newtype Sticky = Sticky data LogOptions = LogOptions { logUseColor :: Bool + , logTermWidth :: Int , logUseUnicode :: Bool , logUseTime :: Bool , logMinLevel :: LogLevel @@ -243,19 +248,24 @@ withRunner :: MonadIO m -> Bool -- ^ use time? -> Bool -- ^ terminal? -> ColorWhen + -> Maybe Int -- ^ terminal width override -> Bool -- ^ reexec? -> (Runner -> m a) -> m a -withRunner logLevel useTime terminal colorWhen reExec inner = do +withRunner logLevel useTime terminal colorWhen widthOverride reExec inner = do useColor <- case colorWhen of ColorNever -> return False ColorAlways -> return True ColorAuto -> liftIO $ hSupportsANSI stderr + termWidth <- clipWidth <$> maybe (fromMaybe defaultTerminalWidth + <$> liftIO getTerminalWidth) + pure widthOverride canUseUnicode <- liftIO getCanUseUnicode withSticky terminal $ \sticky -> inner Runner { runnerReExec = reExec , runnerLogOptions = LogOptions { logUseColor = useColor + , logTermWidth = termWidth , logUseUnicode = canUseUnicode , logUseTime = useTime , logMinLevel = logLevel @@ -264,6 +274,13 @@ withRunner logLevel useTime terminal colorWhen reExec inner = do , runnerTerminal = terminal , runnerSticky = sticky } + where clipWidth w + | w < minTerminalWidth = minTerminalWidth + | w > maxTerminalWidth = maxTerminalWidth + | otherwise = w +#ifdef WINDOWS + getTerminalWidth = pure Nothing +#endif -- | Taken from GHC: determine if we should use Unicode syntax getCanUseUnicode :: IO Bool diff --git a/src/System/Terminal.hsc b/src/System/Terminal.hsc new file mode 100644 index 0000000000..3ca408d91c --- /dev/null +++ b/src/System/Terminal.hsc @@ -0,0 +1,35 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.Terminal +( getTerminalWidth +) where + +import Foreign +import Foreign.C.Types + +#include +#include + +newtype WindowWidth = WindowWidth CUShort + deriving (Eq, Ord, Show) + +instance Storable WindowWidth where + sizeOf _ = (#size struct winsize) + alignment _ = (#alignment struct winsize) + peek p = WindowWidth <$> (#peek struct winsize, ws_col) p + poke p (WindowWidth w) = do + (#poke struct winsize, ws_col) p w + +foreign import ccall "sys/ioctl.h ioctl" + ioctl :: CInt -> CInt -> Ptr WindowWidth -> IO CInt + +-- | Get the width, in columns, of the terminal if we can. +getTerminalWidth :: IO (Maybe Int) +getTerminalWidth = + alloca $ \p -> do + errno <- ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) p + if errno < 0 + then return Nothing + else do + WindowWidth w <- peek p + return . Just . fromIntegral $ w diff --git a/src/Text/PrettyPrint/Leijen/Extended.hs b/src/Text/PrettyPrint/Leijen/Extended.hs index d811e85ac2..e958b141a0 100644 --- a/src/Text/PrettyPrint/Leijen/Extended.hs +++ b/src/Text/PrettyPrint/Leijen/Extended.hs @@ -176,24 +176,24 @@ instance HasAnsiAnn AnsiAnn where instance HasAnsiAnn () where getAnsiAnn _ = mempty -displayPlain :: Display a => a -> T.Text -displayPlain = LT.toStrict . displayAnsiSimple . renderDefault . fmap (const mempty) . display +displayPlain :: Display a => Int -> a -> T.Text +displayPlain w = LT.toStrict . displayAnsiSimple . renderDefault w . fmap (const mempty) . display -- TODO: tweak these settings more? -- TODO: options for settings if this is released as a lib -renderDefault :: Doc a -> SimpleDoc a -renderDefault = renderPretty 1 120 +renderDefault :: Int -> Doc a -> SimpleDoc a +renderDefault = renderPretty 1 -displayAnsi :: (Display a, HasAnsiAnn (Ann a)) => a -> T.Text -displayAnsi = LT.toStrict . displayAnsiSimple . renderDefault . toAnsiDoc . display +displayAnsi :: (Display a, HasAnsiAnn (Ann a)) => Int -> a -> T.Text +displayAnsi w = LT.toStrict . displayAnsiSimple . renderDefault w . toAnsiDoc . display hDisplayAnsi :: (Display a, HasAnsiAnn (Ann a), MonadIO m) - => Handle -> a -> m () -hDisplayAnsi h x = liftIO $ do + => Handle -> Int -> a -> m () +hDisplayAnsi h w x = liftIO $ do useAnsi <- hSupportsANSI h - T.hPutStr h $ if useAnsi then displayAnsi x else displayPlain x + T.hPutStr h $ if useAnsi then displayAnsi w x else displayPlain w x displayAnsiSimple :: SimpleDoc AnsiAnn -> LT.Text displayAnsiSimple doc = diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs index 576c862a03..4d6cd62502 100644 --- a/src/test/Stack/ConfigSpec.hs +++ b/src/test/Stack/ConfigSpec.hs @@ -76,7 +76,7 @@ spec = beforeAll setup $ do describe "loadConfig" $ do let loadConfig' inner = - withRunner logLevel True False ColorAuto False $ \runner -> do + withRunner logLevel True False ColorAuto Nothing False $ \runner -> do lc <- runRIO runner $ loadConfig mempty Nothing SYLDefault inner lc -- TODO(danburton): make sure parent dirs also don't have config file diff --git a/src/test/Stack/NixSpec.hs b/src/test/Stack/NixSpec.hs index 410cfb4b79..870ca9e3be 100644 --- a/src/test/Stack/NixSpec.hs +++ b/src/test/Stack/NixSpec.hs @@ -46,7 +46,7 @@ setup = unsetEnv "STACK_YAML" spec :: Spec spec = beforeAll setup $ do let loadConfig' cmdLineArgs = - withRunner LevelDebug True False ColorAuto False $ \runner -> + withRunner LevelDebug True False ColorAuto Nothing False $ \runner -> runRIO runner $ loadConfig cmdLineArgs Nothing SYLDefault inTempDir test = do currentDirectory <- getCurrentDirectory diff --git a/stack.cabal b/stack.cabal index 0fab39b501..418be1b9fb 100644 --- a/stack.cabal +++ b/stack.cabal @@ -274,6 +274,8 @@ library build-depends: unix >= 2.7.0.1 , pid1 >= 0.1 && < 0.2 , bindings-uname >= 0.1 + build-tools: hsc2hs >= 0.68 + exposed-modules: System.Terminal default-language: Haskell2010 executable stack diff --git a/stack.yaml b/stack.yaml index 42e341e260..edbb2335dd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -24,3 +24,4 @@ extra-deps: - path-io-1.3.3 - extra-1.6 - monad-logger-0.3.25 +- hsc2hs-0.68.2