Attempt to avoid Haddock errors, make them nonfatal anyway

Cabal/ChangeLog.md

@@ -1,4 +1,11 @@
 # 2.4.0.0 (current development version)
+  * `Distribution.Simple.Haddock` now checks to ensure that it 
+    does not erroneously call Haddock with no target modules. 
+    ([#5232](https://github.com/haskell/cabal/issues/5232), 
+    [#5459](https://github.com/haskell/cabal/issues/5459)).
+  * Add more Lens combinators (`to`, `traversed`, `filtered`, 
+    `non`) and an optic to access the modules in a component
+    of a `PackageDescription` by the `ComponentName`.
   * Add `readGhcEnvironmentFile` to parse GHC environment files.
   * Drop support for GHC 7.4, since it is out of our support window
     (and has been for over a year!)

Cabal/Distribution/Compat/Lens.hs

@@ -21,16 +21,21 @@ module Distribution.Compat.Lens (
     -- * Getter
     view,
     use,
+    to,
     -- * Setter
     set,
     over,
     -- * Fold
     toDListOf,
     toListOf,
     toSetOf,
+    -- * Traversal
+    filtered,
+    traversed,
     -- * Lens
     cloneLens,
     aview,
+    non,
     -- * Common lenses
     _1, _2,
     -- * Operators
@@ -52,6 +57,7 @@ import Distribution.Compat.Prelude
 import Control.Applicative (Const (..))
 import Data.Functor.Identity (Identity (..))
 import Control.Monad.State.Class (MonadState (..), gets, modify)
+import Unsafe.Coerce
 
 import qualified Distribution.Compat.DList as DList
 import qualified Data.Set as Set
@@ -89,6 +95,10 @@ use :: MonadState s m => Getting a s a -> m a
 use l = gets (view l)
 {-# INLINE use #-}
 
+to :: (s -> a) -> AGetter s a
+to k f = (unsafeCoerce :: Const t a -> Const t b) . f . k
+{-# INLINE to #-}
+
 -------------------------------------------------------------------------------
 -- Setter
 -------------------------------------------------------------------------------
@@ -112,18 +122,36 @@ toListOf l = DList.runDList . toDListOf l
 toSetOf  :: Getting (Set.Set a) s a -> s -> Set.Set a
 toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s)
 
+-------------------------------------------------------------------------------
+-- Traversal
+-------------------------------------------------------------------------------
+
+filtered :: (a -> Bool) -> Traversal' a a
+filtered p f s = if p s then f s else pure s
+{-# INLINE filtered #-}
+
+traversed :: Traversable f => Traversal (f a) (f b) a b
+traversed = traverse
+{-# INLINE [0] traversed #-}
+
 -------------------------------------------------------------------------------
 -- Lens
 -------------------------------------------------------------------------------
 
 aview :: ALens s t a b -> s -> a
 aview l = pretextPos  . l pretextSell
 {-# INLINE aview #-}
+
 {-
 lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
 lens sa sbt afb s = sbt s <$> afb (sa s)
 -}
 
+non :: Eq a => a -> Lens' (Maybe a) a
+non x afb s = f <$> afb (fromMaybe x s)
+  where f y = if x == y then Nothing else Just y
+{-# INLINE non #-}
+
 -------------------------------------------------------------------------------
 -- Common
 -------------------------------------------------------------------------------

Cabal/Distribution/Simple/Haddock.hs

@@ -525,15 +525,19 @@ runHaddock :: Verbosity
               -> ConfiguredProgram
               -> HaddockArgs
               -> IO ()
-runHaddock verbosity tmpFileOpts comp platform haddockProg args = do
-  let haddockVersion = fromMaybe (error "unable to determine haddock version")
-                       (programVersion haddockProg)
-  renderArgs verbosity tmpFileOpts haddockVersion comp platform args $
-    \(flags,result)-> do
-
-      runProgram verbosity haddockProg flags
-
-      notice verbosity $ "Documentation created: " ++ result
+runHaddock verbosity tmpFileOpts comp platform haddockProg args 
+  | null (argTargets args) = warn verbosity $
+       "Haddocks are being requested, but there aren't any modules given "
+    ++ "to create documentation for."
+  | otherwise = do
+    let haddockVersion = fromMaybe (error "unable to determine haddock version")
+                        (programVersion haddockProg)
+    renderArgs verbosity tmpFileOpts haddockVersion comp platform args $
+      \(flags,result)-> do
+
+        runProgram verbosity haddockProg flags
+
+        notice verbosity $ "Documentation created: " ++ result
 
 
 renderArgs :: Verbosity

Cabal/Distribution/Types/PackageDescription/Lens.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
 module Distribution.Types.PackageDescription.Lens (
     PackageDescription,
     module Distribution.Types.PackageDescription.Lens,
@@ -7,19 +9,27 @@ import Distribution.Compat.Lens
 import Distribution.Compat.Prelude
 import Prelude ()
 
-import Distribution.Compiler                 (CompilerFlavor)
-import Distribution.License                  (License)
-import Distribution.Types.Benchmark          (Benchmark)
-import Distribution.Types.BuildType          (BuildType)
-import Distribution.Types.Executable         (Executable)
-import Distribution.Types.ForeignLib         (ForeignLib)
-import Distribution.Types.Library            (Library)
-import Distribution.Types.PackageDescription (PackageDescription)
-import Distribution.Types.PackageId          (PackageIdentifier)
-import Distribution.Types.SetupBuildInfo     (SetupBuildInfo)
-import Distribution.Types.SourceRepo         (SourceRepo)
-import Distribution.Types.TestSuite          (TestSuite)
-import Distribution.Version                  (Version, VersionRange)
+import Distribution.Compiler                  (CompilerFlavor)
+import Distribution.License                   (License)
+import Distribution.ModuleName                (ModuleName)
+import Distribution.Types.Benchmark           (Benchmark, benchmarkModules)
+import Distribution.Types.Benchmark.Lens      (benchmarkName)
+import Distribution.Types.BuildType           (BuildType)
+import Distribution.Types.ComponentName       (ComponentName(..))
+import Distribution.Types.Executable          (Executable, exeModules)
+import Distribution.Types.Executable.Lens     (exeName)
+import Distribution.Types.ForeignLib          (ForeignLib, foreignLibModules)
+import Distribution.Types.ForeignLib.Lens     (foreignLibName)
+import Distribution.Types.Library             (Library, explicitLibModules)
+import Distribution.Types.Library.Lens        (libName)
+import Distribution.Types.PackageDescription  (PackageDescription)
+import Distribution.Types.PackageId           (PackageIdentifier)
+import Distribution.Types.SetupBuildInfo      (SetupBuildInfo)
+import Distribution.Types.SourceRepo          (SourceRepo)
+import Distribution.Types.TestSuite           (TestSuite, testModules)
+import Distribution.Types.TestSuite.Lens      (testName)
+import Distribution.Types.UnqualComponentName ( UnqualComponentName )
+import Distribution.Version                   (Version, VersionRange)
 
 import qualified Distribution.SPDX                     as SPDX
 import qualified Distribution.Types.PackageDescription as T
@@ -143,3 +153,28 @@ extraTmpFiles f s = fmap (\x -> s { T.extraTmpFiles = x }) (f (T.extraTmpFiles s
 extraDocFiles :: Lens' PackageDescription [String]
 extraDocFiles f s = fmap (\x -> s { T.extraDocFiles = x }) (f (T.extraDocFiles s))
 {-# INLINE extraDocFiles #-}
+
+componentModules :: ComponentName -> AGetter PackageDescription [ModuleName]
+componentModules cname = case cname of
+    CLibName         -> library  . traversed . to explicitLibModules
+    CSubLibName name -> 
+      componentModules' name subLibraries (libName . non "") explicitLibModules
+    CFLibName   name -> 
+      componentModules' name foreignLibs  foreignLibName     foreignLibModules
+    CExeName    name -> 
+      componentModules' name executables  exeName            exeModules
+    CTestName   name -> 
+      componentModules' name testSuites   testName           testModules
+    CBenchName  name ->
+      componentModules' name benchmarks   benchmarkName      benchmarkModules
+  where
+    componentModules' :: UnqualComponentName
+                -> Traversal' PackageDescription [a]
+                -> Traversal' a UnqualComponentName
+                -> (a -> [ModuleName])
+                -> AGetter PackageDescription [ModuleName]
+    componentModules' name pdL nameL modules =
+        pdL
+      . traversed
+      . filtered ((== name) . view nameL)
+      . to modules

cabal-install/Distribution/Client/ProjectBuilding.hs

@@ -67,13 +67,15 @@ import           Distribution.Client.SourceFiles
 import           Distribution.Client.SrcDist (allPackageSourceFiles)
 import           Distribution.Client.Utils (removeExistingFile)
 
+import           Distribution.Compat.Lens
 import           Distribution.Package hiding (InstalledPackageId, installedPackageId)
 import qualified Distribution.PackageDescription as PD
 import           Distribution.InstalledPackageInfo (InstalledPackageInfo)
 import qualified Distribution.InstalledPackageInfo as Installed
 import           Distribution.Simple.BuildPaths (haddockDirName)
 import qualified Distribution.Simple.InstallDirs as InstallDirs
 import           Distribution.Types.BuildType
+import           Distribution.Types.PackageDescription.Lens (componentModules)
 import           Distribution.Simple.Program
 import qualified Distribution.Simple.Setup as Cabal
 import           Distribution.Simple.Command (CommandUI)
@@ -1049,8 +1051,8 @@ buildAndInstallUnpackedPackage verbosity
     isParallelBuild = buildSettingNumJobs >= 2
 
     whenHaddock action
-      | elabBuildHaddocks pkg = action
-      | otherwise             = return ()
+      | hasValidHaddockTargets pkg = action
+      | otherwise                  = return ()
 
     configureCommand = Cabal.configureCommand defaultProgramDb
     configureFlags v = flip filterConfigureFlags v $
@@ -1115,6 +1117,18 @@ buildAndInstallUnpackedPackage verbosity
         Just logFile -> withFile logFile AppendMode (action . Just)
 
 
+hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool
+hasValidHaddockTargets pkg
+  | not (elabBuildHaddocks pkg) = False
+  | otherwise                   = any componentHasHaddocks components
+  where
+    components = elabHaddockTargets pkg
+    pd = elabPkgDescription pkg
+
+    componentHasHaddocks (ComponentTarget name _) = 
+      not (null (pd ^. componentModules name))
+
+
 buildInplaceUnpackedPackage :: Verbosity
                             -> DistDirLayout
                             -> BuildTimeSettings -> Lock -> Lock
@@ -1285,8 +1299,8 @@ buildInplaceUnpackedPackage verbosity
       | otherwise                     = action
 
     whenHaddock action
-      | elabBuildHaddocks pkg = action
-      | otherwise            = return ()
+      | hasValidHaddockTargets pkg = action
+      | otherwise                  = return ()
 
     whenReRegister  action
       = case buildStatus of

cabal-install/Distribution/Client/ProjectOrchestration.hs

@@ -140,8 +140,7 @@ import           Distribution.Simple.Command (commandShowOptions)
 import           Distribution.Simple.Configure (computeEffectiveProfiling)
 
 import           Distribution.Simple.Utils
-                   ( die'
-                   , notice, noticeNoWrap, debugNoWrap )
+                   ( die', warn, notice, noticeNoWrap, debugNoWrap )
 import           Distribution.Verbosity
 import           Distribution.Text
 import           Distribution.Simple.Compiler
@@ -940,7 +939,7 @@ dieOnBuildFailures verbosity plan buildOutcomes
 
        -- For all failures, print either a short summary (if we showed the
        -- build log) or all details
-       die' verbosity $ unlines
+       dieIfNotHaddockFailure verbosity $ unlines
          [ case failureClassification of
              ShowBuildSummaryAndLog reason _
                | verbosity > normal
@@ -969,6 +968,15 @@ dieOnBuildFailures verbosity plan buildOutcomes
            maybeToList (InstallPlan.lookup plan pkgid)
       ]
 
+    dieIfNotHaddockFailure
+      | all isHaddockFailure failuresClassification = warn
+      | otherwise                                   = die'
+      where
+        isHaddockFailure (_, ShowBuildSummaryOnly   (HaddocksFailed _)  ) = True
+        isHaddockFailure (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True
+        isHaddockFailure _                                                = False
+
+
     classifyBuildFailure :: BuildFailure -> BuildFailurePresentation
     classifyBuildFailure BuildFailure {
                            buildFailureReason  = reason,

cabal-install/changelog

@@ -1,6 +1,9 @@
 -*-change-log-*-
 
 2.4.0.0 (current development version)
+	* 'new-build' now treats Haddock errors non-fatally. In addition,
+	  it attempts to avoid trying to generate Haddocks when there is
+	  nothing to generate them from. (#5232, #5459)
 	* 'new-run', 'new-test', and 'new-bench' now will attempt to resolve
 	  ambiguous selectors by filtering out selectors that would be invalid.
 	  (#4679, #5461)