Don't output haddock stdout if verbosity is silent

haskell · Jul 14, 2021 · 5cfdb14 · 5cfdb14
1 parent 3c4023f
commit 5cfdb14
Show file tree

Hide file tree

Showing 5 changed files with 54 additions and 2 deletions.
diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs
@@ -559,7 +559,9 @@ runHaddock verbosity tmpFileOpts comp platform haddockProg args
     renderArgs verbosity tmpFileOpts haddockVersion comp platform args $
       \(flags,result)-> do
 
-        runProgram verbosity haddockProg flags
+        haddockOut <- getProgramOutput verbosity haddockProg flags
+        unless (verbosity <= silent) $
+          putStr haddockOut
 
         notice verbosity $ "Documentation created: " ++ result
 

diff --git a/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.out b/cabal-testsuite/PackageTests/NewHaddock/Fails/cabal.out
@@ -12,4 +12,5 @@ In order, the following will be built:
  - example-1.0 (lib) (first run)
 Preprocessing library for example-1.0..
 Running Haddock on library for example-1.0..
+cabal: '/home/hugin/.ghcup/ghc/<GHCVER>/bin/haddock-ghc-<GHCVER>' exited with an error:
 cabal: Failed to build documentation for example-1.0-inplace.
diff --git a/cabal-testsuite/src/Test/Cabal/Monad.hs b/cabal-testsuite/src/Test/Cabal/Monad.hs
@@ -398,6 +398,10 @@ mkNormalizerEnv = do
     list_out <- liftIO $ readProcess (programPath ghc_pkg_program)
                       ["list", "--global", "--simple-output"] ""
     tmpDir <- liftIO $ getTemporaryDirectory
+    haddock <- let prog = fromJust $ lookupKnownProgram "haddock" (testProgramDb env)
+                 in fmap (fst . fromJust) $ liftIO $
+                    programFindLocation prog (testVerbosity env)
+                        [ProgramSearchPathDefault]
     return NormalizerEnv {
         normalizerRoot
             = addTrailingPathSeparator (testSourceDir env),
@@ -410,8 +414,12 @@ mkNormalizerEnv = do
         normalizerKnownPackages
             = mapMaybe simpleParse (words list_out),
         normalizerPlatform
-            = testPlatform env
+            = testPlatform env,
+        normalizerHaddock
+            = haddock
     }
+    where
+
 
 requireProgramM :: Program -> TestM ConfiguredProgram
 requireProgramM program = do

diff --git a/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs b/cabal-testsuite/src/Test/Cabal/OutputNormalizer.hs
@@ -14,6 +14,7 @@ import Distribution.System
 import Text.Regex.Base
 import Text.Regex.TDFA
 import Data.Array ((!))
+import Data.List (isPrefixOf, isInfixOf)
 
 import qualified Data.Foldable as F
 
@@ -62,18 +63,49 @@ normalizeOutput nenv =
         else id)
   -- hackage-security locks occur non-deterministically
   . resub "(Released|Acquired|Waiting) .*hackage-security-lock\n" ""
+  -- Substitute the haddock binary with <HADDOCK>
+  -- Do this before the <GHCVER> substitution
+  . resub (posixRegexEscape (normalizerHaddock nenv)) "<HADDOCK>"
+  . removeErrors
   where
     packageIdRegex pid =
         resub (posixRegexEscape (display pid) ++ "(-[A-Za-z0-9.-]+)?")
               (prettyShow (packageName pid) ++ "-<VERSION>")
 
+{- Given
+cabal: blah exited with an error:
+Example.hs:6:11: error:
+    * Couldn't match expected type `Int' with actual type `Bool'
+    * In the expression: False
+      In an equation for `example': example = False
+|
+6 | example = False
+| ^^^^^
+cabal: Failed to build documentation for example-1.0-inplace.
+
+this will remove the error in between the first line with "exited with an error"
+and the closing "cabal:". Pretty nasty, but its needed to ignore errors from
+external programs whose output might change.
+-}
+removeErrors :: String -> String
+removeErrors s = unlines (go (lines s) False)
+  where
+    go [] _ = []
+    go (x:xs) True
+      | "cabal:" `isPrefixOf` x = x:(go xs False)
+      | otherwise               = go xs True
+    go (x:xs) False
+      | "exited with an error" `isInfixOf` x = x:(go xs True)
+      | otherwise                            = x:(go xs False)
+
 data NormalizerEnv = NormalizerEnv
     { normalizerRoot          :: FilePath
     , normalizerTmpDir        :: FilePath
     , normalizerGblTmpDir     :: FilePath
     , normalizerGhcVersion    :: Version
     , normalizerKnownPackages :: [PackageId]
     , normalizerPlatform      :: Platform
+    , normalizerHaddock       :: FilePath
     }
 
 posixSpecialChars :: [Char]

diff --git a/changelog.d/pr-7483 b/changelog.d/pr-7483
@@ -0,0 +1,9 @@
+synopsis: Don't output haddock stdout if verbosity is silent
+packages: Cabal
+prs: #7483
+
+description: {
+
+- Silence the output of the Haddock executable if verbosity 'silent' is set.
+- Hide output of 'stderr' if Haddock succeeded.
+}