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