3965675b779cdfe1b1c64c72fdeb1ceae68719af
[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] -- Export items with Names
95 ExportOccMap -- Tracks exported occurrence names
96 [AvailInfo] -- The accumulated exported stuff
97 -- Not nub'd!
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], [AvailInfo])
174
175 exports_from_avail Nothing rdr_env _imports _this_mod
176 -- The same as (module M) where M is the current module name,
177 -- so that's how we handle it, except we also export the data family
178 -- when a data instance is exported.
179 = let avails =
180 map fix_faminst . gresToAvailInfo
181 . filter isLocalGRE . globalRdrEnvElts $ rdr_env
182 in return (Nothing, avails)
183 where
184 -- #11164: when we define a data instance
185 -- but not data family, re-export the family
186 -- Even though we don't check whether this is actually a data family
187 -- only data families can locally define subordinate things (`ns` here)
188 -- without locally defining (and instead importing) the parent (`n`)
189 fix_faminst (AvailTC n ns flds) =
190 let new_ns =
191 case ns of
192 [] -> [n]
193 (p:_) -> if p == n then ns else n:ns
194 in AvailTC n new_ns flds
195
196 fix_faminst avail = avail
197
198
199 exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
200 = do ExportAccum ie_names _ exports
201 <- foldAndRecoverM do_litem emptyExportAccum rdr_items
202 let final_exports = nubAvails exports -- Combine families
203 return (Just ie_names, final_exports)
204 where
205 do_litem :: ExportAccum -> LIE GhcPs -> RnM ExportAccum
206 do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
207
208 -- Maps a parent to its in-scope children
209 kids_env :: NameEnv [GlobalRdrElt]
210 kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
211
212
213 imported_modules = [ imv_name imv
214 | xs <- moduleEnvElts $ imp_mods imports
215 , imv <- importedByUser xs ]
216
217 exports_from_item :: ExportAccum -> LIE GhcPs -> RnM ExportAccum
218 exports_from_item acc@(ExportAccum ie_names occs exports)
219 (L loc (IEModuleContents (L lm mod)))
220 | let earlier_mods = [ mod
221 | (L _ (IEModuleContents (L _ mod))) <- ie_names ]
222 , mod `elem` earlier_mods -- Duplicate export of M
223 = do { warnIf (Reason Opt_WarnDuplicateExports) True
224 (dupModuleExport mod) ;
225 return acc }
226
227 | otherwise
228 = do { let { exportValid = (mod `elem` imported_modules)
229 || (moduleName this_mod == mod)
230 ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env)
231 ; new_exports = map (availFromGRE . fst) gre_prs
232 ; names = map (gre_name . fst) gre_prs
233 ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
234 }
235
236 ; checkErr exportValid (moduleNotImported mod)
237 ; warnIf (Reason Opt_WarnDodgyExports)
238 (exportValid && null gre_prs)
239 (nullModuleExport mod)
240
241 ; traceRn "efa" (ppr mod $$ ppr all_gres)
242 ; addUsedGREs all_gres
243
244 ; occs' <- check_occs (IEModuleContents (noLoc mod)) occs names
245 -- This check_occs not only finds conflicts
246 -- between this item and others, but also
247 -- internally within this item. That is, if
248 -- 'M.x' is in scope in several ways, we'll have
249 -- several members of mod_avails with the same
250 -- OccName.
251 ; traceRn "export_mod"
252 (vcat [ ppr mod
253 , ppr new_exports ])
254 ; return (ExportAccum (L loc (IEModuleContents (L lm mod)) : ie_names)
255 occs'
256 (new_exports ++ exports)) }
257
258 exports_from_item acc@(ExportAccum lie_names occs exports) (L loc ie)
259 | isDoc ie
260 = do new_ie <- lookup_doc_ie ie
261 return (ExportAccum (L loc new_ie : lie_names) occs exports)
262
263 | otherwise
264 = do (new_ie, avail) <-
265 setSrcSpan loc $ lookup_ie ie
266 if isUnboundName (ieName new_ie)
267 then return acc -- Avoid error cascade
268 else do
269
270 occs' <- check_occs ie occs (availNames avail)
271
272 return (ExportAccum (L loc new_ie : lie_names) occs' (avail : exports))
273
274 -------------
275 lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo)
276 lookup_ie (IEVar (L l rdr))
277 = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
278 return (IEVar (L l (replaceWrappedName rdr name)), avail)
279
280 lookup_ie (IEThingAbs (L l rdr))
281 = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
282 return (IEThingAbs (L l (replaceWrappedName rdr name)), avail)
283
284 lookup_ie ie@(IEThingAll n')
285 = do
286 (n, avail, flds) <- lookup_ie_all ie n'
287 let name = unLoc n
288 return (IEThingAll (replaceLWrappedName n' (unLoc n))
289 , AvailTC name (name:avail) flds)
290
291
292 lookup_ie ie@(IEThingWith l wc sub_rdrs _)
293 = do
294 (lname, subs, avails, flds)
295 <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs
296 (_, all_avail, all_flds) <-
297 case wc of
298 NoIEWildcard -> return (lname, [], [])
299 IEWildcard _ -> lookup_ie_all ie l
300 let name = unLoc lname
301 subs' = map (replaceLWrappedName l . unLoc) subs
302 return (IEThingWith (replaceLWrappedName l name) wc subs'
303 (map noLoc (flds ++ all_flds)),
304 AvailTC name (name : avails ++ all_avail)
305 (flds ++ all_flds))
306
307
308
309
310 lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier
311
312 lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName]
313 -> RnM (Located Name, [Located Name], [Name], [FieldLabel])
314 lookup_ie_with (L l rdr) sub_rdrs
315 = do name <- lookupGlobalOccRn $ ieWrappedName rdr
316 (non_flds, flds) <- lookupChildrenExport name
317 (map ieLWrappedName sub_rdrs)
318 if isUnboundName name
319 then return (L l name, [], [name], [])
320 else return (L l name, non_flds
321 , map unLoc non_flds
322 , map unLoc flds)
323 lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName
324 -> RnM (Located Name, [Name], [FieldLabel])
325 lookup_ie_all ie (L l rdr) =
326 do name <- lookupGlobalOccRn $ ieWrappedName rdr
327 let gres = findChildren kids_env name
328 (non_flds, flds) = classifyGREs gres
329 addUsedKids (ieWrappedName rdr) gres
330 warnDodgyExports <- woptM Opt_WarnDodgyExports
331 when (null gres) $
332 if isTyConName name
333 then when warnDodgyExports $
334 addWarn (Reason Opt_WarnDodgyExports)
335 (dodgyExportWarn name)
336 else -- This occurs when you export T(..), but
337 -- only import T abstractly, or T is a synonym.
338 addErr (exportItemErr ie)
339 return (L l name, non_flds, flds)
340
341 -------------
342 lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn)
343 lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc
344 return (IEGroup lev rn_doc)
345 lookup_doc_ie (IEDoc doc) = do rn_doc <- rnHsDoc doc
346 return (IEDoc rn_doc)
347 lookup_doc_ie (IEDocNamed str) = return (IEDocNamed str)
348 lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier
349
350 -- In an export item M.T(A,B,C), we want to treat the uses of
351 -- A,B,C as if they were M.A, M.B, M.C
352 -- Happily pickGREs does just the right thing
353 addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()
354 addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)
355
356 classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
357 classifyGREs = partitionEithers . map classifyGRE
358
359 classifyGRE :: GlobalRdrElt -> Either Name FieldLabel
360 classifyGRE gre = case gre_par gre of
361 FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)
362 FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)
363 _ -> Left n
364 where
365 n = gre_name gre
366
367 isDoc :: IE GhcPs -> Bool
368 isDoc (IEDoc _) = True
369 isDoc (IEDocNamed _) = True
370 isDoc (IEGroup _ _) = True
371 isDoc _ = False
372
373 -- Renaming and typechecking of exports happens after everything else has
374 -- been typechecked.
375
376
377
378 -- Renaming exports lists is a minefield. Five different things can appear in
379 -- children export lists ( T(A, B, C) ).
380 -- 1. Record selectors
381 -- 2. Type constructors
382 -- 3. Data constructors
383 -- 4. Pattern Synonyms
384 -- 5. Pattern Synonym Selectors
385 --
386 -- However, things get put into weird name spaces.
387 -- 1. Some type constructors are parsed as variables (-.->) for example.
388 -- 2. All data constructors are parsed as type constructors
389 -- 3. When there is ambiguity, we default type constructors to data
390 -- constructors and require the explicit `type` keyword for type
391 -- constructors.
392 --
393 -- This function first establishes the possible namespaces that an
394 -- identifier might be in (`choosePossibleNameSpaces`).
395 --
396 -- Then for each namespace in turn, tries to find the correct identifier
397 -- there returning the first positive result or the first terminating
398 -- error.
399 --
400
401
402
403 lookupChildrenExport :: Name -> [Located RdrName]
404 -> RnM ([Located Name], [Located FieldLabel])
405 lookupChildrenExport parent rdr_items =
406 do
407 xs <- mapAndReportM doOne rdr_items
408 return $ partitionEithers xs
409 where
410 -- Pick out the possible namespaces in order of priority
411 -- This is a consequence of how the parser parses all
412 -- data constructors as type constructors.
413 choosePossibleNamespaces :: NameSpace -> [NameSpace]
414 choosePossibleNamespaces ns
415 | ns == varName = [varName, tcName]
416 | ns == tcName = [dataName, tcName]
417 | otherwise = [ns]
418 -- Process an individual child
419 doOne :: Located RdrName
420 -> RnM (Either (Located Name) (Located FieldLabel))
421 doOne n = do
422
423 let bareName = unLoc n
424 lkup v = lookupSubBndrOcc_helper False True
425 parent (setRdrNameSpace bareName v)
426
427 name <- combineChildLookupResult . map lkup $
428 choosePossibleNamespaces (rdrNameSpace bareName)
429 traceRn "lookupChildrenExport" (ppr name)
430 -- Default to data constructors for slightly better error
431 -- messages
432 let unboundName :: RdrName
433 unboundName = if rdrNameSpace bareName == varName
434 then bareName
435 else setRdrNameSpace bareName dataName
436
437 -- Might need to check here for FLs as well
438 name' <- case name of
439 FoundName NoParent n -> checkPatSynParent parent n
440 _ -> return name
441
442 traceRn "lookupChildrenExport" (ppr name')
443
444 case name' of
445 NameNotFound -> Left . L (getLoc n) <$> reportUnboundName unboundName
446 FoundFL fls -> return $ Right (L (getLoc n) fls)
447 FoundName _p name -> return $ Left (L (getLoc n) name)
448 NameErr err_msg -> reportError err_msg >> failM
449 IncorrectParent p g td gs -> do
450 mkDcErrMsg p g td gs >>= reportError
451 failM
452
453
454 -- | Also captures the current context
455 mkNameErr :: SDoc -> TcM ChildLookupResult
456 mkNameErr errMsg = NameErr <$> mkErrTc errMsg
457
458
459
460 --
461 -- Note: [Typing Pattern Synonym Exports]
462 -- It proved quite a challenge to precisely specify which pattern synonyms
463 -- should be allowed to be bundled with which type constructors.
464 -- In the end it was decided to be quite liberal in what we allow. Below is
465 -- how Simon described the implementation.
466 --
467 -- "Personally I think we should Keep It Simple. All this talk of
468 -- satisfiability makes me shiver. I suggest this: allow T( P ) in all
469 -- situations except where `P`'s type is ''visibly incompatible'' with
470 -- `T`.
471 --
472 -- What does "visibly incompatible" mean? `P` is visibly incompatible
473 -- with
474 -- `T` if
475 -- * `P`'s type is of form `... -> S t1 t2`
476 -- * `S` is a data/newtype constructor distinct from `T`
477 --
478 -- Nothing harmful happens if we allow `P` to be exported with
479 -- a type it can't possibly be useful for, but specifying a tighter
480 -- relationship is very awkward as you have discovered."
481 --
482 -- Note that this allows *any* pattern synonym to be bundled with any
483 -- datatype type constructor. For example, the following pattern `P` can be
484 -- bundled with any type.
485 --
486 -- ```
487 -- pattern P :: (A ~ f) => f
488 -- ```
489 --
490 -- So we provide basic type checking in order to help the user out, most
491 -- pattern synonyms are defined with definite type constructors, but don't
492 -- actually prevent a library author completely confusing their users if
493 -- they want to.
494 --
495 -- So, we check for exactly four things
496 -- 1. The name arises from a pattern synonym definition. (Either a pattern
497 -- synonym constructor or a pattern synonym selector)
498 -- 2. The pattern synonym is only bundled with a datatype or newtype.
499 -- 3. Check that the head of the result type constructor is an actual type
500 -- constructor and not a type variable. (See above example)
501 -- 4. Is so, check that this type constructor is the same as the parent
502 -- type constructor.
503 --
504 --
505 -- Note: [Types of TyCon]
506 --
507 -- This check appears to be overlly complicated, Richard asked why it
508 -- is not simply just `isAlgTyCon`. The answer for this is that
509 -- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow.
510 -- (It is either a newtype or data depending on the number of methods)
511 --
512
513 -- | Given a resolved name in the children export list and a parent. Decide
514 -- whether we are allowed to export the child with the parent.
515 -- Invariant: gre_par == NoParent
516 -- See note [Typing Pattern Synonym Exports]
517 checkPatSynParent :: Name -- ^ Type constructor
518 -> Name -- ^ Either a
519 -- a) Pattern Synonym Constructor
520 -- b) A pattern synonym selector
521 -> TcM ChildLookupResult
522 checkPatSynParent parent mpat_syn
523 | isUnboundName parent -- Avoid an error cascade
524 = return (FoundName NoParent mpat_syn)
525 | otherwise = do
526 parent_ty_con <- tcLookupTyCon parent
527 mpat_syn_thing <- tcLookupGlobal mpat_syn
528 let expected_res_ty =
529 mkTyConApp parent_ty_con (mkTyVarTys (tyConTyVars parent_ty_con))
530
531 handlePatSyn errCtxt =
532 addErrCtxt errCtxt
533 . tc_one_ps_export_with expected_res_ty parent_ty_con
534 -- 1. Check that the Id was actually from a thing associated with patsyns
535 case mpat_syn_thing of
536 AnId i
537 | isId i ->
538 case idDetails i of
539 RecSelId { sel_tycon = RecSelPatSyn p } -> handlePatSyn (selErr i) p
540 _ -> NameErr <$> mkDcErrMsg parent mpat_syn (ppr mpat_syn) []
541 AConLike (PatSynCon p) -> handlePatSyn (psErr p) p
542 _ -> NameErr <$> mkDcErrMsg parent mpat_syn (ppr mpat_syn) []
543 where
544
545 psErr = exportErrCtxt "pattern synonym"
546 selErr = exportErrCtxt "pattern synonym record selector"
547
548 assocClassErr :: SDoc
549 assocClassErr =
550 text "Pattern synonyms can be bundled only with datatypes."
551
552 tc_one_ps_export_with :: TcTauType -- ^ TyCon type
553 -> TyCon -- ^ Parent TyCon
554 -> PatSyn -- ^ Corresponding bundled PatSyn
555 -- and pretty printed origin
556 -> TcM ChildLookupResult
557 tc_one_ps_export_with expected_res_ty ty_con pat_syn
558
559 -- 2. See note [Types of TyCon]
560 | not $ isTyConWithSrcDataCons ty_con = mkNameErr assocClassErr
561 -- 3. Is the head a type variable?
562 | Nothing <- mtycon = return (FoundName (ParentIs parent) mpat_syn)
563 -- 4. Ok. Check they are actually the same type constructor.
564 | Just p_ty_con <- mtycon, p_ty_con /= ty_con = mkNameErr typeMismatchError
565 -- 5. We passed!
566 | otherwise = return (FoundName (ParentIs parent) mpat_syn)
567
568 where
569 (_, _, _, _, _, res_ty) = patSynSig pat_syn
570 mtycon = fst <$> tcSplitTyConApp_maybe res_ty
571 typeMismatchError :: SDoc
572 typeMismatchError =
573 text "Pattern synonyms can only be bundled with matching type constructors"
574 $$ text "Couldn't match expected type of"
575 <+> quotes (ppr expected_res_ty)
576 <+> text "with actual type of"
577 <+> quotes (ppr res_ty)
578
579
580
581
582 {-===========================================================================-}
583
584
585 check_occs :: IE GhcPs -> ExportOccMap -> [Name] -> RnM ExportOccMap
586 check_occs ie occs names -- 'names' are the entities specifed by 'ie'
587 = foldlM check occs names
588 where
589 check occs name
590 = case lookupOccEnv occs name_occ of
591 Nothing -> return (extendOccEnv occs name_occ (name, ie))
592
593 Just (name', ie')
594 | name == name' -- Duplicate export
595 -- But we don't want to warn if the same thing is exported
596 -- by two different module exports. See ticket #4478.
597 -> do { warnIf (Reason Opt_WarnDuplicateExports)
598 (not (dupExport_ok name ie ie'))
599 (dupExportWarn name_occ ie ie')
600 ; return occs }
601
602 | otherwise -- Same occ name but different names: an error
603 -> do { global_env <- getGlobalRdrEnv ;
604 addErr (exportClashErr global_env name' name ie' ie) ;
605 return occs }
606 where
607 name_occ = nameOccName name
608
609
610 dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool
611 -- The Name is exported by both IEs. Is that ok?
612 -- "No" iff the name is mentioned explicitly in both IEs
613 -- or one of the IEs mentions the name *alone*
614 -- "Yes" otherwise
615 --
616 -- Examples of "no": module M( f, f )
617 -- module M( fmap, Functor(..) )
618 -- module M( module Data.List, head )
619 --
620 -- Example of "yes"
621 -- module M( module A, module B ) where
622 -- import A( f )
623 -- import B( f )
624 --
625 -- Example of "yes" (Trac #2436)
626 -- module M( C(..), T(..) ) where
627 -- class C a where { data T a }
628 -- instance C Int where { data T Int = TInt }
629 --
630 -- Example of "yes" (Trac #2436)
631 -- module Foo ( T ) where
632 -- data family T a
633 -- module Bar ( T(..), module Foo ) where
634 -- import Foo
635 -- data instance T Int = TInt
636
637 dupExport_ok n ie1 ie2
638 = not ( single ie1 || single ie2
639 || (explicit_in ie1 && explicit_in ie2) )
640 where
641 explicit_in (IEModuleContents _) = False -- module M
642 explicit_in (IEThingAll r)
643 = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..)
644 explicit_in _ = True
645
646 single IEVar {} = True
647 single IEThingAbs {} = True
648 single _ = False
649
650
651 dupModuleExport :: ModuleName -> SDoc
652 dupModuleExport mod
653 = hsep [text "Duplicate",
654 quotes (text "Module" <+> ppr mod),
655 text "in export list"]
656
657 moduleNotImported :: ModuleName -> SDoc
658 moduleNotImported mod
659 = text "The export item `module" <+> ppr mod <>
660 text "' is not imported"
661
662 nullModuleExport :: ModuleName -> SDoc
663 nullModuleExport mod
664 = text "The export item `module" <+> ppr mod <> ptext (sLit "' exports nothing")
665
666
667 dodgyExportWarn :: Name -> SDoc
668 dodgyExportWarn item
669 = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn)
670
671 exportErrCtxt :: Outputable o => String -> o -> SDoc
672 exportErrCtxt herald exp =
673 text "In the" <+> text (herald ++ ":") <+> ppr exp
674
675
676 addExportErrCtxt :: (OutputableBndrId s) => IE s -> TcM a -> TcM a
677 addExportErrCtxt ie = addErrCtxt exportCtxt
678 where
679 exportCtxt = text "In the export:" <+> ppr ie
680
681 exportItemErr :: IE GhcPs -> SDoc
682 exportItemErr export_item
683 = sep [ text "The export item" <+> quotes (ppr export_item),
684 text "attempts to export constructors or class methods that are not visible here" ]
685
686
687 dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc
688 dupExportWarn occ_name ie1 ie2
689 = hsep [quotes (ppr occ_name),
690 text "is exported by", quotes (ppr ie1),
691 text "and", quotes (ppr ie2)]
692
693 dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc
694 dcErrMsg ty_con what_is thing parents =
695 text "The type constructor" <+> quotes (ppr ty_con)
696 <+> text "is not the parent of the" <+> text what_is
697 <+> quotes thing <> char '.'
698 $$ text (capitalise what_is)
699 <> text "s can only be exported with their parent type constructor."
700 $$ (case parents of
701 [] -> empty
702 [_] -> text "Parent:"
703 _ -> text "Parents:") <+> fsep (punctuate comma parents)
704
705 mkDcErrMsg :: Name -> Name -> SDoc -> [Name] -> TcM ErrMsg
706 mkDcErrMsg parent thing thing_doc parents = do
707 ty_thing <- tcLookupGlobal thing
708 mkErrTc $
709 dcErrMsg parent (tyThingCategory' ty_thing) thing_doc (map ppr parents)
710 where
711 tyThingCategory' :: TyThing -> String
712 tyThingCategory' (AnId i)
713 | isRecordSelector i = "record selector"
714 tyThingCategory' i = tyThingCategory i
715
716
717 exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE GhcPs -> IE GhcPs
718 -> MsgDoc
719 exportClashErr global_env name1 name2 ie1 ie2
720 = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon
721 , ppr_export ie1' name1'
722 , ppr_export ie2' name2' ]
723 where
724 occ = nameOccName name1
725 ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>
726 quotes (ppr name))
727 2 (pprNameProvenance (get_gre name)))
728
729 -- get_gre finds a GRE for the Name, so that we can show its provenance
730 get_gre name
731 = fromMaybe (pprPanic "exportClashErr" (ppr name)) (lookupGRE_Name global_env name)
732 get_loc name = greSrcSpan (get_gre name)
733 (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
734 then (name1, ie1, name2, ie2)
735 else (name2, ie2, name1, ie1)