[commit: ghc] wip/nfs-locking: Make output boxes prettier by closing them on the right (8235f15)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/nfs-locking
Link       : http://ghc.haskell.org/trac/ghc/changeset/8235f157b7dc6debca50cce96905ab3327b6fee1/ghc

>---------------------------------------------------------------

commit 8235f157b7dc6debca50cce96905ab3327b6fee1
Author: David Luposchainsky <dluposchainsky at gmail.com>
Date:   Mon Jan 4 14:38:07 2016 +0100

    Make output boxes prettier by closing them on the right


>---------------------------------------------------------------

8235f157b7dc6debca50cce96905ab3327b6fee1
 src/Base.hs | 42 ++++++++++++++++++++++++++++++------------
 1 file changed, 30 insertions(+), 12 deletions(-)

diff --git a/src/Base.hs b/src/Base.hs
index 8733282..69904c4 100644
--- a/src/Base.hs
+++ b/src/Base.hs
@@ -172,23 +172,41 @@ putError msg = do
     putColoured Red msg
     error $ "GHC build system error: " ++ msg
 
--- | Render the given set of lines in a ASCII box
+-- | Render the given set of lines in a nice box of ASCII
 renderBox :: [String] -> String
-renderBox ls =
-    unlines ([begin] ++ map (bar++) ls) ++ end
+renderBox ls = concatMap ('\n' :) (boxTop : map renderLine ls ++ [boxBot])
   where
-    (begin,bar,end)
-      | useUnicode = ( "╭──────────"
-                     , "│ "
-                     , "╰──────────"
-                     )
-      | otherwise  = ( "/----------"
-                     , "| "
-                     , "\\----------"
-                     )
+    -- Minimum total width of the box in characters
+    minimumBoxWidth = 32
+
     -- FIXME: See Shake #364.
     useUnicode = False
 
+    -- Characters to draw the box
+    (dash, pipe, topLeft, topRight, botLeft, botRight, padding)
+        | useUnicode = ('─', '│', '╭',  '╮', '╰', '╯', ' ')
+        | otherwise  = ('-', '|', '/', '\\', '\\', '/', ' ')
+
+    -- Box width, taking minimum desired length and content into account.
+    -- The -4 is for the beginning and end pipe/padding symbols, as
+    -- in "| xxx |".
+    boxContentWidth = (minimumBoxWidth - 4) `max` maxContentLength
+      where
+        maxContentLength = maximum (map length ls)
+
+    renderLine l = concat
+        [ [pipe, padding]
+        , padToLengthWith boxContentWidth padding l
+        , [padding, pipe] ]
+      where
+        padToLengthWith n filler x = x ++ replicate (n - length x) filler
+
+    (boxTop, boxBot) = ( topLeft : dashes ++ [topRight]
+                       , botLeft : dashes ++ [botRight] )
+      where
+        -- +1 for each non-dash (= corner) char
+        dashes = replicate (boxContentWidth + 2) dash
+
 -- Depending on Data.Bifunctor only for this function seems an overkill
 bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
 bimap f g (x, y) = (f x, g y)