Refactor setupMessage use in Cabal library.

I noticed that I was repeatedly writing the same code
to print out more elaborate information when we do builds,
so I refactored it all into one place.  In the process,
I think that I have made the build output more generally
useful.

The key changes:

    - There is a new function setupMessage' which takes in
      more information than the conventional setupMessage
      does, and prints a more informative message: whereas
      setupMessage will only tell you about the package
      it is being run in, setupMessage' will also tell
      you about the component and instantiation.

    - I applied this function to applicable sites, in some
      cases moving around messages to be closer to the place
      where an actual operation takes place.  For example,
      the 'Building' message previously only was triggered
      at the beginning of the build process; now it is
      emitted immediately before we call out to GHC.  This
      is a lot more informative, and avoids people thinking
      that we are slow because of preprocessing (we're not.)
      Something similar happened for Haddock as well.

Before:

Preprocessing library 'spider' for reflex-backpack-0.5.0..
[1 of 1] Compiling Reflex.Spider.Backpack ( src/Reflex/Spider/Backpack.hs, /srv/code/reflex-backpack/dist-newstyle/build/x86_64-linux/ghc-8.1.20170123/reflex-backpack-0.5.0/c/spider/build/spider/Reflex/Spider/Backpack.o )

After:

Preprocessing library 'host' for reflex-backpack-0.5.0..
Building library 'host' instantiated with
  Reflex.Host.Sig = reflex-backpack-0.5.0-inplace-spider:Reflex.Spider.Backpack
  Reflex.Sig = reflex-backpack-0.5.0-inplace-spider:Reflex.Spider.Backpack
for reflex-backpack-0.5.0..
[1 of 8] Compiling Reflex.Host.Sig[sig] ( host/Reflex/Host/Sig.hsig, /srv/code/reflex-backpack/dist-newstyle/build/x86_64-linux/ghc-8.1.20170123/reflex-backpack-0.5.0/c/host/reflex-backpack-0.5.0-inplace-host+FDoWUmUc0MMBtBRwItgjj9/build/reflex-backpack-0.5.0-inplace-host+FDoWUmUc0MMBtBRwItgjj9/Reflex/Host/Sig.o ) [Reflex.Basics changed]

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Cabal/Cabal.cabal

@@ -120,6 +120,7 @@ library
     Distribution.Backpack.Configure
     Distribution.Backpack.ComponentsGraph
     Distribution.Backpack.ConfiguredComponent
+    Distribution.Backpack.DescribeUnitId
     Distribution.Backpack.FullUnitId
     Distribution.Backpack.LinkedComponent
     Distribution.Backpack.ModSubst

Cabal/Distribution/Backpack/DescribeUnitId.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Distribution.Backpack.DescribeUnitId where
+
+import Prelude ()
+import Distribution.Compat.Prelude
+
+import Distribution.Types.ComponentName
+import Distribution.Compat.Stack
+import Distribution.Verbosity
+import Distribution.ModuleName
+import Distribution.Package
+import Distribution.Text
+import Distribution.Simple.Utils
+
+import Text.PrettyPrint
+
+-- Unit identifiers have a well defined, machine-readable format,
+-- but this format isn't very user-friendly for users.  This
+-- module defines some functions for solving common rendering
+-- problems one has for displaying these.
+--
+-- There are three basic problems we tackle:
+--
+--  - Users don't want to see pkg-0.5-inplace-libname,
+--    they want to see "library 'libname' from 'pkg-0.5'"
+--
+--  - Users don't want to see the raw component identifier, which
+--    usually contains a wordy hash that doesn't matter.
+--
+--  - Users don't want to see a hash of the instantiation: they
+--    want to see the actual instantiation, and they want it in
+--    interpretable form.
+--
+
+-- | Print a Setup message stating (1) what operation we are doing,
+-- for (2) which component (with enough details to uniquely identify
+-- the build in question.)
+--
+setupMessage' :: Text a => Verbosity
+             -> String            -- ^ Operation being done (capitalized), on:
+             -> PackageIdentifier -- ^ Package
+             -> ComponentName     -- ^ Component name
+             -> Maybe [(ModuleName, a)] -- ^ Instantiation, if available.
+                                        -- Polymorphic to take
+                                        -- 'OpenModule' or 'Module'
+             -> IO ()
+setupMessage' verbosity msg pkgid cname mb_insts = withFrozenCallStack $ do
+    noticeDoc verbosity $
+      case mb_insts of
+        Just insts | not (null insts) ->
+          hang (msg_doc <+> text "instantiated with") 2
+               (vcat [ disp k <+> text "=" <+> disp v
+                     | (k,v) <- insts ]) $$
+          for_doc
+        _ ->
+          msg_doc <+> for_doc
+
+  where
+    msg_doc = text msg <+> text (showComponentName cname)
+    for_doc = text "for" <+> disp pkgid <<>> text ".."

Cabal/Distribution/Simple/Build.hs

@@ -36,9 +36,11 @@ import Distribution.Types.TargetInfo
 import Distribution.Types.ComponentRequestedSpec
 import Distribution.Types.ForeignLib
 import Distribution.Types.UnqualComponentName
+import Distribution.Types.ComponentLocalBuildInfo
 
 import Distribution.Package
 import Distribution.Backpack
+import Distribution.Backpack.DescribeUnitId
 import qualified Distribution.Simple.GHC   as GHC
 import qualified Distribution.Simple.GHCJS as GHCJS
 import qualified Distribution.Simple.JHC   as JHC
@@ -193,9 +195,8 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes
                comp@(CLib lib) clbi distPref = do
     preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
     extras <- preprocessExtras comp lbi
-    case libName lib of
-        Nothing -> info verbosity $ "Building library..."
-        Just n -> info verbosity $ "Building library " ++ display n ++ "..."
+    setupMessage' verbosity "Building" (packageId pkg_descr)
+      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
     let libbi = libBuildInfo lib
         lib' = lib { libBuildInfo = addExtraCSources libbi extras }
     buildLib verbosity numJobs pkg_descr lbi lib' clbi
@@ -225,15 +226,17 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes
 buildComponent verbosity numJobs pkg_descr lbi suffixes
                comp@(CFLib flib) clbi _distPref = do
     preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
-    info verbosity $ "Building foreign library " ++ display (foreignLibName flib) ++ "..."
+    setupMessage' verbosity "Building" (packageId pkg_descr)
+      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
     buildFLib verbosity numJobs pkg_descr lbi flib clbi
     return Nothing
 
 buildComponent verbosity numJobs pkg_descr lbi suffixes
                comp@(CExe exe) clbi _ = do
     preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
     extras <- preprocessExtras comp lbi
-    info verbosity $ "Building executable " ++ display (exeName exe) ++ "..."
+    setupMessage' verbosity "Building" (packageId pkg_descr)
+      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
     let ebi = buildInfo exe
         exe' = exe { buildInfo = addExtraCSources ebi extras }
     buildExe verbosity numJobs pkg_descr lbi exe' clbi
@@ -246,7 +249,8 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes
     let exe = testSuiteExeV10AsExe test
     preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
     extras <- preprocessExtras comp lbi
-    info verbosity $ "Building test suite " ++ display (testName test) ++ "..."
+    setupMessage' verbosity "Building" (packageId pkg_descr)
+      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
     let ebi = buildInfo exe
         exe' = exe { buildInfo = addExtraCSources ebi extras }
     buildExe verbosity numJobs pkg_descr lbi exe' clbi
@@ -267,7 +271,8 @@ buildComponent verbosity numJobs pkg_descr lbi0 suffixes
           testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd
     preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
     extras <- preprocessExtras comp lbi
-    info verbosity $ "Building test suite " ++ display (testName test) ++ "..."
+    setupMessage' verbosity "Building" (packageId pkg_descr)
+      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
     buildLib verbosity numJobs pkg lbi lib libClbi
     -- NB: need to enable multiple instances here, because on 7.10+
     -- the package name is the same as the library, and we still
@@ -292,7 +297,8 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes
     let (exe, exeClbi) = benchmarkExeV10asExe bm clbi
     preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
     extras <- preprocessExtras comp lbi
-    info verbosity $ "Building benchmark " ++ display (benchmarkName bm) ++ "..."
+    setupMessage' verbosity "Building" (packageId pkg_descr)
+      (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
     let ebi = buildInfo exe
         exe' = exe { buildInfo = addExtraCSources ebi extras }
     buildExe verbosity numJobs pkg_descr lbi exe' exeClbi

Cabal/Distribution/Simple/Configure.hs

@@ -98,6 +98,7 @@ import Distribution.Verbosity
 import qualified Distribution.Compat.Graph as Graph
 import Distribution.Compat.Stack
 import Distribution.Backpack.Configure
+import Distribution.Backpack.DescribeUnitId
 import Distribution.Backpack.PreExistingComponent
 import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour)
 import Distribution.Backpack.Id
@@ -132,9 +133,8 @@ import System.IO
 import Distribution.Text
     ( Text(disp), defaultStyle, display, simpleParse )
 import Text.PrettyPrint
-    ( Doc, (<+>), ($+$), ($$), char, comma, hsep, nest, hang, vcat
+    ( Doc, (<+>), ($+$), char, comma, hsep, nest
     , punctuate, quotes, render, renderStyle, sep, text )
-import qualified Text.PrettyPrint as Disp
 import Distribution.Compat.Environment ( lookupEnv )
 import Distribution.Compat.Exception ( catchExit, catchIO )
 
@@ -361,14 +361,8 @@ configure (pkg_descr0', pbi) cfg = do
     let use_external_internal_deps = isJust mb_cname
     case mb_cname of
         Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0)
-        Just cname -> noticeDoc verbosity $
-            text "Configuring component" <+> disp cname <+>
-            text "from" <+> disp (packageId pkg_descr0) $$
-            if null (configInstantiateWith cfg)
-                then Disp.empty
-                else hang (text "Instantiated with:") 2
-                          (vcat [ disp k <<>> "=" <<>> disp v
-                                | (k,v) <- configInstantiateWith cfg ])
+        Just cname -> setupMessage' verbosity "Configuring" (packageId pkg_descr0)
+                        cname (Just (configInstantiateWith cfg))
 
     -- configCID is only valid for per-component configure
     when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $

Cabal/Distribution/Simple/Haddock.hs

@@ -31,8 +31,10 @@ import qualified Distribution.Simple.GHC   as GHC
 import qualified Distribution.Simple.GHCJS as GHCJS
 
 -- local
+import Distribution.Backpack.DescribeUnitId
 import Distribution.Types.ForeignLib
 import Distribution.Types.UnqualComponentName
+import Distribution.Types.ComponentLocalBuildInfo
 import Distribution.Package
 import qualified Distribution.ModuleName as ModuleName
 import Distribution.PackageDescription as PD hiding (Flag)
@@ -157,7 +159,6 @@ haddock pkg_descr lbi suffixes flags' = do
         haddockTarget =
           fromFlagOrDefault ForDevelopment (haddockForHackage flags')
 
-    setupMessage verbosity "Running Haddock for" (packageId pkg_descr)
     (haddockProg, version, _) <-
       requireProgramVersion verbosity haddockProgram
         (orLaterVersion (mkVersion [2,0])) (withPrograms lbi)
@@ -209,24 +210,32 @@ haddock pkg_descr lbi suffixes flags' = do
            warn (fromFlag $ haddockVerbosity flags)
              "Unsupported component, skipping..."
            return ()
+        -- We define 'smsg' once and then reuse it inside the case, so that
+        -- we don't say we are running Haddock when we actually aren't
+        -- (e.g., Haddock is not run on non-libraries)
+        smsg :: IO ()
+        smsg = setupMessage' verbosity "Running Haddock on" (packageId pkg_descr)
+                (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
       case component of
         CLib lib -> do
           withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $
             \tmp -> do
+              smsg
               libArgs <- fromLibrary verbosity tmp lbi clbi htmlTemplate
                            version lib
               let libArgs' = commonArgs `mappend` libArgs
               runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs'
         CFLib flib -> when (flag haddockForeignLibs) $ do
           withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $
             \tmp -> do
+              smsg
               flibArgs <- fromForeignLib verbosity tmp lbi clbi htmlTemplate
                             version flib
               let libArgs' = commonArgs `mappend` flibArgs
               runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs'
-        CExe   _ -> when (flag haddockExecutables) $ doExe component
-        CTest  _ -> when (flag haddockTestSuites)  $ doExe component
-        CBench _ -> when (flag haddockBenchmarks)  $ doExe component
+        CExe   _ -> when (flag haddockExecutables) $ smsg >> doExe component
+        CTest  _ -> when (flag haddockTestSuites)  $ smsg >> doExe component
+        CBench _ -> when (flag haddockBenchmarks)  $ smsg >> doExe component
 
     for_ (extraDocFiles pkg_descr) $ \ fpath -> do
       files <- matchFileGlob fpath

Cabal/Distribution/Simple/PreProcess.hs

@@ -34,8 +34,10 @@ import Distribution.Compat.Prelude
 import Distribution.Compat.Stack
 
 import Distribution.Simple.PreProcess.Unlit
+import Distribution.Backpack.DescribeUnitId
 import Distribution.Package
 import qualified Distribution.ModuleName as ModuleName
+import Distribution.ModuleName (ModuleName)
 import Distribution.PackageDescription as PD
 import qualified Distribution.InstalledPackageInfo as Installed
 import qualified Distribution.Simple.PackageIndex as PackageIndex
@@ -149,36 +151,35 @@ preprocessComponent :: PackageDescription
                     -> Verbosity
                     -> [PPSuffixHandler]
                     -> IO ()
-preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = case comp of
+preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = do
+ -- NB: never report instantiation here; we'll report it properly when
+ -- building.
+ setupMessage' verbosity "Preprocessing" (packageId pd)
+    (componentLocalName clbi) (Nothing :: Maybe [(ModuleName, Module)])
+ case comp of
   (CLib lib@Library{ libBuildInfo = bi }) -> do
     let dirs = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi
                                   ,autogenPackageModulesDir lbi]
-        extra | componentIsPublic clbi = ""
-              | otherwise = " '" ++ display (componentUnitId clbi) ++ "' for"
-    setupMessage verbosity ("Preprocessing library" ++ extra) (packageId pd)
     for_ (map ModuleName.toFilePath $ allLibModules lib clbi) $
       pre dirs (componentBuildDir lbi clbi) (localHandlers bi)
   (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do
     let nm' = unUnqualComponentName nm
-        flibDir = buildDir lbi </> nm' </> nm' ++ "-tmp"
+    let flibDir = buildDir lbi </> nm' </> nm' ++ "-tmp"
         dirs    = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi
                                      ,autogenPackageModulesDir lbi]
-    setupMessage verbosity ("Preprocessing foreign library '" ++ nm' ++ "' for") (packageId pd)
     for_ (map ModuleName.toFilePath $ foreignLibModules flib) $
       pre dirs flibDir (localHandlers bi)
   (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do
     let nm' = unUnqualComponentName nm
-        exeDir = buildDir lbi </> nm' </> nm' ++ "-tmp"
+    let exeDir = buildDir lbi </> nm' </> nm' ++ "-tmp"
         dirs   = hsSourceDirs bi ++ [autogenComponentModulesDir lbi clbi
                                     ,autogenPackageModulesDir lbi]
-    setupMessage verbosity ("Preprocessing executable '" ++ nm' ++ "' for") (packageId pd)
     for_ (map ModuleName.toFilePath $ otherModules bi) $
       pre dirs exeDir (localHandlers bi)
     pre (hsSourceDirs bi) exeDir (localHandlers bi) $
       dropExtensions (modulePath exe)
   CTest test@TestSuite{ testName = nm } -> do
     let nm' = unUnqualComponentName nm
-    setupMessage verbosity ("Preprocessing test suite '" ++ nm' ++ "' for") (packageId pd)
     case testInterface test of
       TestSuiteExeV10 _ f ->
           preProcessTest test f $ buildDir lbi </> nm' </> nm' ++ "-tmp"
@@ -191,7 +192,6 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = case comp of
                                     ++ "suite type " ++ display tt
   CBench bm@Benchmark{ benchmarkName = nm } -> do
     let nm' = unUnqualComponentName nm
-    setupMessage verbosity ("Preprocessing benchmark '" ++ nm' ++ "' for") (packageId pd)
     case benchmarkInterface bm of
       BenchmarkExeV10 _ f ->
           preProcessBench bm f $ buildDir lbi </> nm' </> nm' ++ "-tmp"

Cabal/Distribution/Simple/Register.hs

@@ -64,6 +64,7 @@ import qualified Distribution.Simple.UHC   as UHC
 import qualified Distribution.Simple.HaskellSuite as HaskellSuite
 import qualified Distribution.Simple.PackageIndex as Index
 
+import Distribution.Backpack.DescribeUnitId
 import Distribution.Simple.Compiler
 import Distribution.Simple.Program
 import Distribution.Simple.Program.Script
@@ -77,6 +78,7 @@ import Distribution.Simple.Utils
 import Distribution.Utils.MapAccum
 import Distribution.System
 import Distribution.Text
+import Distribution.Types.ComponentName
 import Distribution.Verbosity as Verbosity
 import Distribution.Version
 import Distribution.Compat.Graph (IsNode(nodeKey))
@@ -160,10 +162,12 @@ registerAll pkg lbi regFlags ipis
      _ | modeGenerateRegFile   -> writeRegistrationFileOrDirectory
        | modeGenerateRegScript -> writeRegisterScript
        | otherwise             -> do
-           setupMessage verbosity "Registering" (packageId pkg)
-           for_ ipis $ \installedPkgInfo ->
+           for_ ipis $ \ipi -> do
+               setupMessage' verbosity "Registering" (packageId pkg)
+                 (libraryComponentName (IPI.sourceLibName ipi))
+                 (Just (IPI.instantiatedWith ipi))
                registerPackage verbosity (compiler lbi) (withPrograms lbi)
-                               HcPkg.NoMultiInstance packageDbs installedPkgInfo
+                               HcPkg.NoMultiInstance packageDbs ipi
 
   where
     modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))

Cabal/Distribution/Simple/Utils.hs

@@ -377,7 +377,7 @@ noticeDoc verbosity msg = withFrozenCallStack $ do
 
 setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
 setupMessage verbosity msg pkgid = withFrozenCallStack $ do
-    notice verbosity (msg ++ ' ': display pkgid ++ "...")
+    noticeNoWrap verbosity (msg ++ ' ': display pkgid ++ "...\n")
 
 -- | More detail on the operation of some action.
 --

Cabal/Distribution/Types/ComponentLocalBuildInfo.hs

@@ -4,6 +4,7 @@
 module Distribution.Types.ComponentLocalBuildInfo (
   ComponentLocalBuildInfo(..),
   componentIsIndefinite,
+  maybeComponentInstantiatedWith,
   ) where
 
 import Prelude ()
@@ -116,3 +117,8 @@ instance IsNode ComponentLocalBuildInfo where
 componentIsIndefinite :: ComponentLocalBuildInfo -> Bool
 componentIsIndefinite LibComponentLocalBuildInfo{ componentIsIndefinite_ = b } = b
 componentIsIndefinite _ = False
+
+maybeComponentInstantiatedWith :: ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)]
+maybeComponentInstantiatedWith
+    LibComponentLocalBuildInfo { componentInstantiatedWith = insts } = Just insts
+maybeComponentInstantiatedWith _ = Nothing

Cabal/Distribution/Types/ComponentName.hs

@@ -4,6 +4,7 @@
 module Distribution.Types.ComponentName (
   ComponentName(..),
   defaultLibName,
+  libraryComponentName,
   showComponentName,
   componentNameString,
   ) where
@@ -71,3 +72,9 @@ componentNameString (CFLibName  n) = Just n
 componentNameString (CExeName   n) = Just n
 componentNameString (CTestName  n) = Just n
 componentNameString (CBenchName n) = Just n
+
+-- | Convert the 'UnqualComponentName' of a library into a
+-- 'ComponentName'.
+libraryComponentName :: Maybe UnqualComponentName -> ComponentName
+libraryComponentName Nothing = CLibName
+libraryComponentName (Just n) = CSubLibName n