[commit: ghc] wip/nfs-locking: Implement terseRun and arArgs functions. (30138cb)

[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/30138cb17e6a67a6036b8c0077d393134c57edd2/ghc

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

commit 30138cb17e6a67a6036b8c0077d393134c57edd2
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Tue Jan 13 02:27:29 2015 +0000

    Implement terseRun and arArgs functions.


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

30138cb17e6a67a6036b8c0077d393134c57edd2
 src/Oracles/Builder.hs | 35 ++++++++++++++++++++++++++++++++++-
 1 file changed, 34 insertions(+), 1 deletion(-)

diff --git a/src/Oracles/Builder.hs b/src/Oracles/Builder.hs
index 16b5da5..e4cd7da 100644
--- a/src/Oracles/Builder.hs
+++ b/src/Oracles/Builder.hs
@@ -2,7 +2,8 @@
 
 module Oracles.Builder (
     Builder (..),
-    with, run, specified
+    with, run, terseRun, specified,
+    arArgs
     ) where
 
 import Data.Char
@@ -24,6 +25,7 @@ data Builder = Ar
              | GhcCabal
              | Ghc Stage
              | GhcPkg Stage
+             deriving Show
 
 instance ShowArgs Builder where
     showArgs builder = showArgs $ fmap words $ do
@@ -97,6 +99,33 @@ run builder args = do
     [exe] <- showArgs builder
     cmd [exe] =<< args
 
+-- Run the builder with a given collection of arguments printing out a
+-- terse commentary with only 'interesting' info for the builder.
+-- Raises an error if the builder is not uniquely specified in config files
+terseRun :: Builder -> Args -> Action ()
+terseRun builder args = do
+    needBuilder builder
+    [exe] <- showArgs builder
+    args' <- args
+    putNormal $ "--------\nRunning " ++ show builder ++ " with arguments:"
+    mapM_ (putNormal . ("    " ++)) $ interestingInfo builder args'
+    putNormal "--------"
+    quietly $ cmd [exe] args'
+
+interestingInfo :: Builder -> [String] -> [String]
+interestingInfo builder ss = case builder of
+    Ar       -> prefixAndSuffix 3 1 ss
+    Ghc _    -> if head ss == "-M"
+                then prefixAndSuffix 1 1 ss
+                else prefixAndSuffix 0 4 ss
+    GhcPkg _ -> prefixAndSuffix 2 0 ss
+    GhcCabal -> prefixAndSuffix 3 0 ss
+  where
+    prefixAndSuffix n m ss =
+        if length ss <= n + m
+        then ss
+        else take n ss ++ ["..."] ++ drop (length ss - m) ss
+
 -- Check if the builder is uniquely specified in config files
 specified :: Builder -> Condition
 specified builder = do
@@ -104,3 +133,7 @@ specified builder = do
     return $ case exes of
         [_] -> True
         _   -> False
+
+-- TODO: generalise for other builders
+arArgs :: Args
+arArgs = arg "q"