Skip to content

Commit b1c966a

Browse files
mpilgremmpilgrem
committed
Add prettyThrowIO and prettyThrowM to Stack.Prelude
1 parent 540dd1f commit b1c966a

File tree

14 files changed

+74
-87
lines changed

14 files changed

+74
-87
lines changed

‎src/Stack/Build/ConstructPlan.hs

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -278,9 +278,8 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap
278278
planDebug $ show errs
279279
stackYaml <- view stackYamlL
280280
stackRoot <- view stackRootL
281-
throwM $ PrettyException $
282-
ConstructPlanFailed
283-
errs stackYaml stackRoot parents (wanted ctx) prunedGlobalDeps
281+
prettyThrowM $ ConstructPlanFailed
282+
errs stackYaml stackRoot parents (wanted ctx) prunedGlobalDeps
284283
where
285284
hasBaseInDeps = Map.member (mkPackageName "base") (smDeps sourceMap)
286285

‎src/Stack/Build/Execute.hs

Lines changed: 7 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -394,14 +394,8 @@ getSetupExe setupHs setupShimHs tmpdir = do
394394
let pc = setStdout (useHandleOpen stderr) pc0
395395
runProcess_ pc)
396396
`catch` \ece ->
397-
throwM $ PrettyException $
398-
SetupHsBuildFailure
399-
(eceExitCode ece)
400-
Nothing
401-
compilerPath
402-
args
403-
Nothing
404-
[]
397+
prettyThrowM $ SetupHsBuildFailure
398+
(eceExitCode ece) Nothing compilerPath args Nothing []
405399
renameFile tmpExePath exePath
406400
pure $ Just exePath
407401

@@ -770,7 +764,8 @@ executePlan' installedMap0 targets plan ee@ExecuteEnv {..} = do
770764
when (toCoverage $ boptsTestOpts eeBuildOpts) $ do
771765
generateHpcUnifiedReport
772766
generateHpcMarkupIndex
773-
unless (null errs) $ throwM $ PrettyException (ExecutionFailure errs)
767+
unless (null errs) $
768+
prettyThrowM $ ExecutionFailure errs
774769
when (boptsHaddock eeBuildOpts) $ do
775770
snapshotDumpPkgs <- liftIO (readTVarIO eeSnapshotDumpPkgs)
776771
localDumpPkgs <- liftIO (readTVarIO eeLocalDumpPkgs)
@@ -1498,13 +1493,8 @@ withSingleContext ActionContext {..} ee@ExecuteEnv {..} task@Task {..} allDeps m
14981493
.| mungeBuildOutput
14991494
stripTHLoading makeAbsolute pkgDir compilerVer
15001495
.| CL.consume
1501-
throwM $ PrettyException $ CabalExitedUnsuccessfully
1502-
(eceExitCode ece)
1503-
taskProvides
1504-
exeName
1505-
fullArgs
1506-
mlogFile
1507-
bss
1496+
prettyThrowM $ CabalExitedUnsuccessfully
1497+
(eceExitCode ece) taskProvides exeName fullArgs mlogFile bss
15081498
where
15091499
runAndOutput :: ActualCompiler -> RIO env ()
15101500
runAndOutput compilerVer = withWorkingDir (toFilePath pkgDir) $
@@ -1923,7 +1913,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap
19231913
(TTRemotePackage{}, _, _) -> [])
19241914
`catch` \ex -> case ex of
19251915
CabalExitedUnsuccessfully{} ->
1926-
postBuildCheck False >> throwM (PrettyException ex)
1916+
postBuildCheck False >> prettyThrowM ex
19271917
_ -> throwM ex
19281918
postBuildCheck True
19291919

‎src/Stack/Build/Target.hs

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -531,26 +531,26 @@ parseTargets needTargets haddockDeps boptscli smActual = do
531531

532532
case concat [errs1, errs2, errs3] of
533533
[] -> pure ()
534-
errs -> throwIO $ PrettyException $ TargetParseException errs
534+
errs -> prettyThrowIO $ TargetParseException errs
535535

536536
case (Map.null targets, needTargets) of
537537
(False, _) -> pure ()
538538
(True, AllowNoTargets) -> pure ()
539539
(True, NeedTargets)
540540
| null textTargets' && bcImplicitGlobal bconfig ->
541-
throwIO $ PrettyException $ TargetParseException
541+
prettyThrowIO $ TargetParseException
542542
[ fillSep
543543
[ flow "The specified targets matched no packages. Perhaps you \
544544
\need to run"
545545
, style Shell (flow "stack init") <> "?"
546546
]
547547
]
548548
| null textTargets' && Map.null locals ->
549-
throwIO $ PrettyException $ TargetParseException
549+
prettyThrowIO $ TargetParseException
550550
[ flow "The project contains no local packages (packages not \
551551
\marked with 'extra-dep')."
552552
]
553-
| otherwise -> throwIO $ PrettyException $ TargetParseException
553+
| otherwise -> prettyThrowIO $ TargetParseException
554554
[ flow "The specified targets matched no packages." ]
555555

