Skip to content

Commit 71a85a4

Browse files
mpilgremmpilgrem
authored
Merge pull request commercialhaskell#5959 from commercialhaskell/fix5955b
Re commercialhaskell#5955 Prettier Stack.Init exceptions
2 parents c6b32cc + 84bc2d3 commit 71a85a4

File tree

2 files changed

+104
-71
lines changed

2 files changed

+104
-71
lines changed

‎doc/maintainers/stack_errors.md

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -153,10 +153,14 @@ to take stock of the errors that Stack itself can raise, by reference to the
153153
- `Stack.Init.InitException`
154154

155155
~~~haskell
156-
[S-8009] = ConfigFileAlreadyExists FilePath
157-
[S-8332] | SnapshotDownloadFailure SomeException
158-
[S-4934] | NoPackagesToIgnore
159-
[S-2747] | PackagesToIgnoreBug
156+
[S-2747] | NoPackagesToIgnoreBug
157+
~~~
158+
159+
- `Stack.Init.InitPrettyException`
160+
161+
~~~haskell
162+
[S-8332] = SnapshotDownloadFailure SomeException
163+
[S-8009] | ConfigFileAlreadyExists FilePath
160164
[S-5267] | PackageNameInvalid [FilePath]
161165
~~~
162166

‎src/Stack/Init.hs

Lines changed: 96 additions & 67 deletions
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,6 @@ import qualified Data.List.NonEmpty as NonEmpty
2323
import qualified Data.Map.Strict as Map
2424
import qualified Data.Set as Set
2525
import qualified Data.Text as T
26-
import qualified Data.Text.Normalize as T (normalize , NormalizationMode(NFC))
2726
import qualified Data.Yaml as Yaml
2827
import qualified Distribution.PackageDescription as C
2928
import qualified Distribution.Text as C
@@ -49,48 +48,77 @@ import Stack.Types.Version
4948
-- | Type representing exceptions thrown by functions exported by the
5049
-- "Stack.Init" module.
5150
data InitException
52-
= ConfigFileAlreadyExists FilePath
53-
| SnapshotDownloadFailure SomeException
54-
| NoPackagesToIgnore
55-
| PackagesToIgnoreBug
56-
| PackageNameInvalid [FilePath]
51+
= NoPackagesToIgnoreBug
5752
deriving (Show, Typeable)
5853

5954
instance Exception InitException where
60-
displayException (ConfigFileAlreadyExists reldest) = concat
61-
[ "Error: [S-8009]\n"
62-
, "Stack configuration file "
63-
, reldest
64-
, " exists, use '--force' to overwrite it."
65-
]
66-
displayException (SnapshotDownloadFailure e) = concat
67-
[ "Error: [S-8332]\n"
68-
, "Unable to download snapshot list, and therefore could not \
69-
\generate a stack.yaml file automatically\n"
70-
, "This sometimes happens due to missing Certificate Authorities on \
71-
\your system. For more information, see:\n"
72-
, "\n"
73-
, " https://github.com/commercialhaskell/stack/issues/234\n"
74-
, "\n"
75-
, "You can try again, or create your stack.yaml file by hand. See:\n"
76-
, "\n"
77-
, " http://docs.haskellstack.org/en/stable/yaml_configuration/\n"
78-
, "\n"
79-
, "Exception was: "
80-
, displayException e
81-
]
82-
displayException NoPackagesToIgnore =
83-
"Error: [S-4934]\n"
84-
++ "No packages to ignore"
85-
displayException PackagesToIgnoreBug = bugReport "[S-2747]"
55+
displayException NoPackagesToIgnoreBug = bugReport "[S-2747]"
8656
"No packages to ignore."
87-
displayException (PackageNameInvalid rels) = unlines
88-
[ "Error: [S-5267]"
89-
, "Package name as defined in the Cabal file must match the Cabal file \
90-
\name."
91-
, "Please fix the following packages and try again:"
92-
, T.unpack (utf8BuilderToText (formatGroup rels))
93-
]
57+
58+
data InitPrettyException
59+
= SnapshotDownloadFailure SomeException
60+
| ConfigFileAlreadyExists FilePath
61+
| PackageNameInvalid [(Path Abs File, PackageName)]
62+
deriving (Show, Typeable)
63+
64+
instance Pretty InitPrettyException where
65+
pretty (ConfigFileAlreadyExists reldest) =
66+
"[S-8009]"
67+
<> line
68+
<> flow "Stack declined to create a project-level YAML configuration \
69+
\file."
70+
<> blankLine
71+
<> fillSep
72+
[ flow "The file"
73+
, style File (fromString reldest)
74+
, "already exists. To overwrite it, pass the flag"
75+
, style Shell "--force" <> "."
76+
]
77+
pretty (PackageNameInvalid rels) =
78+
"[S-5267]"
79+
<> line
80+
<> flow "Stack did not create project-level YAML configuration, as \
81+
\(like Hackage) it requires a Cabal file name to match the \
82+
\package it defines."
83+
<> blankLine
84+
<> flow "Please rename the following Cabal files:"
85+
<> line
86+
<> bulletedList
87+
( map
88+
( \(fp, name) -> fillSep
89+
[ style File (pretty fp)
90+
, "as"
91+
, style
92+
File
93+
(fromString (packageNameString name) <> ".cabal")
94+
]
95+
)
96+
rels
97+
)
98+
pretty (SnapshotDownloadFailure e) =
99+
"[S-8332]"
100+
<> line
101+
<> flow "Stack failed to create project-level YAML configuration, as \
102+
\it was unable to download the index of available snapshots."
103+
<> blankLine
104+
<> fillSep
105+
[ flow "This sometimes happens because Certificate Authorities \
106+
\are missing on your system. You can try the Stack command \
107+
\again or manually create the configuration file. For help \
108+
\about the content of Stack's YAML configuration files, \
109+
\see (for the most recent release of Stack)"
110+
, style
111+
Url
112+
"http://docs.haskellstack.org/en/stable/yaml_configuration/"
113+
<> "."
114+
]
115+
<> blankLine
116+
<> flow "While downloading the snapshot index, Stack encountered the \
117+
\following exception:"
118+
<> blankLine
119+
<> string (displayException e)
120+
121+
instance Exception InitPrettyException
94122

