Add --report-planning-failure option to cabal-install

cabal-install/Distribution/Client/BuildReports/Anonymous.hs

@@ -18,6 +18,7 @@ module Distribution.Client.BuildReports.Anonymous (
 
     -- * Constructing and writing reports
     new,
+    new',
 
     -- * parsing and pretty printing
     parse,
@@ -106,7 +107,8 @@ data BuildReport
   }
 
 data InstallOutcome
-   = DependencyFailed PackageIdentifier
+   = PlanningFailed
+   | DependencyFailed PackageIdentifier
    | DownloadFailed
    | UnpackFailed
    | SetupFailed
@@ -124,8 +126,13 @@ new :: OS -> Arch -> CompilerId -- -> Version
     -> ConfiguredPackage -> BR.BuildResult
     -> BuildReport
 new os' arch' comp (ConfiguredPackage pkg flags _ deps) result =
+    new' os' arch' comp (packageId pkg) flags deps result
+
+new' :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment
+    -> [PackageIdentifier] -> BR.BuildResult -> BuildReport
+new' os' arch' comp pkgid flags deps result =
   BuildReport {
-    package               = packageId pkg,
+    package               = pkgid,
     os                    = os',
     arch                  = arch',
     compiler              = comp,
@@ -139,6 +146,7 @@ new os' arch' comp (ConfiguredPackage pkg flags _ deps) result =
   }
   where
     convertInstallOutcome = case result of
+      Left  BR.PlanningFailed      -> PlanningFailed
       Left  (BR.DependentFailed p) -> DependencyFailed p
       Left  (BR.DownloadFailed  _) -> DownloadFailed
       Left  (BR.UnpackFailed    _) -> UnpackFailed
@@ -276,6 +284,7 @@ parseFlag = do
     flag       -> return (FlagName flag, True)
 
 instance Text.Text InstallOutcome where
+  disp PlanningFailed  = Disp.text "PlanningFailed"
   disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid
   disp DownloadFailed  = Disp.text "DownloadFailed"
   disp UnpackFailed    = Disp.text "UnpackFailed"
@@ -289,6 +298,7 @@ instance Text.Text InstallOutcome where
   parse = do
     name <- Parse.munch1 Char.isAlphaNum
     case name of
+      "PlanningFailed"   -> return PlanningFailed
       "DependencyFailed" -> do Parse.skipSpaces
                                pkgid <- Text.parse
                                return (DependencyFailed pkgid)

cabal-install/Distribution/Client/BuildReports/Storage.hs

@@ -20,6 +20,7 @@ module Distribution.Client.BuildReports.Storage (
 
     -- * 'InstallPlan' support
     fromInstallPlan,
+    fromPlanningFailure,
   ) where
 
 import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
@@ -30,6 +31,10 @@ import qualified Distribution.Client.InstallPlan as InstallPlan
 import Distribution.Client.InstallPlan
          ( InstallPlan )
 
+import Distribution.Package
+         ( PackageId )
+import Distribution.PackageDescription
+         ( FlagAssignment )
 import Distribution.Simple.InstallDirs
          ( PathTemplate, fromPathTemplate
          , initialPathTemplateEnv, substPathTemplate )
@@ -127,3 +132,11 @@ fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
     -> Just $ (BuildReport.new os arch comp pkg (Left result), repo)
 
   _ -> Nothing
