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