Merge pull request #6040 from commercialhaskell/pretty-2476

Prettier errors S-2476 and S-4764

Author: mpilgrem

doc/maintainers/stack_errors.md

@@ -264,12 +264,10 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-9561] | SetupInfoMissingSevenz
         [S-1457] | DockerStackExeNotFound Version Text
         [S-7748] | UnsupportedSetupConfiguration
-        [S-2476] | InvalidGhcAt (Path Abs File) SomeException
         [S-5308] | MSYS2NotFound Text
         [S-5127] | UnwantedCompilerVersion
         [S-1540] | UnwantedArchitecture
         [S-9953] | SandboxedCompilerNotFound
-        [S-4764] | CompilerNotFound [String]
         [S-8668] | GHCInfoNotValidUTF8 UnicodeException
         [S-4878] | GHCInfoNotListOfPairs
         [S-2965] | GHCInfoMissingGlobalPackageDB
@@ -300,7 +298,9 @@ to take stock of the errors that Stack itself can raise, by reference to the
     -   `Stack.Setup.SetupPrettyException`
 
         ~~~haskell
-        [S-7441]= GHCInstallFailed SomeException StyleDoc String [String] (Path Abs Dir) (Path Abs Dir) (Path Abs Dir)
+        [S-7441] = GHCInstallFailed SomeException StyleDoc String [String] (Path Abs Dir) (Path Abs Dir) (Path Abs Dir)
+        [S-2476] | InvalidGhcAt (Path Abs File) SomeException
+        [S-4764] | ExecutableNotFound [Path Abs File]
         ~~~
 
     -   `Stack.Storage.User.StorageUserException`

src/Stack/Prelude.hs

@@ -54,6 +54,8 @@ module Stack.Prelude
   , mkNarrativeList
   , parens
   , parseStylesUpdateFromString
+  , ppException
+  , prettyDebug
   , prettyDebugL
   , prettyError
   , prettyErrorL
@@ -92,12 +94,12 @@ import           RIO.PrettyPrint
                    ( HasStylesUpdate (..), HasTerm (..), Pretty (..), Style (..)
                    , StyleDoc, (<+>), align, bulletedList, debugBracket
                    , encloseSep, fill, fillSep, flow, hang, hcat, hsep, indent
-                   , line, logLevelToStyle, mkNarrativeList, parens
+                   , line, logLevelToStyle, mkNarrativeList, parens, prettyDebug
                    , prettyDebugL, prettyError, prettyErrorL, prettyInfo
                    , prettyInfoL, prettyInfoS, prettyNote, prettyWarn
                    , prettyWarnL, prettyWarnNoIndent, prettyWarnS, punctuate
                    , sep, softbreak, softline, string, style, stylesUpdateL
-                   , useColorL, vsep
+                   , useColorL, vsep, prettyDebug
                    )
 import           RIO.PrettyPrint.DefaultStyles (defaultStyles)
 import           RIO.PrettyPrint.PrettyException ( PrettyException (..) )
@@ -343,3 +345,9 @@ bugRequest =  "Please report this bug at Stack's repository."
 -- | A \'pretty\' blank line.
 blankLine :: StyleDoc
 blankLine = line <> line
