1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage
{-# LANGUAGE InstanceSigs #-}
module GHC.Iface.Errors.Ppr
( IfaceMessageOpts(..)
, interfaceErrorHints
, interfaceErrorReason
, interfaceErrorDiagnostic
, missingInterfaceErrorHints
, missingInterfaceErrorReason
, missingInterfaceErrorDiagnostic
, readInterfaceErrorDiagnostic
)
where
import GHC.Prelude
import GHC.Types.Error
import GHC.Types.Hint.Ppr () -- Outputable GhcHint
import GHC.Types.Error.Codes ( constructorCode )
import GHC.Types.Name
import GHC.Types.TyThing
import GHC.Unit.State
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Iface.Errors.Types
data IfaceMessageOpts = IfaceMessageOpts { ifaceShowTriedFiles :: !Bool -- ^ Whether to show files we tried to look for or not when printing loader errors
}
defaultIfaceMessageOpts :: IfaceMessageOpts
defaultIfaceMessageOpts = IfaceMessageOpts { ifaceShowTriedFiles = False }
instance Diagnostic IfaceMessage where
type DiagnosticOpts IfaceMessage = IfaceMessageOpts
defaultDiagnosticOpts = defaultIfaceMessageOpts
diagnosticMessage opts reason = mkSimpleDecorated $
interfaceErrorDiagnostic opts reason
diagnosticReason = interfaceErrorReason
diagnosticHints = interfaceErrorHints
diagnosticCode = constructorCode
interfaceErrorHints :: IfaceMessage -> [GhcHint]
interfaceErrorHints = \ case
Can'tFindInterface err _looking_for ->
missingInterfaceErrorHints err
Can'tFindNameInInterface {} ->
noHints
missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint]
missingInterfaceErrorHints = \case
BadSourceImport {} ->
noHints
HomeModError {} ->
noHints
DynamicHashMismatchError {} ->
noHints
CantFindErr {} ->
noHints
BadIfaceFile {} ->
noHints
FailedToLoadDynamicInterface {} ->
noHints
interfaceErrorReason :: IfaceMessage -> DiagnosticReason
interfaceErrorReason (Can'tFindInterface err _)
= missingInterfaceErrorReason err
interfaceErrorReason (Can'tFindNameInInterface {})
= ErrorWithoutFlag
missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason
missingInterfaceErrorReason = \ case
BadSourceImport {} ->
ErrorWithoutFlag
HomeModError {} ->
ErrorWithoutFlag
DynamicHashMismatchError {} ->
ErrorWithoutFlag
CantFindErr {} ->
ErrorWithoutFlag
BadIfaceFile {} ->
ErrorWithoutFlag
FailedToLoadDynamicInterface {} ->
ErrorWithoutFlag
prettyCantFindWhat :: FindOrLoad -> FindingModuleOrInterface -> AmbiguousOrMissing -> SDoc
prettyCantFindWhat Find FindingModule AoM_Missing = text "Could not find module"
prettyCantFindWhat Load FindingModule AoM_Missing = text "Could not load module"
prettyCantFindWhat _ FindingInterface AoM_Missing = text "Failed to load interface for"
prettyCantFindWhat _ FindingModule AoM_Ambiguous = text "Ambiguous module name"
prettyCantFindWhat _ FindingInterface AoM_Ambiguous = text "Ambiguous interface for"
isAmbiguousInstalledReason :: CantFindInstalledReason -> AmbiguousOrMissing
isAmbiguousInstalledReason (MultiplePackages {}) = AoM_Ambiguous
isAmbiguousInstalledReason _ = AoM_Missing
isLoadOrFindReason :: CantFindInstalledReason -> FindOrLoad
isLoadOrFindReason NotAModule {} = Find
isLoadOrFindReason (GenericMissing _ a b c _) | null a && null b && null c = Find
isLoadOrFindReason (ModuleSuggestion {}) = Find
isLoadOrFindReason _ = Load
data FindOrLoad = Find | Load
data AmbiguousOrMissing = AoM_Ambiguous | AoM_Missing
cantFindError :: IfaceMessageOpts -> FindingModuleOrInterface -> CantFindInstalled -> SDoc
cantFindError opts mod_or_interface (CantFindInstalled mod_name cfir) =
let ambig = isAmbiguousInstalledReason cfir
find_or_load = isLoadOrFindReason cfir
ppr_what = prettyCantFindWhat find_or_load mod_or_interface ambig
in
(ppr_what <+> quotes (ppr mod_name) <> dot) $$
case cfir of
NoUnitIdMatching pkg cands ->
let looks_like_srcpkgid :: SDoc
looks_like_srcpkgid =
-- Unsafely coerce a unit id (i.e. an installed package component
-- identifier) into a PackageId and see if it means anything.
case cands of
(pkg:pkgs) ->
parens (text "This unit ID looks like the source package ID;" $$
text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$
(if null pkgs then empty
else text "and" <+> int (length pkgs) <+> text "other candidate" <> plural pkgs))
-- Todo: also check if it looks like a package name!
[] -> empty
in hsep [ text "no unit id matching" <+> quotes (ppr pkg)
, text "was found"] $$ looks_like_srcpkgid
MissingPackageFiles pkg files ->
text "There are files missing in the " <> quotes (ppr pkg) <+>
text "package," $$
text "try running 'ghc-pkg check'." $$
mayShowLocations verbose files
MissingPackageWayFiles build pkg files ->
text "Perhaps you haven't installed the " <> text build <+>
text "libraries for package " <> quotes (ppr pkg) <> char '?' $$
mayShowLocations verbose files
ModuleSuggestion ms fps ->
let pp_suggestions :: [ModuleSuggestion] -> SDoc
pp_suggestions sugs
| null sugs = empty
| otherwise = hang (text "Perhaps you meant")
2 (vcat (map pp_sugg sugs))
-- NB: Prefer the *original* location, and then reexports, and then
-- package flags when making suggestions. ToDo: if the original package
-- also has a reexport, prefer that one
pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o
where provenance ModHidden = empty
provenance (ModUnusable _) = empty
provenance (ModOrigin{ fromOrigUnit = e,
fromExposedReexport = res,
fromPackageFlag = f })
| Just True <- e
= parens (text "from" <+> ppr (moduleUnit mod))
| f && moduleName mod == m
= parens (text "from" <+> ppr (moduleUnit mod))
| (pkg:_) <- res
= parens (text "from" <+> ppr (mkUnit pkg)
<> comma <+> text "reexporting" <+> ppr mod)
| f
= parens (text "defined via package flags to be"
<+> ppr mod)
| otherwise = empty
pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o
where provenance ModHidden = empty
provenance (ModUnusable _) = empty
provenance (ModOrigin{ fromOrigUnit = e,
fromHiddenReexport = rhs })
| Just False <- e
= parens (text "needs flag -package-id"
<+> ppr (moduleUnit mod))
| (pkg:_) <- rhs
= parens (text "needs flag -package-id"
<+> ppr (mkUnit pkg))
| otherwise = empty
in pp_suggestions ms $$ mayShowLocations verbose fps
NotAModule -> text "It is not a module in the current program, or in any known package."
CouldntFindInFiles fps -> vcat (map text fps)
MultiplePackages mods
| Just pkgs <- unambiguousPackages
-> sep [text "it was found in multiple packages:",
hsep (map ppr pkgs)]
| otherwise
-> vcat (map pprMod mods)
where
unambiguousPackages = foldl' unambiguousPackage (Just []) mods
unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)
= Just (moduleUnit m : xs)
unambiguousPackage _ _ = Nothing
GenericMissing using_cabal pkg_hiddens mod_hiddens unusables files ->
vcat (map (pkg_hidden using_cabal) pkg_hiddens) $$
vcat (map mod_hidden mod_hiddens) $$
vcat (map unusable unusables) $$
mayShowLocations verbose files
where
verbose = ifaceShowTriedFiles opts
pprMod (m, o) = text "it is bound as" <+> ppr m <+>
text "by" <+> pprOrigin m o
pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"
pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"
pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (
if e == Just True
then [text "package" <+> ppr (moduleUnit m)]
else [] ++
map ((text "a reexport in package" <+>)
.ppr.mkUnit) res ++
if f then [text "a package flag"] else []
)
pkg_hidden :: BuildingCabalPackage -> (Unit, Maybe UnitInfo) -> SDoc
pkg_hidden using_cabal (uid, uif) =
text "It is a member of the hidden package"
<+> quotes (ppr uid)
--FIXME: we don't really want to show the unit id here we should
-- show the source package id or installed package id if it's ambiguous
<> dot $$ pkg_hidden_hint using_cabal uif
pkg_hidden_hint using_cabal (Just pkg)
| using_cabal == YesBuildingCabalPackage
= text "Perhaps you need to add" <+>
quotes (ppr (unitPackageName pkg)) <+>
text "to the build-depends in your .cabal file."
-- MP: This is ghci specific, remove
| otherwise
= text "You can run" <+>
quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>
text "to expose it." $$
text "(Note: this unloads all the modules in the current scope.)"
pkg_hidden_hint _ Nothing = empty
mod_hidden pkg =
text "it is a hidden module in the package" <+> quotes (ppr pkg)
unusable (pkg, reason)
= text "It is a member of the package"
<+> quotes (ppr pkg)
$$ pprReason (text "which is") reason
mayShowLocations :: Bool -> [FilePath] -> SDoc
mayShowLocations verbose files
| null files = empty
| not verbose =
text "Use -v (or `:set -v` in ghci) " <>
text "to see a list of the files searched for."
| otherwise =
hang (text "Locations searched:") 2 $ vcat (map text files)
interfaceErrorDiagnostic :: IfaceMessageOpts -> IfaceMessage -> SDoc
interfaceErrorDiagnostic opts = \ case
Can'tFindNameInInterface name relevant_tyThings ->
missingDeclInInterface name relevant_tyThings
Can'tFindInterface err looking_for ->
case looking_for of
LookingForName {} ->
missingInterfaceErrorDiagnostic opts err
LookingForModule {} ->
missingInterfaceErrorDiagnostic opts err
LookingForHiBoot mod ->
hang (text "Could not find hi-boot interface for" <+> quotes (ppr mod) <> colon)
2 (missingInterfaceErrorDiagnostic opts err)
LookingForSig sig ->
hang (text "Could not find interface file for signature" <+> quotes (ppr sig) <> colon)
2 (missingInterfaceErrorDiagnostic opts err)
readInterfaceErrorDiagnostic :: ReadInterfaceError -> SDoc
readInterfaceErrorDiagnostic = \ case
ExceptionOccurred fp ex ->
hang (text "Exception when reading interface file " <+> text fp)
2 (text (showException ex))
HiModuleNameMismatchWarn _ m1 m2 ->
hiModuleNameMismatchWarn m1 m2
missingInterfaceErrorDiagnostic :: IfaceMessageOpts -> MissingInterfaceError -> SDoc
missingInterfaceErrorDiagnostic opts reason =
case reason of
BadSourceImport m -> badSourceImport m
HomeModError im ml -> homeModError im ml
DynamicHashMismatchError m ml -> dynamicHashMismatchError m ml
CantFindErr us module_or_interface cfi -> pprWithUnitState us $ cantFindError opts module_or_interface cfi
BadIfaceFile rie -> readInterfaceErrorDiagnostic rie
FailedToLoadDynamicInterface wanted_mod err ->
hang (text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon)
2 (readInterfaceErrorDiagnostic err)
hiModuleNameMismatchWarn :: Module -> Module -> SDoc
hiModuleNameMismatchWarn requested_mod read_mod
| moduleUnit requested_mod == moduleUnit read_mod =
sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,
text "but we were expecting module" <+> quotes (ppr requested_mod),
sep [text "Probable cause: the source code which generated interface file",
text "has an incompatible module name"
]
]
| otherwise =
-- ToDo: This will fail to have enough qualification when the package IDs
-- are the same
withPprStyle (mkUserStyle alwaysQualify AllTheWay) $
-- we want the Modules below to be qualified with package names,
-- so reset the NamePprCtx setting.
hsep [ text "Something is amiss; requested module "
, ppr requested_mod
, text "differs from name found in the interface file"
, ppr read_mod
, parens (text "if these names look the same, try again with -dppr-debug")
]
dynamicHashMismatchError :: Module -> ModLocation -> SDoc
dynamicHashMismatchError wanted_mod loc =
vcat [ text "Dynamic hash doesn't match for" <+> quotes (ppr wanted_mod)
, text "Normal interface file from" <+> text (ml_hi_file loc)
, text "Dynamic interface file from" <+> text (ml_dyn_hi_file loc)
, text "You probably need to recompile" <+> quotes (ppr wanted_mod) ]
homeModError :: InstalledModule -> ModLocation -> SDoc
-- See Note [Home module load error]
homeModError mod location
= text "attempting to use module " <> quotes (ppr mod)
<> (case ml_hs_file location of
Just file -> space <> parens (text file)
Nothing -> empty)
<+> text "which is not loaded"
missingDeclInInterface :: Name -> [TyThing] -> SDoc
missingDeclInInterface name things =
whenPprDebug (found_things $$ empty) $$
hang (text "Can't find interface-file declaration for" <+>
pprNameSpace (nameNameSpace name) <+> ppr name)
2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file",
text "Use -ddump-if-trace to get an idea of which file caused the error"])
where
found_things =
hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon)
2 (vcat (map ppr things))
badSourceImport :: Module -> SDoc
badSourceImport mod
= hang (text "You cannot {-# SOURCE #-} import a module from another package")
2 (text "but" <+> quotes (ppr mod) <+> text "is from package"
<+> quotes (ppr (moduleUnit mod)))
|