Refactor TcRnMonad.mapAndRecoverM
[ghc.git] / compiler / typecheck / TcRnExports.hs
1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE TypeFamilies #-}
6 module TcRnExports (tcRnExports, exports_from_avail) where
7
8 import GhcPrelude
9
10 import HsSyn
11 import PrelNames
12 import RdrName
13 import TcRnMonad
14 import TcEnv
15 import TcType
16 import RnNames
17 import RnEnv
18 import RnUnbound ( reportUnboundName )
19 import ErrUtils
20 import Id
21 import IdInfo
22 import Module
23 import Name
24 import NameEnv
25 import NameSet
26 import Avail
27 import TyCon
28 import SrcLoc
29 import HscTypes
30 import Outputable
31 import ConLike
32 import DataCon
33 import PatSyn
34 import Maybes
35 import UniqSet
36 import Util (capitalise)
37 import FastString (fsLit)
38
39 import Control.Monad
40 import DynFlags
41 import RnHsDoc ( rnHsDoc )
42 import RdrHsSyn ( setRdrNameSpace )
43 import Data.Either ( partitionEithers )
44
45 {-
46 ************************************************************************
47 * *
48 \subsection{Export list processing}
49 * *
50 ************************************************************************
51
52 Processing the export list.
53
54 You might think that we should record things that appear in the export
55 list as ``occurrences'' (using @addOccurrenceName@), but you'd be
56 wrong. We do check (here) that they are in scope, but there is no
57 need to slurp in their actual declaration (which is what
58 @addOccurrenceName@ forces).
59
60 Indeed, doing so would big trouble when compiling @PrelBase@, because
61 it re-exports @GHC@, which includes @takeMVar#@, whose type includes
62 @ConcBase.StateAndSynchVar#@, and so on...
63
64 Note [Exports of data families]
65 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
66 Suppose you see (Trac #5306)
67 module M where
68 import X( F )
69 data instance F Int = FInt
70 What does M export? AvailTC F [FInt]
71 or AvailTC F [F,FInt]?
72 The former is strictly right because F isn't defined in this module.
73 But then you can never do an explicit import of M, thus
74 import M( F( FInt ) )
75 because F isn't exported by M. Nor can you import FInt alone from here
76 import M( FInt )
77 because we don't have syntax to support that. (It looks like an import of
78 the type FInt.)
79
80 At one point I implemented a compromise:
81 * When constructing exports with no export list, or with module M(
82 module M ), we add the parent to the exports as well.
83 * But not when you see module M( f ), even if f is a
84 class method with a parent.
85 * Nor when you see module M( module N ), with N /= M.
86
87 But the compromise seemed too much of a hack, so we backed it out.
88 You just have to use an explicit export list:
89 module M( F(..) ) where ...
90 -}
91
92 data ExportAccum -- The type of the accumulating parameter of
93 -- the main worker function in rnExports
94 = ExportAccum
95 ExportOccMap -- Tracks exported occurrence names
96 (UniqSet ModuleName) -- Tracks (re-)exported module names
97
98 emptyExportAccum :: ExportAccum
99 emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet
100
101 accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y)))
102 -> [x]
103 -> TcRn [y]
104 accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum
105 where f' acc x = do
106 m <- try_m (f acc x)
107 pure $ case m of
108 Right (Just (acc', y)) -> (acc', Just y)
109 _ -> (acc, Nothing)
110
111 type ExportOccMap = OccEnv (Name, IE GhcPs)
112 -- Tracks what a particular exported OccName
113 -- in an export list refers to, and which item
114 -- it came from. It's illegal to export two distinct things
115 -- that have the same occurrence name
116
117 tcRnExports :: Bool -- False => no 'module M(..) where' header at all
118 -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list
119 -> TcGblEnv
120 -> RnM TcGblEnv
121
122 -- Complains if two distinct exports have same OccName
123 -- Warns about identical exports.
124 -- Complains about exports items not in scope
125
126 tcRnExports explicit_mod exports
127 tcg_env@TcGblEnv { tcg_mod = this_mod,
128 tcg_rdr_env = rdr_env,
129 tcg_imports = imports,
130 tcg_src = hsc_src }
131 = unsetWOptM Opt_WarnWarningsDeprecations $
132 -- Do not report deprecations arising from the export
133 -- list, to avoid bleating about re-exporting a deprecated
134 -- thing (especially via 'module Foo' export item)
135 do {
136 -- In interactive mode, we behave as if he had
137 -- written "module Main where ..."
138 ; dflags <- getDynFlags
139 ; let is_main_mod = mainModIs dflags == this_mod
140 ; let default_main = case mainFunIs dflags of
141 Just main_fun
142 | is_main_mod -> mkUnqual varName (fsLit main_fun)
143 _ -> main_RDR_Unqual
144 ; let real_exports
145 | explicit_mod = exports
146 | ghcLink dflags == LinkInMemory = Nothing
147 | otherwise
148 = Just (noLoc [noLoc (IEVar noExt
149 (noLoc (IEName $ noLoc default_main)))])
150 -- ToDo: the 'noLoc' here is unhelpful if 'main'
151 -- turns out to be out of scope
152
153 ; let do_it = exports_from_avail real_exports rdr_env imports this_mod
154 ; (rn_exports, final_avails)
155 <- if hsc_src == HsigFile
156 then do (msgs, mb_r) <- tryTc do_it
157 case mb_r of
158 Just r -> return r
159 Nothing -> addMessages msgs >> failM
160 else checkNoErrs do_it
161 ; let final_ns = availsToNameSetWithSelectors final_avails
162
163 ; traceRn "rnExports: Exports:" (ppr final_avails)
164
165 ; let new_tcg_env =
166 tcg_env { tcg_exports = final_avails,
167 tcg_rn_exports = case tcg_rn_exports tcg_env of
168 Nothing -> Nothing
169 Just _ -> rn_exports,
170 tcg_dus = tcg_dus tcg_env `plusDU`
171 usesOnly final_ns }
172 ; failIfErrsM
173 ; return new_tcg_env }
174
175 exports_from_avail :: Maybe (Located [LIE GhcPs])
176 -- Nothing => no explicit export list
177 -> GlobalRdrEnv
178 -> ImportAvails
179 -- Imported modules; this is used to test if a
180 -- 'module Foo' export is valid (it's not valid
181 -- if we didn't import Foo!)
182 -> Module
183 -> RnM (Maybe [(LIE GhcRn, Avails)], Avails)
184 -- (Nothing, _) <=> no explicit export list
185 -- if explicit export list is present it contains
186 -- each renamed export item together with its exported
187 -- names.
188
189 exports_from_avail Nothing rdr_env _imports _this_mod
190 -- The same as (module M) where M is the current module name,
191 -- so that's how we handle it, except we also export the data family
192 -- when a data instance is exported.
193 = do {
194 ; warnMissingExportList <- woptM Opt_WarnMissingExportList
195 ; warnIfFlag Opt_WarnMissingExportList
196 warnMissingExportList
197 (missingModuleExportWarn $ moduleName _this_mod)
198 ; let avails =
199 map fix_faminst . gresToAvailInfo
200 . filter isLocalGRE . globalRdrEnvElts $ rdr_env
201 ; return (Nothing, avails) }
202 where
203 -- #11164: when we define a data instance
204 -- but not data family, re-export the family
205 -- Even though we don't check whether this is actually a data family
206 -- only data families can locally define subordinate things (`ns` here)
207 -- without locally defining (and instead importing) the parent (`n`)
208 fix_faminst (AvailTC n ns flds) =
209 let new_ns =
210 case ns of
211 [] -> [n]
212 (p:_) -> if p == n then ns else n:ns
213 in AvailTC n new_ns flds
214
215 fix_faminst avail = avail
216
217
218 exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
219 = do ie_avails <- accumExports do_litem rdr_items
220 let final_exports = nubAvails (concat (map snd ie_avails)) -- Combine families
221 return (Just ie_avails, final_exports)
222 where
223 do_litem :: ExportAccum -> LIE GhcPs
224 -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
225 do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
226
227 -- Maps a parent to its in-scope children
228 kids_env :: NameEnv [GlobalRdrElt]
229 kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
230
231
232 imported_modules = [ imv_name imv
233 | xs <- moduleEnvElts $ imp_mods imports
234 , imv <- importedByUser xs ]
235
236 exports_from_item :: ExportAccum -> LIE GhcPs
237 -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
238 exports_from_item (ExportAccum occs earlier_mods)
239 (L loc ie@(IEModuleContents _ lmod@(L _ mod)))
240 | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M
241 = do { warnIfFlag Opt_WarnDuplicateExports True
242 (dupModuleExport mod) ;
243 return Nothing }
244
245 | otherwise
246 = do { let { exportValid = (mod `elem` imported_modules)
247 || (moduleName this_mod == mod)
248 ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env)
249 ; new_exports = map (availFromGRE . fst) gre_prs
250 ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
251 ; mods = addOneToUniqSet earlier_mods mod
252 }
253
254 ; checkErr exportValid (moduleNotImported mod)
255 ; warnIfFlag Opt_WarnDodgyExports
256 (exportValid && null gre_prs)
257 (nullModuleExport mod)
258
259 ; traceRn "efa" (ppr mod $$ ppr all_gres)
260 ; addUsedGREs all_gres
261
262 ; occs' <- check_occs ie occs new_exports
263 -- This check_occs not only finds conflicts
264 -- between this item and others, but also
265 -- internally within this item. That is, if
266 -- 'M.x' is in scope in several ways, we'll have
267 -- several members of mod_avails with the same
268 -- OccName.
269 ; traceRn "export_mod"
270 (vcat [ ppr mod
271 , ppr new_exports ])
272
273 ; return (Just ( ExportAccum occs' mods
274 , ( L loc (IEModuleContents noExt lmod)
275 , new_exports))) }
276
277 exports_from_item acc@(ExportAccum occs mods) (L loc ie)
278 | isDoc ie
279 = do new_ie <- lookup_doc_ie ie
280 return (Just (acc, (L loc new_ie, [])))
281
282 | otherwise
283 = do (new_ie, avail) <- lookup_ie ie
284 if isUnboundName (ieName new_ie)
285 then return Nothing -- Avoid error cascade
286 else do
287
288 occs' <- check_occs ie occs [avail]
289
290 return (Just ( ExportAccum occs' mods
291 , (L loc new_ie, [avail])))
292
293 -------------
294 lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo)
295 lookup_ie (IEVar _ (L l rdr))
296 = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
297 return (IEVar noExt (L l (replaceWrappedName rdr name)), avail)
298
299 lookup_ie (IEThingAbs _ (L l rdr))
300 = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
301 return (IEThingAbs noExt (L l (replaceWrappedName rdr name))
302 , avail)
303
304 lookup_ie ie@(IEThingAll _ n')
305 = do
306 (n, avail, flds) <- lookup_ie_all ie n'
307 let name = unLoc n
308 return (IEThingAll noExt (replaceLWrappedName n' (unLoc n))
309 , AvailTC name (name:avail) flds)
310
311
312 lookup_ie ie@(IEThingWith _ l wc sub_rdrs _)
313 = do
314 (lname, subs, avails, flds)
315 <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs
316 (_, all_avail, all_flds) <-
317 case wc of
318 NoIEWildcard -> return (lname, [], [])
319 IEWildcard _ -> lookup_ie_all ie l
320 let name = unLoc lname
321 return (IEThingWith noExt (replaceLWrappedName l name) wc subs
322 (flds ++ (map noLoc all_flds)),
323 AvailTC name (name : avails ++ all_avail)
324 (map unLoc flds ++ all_flds))
325
326
327 lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier
328
329
330 lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName]
331 -> RnM (Located Name, [LIEWrappedName Name], [Name],
332 [Located FieldLabel])
333 lookup_ie_with (L l rdr) sub_rdrs
334 = do name <- lookupGlobalOccRn $ ieWrappedName rdr
335 (non_flds, flds) <- lookupChildrenExport name sub_rdrs
336 if isUnboundName name
337 then return (L l name, [], [name], [])
338 else return (L l name, non_flds
339 , map (ieWrappedName . unLoc) non_flds
340 , flds)
341
342 lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName
343 -> RnM (Located Name, [Name], [FieldLabel])
344 lookup_ie_all ie (L l rdr) =
345 do name <- lookupGlobalOccRn $ ieWrappedName rdr
346 let gres = findChildren kids_env name
347 (non_flds, flds) = classifyGREs gres
348 addUsedKids (ieWrappedName rdr) gres
349 warnDodgyExports <- woptM Opt_WarnDodgyExports
350 when (null gres) $
351 if isTyConName name
352 then when warnDodgyExports $
353 addWarn (Reason Opt_WarnDodgyExports)
354 (dodgyExportWarn name)
355 else -- This occurs when you export T(..), but
356 -- only import T abstractly, or T is a synonym.
357 addErr (exportItemErr ie)
358 return (L l name, non_flds, flds)
359
360 -------------
361 lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn)
362 lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc
363 return (IEGroup noExt lev rn_doc)
364 lookup_doc_ie (IEDoc _ doc) = do rn_doc <- rnHsDoc doc
365 return (IEDoc noExt rn_doc)
366 lookup_doc_ie (IEDocNamed _ str) = return (IEDocNamed noExt str)
367 lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier
368
369 -- In an export item M.T(A,B,C), we want to treat the uses of
370 -- A,B,C as if they were M.A, M.B, M.C
371 -- Happily pickGREs does just the right thing
372 addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()
373 addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)
374
375 classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
376 classifyGREs = partitionEithers . map classifyGRE
377
378 classifyGRE :: GlobalRdrElt -> Either Name FieldLabel
379 classifyGRE gre = case gre_par gre of
380 FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)
381 FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)
382 _ -> Left n
383 where
384 n = gre_name gre
385
386 isDoc :: IE GhcPs -> Bool
387 isDoc (IEDoc {}) = True
388 isDoc (IEDocNamed {}) = True
389 isDoc (IEGroup {}) = True
390 isDoc _ = False
391
392 -- Renaming and typechecking of exports happens after everything else has
393 -- been typechecked.
394
395
396
397 -- Renaming exports lists is a minefield. Five different things can appear in
398 -- children export lists ( T(A, B, C) ).
399 -- 1. Record selectors
400 -- 2. Type constructors
401 -- 3. Data constructors
402 -- 4. Pattern Synonyms
403 -- 5. Pattern Synonym Selectors
404 --
405 -- However, things get put into weird name spaces.
406 -- 1. Some type constructors are parsed as variables (-.->) for example.
407 -- 2. All data constructors are parsed as type constructors
408 -- 3. When there is ambiguity, we default type constructors to data
409 -- constructors and require the explicit `type` keyword for type
410 -- constructors.
411 --
412 -- This function first establishes the possible namespaces that an
413 -- identifier might be in (`choosePossibleNameSpaces`).
414 --
415 -- Then for each namespace in turn, tries to find the correct identifier
416 -- there returning the first positive result or the first terminating
417 -- error.
418 --
419
420
421
422 lookupChildrenExport :: Name -> [LIEWrappedName RdrName]
423 -> RnM ([LIEWrappedName Name], [Located FieldLabel])
424 lookupChildrenExport spec_parent rdr_items =
425 do
426 xs <- mapAndReportM doOne rdr_items
427 return $ partitionEithers xs
428 where
429 -- Pick out the possible namespaces in order of priority
430 -- This is a consequence of how the parser parses all
431 -- data constructors as type constructors.
432 choosePossibleNamespaces :: NameSpace -> [NameSpace]
433 choosePossibleNamespaces ns
434 | ns == varName = [varName, tcName]
435 | ns == tcName = [dataName, tcName]
436 | otherwise = [ns]
437 -- Process an individual child
438 doOne :: LIEWrappedName RdrName
439 -> RnM (Either (LIEWrappedName Name) (Located FieldLabel))
440 doOne n = do
441
442 let bareName = (ieWrappedName . unLoc) n
443 lkup v = lookupSubBndrOcc_helper False True
444 spec_parent (setRdrNameSpace bareName v)
445
446 name <- combineChildLookupResult $ map lkup $
447 choosePossibleNamespaces (rdrNameSpace bareName)
448 traceRn "lookupChildrenExport" (ppr name)
449 -- Default to data constructors for slightly better error
450 -- messages
451 let unboundName :: RdrName
452 unboundName = if rdrNameSpace bareName == varName
453 then bareName
454 else setRdrNameSpace bareName dataName
455
456 case name of
457 NameNotFound -> do { ub <- reportUnboundName unboundName
458 ; let l = getLoc n
459 ; return (Left (L l (IEName (L l ub))))}
460 FoundFL fls -> return $ Right (L (getLoc n) fls)
461 FoundName par name -> do { checkPatSynParent spec_parent par name
462 ; return $ Left (replaceLWrappedName n name) }
463 IncorrectParent p g td gs -> failWithDcErr p g td gs
464
465
466 -- Note: [Typing Pattern Synonym Exports]
467 -- It proved quite a challenge to precisely specify which pattern synonyms
468 -- should be allowed to be bundled with which type constructors.
469 -- In the end it was decided to be quite liberal in what we allow. Below is
470 -- how Simon described the implementation.
471 --
472 -- "Personally I think we should Keep It Simple. All this talk of
473 -- satisfiability makes me shiver. I suggest this: allow T( P ) in all
474 -- situations except where `P`'s type is ''visibly incompatible'' with
475 -- `T`.
476 --
477 -- What does "visibly incompatible" mean? `P` is visibly incompatible
478 -- with
479 -- `T` if
480 -- * `P`'s type is of form `... -> S t1 t2`
481 -- * `S` is a data/newtype constructor distinct from `T`
482 --
483 -- Nothing harmful happens if we allow `P` to be exported with
484 -- a type it can't possibly be useful for, but specifying a tighter
485 -- relationship is very awkward as you have discovered."
486 --
487 -- Note that this allows *any* pattern synonym to be bundled with any
488 -- datatype type constructor. For example, the following pattern `P` can be
489 -- bundled with any type.
490 --
491 -- ```
492 -- pattern P :: (A ~ f) => f
493 -- ```
494 --
495 -- So we provide basic type checking in order to help the user out, most
496 -- pattern synonyms are defined with definite type constructors, but don't
497 -- actually prevent a library author completely confusing their users if
498 -- they want to.
499 --
500 -- So, we check for exactly four things
501 -- 1. The name arises from a pattern synonym definition. (Either a pattern
502 -- synonym constructor or a pattern synonym selector)
503 -- 2. The pattern synonym is only bundled with a datatype or newtype.
504 -- 3. Check that the head of the result type constructor is an actual type
505 -- constructor and not a type variable. (See above example)
506 -- 4. Is so, check that this type constructor is the same as the parent
507 -- type constructor.
508 --
509 --
510 -- Note: [Types of TyCon]
511 --
512 -- This check appears to be overlly complicated, Richard asked why it
513 -- is not simply just `isAlgTyCon`. The answer for this is that
514 -- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow.
515 -- (It is either a newtype or data depending on the number of methods)
516 --
517
518 -- | Given a resolved name in the children export list and a parent. Decide
519 -- whether we are allowed to export the child with the parent.
520 -- Invariant: gre_par == NoParent
521 -- See note [Typing Pattern Synonym Exports]
522 checkPatSynParent :: Name -- ^ Alleged parent type constructor
523 -- User wrote T( P, Q )
524 -> Parent -- The parent of P we discovered
525 -> Name -- ^ Either a
526 -- a) Pattern Synonym Constructor
527 -- b) A pattern synonym selector
528 -> TcM () -- Fails if wrong parent
529 checkPatSynParent _ (ParentIs {}) _
530 = return ()
531
532 checkPatSynParent _ (FldParent {}) _
533 = return ()
534
535 checkPatSynParent parent NoParent mpat_syn
536 | isUnboundName parent -- Avoid an error cascade
537 = return ()
538
539 | otherwise
540 = do { parent_ty_con <- tcLookupTyCon parent
541 ; mpat_syn_thing <- tcLookupGlobal mpat_syn
542
543 -- 1. Check that the Id was actually from a thing associated with patsyns
544 ; case mpat_syn_thing of
545 AnId i | isId i
546 , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i
547 -> handle_pat_syn (selErr i) parent_ty_con p
548
549 AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p
550
551 _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] }
552 where
553 psErr = exportErrCtxt "pattern synonym"
554 selErr = exportErrCtxt "pattern synonym record selector"
555
556 assocClassErr :: SDoc
557 assocClassErr = text "Pattern synonyms can be bundled only with datatypes."
558
559 handle_pat_syn :: SDoc
560 -> TyCon -- ^ Parent TyCon
561 -> PatSyn -- ^ Corresponding bundled PatSyn
562 -- and pretty printed origin
563 -> TcM ()
564 handle_pat_syn doc ty_con pat_syn
565
566 -- 2. See note [Types of TyCon]
567 | not $ isTyConWithSrcDataCons ty_con
568 = addErrCtxt doc $ failWithTc assocClassErr
569
570 -- 3. Is the head a type variable?
571 | Nothing <- mtycon
572 = return ()
573 -- 4. Ok. Check they are actually the same type constructor.
574
575 | Just p_ty_con <- mtycon, p_ty_con /= ty_con
576 = addErrCtxt doc $ failWithTc typeMismatchError
577
578 -- 5. We passed!
579 | otherwise
580 = return ()
581
582 where
583 expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
584 (_, _, _, _, _, res_ty) = patSynSig pat_syn
585 mtycon = fst <$> tcSplitTyConApp_maybe res_ty
586 typeMismatchError :: SDoc
587 typeMismatchError =
588 text "Pattern synonyms can only be bundled with matching type constructors"
589 $$ text "Couldn't match expected type of"
590 <+> quotes (ppr expected_res_ty)
591 <+> text "with actual type of"
592 <+> quotes (ppr res_ty)
593
594
595 {-===========================================================================-}
596 check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo]
597 -> RnM ExportOccMap
598 check_occs ie occs avails
599 -- 'names' and 'fls' are the entities specified by 'ie'
600 = foldlM check occs names_with_occs
601 where
602 -- Each Name specified by 'ie', paired with the OccName used to
603 -- refer to it in the GlobalRdrEnv
604 -- (see Note [Representing fields in AvailInfo] in Avail).
605 --
606 -- We check for export clashes using the selector Name, but need
607 -- the field label OccName for presenting error messages.
608 names_with_occs = availsNamesWithOccs avails
609
610 check occs (name, occ)
611 = case lookupOccEnv occs name_occ of
612 Nothing -> return (extendOccEnv occs name_occ (name, ie))
613
614 Just (name', ie')
615 | name == name' -- Duplicate export
616 -- But we don't want to warn if the same thing is exported
617 -- by two different module exports. See ticket #4478.
618 -> do { warnIfFlag Opt_WarnDuplicateExports
619 (not (dupExport_ok name ie ie'))
620 (dupExportWarn occ ie ie')
621 ; return occs }
622
623 | otherwise -- Same occ name but different names: an error
624 -> do { global_env <- getGlobalRdrEnv ;
625 addErr (exportClashErr global_env occ name' name ie' ie) ;
626 return occs }
627 where
628 name_occ = nameOccName name
629
630
631 dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool
632 -- The Name is exported by both IEs. Is that ok?
633 -- "No" iff the name is mentioned explicitly in both IEs
634 -- or one of the IEs mentions the name *alone*
635 -- "Yes" otherwise
636 --
637 -- Examples of "no": module M( f, f )
638 -- module M( fmap, Functor(..) )
639 -- module M( module Data.List, head )
640 --
641 -- Example of "yes"
642 -- module M( module A, module B ) where
643 -- import A( f )
644 -- import B( f )
645 --
646 -- Example of "yes" (Trac #2436)
647 -- module M( C(..), T(..) ) where
648 -- class C a where { data T a }
649 -- instance C Int where { data T Int = TInt }
650 --
651 -- Example of "yes" (Trac #2436)
652 -- module Foo ( T ) where
653 -- data family T a
654 -- module Bar ( T(..), module Foo ) where
655 -- import Foo
656 -- data instance T Int = TInt
657
658 dupExport_ok n ie1 ie2
659 = not ( single ie1 || single ie2
660 || (explicit_in ie1 && explicit_in ie2) )
661 where
662 explicit_in (IEModuleContents {}) = False -- module M
663 explicit_in (IEThingAll _ r)
664 = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..)
665 explicit_in _ = True
666
667 single IEVar {} = True
668 single IEThingAbs {} = True
669 single _ = False
670
671
672 dupModuleExport :: ModuleName -> SDoc
673 dupModuleExport mod
674 = hsep [text "Duplicate",
675 quotes (text "Module" <+> ppr mod),
676 text "in export list"]
677
678 moduleNotImported :: ModuleName -> SDoc
679 moduleNotImported mod
680 = hsep [text "The export item",
681 quotes (text "module" <+> ppr mod),
682 text "is not imported"]
683
684 nullModuleExport :: ModuleName -> SDoc
685 nullModuleExport mod
686 = hsep [text "The export item",
687 quotes (text "module" <+> ppr mod),
688 text "exports nothing"]
689
690 missingModuleExportWarn :: ModuleName -> SDoc
691 missingModuleExportWarn mod
692 = hsep [text "The export item",
693 quotes (text "module" <+> ppr mod),
694 text "is missing an export list"]
695
696
697 dodgyExportWarn :: Name -> SDoc
698 dodgyExportWarn item
699 = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn)
700
701 exportErrCtxt :: Outputable o => String -> o -> SDoc
702 exportErrCtxt herald exp =
703 text "In the" <+> text (herald ++ ":") <+> ppr exp
704
705
706 addExportErrCtxt :: (OutputableBndrId (GhcPass p))
707 => IE (GhcPass p) -> TcM a -> TcM a
708 addExportErrCtxt ie = addErrCtxt exportCtxt
709 where
710 exportCtxt = text "In the export:" <+> ppr ie
711
712 exportItemErr :: IE GhcPs -> SDoc
713 exportItemErr export_item
714 = sep [ text "The export item" <+> quotes (ppr export_item),
715 text "attempts to export constructors or class methods that are not visible here" ]
716
717
718 dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc
719 dupExportWarn occ_name ie1 ie2
720 = hsep [quotes (ppr occ_name),
721 text "is exported by", quotes (ppr ie1),
722 text "and", quotes (ppr ie2)]
723
724 dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc
725 dcErrMsg ty_con what_is thing parents =
726 text "The type constructor" <+> quotes (ppr ty_con)
727 <+> text "is not the parent of the" <+> text what_is
728 <+> quotes thing <> char '.'
729 $$ text (capitalise what_is)
730 <> text "s can only be exported with their parent type constructor."
731 $$ (case parents of
732 [] -> empty
733 [_] -> text "Parent:"
734 _ -> text "Parents:") <+> fsep (punctuate comma parents)
735
736 failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a
737 failWithDcErr parent thing thing_doc parents = do
738 ty_thing <- tcLookupGlobal thing
739 failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing)
740 thing_doc (map ppr parents)
741 where
742 tyThingCategory' :: TyThing -> String
743 tyThingCategory' (AnId i)
744 | isRecordSelector i = "record selector"
745 tyThingCategory' i = tyThingCategory i
746
747
748 exportClashErr :: GlobalRdrEnv -> OccName
749 -> Name -> Name
750 -> IE GhcPs -> IE GhcPs
751 -> MsgDoc
752 exportClashErr global_env occ name1 name2 ie1 ie2
753 = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon
754 , ppr_export ie1' name1'
755 , ppr_export ie2' name2' ]
756 where
757 ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>
758 quotes (ppr_name name))
759 2 (pprNameProvenance (get_gre name)))
760
761 -- DuplicateRecordFields means that nameOccName might be a mangled
762 -- $sel-prefixed thing, in which case show the correct OccName alone
763 ppr_name name
764 | nameOccName name == occ = ppr name
765 | otherwise = ppr occ
766
767 -- get_gre finds a GRE for the Name, so that we can show its provenance
768 get_gre name
769 = fromMaybe (pprPanic "exportClashErr" (ppr name))
770 (lookupGRE_Name_OccName global_env name occ)
771 get_loc name = greSrcSpan (get_gre name)
772 (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
773 then (name1, ie1, name2, ie2)
774 else (name2, ie2, name1, ie1)