+
+-- | Provide the prettiest available information about an exception.
+ppException :: SomeException -> StyleDoc
+ppException e = case fromException e of
+  Just (PrettyException e') -> pretty e'
+  Nothing -> (string . displayException) e

src/Stack/Setup.hs

@@ -159,12 +159,10 @@ data SetupException
   | SetupInfoMissingSevenz
   | DockerStackExeNotFound Version Text
   | UnsupportedSetupConfiguration
-  | InvalidGhcAt (Path Abs File) SomeException
   | MSYS2NotFound Text
   | UnwantedCompilerVersion
   | UnwantedArchitecture
   | SandboxedCompilerNotFound
-  | CompilerNotFound [String]
   | GHCInfoNotValidUTF8 UnicodeException
   | GHCInfoNotListOfPairs
   | GHCInfoMissingGlobalPackageDB
@@ -256,13 +254,6 @@ instance Exception SetupException where
     "Error: [S-7748]\n"
     ++ "Stack does not know how to install GHC on your system \
        \configuration, please install manually."
-  displayException (InvalidGhcAt compiler e) = concat
-    [ "Error: [S-2476]\n"
-    , "Found an invalid compiler at "
-    , show (toFilePath compiler)
-    , ": "
-    , displayException e
-    ]
   displayException (MSYS2NotFound osKey) = concat
     [ "Error: [S-5308]\n"
     , "MSYS2 not found for "
@@ -277,11 +268,6 @@ instance Exception SetupException where
   displayException SandboxedCompilerNotFound =
     "Error: [S-9953]\n"
     ++ "Could not find sandboxed compiler."
-  displayException (CompilerNotFound toTry) = concat
-    [ "Error: [S-4764]\n"
-    , "Could not find any of: "
-    , show toTry
-    ]
   displayException (GHCInfoNotValidUTF8 e) = concat
     [ "Error: [S-8668]\n"
     , "GHC info is not valid UTF-8: "
@@ -407,11 +393,13 @@ data SetupPrettyException
       (Path Abs Dir)
       (Path Abs Dir)
       (Path Abs Dir)
+  | InvalidGhcAt (Path Abs File) SomeException
+  | ExecutableNotFound [Path Abs File]
   deriving (Show, Typeable)
 
 instance Pretty SetupPrettyException where
   pretty (GHCInstallFailed ex step cmd args wd tempDir destDir) =
-       "[S-7441]"
+    "[S-7441]"
     <> line
     <> string (displayException ex)
     <> line
@@ -442,6 +430,24 @@ instance Pretty SetupPrettyException where
          , "flag."
          ]
     <> line
+  pretty (InvalidGhcAt compiler e) =
+    "[S-2476]"
+    <> line
+    <> fillSep
+         [ flow "Stack considers the compiler at"
+         , pretty compiler
+         , flow "to be invalid."
+         ]
+    <> blankLine
+    <> flow "While assessing that compiler, Stack encountered the error:"
+    <> blankLine
+    <> ppException e
+  pretty (ExecutableNotFound toTry) =
+    "[S-4764]"
+    <> line
+    <> flow "Stack could not find any of the following executables:"
+    <> line
+    <> bulletedList (map pretty toTry)
 
 instance Exception SetupPrettyException
 
@@ -1177,17 +1183,21 @@ pathsFromCompiler wc compilerBuild isSandboxed compiler =
         suffixes = maybe id (:) msuffixWithVersion [suffixNoVersion]
         findHelper :: (WhichCompiler -> [String]) -> RIO env (Path Abs File)
         findHelper getNames = do
-          let toTry = [ dir ++ name ++ suffix
-                      | suffix <- suffixes, name <- getNames wc
-                      ]
-              loop [] = throwIO $ CompilerNotFound toTry
-              loop (guessedPath':rest) = do
-                guessedPath <- parseAbsFile guessedPath'
+          toTry <- mapM
+                     parseAbsFile
+                     [ dir ++ name ++ suffix
+                     | suffix <- suffixes, name <- getNames wc
+                     ]
+          let loop [] = throwIO $ PrettyException $ ExecutableNotFound toTry
+              loop (guessedPath:rest) = do
                 exists <- doesFileExist guessedPath
                 if exists
                   then pure guessedPath
                   else loop rest
-          logDebug $ "Looking for executable(s): " <> displayShow toTry
+          prettyDebug $
+               flow "Looking for executable(s):"
+            <> line
+            <> bulletedList (map pretty toTry)
           loop toTry
     pkg <- fmap GhcPkgExe $ findHelper $ \case
                                Ghc -> ["ghc-pkg"]
@@ -1268,7 +1278,7 @@ pathsFromCompiler wc compilerBuild isSandboxed compiler =
       , cpGlobalDump = globalDump
       }
  where
-  onErr = throwIO . InvalidGhcAt compiler
+  onErr = throwIO . PrettyException . InvalidGhcAt compiler
 
   withCache inner = do
     eres <- tryAny $ loadCompilerPaths compiler compilerBuild isSandboxed

src/Stack/Types/Build.hs

@@ -395,15 +395,14 @@ instance Pretty BuildPrettyException where
     <> line
     <> flow "Stack failed to execute the build plan."
     <> blankLine
-    <> flow "While executing the build plan, Stack encountered the \
-            \following errors:"
+    <> fillSep
+         [ flow "While executing the build plan, Stack encountered the"
+         , case es of
+             [_] -> "error:"
+             _ -> flow "following errors:"
+         ]
     <> blankLine
-    <> hcat (L.intersperse blankLine (map ppExceptions es))
-   where
-    ppExceptions :: SomeException -> StyleDoc
-    ppExceptions e = case fromException e of
-      Just (PrettyException e') -> pretty e'
-      Nothing -> (string . show) e
+    <> hcat (L.intersperse blankLine (map ppException es))
   pretty (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) =
     showBuildError "[S-7011]"
       False exitCode (Just taskProvides') execName fullArgs logFiles bss