RFC: UI fixes for --compact mode

shake.cabal

@@ -111,7 +111,7 @@ library
 
     if flag(cloud)
         cpp-options: -DNETWORK
-        build-depends: network, network-uri
+        build-depends: network, network-uri, HTTP
 
     if impl(ghc < 8.0)
         build-depends: semigroups >= 0.18
@@ -170,6 +170,7 @@ library
         Development.Shake.Internal.Rules.Oracle
         Development.Shake.Internal.Rules.OrderOnly
         Development.Shake.Internal.Rules.Rerun
+        Development.Shake.Internal.TermSize
         Development.Shake.Internal.Value
         General.Bilist
         General.Binary
@@ -231,7 +232,7 @@ executable shake
 
     if flag(cloud)
         cpp-options: -DNETWORK
-        build-depends: network, network-uri
+        build-depends: network, network-uri, HTTP
 
     if impl(ghc < 8.0)
         build-depends: semigroups >= 0.18
@@ -285,6 +286,7 @@ executable shake
         Development.Shake.Internal.Rules.Oracle
         Development.Shake.Internal.Rules.OrderOnly
         Development.Shake.Internal.Rules.Rerun
+        Development.Shake.Internal.TermSize
         Development.Shake.Internal.Value
         General.Bilist
         General.Binary
@@ -349,7 +351,7 @@ test-suite shake-test
 
     if flag(cloud)
         cpp-options: -DNETWORK
-        build-depends: network, network-uri
+        build-depends: network, network-uri, HTTP
 
     if impl(ghc < 8.0)
         build-depends: semigroups >= 0.18
@@ -405,6 +407,7 @@ test-suite shake-test
         Development.Shake.Internal.Rules.Oracle
         Development.Shake.Internal.Rules.OrderOnly
         Development.Shake.Internal.Rules.Rerun
+        Development.Shake.Internal.TermSize
         Development.Shake.Internal.Value
         Development.Shake.Rule
         Development.Shake.Util

src/Development/Shake/Internal/CompactUI.hs

@@ -7,6 +7,7 @@ module Development.Shake.Internal.CompactUI(
 import Development.Shake.Internal.CmdOption
 import Development.Shake.Internal.Options
 import Development.Shake.Internal.Progress
+import Development.Shake.Internal.TermSize
 
 import System.Time.Extra
 import General.Extra
@@ -15,6 +16,7 @@ import General.Thread
 import General.EscCodes
 import Data.IORef
 import Control.Monad.Extra
+import Data.Maybe
 
 
 data S = S
@@ -24,10 +26,23 @@ data S = S
     ,sUnwind :: Int -- ^ Number of lines we used last time around
     }
 
-emptyS = S [] "Starting..." [] 0
+startString = escForeground Green ++ escBold ++ "Starting" ++ escNormal ++ "..."
+emptyS = S [] "" [] 0
+
+progressToString Starting      = startString
+progressToString (Finished t)  = "Finished in " ++ showDuration t
+progressToString (Executing p t secs perc done todo predicted) =
+    let failed = maybe "" (", Failure! " ++) (isFailure p)
+        sdone  = escBold ++ escForeground Blue ++ show done ++ escNormal ++ escBold
+        stodo  = escForeground Green ++ show todo ++ escNormal
+        spred | floor perc < 20 = escBold ++ escForeground Red    ++ predicted ++ escNormal
+              | floor perc < 60 = escBold ++ escForeground Yellow ++ predicted ++ escNormal
+              | otherwise       = escBold ++ escForeground Green  ++ predicted ++ escNormal
+    in "Building for " ++ showDurationSecs t ++ " [" ++ sdone ++ "/" ++ stodo ++ "]" ++
+       ", ETA: " ++ spred ++ failed
 
 addOutput pri msg s = s{sOutput = msg : sOutput s}
-addProgress x s = s{sProgress = x}
+addProgress x s = s{sProgress = progressToString x}
 
 addTrace key msg start time s
     | start = s{sTraces = insert (key,msg,time) $ sTraces s}
@@ -41,22 +56,39 @@ addTrace key msg start time s
         remove f (x:xs) = x : remove f xs
         remove f [] = []
 
+clearCursorUp n = concat (replicate n (escClearLine ++ escCursorUp 1))
 
