Improve build reporting for 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 )
@@ -49,7 +54,7 @@ import System.FilePath
 import System.Directory
          ( createDirectoryIfMissing )
 
-storeAnonymous :: [(BuildReport, Repo)] -> IO ()
+storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO ()
 storeAnonymous reports = sequence_
   [ appendFile file (concatMap format reports')
   | (repo, reports') <- separate reports
@@ -59,7 +64,7 @@ storeAnonymous reports = sequence_
 
   where
     format r = '\n' : BuildReport.show r ++ "\n"
-    separate :: [(BuildReport, Repo)]
+    separate :: [(BuildReport, Maybe Repo)]
              -> [(Repo, [BuildReport])]
     separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))
              . map concat
@@ -69,12 +74,12 @@ storeAnonymous reports = sequence_
              . onlyRemote
     repoName (_,_,rrepo) = remoteRepoName rrepo
 
-    onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]
+    onlyRemote :: [(BuildReport, Maybe Repo)] -> [(BuildReport, Repo, RemoteRepo)]
     onlyRemote rs =
       [ (report, repo, remoteRepo)
-      | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]
+      | (report, Just repo@Repo { repoKind = Left remoteRepo }) <- rs ]
 
-storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> Platform -> IO ()
+storeLocal :: [PathTemplate] -> [(BuildReport, Maybe Repo)] -> Platform -> IO ()
 storeLocal templates reports platform = sequence_
   [ do createDirectoryIfMissing True (takeDirectory file)
        appendFile file output
@@ -109,7 +114,7 @@ storeLocal templates reports platform = sequence_
 -- * InstallPlan support
 -- ------------------------------------------------------------
 
-fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]
+fromInstallPlan :: InstallPlan -> [(BuildReport, Maybe Repo)]
 fromInstallPlan plan = catMaybes
                      . map (fromPlanPackage platform comp)
                      . InstallPlan.toList
@@ -119,16 +124,24 @@ fromInstallPlan plan = catMaybes
 
 fromPlanPackage :: Platform -> CompilerId
                 -> InstallPlan.PlanPackage
-                -> Maybe (BuildReport, Repo)
+                -> Maybe (BuildReport, Maybe Repo)
 fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
 
-  InstallPlan.Installed pkg@(ReadyPackage (SourcePackage {
-                          packageSource = RepoTarballPackage repo _ _ }) _ _ _) result
+  InstallPlan.Installed pkg@(ReadyPackage srcPkg _ _ _) result
     -> Just $ (BuildReport.new os arch comp
-               (readyPackageToConfiguredPackage pkg) (Right result), repo)
+               (readyPackageToConfiguredPackage pkg) (Right result), extractRepo srcPkg)
 
-  InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage {
-                       packageSource = RepoTarballPackage repo _ _ }) _ _ _) result
-    -> Just $ (BuildReport.new os arch comp pkg (Left result), repo)
+  InstallPlan.Failed pkg@(ConfiguredPackage srcPkg _ _ _) result
+    -> Just $ (BuildReport.new os arch comp pkg (Left result), extractRepo srcPkg)
 
   _ -> Nothing
+
+  where
+    extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ }) = Just repo
+    extractRepo _ = Nothing
+
+fromPlanningFailure :: Platform -> CompilerId
+    -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)]
+fromPlanningFailure (Platform arch os) comp pkgids flags =
+  [ (BuildReport.new' os arch comp pkgid flags [] (Left PlanningFailed), Nothing)
+  | pkgid <- pkgids ]

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,8 +44,10 @@ import System.Exit
          ( ExitCode(..) )
 import Distribution.Compat.Exception
          ( catchIO, catchExit )
+import Control.Applicative
+         ( (<$>) )
 import Control.Monad
-         ( when, unless )
+         ( forM_, when, unless )
 import System.Directory
          ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,
            createDirectoryIfMissing, removeFile, renameDirectory )
@@ -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
@@ -99,7 +101,7 @@ import Distribution.Client.JobControl
 
 import Distribution.Simple.Compiler
          ( CompilerId(..), Compiler(compilerId), compilerFlavor
-         , PackageDB(..), PackageDBStack )
+         , packageKeySupported , PackageDB(..), PackageDBStack )
 import Distribution.Simple.Program (ProgramConfiguration,
                                     defaultProgramConfiguration)
 import qualified Distribution.Simple.InstallDirs as InstallDirs
