Re #5911 Add pretty exceptions and use in Stack.Setup

doc/maintainers/stack_errors.md

@@ -5,7 +5,7 @@
 In connection with considering Stack's support of the
 [Haskell Error Index](https://errors.haskell.org/) initiative, this page seeks
 to take stock of the errors that Stack itself can raise, by reference to the
-`master` branch of the Stack repository. Last updated: 2022-11-06.
+`master` branch of the Stack repository. Last updated: 2022-11-10.
 
 *   `Main.main`: catches exceptions from action `commandLineHandler`.
 
@@ -256,6 +256,12 @@ to take stock of the errors that Stack itself can raise, by reference to the
         | ExistingMSYS2NotDeleted (Path Abs Dir) IOException
         ~~~
 
+    -   `Stack.Setup.SetupPrettyException`
+
+        ~~~haskell
+        = GHCInstallFailed SomeException StyleDoc String [String] (Path Abs Dir) (Path Abs Dir) (Path Abs Dir)
+        ~~~
+
     -   `Stack.Storage.User.StorageUserException`
 
         ~~~haskell

src/Stack/Prelude.hs

@@ -1,9 +1,11 @@
-{-# LANGUAGE NoImplicitPrelude   #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NoImplicitPrelude         #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE ScopedTypeVariables       #-}
 
 module Stack.Prelude
-  ( withSystemTempDir
+  ( PrettyException (..)
+  , withSystemTempDir
   , withKeepSystemTempDir
   , sinkProcessStderrStdout
   , sinkProcessStdout
@@ -25,41 +27,64 @@ module Stack.Prelude
   , module X
   ) where
 
-import           RIO                  as X
-import           RIO.File             as X hiding (writeBinaryFileAtomic)
-import           Data.Conduit         as X (ConduitM, runConduit, (.|))
-import           Path                 as X (Abs, Dir, File, Path, Rel,
-                                            toFilePath)
-import           Pantry               as X hiding (Package (..), loadSnapshot)
-
-import           Data.Monoid          as X (First (..), Any (..), Sum (..), Endo (..))
-
-import qualified Path.IO
-
-import           System.IO.Echo (withoutInputEcho)
+import           Data.Monoid as X
+                   ( First (..), Any (..), Sum (..), Endo (..) )
 
+import           Data.Conduit as X ( ConduitM, runConduit, (.|) )
 import qualified Data.Conduit.Binary as CB
 import qualified Data.Conduit.List as CL
-import           Data.Conduit.Process.Typed (withLoggedProcess_, createSource, byteStringInput)
-import           RIO.Process (HasProcessContext (..), ProcessContext, setStdin, closed, getStderr, getStdout, proc, withProcessWait_, setStdout, setStderr, ProcessConfig, readProcess_, workingDirL, waitExitCode)
-
+import           Data.Conduit.Process.Typed
+                   ( withLoggedProcess_, createSource, byteStringInput)
 import qualified Data.Text.IO as T
+import           Pantry as X hiding ( Package (..), loadSnapshot )
+import           Path as X
+                   ( Abs, Dir, File, Path, Rel, toFilePath )
+import qualified Path.IO
+import           RIO as X
+import           RIO.File as X hiding ( writeBinaryFileAtomic )
+import           RIO.PrettyPrint ( Pretty (..) )
+import           RIO.Process
+                   ( HasProcessContext (..), ProcessContext, setStdin, closed
+                   , getStderr, getStdout, proc, withProcessWait_, setStdout
+                   , setStderr, ProcessConfig, readProcess_, workingDirL
+                   , waitExitCode
+                   )
 import qualified RIO.Text as T
+import           System.IO.Echo ( withoutInputEcho )
+
+-- | Type representing pretty exceptions
+data PrettyException
+  = forall e. (Pretty e, Exception e) => PrettyException e
+  deriving Typeable
+
+instance Show PrettyException where
+  show (PrettyException e) = show e
+
+instance Pretty PrettyException where
+  pretty (PrettyException e) = pretty e
+
+instance Exception PrettyException
 
 -- | Path version
 withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a
-withSystemTempDir str inner = withRunInIO $ \run -> Path.IO.withSystemTempDir str $ run . inner
+withSystemTempDir str inner = withRunInIO $ \run ->
+  Path.IO.withSystemTempDir str $ run . inner
 
 -- | Like `withSystemTempDir`, but the temporary directory is not deleted.
-withKeepSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a
+withKeepSystemTempDir :: MonadUnliftIO m
+                      => String
+                      -> (Path Abs Dir -> m a)
+                      -> m a
 withKeepSystemTempDir str inner = withRunInIO $ \run -> do
   path <- Path.IO.getTempDir
   dir <- Path.IO.createTempDir path str
   run $ inner dir
 
--- | Consume the stdout and stderr of a process feeding strict 'ByteString's to the consumers.
+-- | Consume the stdout and stderr of a process feeding strict 'ByteString's to
+-- the consumers.
 --
--- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ExitCodeException' if the process itself fails.
+-- Throws a 'ReadProcessException' if unsuccessful in launching, or
+-- 'ExitCodeException' if the process itself fails.
 sinkProcessStderrStdout
   :: forall e o env. (HasProcessContext env, HasLogFunc env, HasCallStack)
   => String -- ^ Command
@@ -120,7 +145,10 @@ readProcessNull name args =
 
 -- | Use the new 'ProcessContext', but retain the working directory
 -- from the parent environment.
-withProcessContext :: HasProcessContext env => ProcessContext -> RIO env a -> RIO env a
+withProcessContext :: HasProcessContext env
+                   => ProcessContext
+                   -> RIO env a
+                   -> RIO env a
 withProcessContext pcNew inner = do
   pcOld <- view processContextL
   let pcNew' = set workingDirL (view workingDirL pcOld) pcNew

src/Stack/Setup.hs

@@ -289,6 +289,46 @@ instance Show SetupException where
 
 instance Exception SetupException
 
+-- | Type representing pretty exceptions thrown by functions exported by the
+-- "Stack.Setup" module
+data SetupPrettyException
+    = GHCInstallFailed SomeException String String [String] (Path Abs Dir)
+          (Path Abs Dir) (Path Abs Dir)
+    deriving (Show, Typeable)
+
+instance Pretty SetupPrettyException where
+    pretty (GHCInstallFailed ex step cmd args wd tempDir destDir) =
+         string (show ex)
+      <> line
+      <> hang 2 (  flow "Error encountered while" <+> fromString step <+> flow "GHC with"
+                <> line
+                <> style Shell (fromString (unwords (cmd : args)))
+                <> line
+                -- TODO: Figure out how to insert \ in the appropriate spots
+                -- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>
+                <> flow "run in" <+> pretty wd
+                )
+      <> line <> line
+      <> flow "The following directories may now contain files, but won't be \
+              \used by Stack:"
+      <> line
+      <> "  -" <+> pretty tempDir
+      <> line
+      <> "  -" <+> pretty destDir
+      <> line <> line
+      <> flow "For more information consider rerunning with --verbose flag"
+      <> line
+
+-- | @string@ is not exported by module "Text.PrettyPrint.Leijen.Extended" of
+-- the @rio-prettyprint@ package.
+string :: String -> StyleDoc
+string "" = mempty
+string ('\n':s) = line <> string s
+string s        = case (span (/='\n') s) of
+                      (xs, ys) -> fromString xs <> string ys
+
+instance Exception SetupPrettyException
+
 -- | Type representing exceptions thrown by 'performPathChecking'
 data PerformPathCheckingException
     = ProcessExited ExitCode String [String]
@@ -1563,28 +1603,9 @@ installGHCPosix downloadInfo _ archiveFile archiveType tempDir destDir = do
           void $ withWorkingDir (toFilePath wd) $
                 withProcessContext menv' $
                 sinkProcessStderrStdout cmd args logStderr logStdout
-                `catchAny` \ex -> do
-                  logError $ displayShow ex
-                  prettyError $ hang 2 (
-                      "Error encountered while" <+> step <+> "GHC with"
-                      <> line <>
-                      style Shell (fromString (unwords (cmd : args)))
-                      <> line <>
-                      -- TODO: Figure out how to insert \ in the appropriate spots
-                      -- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>
-                      "run in " <> pretty wd
-                      )
-                    <> line <> line <>
-                    "The following directories may now contain files, but \
-                    \won't be used by Stack:"
-                    <> line <>
-                    "  -" <+> pretty tempDir
-                    <> line <>
-                    "  -" <+> pretty destDir
-                    <> line <> line <>
-                    "For more information consider rerunning with --verbose flag"
-                    <> line
-                  exitFailure
+                `catchAny` \ex ->
+                    throwIO $ PrettyException
+                      (GHCInstallFailed ex step cmd args wd tempDir destDir)
 
     logSticky $
       "Unpacking GHC into " <>

src/main/Main.hs

@@ -129,23 +129,37 @@ main = do
   case eGlobalRun of
     Left (exitCode :: ExitCode) ->
       throwIO exitCode
-    Right (globalMonoid,run) -> do
+    Right (globalMonoid, run) -> do
       global <- globalOptsFromMonoid isTerminal globalMonoid
       when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString'
       case globalReExecVersion global of
-          Just expectVersion -> do
-              expectVersion' <- parseVersionThrowing expectVersion
-              unless (checkVersion MatchMinor expectVersion' (mkVersion' Meta.version))
-                  $ throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)
-          _ -> pure ()
-      withRunnerGlobal global $ run `catch` \e ->
-          -- This special handler stops "stack: " from being printed before the
-          -- exception
-          case fromException e of
-              Just ec -> exitWith ec
-              Nothing -> do
-                  logError $ fromString $ displayException e
-                  exitFailure
+        Just expectVersion -> do
+            expectVersion' <- parseVersionThrowing expectVersion
+            unless (checkVersion MatchMinor expectVersion' (mkVersion' Meta.version))
+                $ throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)
+        _ -> pure ()
+      withRunnerGlobal global $ run `catches`
+        [ Handler handleExitCode
+        , Handler handlePrettyException
+        , Handler handleSomeException
+        ]
+
+-- | Handle ExitCode exceptions.
+handleExitCode :: ExitCode -> RIO Runner a
+handleExitCode = exitWith
+
+-- | Handle PrettyException exceptions.
+handlePrettyException :: PrettyException -> RIO Runner a
+handlePrettyException e = do
+  prettyError $ pretty e
+  exitFailure
+
+-- | Handle SomeException exceptions. This special handler stops "stack: " from
+-- being printed before the exception.
+handleSomeException :: SomeException -> RIO Runner a
+handleSomeException (SomeException e) = do
+  logError $ fromString $ displayException e
+  exitFailure
 
 -- Vertically combine only the error component of the first argument with the
 -- error component of the second.