-display :: Seconds -> S -> (S, String)
-display time s = (s{sOutput=[], sUnwind=length post}, escCursorUp (sUnwind s) ++ unlines (map pad $ pre ++ post))
+display :: Bool -> Int -> Seconds -> S -> (S, String)
+display True _ _ s = (s, clearCursorUp (sUnwind s) ++ escClearLine)
+display False cols time s = (s{sOutput=[], sUnwind=length post}, clearCursorUp (sUnwind s) ++ unlines (map pad $ pre ++ post))
     where
         pre = sOutput s
-        post = "" : (escForeground Green ++ "Status: " ++ sProgress s ++ escNormal) : map f (sTraces s)
+        post = (sProgress s ++ escNormal) : mapMaybe f (sTraces s)
 
         pad x = x ++ escClearLine
-        f Nothing = " *"
-        f (Just (k,m,t)) = " * " ++ k ++ " (" ++ g (time - t) m ++ ")"
+        f Nothing = Nothing
+        f (Just (k,m,t)) = Just result
+          where
+            full = " * " ++ k ++ " (" ++ g (time - t) m ++ ")"
+            full_size = length full
+
+            elide_size = (cols - 3) `div` 2 -- space for '...'
+            start = take elide_size full
+            end = drop (full_size - elide_size) full
 
-        g i m | showDurationSecs i == "0s" = m
-              | i < 10 = s
-              | otherwise = escForeground (if i > 20 then Red else Yellow) ++ s ++ escNormal
-            where s = m ++ " " ++ showDurationSecs i
+            result | full_size > cols = start ++ "..." ++ end
+                   | otherwise        = full
 
+        g i m = case i of
+          -- fast things just show the command
+          _ | dur == "0s" -> cmd
+          -- fast-ish things show command + time taken
+          _ | i < 10 -> cmd ++ " " ++ dur
+          -- slow commands show colored results
+          _ | otherwise -> alert ++ cmd ++ " " ++ alert ++ dur ++ escNormal
+          where dur   = showDurationSecs i
+                cmd   = escBold ++ m ++ escNormal
+                alert = escForeground (if i > 20 then Red else Yellow)
 
 -- | Run a compact UI, with the ShakeOptions modifier, combined with
 compactUI :: ShakeOptions -> IO (ShakeOptions, IO ())
@@ -66,12 +98,16 @@ compactUI opts = do
     ref <- newIORef emptyS
     let tweak f = atomicModifyIORef ref $ \s -> (f s, ())
     time <- offsetTime
+    (_rows, columns) <- getTermSize
     opts <- return $ opts
         {shakeTrace = \a b c -> do t <- time; tweak (addTrace a b c t)
         ,shakeOutput = \a b -> tweak (addOutput a b)
-        ,shakeProgress = \x -> void $ progressDisplay 1 (tweak . addProgress) x `withThreadsBoth` shakeProgress opts x
+        ,shakeProgress = \x -> void $ withThreadsBoth
+            (progressRaw 1 (tweak . addProgress) x)
+            (shakeProgress opts x)
         ,shakeCommandOptions = [EchoStdout False, EchoStderr False] ++ shakeCommandOptions opts
         ,shakeVerbosity = Quiet
         }
-    let tick = do t <- time; mask_ $ putStr =<< atomicModifyIORef ref (display t)
-    return (opts, forever (tick >> sleep 0.4) `finally` tick)
+
+    let tick final = do t <- time; mask_ $ putStr =<< atomicModifyIORef ref (display final columns t)
+    return (opts, forever (tick False >> sleep 0.4) `finally` tick True)

src/Development/Shake/Internal/Progress.hs

@@ -4,7 +4,7 @@
 module Development.Shake.Internal.Progress(
     progress,
     progressSimple, progressDisplay, progressTitlebar, progressProgram,
-    ProgressEntry(..), progressReplay, writeProgressReport -- INTERNAL USE ONLY
+    ProgressEntry(..), RawProgress(..), progressReplay, writeProgressReport, progressRaw -- INTERNAL USE ONLY
     ) where
 
 import Control.Applicative
@@ -205,12 +205,26 @@ message input = liftA3 (,,) time perc debug
 --   while time left is calculated by scaling @remaining@ by the observed work rate in this build,
 --   roughly @done / time_elapsed@.
 progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()
