detect terminal width and use it for pretty-printed output

src/Stack/Constants.hs

@@ -28,6 +28,8 @@ module Stack.Constants
     ,platformVariantEnvVar
     ,compilerOptionsCabalFlag
     ,ghcColorForceFlag
+    ,minTerminalWidth
+    ,defaultTerminalWidth
     )
     where
 
@@ -216,3 +218,9 @@ compilerOptionsCabalFlag Ghcjs = "--ghcjs-options"
 
 ghcColorForceFlag :: String
 ghcColorForceFlag = "-fdiagnostics-color=always"
+
+minTerminalWidth :: Int
+minTerminalWidth = 20
+
+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,12 @@ 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
+import           System.Terminal
 
 -- | Monadic environment.
 data Runner = Runner
@@ -77,6 +79,7 @@ newtype Sticky = Sticky
 
 data LogOptions = LogOptions
   { logUseColor      :: Bool
+  , logTermWidth     :: Int
   , logUseUnicode    :: Bool
   , logUseTime       :: Bool
   , logMinLevel      :: LogLevel
@@ -243,19 +246,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 <- case widthOverride >>= checkWidth of
+      Nothing -> fromMaybe defaultTerminalWidth <$> liftIO getTerminalWidth
+      Just w -> return w
   canUseUnicode <- liftIO getCanUseUnicode
   withSticky terminal $ \sticky -> inner Runner
     { runnerReExec = reExec
     , runnerLogOptions = LogOptions
         { logUseColor = useColor
+        , logTermWidth = termWidth
         , logUseUnicode = canUseUnicode
         , logUseTime = useTime
         , logMinLevel = logLevel
@@ -264,6 +272,9 @@ withRunner logLevel useTime terminal colorWhen reExec inner = do
     , runnerTerminal = terminal
     , runnerSticky = sticky
     }
+  where checkWidth w
+          | w < minTerminalWidth = Nothing
+          | otherwise = Just w
 
 -- | Taken from GHC: determine if we should use Unicode syntax
 getCanUseUnicode :: IO Bool

src/System/Terminal.hsc

@@ -0,0 +1,44 @@
+{-# LANGUAGE CPP #-}
+#ifndef WINDOWS
+{-# LANGUAGE ForeignFunctionInterface #-}
+#endif
+
+module System.Terminal
+( getTerminalWidth
+) where
+
+#ifndef WINDOWS
+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
+#endif
+
+-- | Get the width, in columns, of the terminal if we can.
+getTerminalWidth :: IO (Maybe Int)
+#ifndef WINDOWS
+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
+#else
+getTerminalWidth = pure Nothing
+#endif

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 =

stack.cabal

@@ -187,6 +187,7 @@ library
                      System.Process.PagerEditor
                      System.Process.Read
                      System.Process.Run
+                     System.Terminal
   other-modules:     Hackage.Security.Client.Repository.HttpLib.HttpClient
   build-depends:     Cabal >= 2.0 && < 2.1
                    , aeson (>= 1.0 && < 1.2)
@@ -267,6 +268,7 @@ library
                    , store-core >= 0.4 && < 0.5
                    , annotated-wl-pprint
                    , file-embed >= 0.0.10
+  build-tools:       hsc2hs >= 0.68
   if os(windows)
     cpp-options:     -DWINDOWS
     build-depends:   Win32