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

@@ -148,6 +148,13 @@ haddock pkg_descr _ _ haddockFlags
         ++ "a library. Perhaps you want to use the --executables, --tests,"
         ++ " --benchmarks or --foreign-libraries flags."
 
+haddock _ _ _ haddockFlags
+  | null (argTargets haddockFlags) = warn verbosity $
+       "Haddocks are being requested, but there aren't any modules given "
+    ++ "to create documentation for."
+  where
+    verbosity = fromFlag $ haddockVerbosity haddockFlags
+
 haddock pkg_descr lbi suffixes flags' = do
     let verbosity     = flag haddockVerbosity
         comp          = compiler lbi

Cabal/Distribution/Types/PackageDescription/Lens.hs

@@ -9,16 +9,21 @@ import Prelude ()
 
 import Distribution.Compiler                 (CompilerFlavor)
 import Distribution.License                  (License)
-import Distribution.Types.Benchmark          (Benchmark)
+import Distribution.Types.Benchmark          (Benchmark, benchmarkModules)
+import Distribution.Types.Benchmark.Lens     (benchmarkName)
 import Distribution.Types.BuildType          (BuildType)
-import Distribution.Types.Executable         (Executable)
-import Distribution.Types.ForeignLib         (ForeignLib)
-import Distribution.Types.Library            (Library)
+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, libModules)
+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)
+import Distribution.Types.TestSuite          (TestSuite, testModules)
+import Distribution.Types.TestSuite.Lens     (testName)
 import Distribution.Version                  (Version, VersionRange)
 
 import qualified Distribution.SPDX                     as SPDX
@@ -143,3 +148,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 -> Traversal' PackageDescription [ModuleName]
+componentModules cname = case cname of
+    CLibName         -> library  . traversed . to libModules
+    CSubLibName name -> 
+      componentModules' name subLibraries (libName . non "") libModules
+    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])
+                -> Traversal' PackageDescription BuildInfo
+    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 = 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 = action
+      | otherwise              = return ()
 
     whenReRegister  action
       = case buildStatus of

cabal-install/Distribution/Client/ProjectOrchestration.hs

@@ -940,7 +940,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
+       fail' verbosity $ unlines
          [ case failureClassification of
              ShowBuildSummaryAndLog reason _
                | verbosity > normal
@@ -969,6 +969,15 @@ dieOnBuildFailures verbosity plan buildOutcomes
            maybeToList (InstallPlan.lookup plan pkgid)
       ]
 
+    fail'
+      | 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,7 +1,10 @@
 -*-change-log-*-
 
 2.4.0.0 (current development version)
-	* 'new-install' now supports installing libraries and local
+	* '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-install' now supports installing libraries and local 
 	  components. (#5399)
 	* Drop support for GHC 7.4, since it is out of our support window
 	  (and has been for over a year!).