556556
addedDeps' <- mapM (additionalDepPackage haddockDeps . PLImmutable) addedDeps

‎src/Stack/Config.hs

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -270,7 +270,7 @@ configFromConfigMonoid
270270
(parseRelDir x)
271271
( \e -> case e of
272272
InvalidRelDir _ ->
273-
throwIO $ PrettyException $ StackWorkEnvNotRelativeDir x
273+
prettyThrowIO $ StackWorkEnvNotRelativeDir x
274274
_ -> throwIO e
275275
)
276276
in maybe (pure relDirStackWork) (liftIO . parseStackWorkEnv) mstackWorkEnv
@@ -429,7 +429,7 @@ configFromConfigMonoid
429429
Just [pic] -> do
430430
prettyWarn packageIndicesWarning
431431
pure pic
432-
Just x -> throwIO $ PrettyException $ MultiplePackageIndices x
432+
Just x -> prettyThrowIO $ MultiplePackageIndices x
433433
Just pic -> pure pic
434434
mpantryRoot <- liftIO $ lookupEnv pantryRootEnvVar
435435
pantryRoot <-
@@ -934,8 +934,7 @@ loadConfigYaml ::
934934
loadConfigYaml parser path = do
935935
eres <- loadYaml parser path
936936
case eres of
937-
Left err -> liftIO $
938-
throwM $ PrettyException (ParseConfigFileException path err)
937+
Left err -> prettyThrowM (ParseConfigFileException path err)
939938
Right res -> pure res
940939

941940
-- | Load and parse YAML from the given file.

‎src/Stack/Ghci.hs

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -248,8 +248,7 @@ preprocessTargets buildOptsCLI sma rawTargets = do
248248
`catch` \pex@(PrettyException ex) ->
249249
case fromException $ toException ex of
250250
Just (TargetParseException xs) ->
251-
throwM $ PrettyException $
252-
GhciTargetParseException xs
251+
prettyThrowM $ GhciTargetParseException xs
253252
_ -> throwM pex
254253
unless (null fileTargetsRaw) $ throwM Can'tSpecifyFilesAndTargets
255254
pure (Right $ smtTargets normalTargets)

‎src/Stack/Hoogle.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -260,7 +260,7 @@ hoogleCmd (args, setup, rebuild, startServer) =
260260
, flow "to disable) ..."
261261
]
262262
installHoogle
263-
| otherwise -> throwIO $ PrettyException $ HoogleNotFound err
263+
| otherwise -> prettyThrowIO $ HoogleNotFound err
264264

265265
envSettings =
266266
EnvSettings

‎src/Stack/Init.hs

Lines changed: 6 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -126,7 +126,7 @@ initProject currDir initOpts mresolver = do
126126

127127
exists <- doesFileExist dest
128128
when (not (forceOverwrite initOpts) && exists) $
129-
throwIO $ PrettyException $ ConfigFileAlreadyExists reldest
129+
prettyThrowIO $ ConfigFileAlreadyExists reldest
130130

