detect terminal width and use it for pretty-printed output

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:
 

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

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

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
 

src/Stack/Runners.hs

@@ -214,6 +214,7 @@ withRunnerGlobal GlobalOpts{..} = withRunner
   globalTimeInLog
   globalTerminal
   globalColorWhen
+  globalTermWidth
   (isJust globalReExecVersion)
 
 withMiniConfigAndLock

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)
 

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

src/System/Terminal.hsc

@@ -0,0 +1,35 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module System.Terminal
+( getTerminalWidth
+) where
+
+import           Foreign
+import           Foreign.C.Types
+
+#include <sys/ioctl.h>
+#include <unistd.h>
+
+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

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 =

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

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

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

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