+
+fromPlanningFailure :: Platform -> CompilerId
+    -> [PackageId] -> FlagAssignment -> [Repo] -> [(BuildReport, Repo)]
+fromPlanningFailure (Platform arch os) comp pkgids flags repos =
+    [ (BuildReport.new' os arch comp pkgid flags [] (Left PlanningFailed), repo)
+    | pkgid <- pkgids
+    , repo@Repo{ repoKind = Left RemoteRepo{} } <- repos
+    ]

cabal-install/Distribution/Client/Install.hs

@@ -32,7 +32,7 @@ import Data.List
          ( isPrefixOf, unfoldr, nub, sort, (\\) )
 import qualified Data.Set as S
 import Data.Maybe
-         ( isJust, fromMaybe, maybeToList )
+         ( isJust, fromMaybe, mapMaybe, maybeToList )
 import Control.Exception as Exception
          ( Exception(toException), bracket, catches
          , Handler(Handler), handleJust, IOException, SomeException )
@@ -44,6 +44,8 @@ import System.Exit
          ( ExitCode(..) )
 import Distribution.Compat.Exception
          ( catchIO, catchExit )
+import Control.Applicative
+         ( (<$>) )
 import Control.Monad
          ( when, unless )
 import System.Directory
@@ -87,7 +89,7 @@ import Distribution.Client.SetupWrapper
          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
 import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
 import qualified Distribution.Client.BuildReports.Storage as BuildReports
-         ( storeAnonymous, storeLocal, fromInstallPlan )
+         ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure )
 import qualified Distribution.Client.InstallSymlink as InstallSymlink
          ( symlinkBinaries )
 import qualified Distribution.Client.PackageIndex as SourcePackageIndex
@@ -121,7 +123,7 @@ import Distribution.Simple.InstallDirs as InstallDirs
          ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
          , initialPathTemplateEnv, installDirsTemplateEnv )
 import Distribution.Package
