[commit: ghc] wip/nfs-locking: Use Target fields for printing out relevant build information. (f415ad1)

[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/f415ad1d528c29d0a1708e2406c4fabd99484e31/ghc

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

commit f415ad1d528c29d0a1708e2406c4fabd99484e31
Author: Andrey Mokhov <andrey.mokhov at gmail.com>
Date:   Tue Dec 29 15:39:52 2015 +0000

    Use Target fields for printing out relevant build information.


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

f415ad1d528c29d0a1708e2406c4fabd99484e31
 shaking-up-ghc.cabal |  1 +
 src/Builder.hs       | 10 +++++++++-
 src/Rules/Actions.hs | 44 +++++++++++++++++---------------------------
 3 files changed, 27 insertions(+), 28 deletions(-)

diff --git a/shaking-up-ghc.cabal b/shaking-up-ghc.cabal
index 0e60637..f530894 100644
--- a/shaking-up-ghc.cabal
+++ b/shaking-up-ghc.cabal
@@ -84,6 +84,7 @@ executable ghc-shake
                        , DeriveGeneric
                        , FlexibleInstances
                        , OverloadedStrings
+                       , RecordWildCards
     build-depends:       base
                        , ansi-terminal >= 0.6
                        , Cabal >= 1.22
diff --git a/src/Builder.hs b/src/Builder.hs
index 0174dad..b4b01c3 100644
--- a/src/Builder.hs
+++ b/src/Builder.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 module Builder (
-    Builder (..), builderPath, getBuilderPath, specified, needBuilder
+    Builder (..), isStaged, builderPath, getBuilderPath, specified, needBuilder
     ) where
 
 import Control.Monad.Trans.Reader
@@ -43,6 +43,14 @@ data Builder = Alex
              | Unlit
              deriving (Show, Eq, Generic)
 
+isStaged :: Builder -> Bool
+isStaged (Gcc    _) = True
+isStaged (GccM   _) = True
+isStaged (Ghc    _) = True
+isStaged (GhcM   _) = True
+isStaged (GhcPkg _) = True
+isStaged _          = False
+
 -- Configuration files refer to Builders as follows:
 builderKey :: Builder -> String
 builderKey builder = case builder of
diff --git a/src/Rules/Actions.hs b/src/Rules/Actions.hs
index 086cb8e..8b243eb 100644
--- a/src/Rules/Actions.hs
+++ b/src/Rules/Actions.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE RecordWildCards #-}
 module Rules.Actions (build, buildWithResources) where
 
 import Base
@@ -22,9 +23,7 @@ buildWithResources rs target = do
     -- The line below forces the rule to be rerun if the args hash has changed
     checkArgsHash target
     withResources rs $ do
-        unless verbose $ do
-            putBuild $ renderBox $ [ "Running " ++ show builder ++ " with arguments:" ]
-                                  ++ map ("  "++) (interestingInfo builder argList)
+        unless verbose $ putInfo target
         quietlyUnlessVerbose $ case builder of
             Ar -> arCmd path argList
 
@@ -46,28 +45,19 @@ buildWithResources rs target = do
 build :: Target -> Action ()
 build = buildWithResources []
 
-interestingInfo :: Builder -> [String] -> [String]
-interestingInfo builder ss = case builder of
-    Alex            -> prefixAndSuffix 0 3 ss
-    Ar              -> prefixAndSuffix 2 1 ss
-    DeriveConstants -> prefixAndSuffix 3 0 ss
-    Gcc _           -> prefixAndSuffix 0 4 ss
-    GccM _          -> prefixAndSuffix 0 1 ss
-    Ghc _           -> prefixAndSuffix 0 4 ss
-    GhcCabal        -> prefixAndSuffix 3 0 ss
-    GhcM _          -> prefixAndSuffix 1 1 ss
-    GhcPkg _        -> prefixAndSuffix 3 0 ss
-    Haddock         -> prefixAndSuffix 1 0 ss
-    Happy           -> prefixAndSuffix 0 3 ss
-    Hsc2Hs          -> prefixAndSuffix 0 3 ss
-    HsCpp           -> prefixAndSuffix 0 1 ss
-    Ld              -> prefixAndSuffix 4 0 ss
-    _               -> ss
+-- Print out key information about the command being executed
+putInfo :: Target.Target -> Action ()
+putInfo (Target.Target {..}) = putBuild $ renderBox $
+    [ "Running " ++ show builder
+      ++ " (" ++ stageInfo
+      ++ "package = " ++ pkgNameString package
+      ++ wayInfo ++ "):"
+    , "    input: " ++ digest inputs
+    , "=> output: " ++ digest outputs ]
   where
-    prefixAndSuffix n m list =
-        let len = length list in
-        if len <= n + m + 1
-        then list
-        else take n list
-             ++ ["... skipping " ++ show (len - n - m) ++ " arguments ..."]
-             ++ drop (len - m) list
+    stageInfo = if isStaged builder then "" else "stage = " ++ show stage ++ ", "
+    wayInfo   = if way == vanilla   then "" else ", way = " ++ show way
+    digest list = case list of
+        []  -> "none"
+        [x] -> x
+        xs  -> head xs ++ " (and " ++ show (length xs - 1) ++ " more)"