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