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