Clearer error messages when build of Setup.hs fails commercialhaskell#3560

mgsloan · mgsloan · commit 94eca69d4d2e · 2017-11-13T16:31:14.000-08:00
diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
@@ -306,7 +306,10 @@ getSetupExe setupHs setupShimHs tmpdir = do
                     , toFilePath tmpOutputPath
                     ] ++
                     ["-build-runner" | wc == Ghcjs]
-            runCmd' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args) Nothing
+            callProcess' (\cp -> cp { std_out = UseHandle stderr }) (Cmd (Just tmpdir) (compilerExeName wc) menv args)
+                `catch` \(ProcessExitedUnsuccessfully _ ec) -> do
+                    compilerPath <- getCompilerPath wc
+                    throwM $ SetupHsBuildFailure ec Nothing compilerPath args Nothing []
             when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath
             renameFile tmpExePath exePath
             return $ Just exePath
@@ -1073,9 +1076,9 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
                                         =$= CT.decodeUtf8Lenient
                                         $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir compilerVer
                                         =$ CL.consume
-                        throwM $ CabalExitedUnsuccessfully
+                        throwM $ SetupHsBuildFailure
                             ec
-                            taskProvides
+                            (Just taskProvides)
                             exeName
                             fullArgs
                             (fmap fst mlogFile)
@@ -1104,10 +1107,9 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
                         ExcludeTHLoading -> ConvertPathsToAbsolute
                         KeepTHLoading    -> KeepPathsAsIs
 
-            wc <- view $ actualCompilerVersionL.whichCompilerL
-            exeName <- case (esetupexehs, wc) of
-                (Left setupExe, _) -> return setupExe
-                (Right setuphs, compiler) -> do
+            exeName <- case esetupexehs of
+                Left setupExe -> return setupExe
+                Right setuphs -> do
                     distDir <- distDirFromDir pkgDir
                     let setupDir = distDir </> $(mkRelDir "setup")
                         outputFile = setupDir </> $(mkRelFile "setup")
@@ -1116,6 +1118,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
                         then return outputFile
                         else do
                             ensureDir setupDir
+                            compiler <- view $ actualCompilerVersionL.whichCompilerL
                             compilerPath <-
                                 case compiler of
                                     Ghc -> eeGetGhcPath
diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs
@@ -111,6 +111,13 @@ data StackBuildException
         [String]         -- cabal arguments
         (Maybe (Path Abs File)) -- logfiles location
         [Text]     -- log contents
+  | SetupHsBuildFailure
+        ExitCode
+        (Maybe PackageIdentifier) -- which package's custom setup, is simple setup if Nothing
+        (Path Abs File)  -- ghc Executable
+        [String]         -- ghc arguments
+        (Maybe (Path Abs File)) -- logfiles location
+        [Text]     -- log contents
   | ExecutionFailure [SomeException]
   | LocalPackageDoesn'tMatchTarget
         PackageName
@@ -220,23 +227,9 @@ instance Show StackBuildException where
               "Unsupported test suite type: " <> show interface
      -- Supressing duplicate output
     show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) =
-        let fullCmd = unwords
-                    $ dropQuotes (toFilePath execName)
-                    : map (T.unpack . showProcessArgDebug) fullArgs
-            logLocations = maybe "" (\fp -> "\n    Logs have been written to: " ++ toFilePath fp) logFiles
-        in "\n--  While building package " ++ dropQuotes (show taskProvides') ++ " using:\n" ++
-           "      " ++ fullCmd ++ "\n" ++
-           "    Process exited with code: " ++ show exitCode ++
-           (if exitCode == ExitFailure (-9)
-                then " (THIS MAY INDICATE OUT OF MEMORY)"
-                else "") ++
-           logLocations ++
-           (if null bss
-                then ""
-                else "\n\n" ++ doubleIndent (map T.unpack bss))
-         where
-          doubleIndent = dropWhileEnd isSpace . unlines . fmap (\line -> "    " ++ line)
-          dropQuotes = filter ('\"' /=)
+      showBuildError False exitCode (Just taskProvides') execName fullArgs logFiles bss
+    show (SetupHsBuildFailure exitCode mtaskProvides execName fullArgs logFiles bss) =
+      showBuildError True exitCode mtaskProvides execName fullArgs logFiles bss
     show (ExecutionFailure es) = intercalate "\n\n" $ map show es
     show (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat
         [ "Version for local package "
@@ -338,6 +331,40 @@ missingExeError isSimpleBuildType msg =
             then []
             else ["The Setup.hs file is changing the installation target dir."]
 
+showBuildError
+  :: Bool
+  -> ExitCode
+  -> Maybe PackageIdentifier
+  -> Path Abs File
+  -> [String]
+  -> Maybe (Path Abs File)
+  -> [Text]
+  -> String
+showBuildError isBuildingSetup exitCode mtaskProvides execName fullArgs logFiles bss =
+  let fullCmd = unwords
+              $ dropQuotes (toFilePath execName)
+              : map (T.unpack . showProcessArgDebug) fullArgs
+      logLocations = maybe "" (\fp -> "\n    Logs have been written to: " ++ toFilePath fp) logFiles
+  in "\n--  While building " ++
+     (case (isBuildingSetup, mtaskProvides) of
+       (False, Nothing) -> error "Invariant violated: unexpected case in showBuildError"
+       (False, Just taskProvides') -> "package " ++ dropQuotes (show taskProvides')
+       (True, Nothing) -> "simple Setup.hs"
+       (True, Just taskProvides') -> "custom Setup.hs for package " ++ dropQuotes (show taskProvides')
+     ) ++
+     " using:\n      " ++ fullCmd ++ "\n" ++
+     "    Process exited with code: " ++ show exitCode ++
+     (if exitCode == ExitFailure (-9)
+          then " (THIS MAY INDICATE OUT OF MEMORY)"
+          else "") ++
+     logLocations ++
+     (if null bss
+          then ""
+          else "\n\n" ++ doubleIndent (map T.unpack bss))
+   where
+    doubleIndent = dropWhileEnd isSpace . unlines . fmap (\line -> "    " ++ line)
+    dropQuotes = filter ('\"' /=)
+
 instance Exception StackBuildException
 
 ----------------------------------------------
