Skip to content

Commit a7e2cfa

Browse files
mpilgremmpilgrem
authored
Merge pull request #5936 from commercialhaskell/re5911-pretty
Re #5911 Add pretty exceptions and use in Stack.Setup
2 parents d0bc335 + b6944ae commit a7e2cfa

File tree

4 files changed

+130
-61
lines changed

4 files changed

+130
-61
lines changed

‎doc/maintainers/stack_errors.md

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,7 @@
55
In connection with considering Stack's support of the
66
[Haskell Error Index](https://errors.haskell.org/) initiative, this page seeks
77
to take stock of the errors that Stack itself can raise, by reference to the
8-
`master` branch of the Stack repository. Last updated: 2022-11-06.
8+
`master` branch of the Stack repository. Last updated: 2022-11-10.
99

1010
* `Main.main`: catches exceptions from action `commandLineHandler`.
1111

@@ -256,6 +256,12 @@ to take stock of the errors that Stack itself can raise, by reference to the
256256
| ExistingMSYS2NotDeleted (Path Abs Dir) IOException
257257
~~~
258258
259+
- `Stack.Setup.SetupPrettyException`
260+
261+
~~~haskell
262+
= GHCInstallFailed SomeException StyleDoc String [String] (Path Abs Dir) (Path Abs Dir) (Path Abs Dir)
263+
~~~
264+
259265
- `Stack.Storage.User.StorageUserException`
260266
261267
~~~haskell

‎src/Stack/Prelude.hs

Lines changed: 52 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,11 @@
1-
{-# LANGUAGE NoImplicitPrelude #-}
2-
{-# LANGUAGE OverloadedStrings #-}
3-
{-# LANGUAGE ScopedTypeVariables #-}
1+
{-# LANGUAGE NoImplicitPrelude #-}
2+
{-# LANGUAGE ExistentialQuantification #-}
3+
{-# LANGUAGE OverloadedStrings #-}
4+
{-# LANGUAGE ScopedTypeVariables #-}
45

56
module Stack.Prelude
6-
( withSystemTempDir
7+
( PrettyException (..)
8+
, withSystemTempDir
79
, withKeepSystemTempDir
810
, sinkProcessStderrStdout
911
, sinkProcessStdout
@@ -25,41 +27,64 @@ module Stack.Prelude
2527
, module X
2628
) where
2729

28-
import RIO as X
29-
import RIO.File as X hiding (writeBinaryFileAtomic)
30-
import Data.Conduit as X (ConduitM, runConduit, (.|))
31-
import Path as X (Abs, Dir, File, Path, Rel,
32-
toFilePath)
33-
import Pantry as X hiding (Package (..), loadSnapshot)
34-
35-
import Data.Monoid as X (First (..), Any (..), Sum (..), Endo (..))
36-
37-
import qualified Path.IO
38-
39-
import System.IO.Echo (withoutInputEcho)
30+
import Data.Monoid as X
31+
( First (..), Any (..), Sum (..), Endo (..) )
4032

33+
import Data.Conduit as X ( ConduitM, runConduit, (.|) )
4134
import qualified Data.Conduit.Binary as CB
4235
import qualified Data.Conduit.List as CL
43-
import Data.Conduit.Process.Typed (withLoggedProcess_, createSource, byteStringInput)
44-
import RIO.Process (HasProcessContext (..), ProcessContext, setStdin, closed, getStderr, getStdout, proc, withProcessWait_, setStdout, setStderr, ProcessConfig, readProcess_, workingDirL, waitExitCode)
45-
36+
import Data.Conduit.Process.Typed
37+
( withLoggedProcess_, createSource, byteStringInput)
4638
import qualified Data.Text.IO as T
39+
import Pantry as X hiding ( Package (..), loadSnapshot )
40+
import Path as X
41+
( Abs, Dir, File, Path, Rel, toFilePath )
42+
import qualified Path.IO
43+
import RIO as X
44+
import RIO.File as X hiding ( writeBinaryFileAtomic )
45+
import RIO.PrettyPrint ( Pretty (..) )
46+
import RIO.Process
47+
( HasProcessContext (..), ProcessContext, setStdin, closed
48+
, getStderr, getStdout, proc, withProcessWait_, setStdout
49+
, setStderr, ProcessConfig, readProcess_, workingDirL
50+
, waitExitCode
51+
)
4752
import qualified RIO.Text as T
53+
import System.IO.Echo ( withoutInputEcho )
54+
55+
-- | Type representing pretty exceptions
56+
data PrettyException
57+
= forall e. (Pretty e, Exception e) => PrettyException e
58+
deriving Typeable
59+
60+
instance Show PrettyException where
61+
show (PrettyException e) = show e
62+
63+
instance Pretty PrettyException where
64+
pretty (PrettyException e) = pretty e
65+
66+
instance Exception PrettyException
4867

4968
-- | Path version
5069
withSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a
51-
withSystemTempDir str inner = withRunInIO $ \run -> Path.IO.withSystemTempDir str $ run . inner
70+
withSystemTempDir str inner = withRunInIO $ \run ->
71+
Path.IO.withSystemTempDir str $ run . inner
5272

5373
-- | Like `withSystemTempDir`, but the temporary directory is not deleted.
54-
withKeepSystemTempDir :: MonadUnliftIO m => String -> (Path Abs Dir -> m a) -> m a
74+
withKeepSystemTempDir :: MonadUnliftIO m
75+
=> String
76+
-> (Path Abs Dir -> m a)
77+
-> m a
5578
withKeepSystemTempDir str inner = withRunInIO $ \run -> do
5679
path <- Path.IO.getTempDir
5780
dir <- Path.IO.createTempDir path str
5881
run $ inner dir
5982

60-
-- | Consume the stdout and stderr of a process feeding strict 'ByteString's to the consumers.
83+
-- | Consume the stdout and stderr of a process feeding strict 'ByteString's to
84+
-- the consumers.
6185
--
62-
-- Throws a 'ReadProcessException' if unsuccessful in launching, or 'ExitCodeException' if the process itself fails.
86+
-- Throws a 'ReadProcessException' if unsuccessful in launching, or
87+
-- 'ExitCodeException' if the process itself fails.
6388
sinkProcessStderrStdout
6489
:: forall e o env. (HasProcessContext env, HasLogFunc env, HasCallStack)
6590
=> String -- ^ Command
@@ -120,7 +145,10 @@ readProcessNull name args =
120145

121146
-- | Use the new 'ProcessContext', but retain the working directory
122147
-- from the parent environment.
123-
withProcessContext :: HasProcessContext env => ProcessContext -> RIO env a -> RIO env a
148+
withProcessContext :: HasProcessContext env
149+
=> ProcessContext
150+
-> RIO env a
151+
-> RIO env a
124152
withProcessContext pcNew inner = do
125153
pcOld <- view processContextL
126154
let pcNew' = set workingDirL (view workingDirL pcOld) pcNew

‎src/Stack/Setup.hs

Lines changed: 43 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -289,6 +289,46 @@ instance Show SetupException where
289289

290290
instance Exception SetupException
291291

292+
-- | Type representing pretty exceptions thrown by functions exported by the
293+
-- "Stack.Setup" module
294+
data SetupPrettyException
295+
= GHCInstallFailed SomeException String String [String] (Path Abs Dir)
296+
(Path Abs Dir) (Path Abs Dir)
297+
deriving (Show, Typeable)
298+
299+
instance Pretty SetupPrettyException where
300+
pretty (GHCInstallFailed ex step cmd args wd tempDir destDir) =
301+
string (show ex)
302+
<> line
303+
<> hang 2 ( flow "Error encountered while" <+> fromString step <+> flow "GHC with"
304+
<> line
305+
<> style Shell (fromString (unwords (cmd : args)))
306+
<> line
307+
-- TODO: Figure out how to insert \ in the appropriate spots
308+
-- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>
309+
<> flow "run in" <+> pretty wd
310+
)
311+
<> line <> line
312+
<> flow "The following directories may now contain files, but won't be \
313+
\used by Stack:"
314+
<> line
315+
<> " -" <+> pretty tempDir
316+
<> line
317+
<> " -" <+> pretty destDir
318+
<> line <> line
319+
<> flow "For more information consider rerunning with --verbose flag"
320+
<> line
321+
322+
-- | @string@ is not exported by module "Text.PrettyPrint.Leijen.Extended" of
323+
-- the @rio-prettyprint@ package.
324+
string :: String -> StyleDoc
325+
string "" = mempty
326+
string ('\n':s) = line <> string s
327+
string s = case (span (/='\n') s) of
328+
(xs, ys) -> fromString xs <> string ys
329+
330+
instance Exception SetupPrettyException
331+
292332
-- | Type representing exceptions thrown by 'performPathChecking'
293333
data PerformPathCheckingException
294334
= ProcessExited ExitCode String [String]
@@ -1563,28 +1603,9 @@ installGHCPosix downloadInfo _ archiveFile archiveType tempDir destDir = do
15631603
void $ withWorkingDir (toFilePath wd) $
15641604
withProcessContext menv' $
15651605
sinkProcessStderrStdout cmd args logStderr logStdout
1566-
`catchAny` \ex -> do
1567-
logError $ displayShow ex
1568-
prettyError $ hang 2 (
1569-
"Error encountered while" <+> step <+> "GHC with"
1570-
<> line <>
1571-
style Shell (fromString (unwords (cmd : args)))
1572-
<> line <>
1573-
-- TODO: Figure out how to insert \ in the appropriate spots
1574-
-- hang 2 (shellColor (fillSep (fromString cmd : map fromString args))) <> line <>
1575-
"run in " <> pretty wd
1576-
)
1577-
<> line <> line <>
1578-
"The following directories may now contain files, but \
1579-
\won't be used by Stack:"
1580-
<> line <>
1581-
" -" <+> pretty tempDir
1582-
<> line <>
1583-
" -" <+> pretty destDir
1584-
<> line <> line <>
1585-
"For more information consider rerunning with --verbose flag"
1586-
<> line
1587-
exitFailure
1606+
`catchAny` \ex ->
1607+
throwIO $ PrettyException
1608+
(GHCInstallFailed ex step cmd args wd tempDir destDir)
15881609

15891610
logSticky $
15901611
"Unpacking GHC into " <>

‎src/main/Main.hs

Lines changed: 28 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -129,23 +129,37 @@ main = do
129129
case eGlobalRun of
130130
Left (exitCode :: ExitCode) ->
131131
throwIO exitCode
132-
Right (globalMonoid,run) -> do
132+
Right (globalMonoid, run) -> do
133133
global <- globalOptsFromMonoid isTerminal globalMonoid
134134
when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString'
135135
case globalReExecVersion global of
136-
Just expectVersion -> do
137-
expectVersion' <- parseVersionThrowing expectVersion
138-
unless (checkVersion MatchMinor expectVersion' (mkVersion' Meta.version))
139-
$ throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)
140-
_ -> pure ()
141-
withRunnerGlobal global $ run `catch` \e ->
142-
-- This special handler stops "stack: " from being printed before the
143-
-- exception
144-
case fromException e of
145-
Just ec -> exitWith ec
146-
Nothing -> do
147-
logError $ fromString $ displayException e
148-
exitFailure
136+
Just expectVersion -> do
137+
expectVersion' <- parseVersionThrowing expectVersion
138+
unless (checkVersion MatchMinor expectVersion' (mkVersion' Meta.version))
139+
$ throwIO $ InvalidReExecVersion expectVersion (showVersion Meta.version)
140+
_ -> pure ()
141+
withRunnerGlobal global $ run `catches`
142+
[ Handler handleExitCode
143+
, Handler handlePrettyException
144+
, Handler handleSomeException
145+
]
146+
147+
-- | Handle ExitCode exceptions.
148+
handleExitCode :: ExitCode -> RIO Runner a
149+
handleExitCode = exitWith
150+
151+
-- | Handle PrettyException exceptions.
152+
handlePrettyException :: PrettyException -> RIO Runner a
153+
handlePrettyException e = do
154+
prettyError $ pretty e
155+
exitFailure
156+
157+
-- | Handle SomeException exceptions. This special handler stops "stack: " from
158+
-- being printed before the exception.
159+
handleSomeException :: SomeException -> RIO Runner a
160+
handleSomeException (SomeException e) = do
161+
logError $ fromString $ displayException e
162+
exitFailure
149163

150164
-- Vertically combine only the error component of the first argument with the
151165
-- error component of the second.

0 commit comments

Comments
 (0)