131131
dirs <- mapM (resolveDir' . T.unpack) (searchDirs initOpts)
132132
let find = findCabalDirs (includeSubDirs initOpts)
@@ -413,7 +413,7 @@ renderStackYaml p ignoredPackages dupPackages =
413413
getSnapshots' :: HasConfig env => RIO env Snapshots
414414
getSnapshots' = catchAny
415415
getSnapshots
416-
(throwIO . PrettyException . SnapshotDownloadFailure)
416+
(prettyThrowIO . SnapshotDownloadFailure)
417417

418418
-- | Get the default resolver value
419419
getDefaultResolver ::
@@ -446,8 +446,7 @@ getDefaultResolver initOpts mresolver pkgDirs = do
446446
(c, l, r) <- selectBestSnapshot (Map.elems pkgDirs) snaps
447447
case r of
448448
BuildPlanCheckFail {} | not (omitPackages initOpts)
449-
-> throwM $ PrettyException $
450-
NoMatchingSnapshot snaps
449+
-> prettyThrowM $ NoMatchingSnapshot snaps
451450
_ -> pure (c, l)
452451

453452
getWorkingResolverPlan ::
@@ -538,8 +537,7 @@ checkBundleResolver initOpts snapshotLoc snapCandidate pkgDirs = do
538537
prettyWarnS "Omitting packages with unsatisfied dependencies"
539538
pure $ Left $ failedUserPkgs e
540539
else
541-
throwM $ PrettyException $
542-
ResolverPartial snapshotLoc (show result)
540+
prettyThrowM $ ResolverPartial snapshotLoc (show result)
543541
BuildPlanCheckFail _ e _
544542
| omitPackages initOpts -> do
545543
prettyWarn $
@@ -550,8 +548,7 @@ checkBundleResolver initOpts snapshotLoc snapCandidate pkgDirs = do
550548
<> line
551549
<> indent 4 (string $ show result)
552550
pure $ Left $ failedUserPkgs e
553-
| otherwise -> throwM $
554-
PrettyException $ ResolverMismatch snapshotLoc (show result)
551+
| otherwise -> prettyThrowM $ ResolverMismatch snapshotLoc (show result)
555552
where
556553
warnPartial res = do
557554
prettyWarn $
@@ -662,7 +659,7 @@ cabalPackagesCheck cabaldirs = do
662659
Left e -> throwIO e
663660
let (nameMismatchPkgs, packages) = partitionEithers ePackages
664661
when (nameMismatchPkgs /= []) $
665-
throwIO $ PrettyException $ PackageNameInvalid nameMismatchPkgs
662+
prettyThrowIO $ PackageNameInvalid nameMismatchPkgs
666663

667664
let dupGroups = filter ((> 1) . length)
668665
. groupSortOn (gpdPackageName . snd)

‎src/Stack/Lock.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -180,7 +180,7 @@ lockCachedWanted stackFile resolver fillWanted = do
180180
header <>
181181
byteString (Yaml.encode newLocked)
182182
LFBErrorOnWrite ->
183-
throwIO $ PrettyException $ WritingLockFileError lockFile newLocked
183+
prettyThrowIO $ WritingLockFileError lockFile newLocked
184184
LFBIgnore -> pure ()
185185
LFBReadOnly -> pure ()
186186
pure wanted

‎src/Stack/New.hs

Lines changed: 29 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -252,7 +252,7 @@ data NewOpts = NewOpts
252252
new :: HasConfig env => NewOpts -> Bool -> RIO env (Path Abs Dir)
253253
new opts forceOverwrite = do
254254
when (project `elem` wiredInPackages) $
255-
throwM $ PrettyException $ MagicPackageNameInvalid projectName
255+
prettyThrowM $ MagicPackageNameInvalid projectName
256256
pwd <- getCurrentDir
257257
absDir <- if bare
258258
then pure pwd
@@ -264,8 +264,7 @@ new opts forceOverwrite = do
264264
, configTemplate
265265
]
266266
if exists && not bare
267-
then throwM $ PrettyException $
268-
ProjectDirAlreadyExists projectName absDir
267+
then prettyThrowM $ ProjectDirAlreadyExists projectName absDir
269268
else do
270269
templateText <- loadTemplate template (logUsing absDir template)
271270
files <-
@@ -356,12 +355,10 @@ loadTemplate name logIt = do
356355
then do
357356
bs <- readFileBinary (toFilePath path) --readFileUtf8 (toFilePath path)
358357
case extract bs of
359-
Left err -> throwM $ PrettyException $
360-
ExtractTemplateFailed name path err
358+
Left err -> prettyThrowM $ ExtractTemplateFailed name path err
361359
Right template ->
362360
pure template
363-
else throwM $ PrettyException $
364-
LoadTemplateFailed name path
361+
else prettyThrowM $ LoadTemplateFailed name path
365362

366363
relSettings :: String -> Maybe (RIO env TemplateDownloadSettings)
367364
relSettings req = do
@@ -413,8 +410,7 @@ loadTemplate name logIt = do
413410
\most recent version though."
414411
)
415412
else
416-
throwM $ PrettyException $
417-
DownloadTemplateFailed (templateName name) url exception
413+
prettyThrowM $ DownloadTemplateFailed (templateName name) url exception
418414

419415
-- | Type representing settings for the download of Stack project templates.
420416
data TemplateDownloadSettings = TemplateDownloadSettings
@@ -528,22 +524,18 @@ applyTemplate project template nonceParams dir templateText = do
528524
unpackTemplate receiveMem id
529525
)
530526
( \(e :: ProjectTemplateException) ->
531-
throwM $ PrettyException $
532-
TemplateInvalid template (string $ displayException e)
527+
prettyThrowM $ TemplateInvalid template (string $ displayException e)
533528
)
534529
when (M.null files) $
535-
throwM $ PrettyException $
536-
TemplateInvalid
537-
template
538-
(flow "the template does not contain any files.")
530+
prettyThrowM $ TemplateInvalid
531+
template
532+
(flow "the template does not contain any files.")
539533

