From b6944ae2a423ee72fd1b258f13f5cb18f1e33cfc Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Thu, 10 Nov 2022 01:37:25 +0000 Subject: [PATCH] Re #5911 Add pretty exceptions and use in Stack.Setup --- doc/maintainers/stack_errors.md | 8 +++- src/Stack/Prelude.hs | 76 ++++++++++++++++++++++----------- src/Stack/Setup.hs | 65 ++++++++++++++++++---------- src/main/Main.hs | 42 ++++++++++++------ 4 files changed, 130 insertions(+), 61 deletions(-) diff --git a/doc/maintainers/stack_errors.md b/doc/maintainers/stack_errors.md index 81c6e5f2f2..3c73a966a8 100644 --- a/doc/maintainers/stack_errors.md +++ b/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 diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs index 22e7fa571b..a92590cecf 100644 --- a/src/Stack/Prelude.hs +++ b/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 diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 2ae2918066..ef98ff6533 100644 --- a/src/Stack/Setup.hs +++ b/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 " <> diff --git a/src/main/Main.hs b/src/main/Main.hs index 539945c24a..0eb5c23e7b 100644 --- a/src/main/Main.hs +++ b/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.