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