95123
-- | Generate stack.yaml
96124
initProject
@@ -106,7 +134,7 @@ initProject currDir initOpts mresolver = do
106134

107135
exists <- doesFileExist dest
108136
when (not (forceOverwrite initOpts) && exists) $
109-
throwIO $ ConfigFileAlreadyExists reldest
137+
throwIO $ PrettyException $ ConfigFileAlreadyExists reldest
110138

111139
dirs <- mapM (resolveDir' . T.unpack) (searchDirs initOpts)
112140
let find = findCabalDirs (includeSubDirs initOpts)
@@ -361,8 +389,9 @@ renderStackYaml p ignoredPackages dupPackages =
361389
]
362390

363391
getSnapshots' :: HasConfig env => RIO env Snapshots
364-
getSnapshots' = do
365-
getSnapshots `catchAny` \e -> throwIO $ SnapshotDownloadFailure e
392+
getSnapshots' = catchAny
393+
getSnapshots
394+
(\e -> throwIO $ PrettyException $ SnapshotDownloadFailure e)
366395

367396
-- | Get the default resolver value
368397
getDefaultResolver
@@ -431,7 +460,7 @@ getWorkingResolverPlan initOpts pkgDirs0 snapCandidate snapLoc = do
431460
pure (snapLoc, Map.empty, Map.empty, Map.empty)
432461
| otherwise -> do
433462
when (Map.size available == Map.size pkgDirs) $
434-
throwM NoPackagesToIgnore
463+
throwM NoPackagesToIgnoreBug
435464

436465
if length ignored > 1 then do
437466
logWarn "*** Ignoring packages:"
@@ -440,7 +469,7 @@ getWorkingResolverPlan initOpts pkgDirs0 snapCandidate snapLoc = do
440469
logWarn $ "*** Ignoring package: "
441470
<> fromString
442471
(case ignored of
443-
[] -> throwM PackagesToIgnoreBug
472+
[] -> throwM NoPackagesToIgnoreBug
444473
x:_ -> packageNameString x)
445474

446475
go available
@@ -551,29 +580,29 @@ cabalPackagesCheck cabaldirs = do
551580
logWarn "If this isn't what you want, please delete the generated \"stack.yaml\""
552581

553582
relpaths <- mapM prettyPath cabaldirs
554-
logInfo "Using cabal packages:"
555-
logInfo $ formatGroup relpaths
556-
557-
packages <- for cabaldirs $ \dir -> do
558-
(gpdio, _name, cabalfp) <- loadCabalFilePath (Just stackProgName') dir
559-
gpd <- liftIO $ gpdio YesPrintWarnings
560-
pure (cabalfp, gpd)
561-
562-
-- package name cannot be empty or missing otherwise
563-
-- it will result in Cabal solver failure.
564-
-- Stack requires packages name to match the Cabal file name
565-
-- Just the latter check is enough to cover both the cases
566-
567-
let normalizeString = T.unpack . T.normalize T.NFC . T.pack
568-
getNameMismatchPkg (fp, gpd)
569-
| (normalizeString . packageNameString . gpdPackageName) gpd /= (normalizeString . FP.takeBaseName . toFilePath) fp
570-
= Just fp
571-
| otherwise = Nothing
572-
nameMismatchPkgs = mapMaybe getNameMismatchPkg packages
573-
574-
when (nameMismatchPkgs /= []) $ do
575-
rels <- mapM prettyPath nameMismatchPkgs
576-
throwIO $ PackageNameInvalid rels
583+
unless (null relpaths) $
584+
prettyInfo $
585+
flow "Using the Cabal packages:"
586+
<> line
587+
<> bulletedList (map (style File . fromString) relpaths)
588+
<> line
589+
590+
-- A package name cannot be empty or missing otherwise it will result in
591+
-- Cabal solver failure. Stack requires packages name to match the Cabal
592+
-- file name. Just the latter check is enough to cover both the cases.
593+
ePackages <- for cabaldirs $ \dir -> do
594+
-- Pantry's 'loadCabalFilePath' throws 'MismatchedCabalName' (error
595+
-- [S-910]) if the Cabal file name does not match the package it
596+
-- defines.
597+
(gpdio, _name, cabalfp) <- loadCabalFilePath (Just stackProgName') dir
598+
eres <- liftIO $ try (gpdio YesPrintWarnings)
599+
case eres :: Either PantryException C.GenericPackageDescription of
600+
Right gpd -> pure $ Right (cabalfp, gpd)
601+
Left (MismatchedCabalName fp name) -> pure $ Left (fp, name)
602+
Left e -> throwIO e
603+
let (nameMismatchPkgs, packages) = partitionEithers ePackages
604+
when (nameMismatchPkgs /= []) $
605+
throwIO $ PrettyException $ PackageNameInvalid nameMismatchPkgs
577606

578607
let dupGroups = filter ((> 1) . length)
579608
. groupSortOn (gpdPackageName . snd)

0 commit comments

Comments
 (0)