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