-progressDisplay sample disp prog = do
-    disp "Starting..." -- no useful info at this stage
+progressDisplay sample disp prog = progressRaw sample (disp . format) prog
+  where format Starting     = "Starting..."
+        format (Finished t) = "Finished in " ++ showDuration t
+        format (Executing p t secs perc done todo predicted) =
+            "Running for " ++ showDurationSecs t ++ " [" ++ show done ++ "/" ++ show todo ++ "]" ++
+            ", predicted " ++ predicted ++
+            maybe "" (", Failure! " ++) (isFailure p)
+
+data RawProgress
+  = Starting
+  | Finished Double
+  | Executing Progress Double Double Double Int Int String
+
+progressRaw :: Double -> (RawProgress -> IO ()) -> IO Progress -> IO ()
+progressRaw sample disp prog = do
+    disp Starting -- no useful info at this stage
     time <- offsetTime
     catchJust (\x -> if x == ThreadKilled then Just () else Nothing)
         (loop time $ message echoMealy)
-        (const $ do t <- time; disp $ "Finished in " ++ showDuration t)
+        (const $ do t <- time; disp $ Finished t)
     where
         loop :: IO Double -> Mealy (Double, Progress) (Double, Double, String) -> IO ()
         loop time mealy = do
@@ -221,10 +235,7 @@ progressDisplay sample disp prog = do
             -- putStrLn _debug
             let done = countSkipped p + countBuilt p
             let todo = done + countUnknown p + countTodo p
-            disp $
-                "Running for " ++ showDurationSecs t ++ " [" ++ show done ++ "/" ++ show todo ++ "]" ++
-                ", predicted " ++ formatMessage secs perc ++
-                maybe "" (", Failure! " ++) (isFailure p)
+            disp $ Executing p t secs perc done todo (formatMessage secs perc)
             loop time mealy
 
 

src/Development/Shake/Internal/TermSize.hsc

@@ -0,0 +1,48 @@
+
+-- | Get terminal size with @ioctl@
+module Development.Shake.Internal.TermSize (
+    getTermSize
+    ) where
+
+#ifdef WIN32
+getTermSize :: IO (Int, Int)
+getTermSize = return (25,80)
+#else
+
+import Foreign
+import Foreign.C.Error
+import Foreign.C.Types
+
+#include <sys/ioctl.h>
+#include <unistd.h>
+
+-- Trick for calculating alignment of a type, taken from
+-- http://www.haskell.org/haskellwiki/FFICookBook#Working_with_structs
+#let our_alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
+
+-- The ws_xpixel and ws_ypixel fields are unused, so I've omitted them here.
+data WinSize = WinSize { wsRow, wsCol :: CUShort }
+
+instance Storable WinSize where
+  sizeOf _ = (#size struct winsize)
+  alignment _ = (#our_alignment struct winsize)
+  peek ptr = do
+    row <- (#peek struct winsize, ws_row) ptr
+    col <- (#peek struct winsize, ws_col) ptr
+    return $ WinSize row col
+  poke ptr (WinSize row col) = do
+    (#poke struct winsize, ws_row) ptr row
+    (#poke struct winsize, ws_col) ptr col
+
+foreign import ccall "sys/ioctl.h ioctl"
+  ioctl :: CInt -> CInt -> Ptr WinSize -> IO CInt
+
+-- | Return current number of (rows, columns) of the terminal.
+getTermSize :: IO (Int, Int)
+getTermSize =
+  with (WinSize 0 0) $ \ws -> do
+    throwErrnoIfMinus1 "ioctl" $
+      ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) ws
+    WinSize row col <- peek ws
+    return (fromIntegral row, fromIntegral col)
+#endif

src/General/EscCodes.hs

@@ -9,6 +9,7 @@ module General.EscCodes(
     escCursorUp,
     escClearLine,
     escForeground,
+    escBold,
     escNormal
     ) where
 
@@ -88,6 +89,8 @@ escCursorUp i = "\ESC[" ++ show i ++ "A"
 escClearLine :: String
 escClearLine = "\ESC[K"
 
+escBold :: String
+escBold = "\ESC[1m"
 
 data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
     deriving (Show,Enum)