-         ( PackageIdentifier, PackageId, packageName, packageVersion
+         ( PackageIdentifier(..), PackageId, packageName, packageVersion
          , Package(..), PackageFixedDeps(..)
          , Dependency(..), thisPackageVersion, InstalledPackageId )
 import qualified Distribution.PackageDescription as PackageDescription
@@ -133,7 +135,7 @@ import Distribution.PackageDescription.Configuration
 import Distribution.ParseUtils
          ( showPWarning )
 import Distribution.Version
-         ( Version )
+         ( Version, VersionRange, foldVersionRange )
 import Distribution.Simple.Utils as Utils
          ( notice, info, warn, debug, debugNoWrap, die
          , intercalate, withTempDirectory )
@@ -187,10 +189,15 @@ install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo
   userTargets0 = do
 
     installContext <- makeInstallContext verbosity args (Just userTargets0)
-    installPlan    <- foldProgress logMsg die' return =<<
+    planResult     <- foldProgress logMsg (return . Left) (return . Right) =<<
                       makeInstallPlan verbosity args installContext
 
-    processInstallPlan verbosity args installContext installPlan
+    case planResult of
+        Left message -> do
+            reportPlanningFailure verbosity args installContext
+            die' message
+        Right installPlan ->
+            processInstallPlan verbosity args installContext installPlan
   where
     args :: InstallArgs
     args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,
@@ -641,6 +648,54 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
 -- * Post installation stuff
 -- ------------------------------------------------------------
 
+-- | Report a solver failure. This works slightly differently to
+-- 'postInstallActions', as (by definition) we don't have an install plan.
+reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> IO ()
+reportPlanningFailure verbosity
+  (_, repos, comp, platform, _, _, _
+  ,_, configFlags, _, installFlags, _)
+  (_, sourcePkgDb, _, pkgSpecifiers) = do
+
+  when reportFailure $ do
+
+    -- Only create reports for explicitly named packages
+    let pkgids =
+          filter (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $
+          mapMaybe theSpecifiedPackage pkgSpecifiers
+
+        buildReports = BuildReports.fromPlanningFailure platform (compilerId comp)
+          pkgids (configConfigurationsFlags configFlags) repos
+
+    when (not (null buildReports)) $
+      notice verbosity $
+        "Notice: this solver failure will be reported for "
+        ++ intercalate "," (map display pkgids)
+
+    -- Save reports
+    BuildReports.storeLocal (installSummaryFile installFlags) buildReports platform
+
+  where
+    reportFailure = fromFlag (installReportPlanningFailure installFlags)
+
+-- | If a 'PackageSpecifier' refers to a single package, return Just that package.
+theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId
+theSpecifiedPackage pkgSpec =
+  case pkgSpec of
+    NamedPackage name [PackageConstraintVersion name' version]
+      | name == name' -> PackageIdentifier name <$> trivialRange version
+    NamedPackage _ _ -> Nothing
+    SpecificSourcePackage pkg -> Just $ packageId pkg
+  where
+    -- | If a range includes only a single version, return Just that version.
+    trivialRange :: VersionRange -> Maybe Version
+    trivialRange = foldVersionRange
+        Nothing
+        Just     -- "== v"
+        (\_ -> Nothing)
+        (\_ -> Nothing)
+        (\_ _ -> Nothing)
+        (\_ _ -> Nothing)
+
 -- | Various stuff we do after successful or unsuccessfully installing a bunch
 -- of packages. This includes:
 --
@@ -836,6 +891,9 @@ printBuildFailures plan =
       InstallFailed   e -> " failed during the final install step."
                         ++ showException e
 
+      -- This will never happen, but we include it for completeness
+      PlanningFailed -> " failed during the planning phase."
+
     showException e   =  " The exception was:\n  " ++ show e ++ maybeOOM e
 #ifdef mingw32_HOST_OS
     maybeOOM _        = ""

cabal-install/Distribution/Client/Setup.hs

@@ -953,6 +953,7 @@ data InstallFlags = InstallFlags {
     installSummaryFile      :: [PathTemplate],
     installLogFile          :: Flag PathTemplate,
     installBuildReports     :: Flag ReportLevel,
+    installReportPlanningFailure :: Flag Bool,
     installSymlinkBinDir    :: Flag FilePath,
     installOneShot          :: Flag Bool,
     installNumJobs          :: Flag (Maybe Int),
@@ -979,6 +980,7 @@ defaultInstallFlags = InstallFlags {
     installSummaryFile     = mempty,
     installLogFile         = mempty,
     installBuildReports    = Flag NoReports,
+    installReportPlanningFailure = Flag False,
     installSymlinkBinDir   = mempty,
     installOneShot         = Flag False,
     installNumJobs         = mempty,
@@ -1157,6 +1159,11 @@ installOptions showOrParseArgs =
                                       (toFlag `fmap` parse))
                           (flagToList . fmap display))
 
+      , option [] ["report-planning-failure"]
+          "Generate build reports when the dependency solver fails. This is used by the Hackage build bot."
+          installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v })
+          trueArg
+
       , option [] ["one-shot"]
           "Do not record the packages in the world file."
           installOneShot (\v flags -> flags { installOneShot = v })
@@ -1200,6 +1207,7 @@ instance Monoid InstallFlags where
     installSummaryFile     = mempty,
     installLogFile         = mempty,
     installBuildReports    = mempty,
+    installReportPlanningFailure = mempty,
     installSymlinkBinDir   = mempty,
     installOneShot         = mempty,
     installNumJobs         = mempty,
@@ -1224,6 +1232,7 @@ instance Monoid InstallFlags where
     installSummaryFile     = combine installSummaryFile,
     installLogFile         = combine installLogFile,
     installBuildReports    = combine installBuildReports,
+    installReportPlanningFailure = combine installReportPlanningFailure,
     installSymlinkBinDir   = combine installSymlinkBinDir,
     installOneShot         = combine installOneShot,
     installNumJobs         = combine installNumJobs,

cabal-install/Distribution/Client/Types.hs

@@ -195,7 +195,8 @@ data Repo = Repo {
 -- ------------------------------------------------------------
 
 type BuildResult  = Either BuildFailure BuildSuccess
-data BuildFailure = DependentFailed PackageId
+data BuildFailure = PlanningFailed
+                  | DependentFailed PackageId
                   | DownloadFailed  SomeException
                   | UnpackFailed    SomeException
                   | ConfigureFailed SomeException