540534
let isPkgSpec f = ".cabal" `L.isSuffixOf` f || f == "package.yaml"
541535
unless (any isPkgSpec . M.keys $ files) $
542-
throwM $ PrettyException $
543-
TemplateInvalid
544-
template
545-
( flow "the template does not contain a Cabal or package.yaml file."
546-
)
536+
prettyThrowM $ TemplateInvalid
537+
template
538+
(flow "the template does not contain a Cabal or package.yaml file.")
547539

548540
-- Apply Mustache templating to a single file within the project template.
549541
let applyMustache bytes
@@ -553,20 +545,22 @@ applyTemplate project template nonceParams dir templateText = do
553545
-- https://github.com/commercialhaskell/stack/issues/4133.
554546
| LB.length bytes < 50000
555547
, Right text <- TLE.decodeUtf8' bytes = do
556-
let etemplateCompiled = Mustache.compileTemplate (T.unpack (templateName template)) $ TL.toStrict text
548+
let etemplateCompiled =
549+
Mustache.compileTemplate (T.unpack (templateName template)) $ TL.toStrict text
557550
templateCompiled <- case etemplateCompiled of
558-
Left e -> throwM $ PrettyException $
559-
TemplateInvalid
560-
template
561-
( flow "Stack encountered the following error:"
562-
<> blankLine
563-
-- Text.Parsec.Error.ParseError is not an instance
564-
-- of Control.Exception.
565-
<> string (show e)
566-
)
551+
Left e -> prettyThrowM $ TemplateInvalid
552+
template
553+
( flow "Stack encountered the following error:"
554+
<> blankLine
555+
-- Text.Parsec.Error.ParseError is not an instance
556+
-- of Control.Exception.
557+
<> string (show e)
558+
)
567559
Right t -> pure t
568-
let (substitutionErrors, applied) = Mustache.checkedSubstitute templateCompiled context
569-
missingKeys = S.fromList $ concatMap onlyMissingKeys substitutionErrors
560+
let (substitutionErrors, applied) =
561+
Mustache.checkedSubstitute templateCompiled context
562+
missingKeys =
563+
S.fromList $ concatMap onlyMissingKeys substitutionErrors
570564
pure (LB.fromStrict $ encodeUtf8 applied, missingKeys)
571565

572566
-- Too large or too binary
@@ -659,7 +653,7 @@ checkForOverwrite ::
659653
checkForOverwrite name files = do
660654
overwrites <- filterM doesFileExist files
661655
unless (null overwrites) $
662-
throwM $ PrettyException $ AttemptedOverwrites name overwrites
656+
prettyThrowM $ AttemptedOverwrites name overwrites
663657

664658
-- | Write files to the new project directory.
665659
writeTemplateFiles ::
@@ -698,9 +692,9 @@ templatesHelp = do
698692
req <- fmap setGitHubHeaders (parseUrlThrow url)
699693
resp <- catch
700694
(httpLbs req)
701-
(throwM . PrettyException. DownloadTemplatesHelpFailed)
695+
(prettyThrowM . DownloadTemplatesHelpFailed)
702696
case decodeUtf8' $ LB.toStrict $ getResponseBody resp of
703-
Left err -> throwM $ PrettyException $ TemplatesHelpEncodingInvalid url err
697+
Left err -> prettyThrowM $ TemplatesHelpEncodingInvalid url err
704698
Right txt -> logInfo $ display txt
705699

706700
--------------------------------------------------------------------------------

‎src/Stack/Prelude.hs

Lines changed: 12 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,9 @@ module Stack.Prelude
2525
, bugReport
2626
, bugPrettyReport
2727
, blankLine
28+
, ppException
29+
, prettyThrowIO
30+
, prettyThrowM
2831
, module X
2932
-- * Re-exports from the rio-pretty print package
3033
, HasStylesUpdate (..)
@@ -54,7 +57,6 @@ module Stack.Prelude
5457
, mkNarrativeList
5558
, parens
5659
, parseStylesUpdateFromString
57-
, ppException
5860
, prettyDebug
5961
, prettyDebugL
6062
, prettyError
@@ -351,3 +353,12 @@ ppException :: SomeException -> StyleDoc
351353
ppException e = case fromException e of
352354
Just (PrettyException e') -> pretty e'
353355
Nothing -> (string . displayException) e
356+
357+
-- | Synchronously throw the given exception as a 'PrettyException'.
358+
prettyThrowIO :: (Exception e, MonadIO m, Pretty e) => e -> m a
359+
prettyThrowIO = throwIO . PrettyException
360+
361+
-- | Throw the given exception as a 'PrettyException', when the action is run in
362+
-- the monad @m@.
363+
prettyThrowM :: (Exception e, MonadThrow m, Pretty e) => e -> m a
364+
prettyThrowM = throwM . PrettyException

0 commit comments

Comments
 (0)