@@ -121,8 +123,8 @@ import Distribution.Simple.InstallDirs as InstallDirs
          ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
          , initialPathTemplateEnv, installDirsTemplateEnv )
 import Distribution.Package
-         ( PackageIdentifier, PackageId, packageName, packageVersion
-         , Package(..), PackageFixedDeps(..), PackageKey
+         ( PackageIdentifier(..), PackageId, packageName, packageVersion
+         , Package(..), PackageFixedDeps(..), PackageKey, mkPackageKey
          , Dependency(..), thisPackageVersion, InstalledPackageId )
 import qualified Distribution.PackageDescription as PackageDescription
 import Distribution.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 message
+            die' message
+        Right installPlan ->
+            processInstallPlan verbosity args installContext installPlan
   where
     args :: InstallArgs
     args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,
@@ -596,12 +603,11 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
     showLatest :: ReadyPackage -> String
     showLatest pkg = case mLatestVersion of
         Just latestVersion ->
-            if pkgVersion < latestVersion
+            if packageVersion pkg < latestVersion
             then (" (latest: " ++ display latestVersion ++ ")")
             else ""
         Nothing -> ""
       where
-        pkgVersion    = packageVersion pkg
         mLatestVersion :: Maybe Version
         mLatestVersion = case SourcePackageIndex.lookupPackageName
                                 (packageIndex sourcePkgDb)
@@ -643,6 +649,70 @@ 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 -> String -> IO ()
+reportPlanningFailure verbosity
+  (_, _, comp, platform, _, _, _
+  ,_, configFlags, _, installFlags, _)
+  (_, sourcePkgDb, _, pkgSpecifiers)
+  message = 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)
+
+    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
+
+    -- Save solver log
+    case logFile of
+      Nothing -> return ()
+      Just template -> forM_ pkgids $ \pkgid ->
+        let env = initialPathTemplateEnv pkgid dummyPackageKey
+                    (compilerId comp) platform
+            path = fromPathTemplate $ substPathTemplate env template
+        in  writeFile path message
+
+  where
+    reportFailure = fromFlag (installReportPlanningFailure installFlags)
+    logFile = flagToMaybe (installLogFile installFlags)
+
+    -- A PackageKey is calculated from the transitive closure of
+    -- dependencies, but when the solver fails we don't have that.
+    -- So we fail.
+    dummyPackageKey = error "reportPlanningFailure: package key not available"
+
+-- | 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:
 --
@@ -693,7 +763,7 @@ postInstallActions verbosity
     worldFile      = fromFlag $ globalWorldFile globalFlags
 
 storeDetailedBuildReports :: Verbosity -> FilePath
-                          -> [(BuildReports.BuildReport, Repo)] -> IO ()
+                          -> [(BuildReports.BuildReport, Maybe Repo)] -> IO ()
 storeDetailedBuildReports verbosity logsDir reports = sequence_
   [ do dotCabal <- defaultCabalDir
        let logFileName = display (BuildReports.package report) <.> "log"
@@ -706,7 +776,7 @@ storeDetailedBuildReports verbosity logsDir reports = sequence_
          createDirectoryIfMissing True reportsDir -- FIXME
          writeFile reportFile (show (BuildReports.show report, buildLog))
 
-  | (report, Repo { repoKind = Left remoteRepo }) <- reports
+  | (report, Just Repo { repoKind = Left remoteRepo }) <- reports
   , isLikelyToHaveLogFile (BuildReports.installOutcome report) ]
 
   where
@@ -841,6 +911,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

@@ -973,6 +973,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),
@@ -999,6 +1000,7 @@ defaultInstallFlags = InstallFlags {
     installSummaryFile     = mempty,
     installLogFile         = mempty,
     installBuildReports    = Flag NoReports,
+    installReportPlanningFailure = Flag False,
     installSymlinkBinDir   = mempty,
     installOneShot         = Flag False,
     installNumJobs         = mempty,
@@ -1177,6 +1179,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 })
@@ -1220,6 +1227,7 @@ instance Monoid InstallFlags where
     installSummaryFile     = mempty,
     installLogFile         = mempty,
     installBuildReports    = mempty,
+    installReportPlanningFailure = mempty,
     installSymlinkBinDir   = mempty,
     installOneShot         = mempty,
     installNumJobs         = mempty,
@@ -1244,6 +1252,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

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