2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnEnv]{Environment manipulation for the renamer monad}
7 module RnEnv where -- Export everything
9 #include "HsVersions.h"
11 import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches,
12 opt_WarnUnusedBinds, opt_WarnUnusedImports )
14 import RdrHsSyn ( RdrNameIE )
15 import RnHsSyn ( RenamedHsType )
16 import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
17 mkRdrUnqual, qualifyRdrName
19 import HsTypes ( getTyVarName, replaceTyVarName )
22 import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
23 ImportReason(..), getSrcLoc,
24 mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName,
25 mkIPName, isSystemName,
26 nameOccName, setNameModule, nameModule,
27 pprOccName, isLocallyDefined, nameUnique, nameOccName,
29 setNameProvenance, getNameProvenance, pprNameProvenance
32 import OccName ( OccName,
33 mkDFunOcc, occNameUserString, occNameString,
36 import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon )
37 import Type ( funTyCon )
38 import Module ( ModuleName, mkThisModule, mkVanillaModule, moduleName )
39 import TyCon ( TyCon )
41 import Unique ( Unique, Uniquable(..) )
42 import UniqFM ( emptyUFM, listToUFM, plusUFM_C )
44 import SrcLoc ( SrcLoc, noSrcLoc )
46 import Util ( removeDups, equivClasses, thenCmp )
48 import Maybes ( mapMaybe )
53 %*********************************************************
55 \subsection{Making new names}
57 %*********************************************************
60 newImportedGlobalName :: ModuleName -> OccName -> Module -> RnM d Name
61 newImportedGlobalName mod_name occ mod
62 = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
66 case lookupFM cache key of
67 Just name -> returnRn name
68 Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_`
71 (us', us1) = splitUniqSupply us
72 uniq = uniqFromSupply us1
73 name = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport False)
74 new_cache = addToFM cache key name
76 updateProvenances :: [Name] -> RnM d ()
77 updateProvenances names
78 = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
79 setNameSupplyRn (us, inst_ns, update cache names, ipcache)
81 update cache [] = cache
82 update cache (name:names) = WARN( not (key `elemFM` cache), ppr name )
83 update (addToFM cache key name) names
85 key = (moduleName (nameModule name), nameOccName name)
87 newImportedBinder :: Module -> RdrName -> RnM d Name
88 newImportedBinder mod rdr_name
89 = ASSERT2( isUnqual rdr_name, ppr rdr_name )
90 newImportedGlobalName (moduleName mod) (rdrNameOcc rdr_name) mod
92 -- Make an imported global name, checking first to see if it's in the cache
93 mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name
94 mkImportedGlobalName mod_name occ
95 = lookupModuleRn mod_name `thenRn` \ mod ->
96 newImportedGlobalName mod_name occ mod --(mkVanillaModule mod_name)
98 mkImportedGlobalFromRdrName :: RdrName -> RnM d Name
99 mkImportedGlobalFromRdrName rdr_name
101 = mkImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
104 = -- An Unqual is allowed; interface files contain
105 -- unqualified names for locally-defined things, such as
106 -- constructors of a data type.
107 getModuleRn `thenRn ` \ mod_name ->
108 mkImportedGlobalName mod_name (rdrNameOcc rdr_name)
111 newLocalTopBinder :: Module -> OccName
112 -> (Name -> ExportFlag) -> SrcLoc
114 newLocalTopBinder mod occ rec_exp_fn loc
115 = -- First check the cache
116 getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
118 key = (moduleName mod,occ)
119 mk_prov name = LocalDef loc (rec_exp_fn name)
120 -- We must set the provenance of the thing in the cache
121 -- correctly, particularly whether or not it is locally defined.
123 -- Since newLocallyDefinedGlobalName is used only
124 -- at binding occurrences, we may as well get the provenance
125 -- dead right first time; hence the rec_exp_fn passed in
127 case lookupFM cache key of
129 -- A hit in the cache!
130 -- Overwrite whatever provenance is in the cache already;
131 -- this updates WiredIn things and known-key things,
132 -- which are there from the start, to LocalDef.
134 -- It also means that if there are two defns for the same thing
135 -- in a module, then each gets a separate SrcLoc
137 new_name = setNameProvenance name (mk_prov new_name)
138 new_cache = addToFM cache key new_name
140 setNameSupplyRn (us, inst_ns, new_cache, ipcache) `thenRn_`
143 -- Miss in the cache!
144 -- Build a new original name, and put it in the cache
146 (us', us1) = splitUniqSupply us
147 uniq = uniqFromSupply us1
148 new_name = mkGlobalName uniq mod occ (mk_prov new_name)
149 new_cache = addToFM cache key new_name
151 setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_`
155 = getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
156 case lookupFM ipcache key of
157 Just name -> returnRn name
158 Nothing -> setNameSupplyRn (us', inst_ns, cache, new_ipcache) `thenRn_`
161 (us', us1) = splitUniqSupply us
162 uniq = uniqFromSupply us1
163 name = mkIPName uniq key
164 new_ipcache = addToFM ipcache key name
165 where key = (rdrNameOcc rdr_name)
168 %*********************************************************
170 \subsection{Dfuns and default methods}
172 %*********************************************************
174 @newImplicitBinder@ is used for (a) dfuns
175 (b) default methods, defined in this module.
178 newImplicitBinder occ src_loc
179 = getModuleRn `thenRn` \ mod_name ->
180 newLocalTopBinder (mkThisModule mod_name) occ (\_ -> Exported) src_loc
183 Make a name for the dict fun for an instance decl
186 newDFunName :: (OccName, OccName) -> SrcLoc -> RnMS Name
187 newDFunName key@(cl_occ, tycon_occ) loc
188 = newInstUniq string `thenRn` \ inst_uniq ->
189 newImplicitBinder (mkDFunOcc string inst_uniq) loc
191 -- Any string that is somewhat unique will do
192 string = occNameString cl_occ ++ occNameString tycon_occ
196 getDFunKey :: RenamedHsType -> (OccName, OccName) -- Used to manufacture DFun names
197 getDFunKey (HsForAllTy _ _ ty) = getDFunKey ty
198 getDFunKey (MonoFunTy _ ty) = getDFunKey ty
199 getDFunKey (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty)
201 get_tycon_key (MonoTyVar tv) = nameOccName (getName tv)
202 get_tycon_key (MonoTyApp ty _) = get_tycon_key ty
203 get_tycon_key (MonoTupleTy tys True) = getOccName (tupleTyCon (length tys))
204 get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys))
205 get_tycon_key (MonoListTy _) = getOccName listTyCon
206 get_tycon_key (MonoFunTy _ _) = getOccName funTyCon
210 %*********************************************************
214 %*********************************************************
217 -------------------------------------
218 bindLocatedLocalsRn :: SDoc -- Documentation string for error message
219 -> [(RdrName,SrcLoc)]
220 -> ([Name] -> RnMS a)
222 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
223 = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
225 getLocalNameEnv `thenRn` \ name_env ->
226 (if opt_WarnNameShadowing
228 mapRn_ (check_shadow name_env) rdr_names_w_loc
233 getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
234 getModeRn `thenRn` \ mode ->
236 n = length rdr_names_w_loc
237 (us', us1) = splitUniqSupply us
238 uniqs = uniqsFromSupply n us1
239 names = [ mk_name uniq (rdrNameOcc rdr_name) loc
240 | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
242 mk_name = case mode of
243 SourceMode -> mkLocalName
244 InterfaceMode -> mkImportedLocalName
245 -- Keep track of whether the name originally came from
246 -- an interface file.
248 setNameSupplyRn (us', inst_ns, cache, ipcache) `thenRn_`
251 new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
253 setLocalNameEnv new_name_env (enclosed_scope names)
256 check_shadow name_env (rdr_name,loc)
257 = case lookupRdrEnv name_env rdr_name of
258 Nothing -> returnRn ()
259 Just name -> pushSrcLocRn loc $
260 addWarnRn (shadowedNameWarn rdr_name)
262 bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars))
263 -> RnMS (a, FreeVars)
264 -- A specialised variant when renaming stuff from interface
265 -- files (of which there is a lot)
267 -- * no checks for shadowing
269 -- * deal with free vars
270 bindCoreLocalFVRn rdr_name enclosed_scope
271 = getSrcLocRn `thenRn` \ loc ->
272 getLocalNameEnv `thenRn` \ name_env ->
273 getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
275 (us', us1) = splitUniqSupply us
276 uniq = uniqFromSupply us1
277 name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
279 setNameSupplyRn (us', inst_ns, cache, ipcache) `thenRn_`
281 new_name_env = extendRdrEnv name_env rdr_name name
283 setLocalNameEnv new_name_env (enclosed_scope name) `thenRn` \ (result, fvs) ->
284 returnRn (result, delFromNameSet fvs name)
286 bindCoreLocalsFVRn [] thing_inside = thing_inside []
287 bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b $ \ name' ->
288 bindCoreLocalsFVRn bs $ \ names' ->
289 thing_inside (name':names')
291 -------------------------------------
292 bindLocalRn doc rdr_name enclosed_scope
293 = getSrcLocRn `thenRn` \ loc ->
294 bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) ->
298 bindLocalsRn doc rdr_names enclosed_scope
299 = getSrcLocRn `thenRn` \ loc ->
300 bindLocatedLocalsRn doc
301 (rdr_names `zip` repeat loc)
304 -- binLocalsFVRn is the same as bindLocalsRn
305 -- except that it deals with free vars
306 bindLocalsFVRn doc rdr_names enclosed_scope
307 = bindLocalsRn doc rdr_names $ \ names ->
308 enclosed_scope names `thenRn` \ (thing, fvs) ->
309 returnRn (thing, delListFromNameSet fvs names)
311 -------------------------------------
312 bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars)
313 bindUVarRn = bindLocalRn
315 -------------------------------------
316 extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
317 -- This tiresome function is used only in rnDecl on InstDecl
318 extendTyVarEnvFVRn tyvars enclosed_scope
319 = getLocalNameEnv `thenRn` \ env ->
321 tyvar_names = map getTyVarName tyvars
322 new_env = addListToRdrEnv env [ (mkRdrUnqual (getOccName name), name)
323 | name <- tyvar_names
326 setLocalNameEnv new_env enclosed_scope `thenRn` \ (thing, fvs) ->
327 returnRn (thing, delListFromNameSet fvs tyvar_names)
329 bindTyVarsRn :: SDoc -> [HsTyVar RdrName]
330 -> ([HsTyVar Name] -> RnMS a)
332 bindTyVarsRn doc_str tyvar_names enclosed_scope
333 = bindTyVars2Rn doc_str tyvar_names $ \ names tyvars ->
334 enclosed_scope tyvars
336 -- Gruesome name: return Names as well as HsTyVars
337 bindTyVars2Rn :: SDoc -> [HsTyVar RdrName]
338 -> ([Name] -> [HsTyVar Name] -> RnMS a)
340 bindTyVars2Rn doc_str tyvar_names enclosed_scope
341 = getSrcLocRn `thenRn` \ loc ->
343 located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names]
345 bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
346 enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
348 bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName]
349 -> ([HsTyVar Name] -> RnMS (a, FreeVars))
350 -> RnMS (a, FreeVars)
351 bindTyVarsFVRn doc_str rdr_names enclosed_scope
352 = bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
353 enclosed_scope tyvars `thenRn` \ (thing, fvs) ->
354 returnRn (thing, delListFromNameSet fvs names)
356 bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName]
357 -> ([Name] -> [HsTyVar Name] -> RnMS (a, FreeVars))
358 -> RnMS (a, FreeVars)
359 bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
360 = bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
361 enclosed_scope names tyvars `thenRn` \ (thing, fvs) ->
362 returnRn (thing, delListFromNameSet fvs names)
365 -------------------------------------
366 checkDupOrQualNames, checkDupNames :: SDoc
367 -> [(RdrName, SrcLoc)]
369 -- Works in any variant of the renamer monad
371 checkDupOrQualNames doc_str rdr_names_w_loc
372 = -- Check for use of qualified names
373 mapRn_ (qualNameErr doc_str) quals `thenRn_`
374 checkDupNames doc_str rdr_names_w_loc
376 quals = filter (isQual.fst) rdr_names_w_loc
378 checkDupNames doc_str rdr_names_w_loc
379 = -- Check for duplicated names in a binding group
380 mapRn_ (dupNamesErr doc_str) dups
382 (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
386 %*********************************************************
388 \subsection{Looking up names}
390 %*********************************************************
392 Looking up a name in the RnEnv.
395 lookupBndrRn rdr_name
396 = getNameEnvs `thenRn` \ (global_env, local_env) ->
399 case lookupRdrEnv local_env rdr_name of {
400 Just name -> returnRn name ;
403 getModeRn `thenRn` \ mode ->
405 InterfaceMode -> -- Look in the global name cache
406 mkImportedGlobalFromRdrName rdr_name
408 SourceMode -> -- Source mode, so look up a *qualified* version
409 -- of the name, so that we get the right one even
410 -- if there are many with the same occ name
411 -- There must *be* a binding
412 getModuleRn `thenRn` \ mod ->
413 case lookupRdrEnv global_env (qualifyRdrName mod rdr_name) of
414 Just (name:rest) -> ASSERT( null rest )
416 Nothing -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_name)
419 -- Just like lookupRn except that we record the occurrence too
420 -- Perhaps surprisingly, even wired-in names are recorded.
421 -- Why? So that we know which wired-in names are referred to when
422 -- deciding which instance declarations to import.
423 lookupOccRn :: RdrName -> RnMS Name
425 = getNameEnvs `thenRn` \ (global_env, local_env) ->
426 lookup_occ global_env local_env rdr_name
428 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
429 -- environment. It's used only for
430 -- record field names
431 -- class op names in class and instance decls
432 lookupGlobalOccRn :: RdrName -> RnMS Name
433 lookupGlobalOccRn rdr_name
434 = getNameEnvs `thenRn` \ (global_env, local_env) ->
435 lookup_global_occ global_env rdr_name
437 -- Look in both local and global env
438 lookup_occ global_env local_env rdr_name
439 = case lookupRdrEnv local_env rdr_name of
440 Just name -> returnRn name
441 Nothing -> lookup_global_occ global_env rdr_name
443 -- Look in global env only
444 lookup_global_occ global_env rdr_name
445 = case lookupRdrEnv global_env rdr_name of
446 Just [name] -> returnRn name
447 Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_`
449 Nothing -> getModeRn `thenRn` \ mode ->
451 -- Not found when processing source code; so fail
452 SourceMode -> failWithRn (mkUnboundName rdr_name)
453 (unknownNameErr rdr_name)
455 -- Not found when processing an imported declaration,
456 -- so we create a new name for the purpose
457 InterfaceMode -> mkImportedGlobalFromRdrName rdr_name
460 @lookupImplicitOccRn@ takes an RdrName representing an {\em original} name,
461 and adds it to the occurrence pool so that it'll be loaded later.
462 This is used when language constructs
463 (such as monad comprehensions, overloaded literals, or deriving clauses)
464 require some stuff to be loaded that isn't explicitly mentioned in the code.
466 This doesn't apply in interface mode, where everything is explicit,
467 but we don't check for this case:
468 it does no harm to record an ``extra'' occurrence
469 and @lookupImplicitOccRn@ isn't used much in interface mode
470 (it's only the @Nothing@ clause of @rnDerivs@ that calls it at all I think).
472 \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
474 For List and Tuple types it's important to get the correct
475 @isLocallyDefined@ flag, which is used in turn when deciding
476 whether there are any instance decls in this module are ``special''.
477 The name cache should have the correct provenance, though.
480 lookupImplicitOccRn :: RdrName -> RnM d Name
481 lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name
484 @unQualInScope@ returns a function that takes a @Name@ and tells whether
485 its unqualified name is in scope. This is put as a boolean flag in
486 the @Name@'s provenance to guide whether or not to print the name qualified
490 unQualInScope :: GlobalRdrEnv -> Name -> Bool
494 lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
495 Just [name'] -> name == name'
499 %************************************************************************
501 \subsection{Envt utility functions}
503 %************************************************************************
505 \subsubsection{NameEnv}% ================
508 plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
509 plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
511 addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> Name -> GlobalRdrEnv
512 addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]
514 delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv
515 delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name
517 combine_globals :: [Name] -- Old
520 combine_globals ns_old ns_new -- ns_new is often short
521 = foldr add ns_old ns_new
523 add n ns | any (is_duplicate n) ns_old = map choose ns -- Eliminate duplicates
526 choose n' | n==n' && better_provenance n n' = n
530 -- a local thing over an imported thing
531 -- a user-imported thing over a non-user-imported thing
532 -- an explicitly-imported thing over an implicitly imported thing
533 better_provenance n1 n2
534 = case (getNameProvenance n1, getNameProvenance n2) of
535 (LocalDef _ _, _ ) -> True
536 (NonLocalDef (UserImport _ _ True) _, _ ) -> True
537 (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True
540 is_duplicate :: Name -> Name -> Bool
541 is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False
542 | otherwise = n1 == n2
544 We treat two bindings of a locally-defined name as a duplicate,
545 because they might be two separate, local defns and we want to report
546 and error for that, {\em not} eliminate a duplicate.
548 On the other hand, if you import the same name from two different
549 import statements, we {\em d}* want to eliminate the duplicate, not report
552 If a module imports itself then there might be a local defn and an imported
553 defn of the same name; in this case the names will compare as equal, but
554 will still have different provenances.
558 \subsubsection{ExportAvails}% ================
561 mkEmptyExportAvails :: ModuleName -> ExportAvails
562 mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
564 mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
565 mkExportAvails mod_name unqual_imp name_env avails
566 = (mod_avail_env, entity_avail_env)
568 mod_avail_env = unitFM mod_name unqual_avails
570 -- unqual_avails is the Avails that are visible in *unqualfied* form
571 -- (1.4 Report, Section 5.1.1)
573 -- import T hiding( f )
574 -- we delete f from avails
576 unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
577 | otherwise = mapMaybe prune avails
579 prune (Avail n) | unqual_in_scope n = Just (Avail n)
580 prune (Avail n) | otherwise = Nothing
581 prune (AvailTC n ns) | null uqs = Nothing
582 | otherwise = Just (AvailTC n uqs)
584 uqs = filter unqual_in_scope ns
586 unqual_in_scope n = unQualInScope name_env n
588 entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
589 name <- availNames avail]
591 plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
592 plusExportAvails (m1, e1) (m2, e2)
593 = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2)
594 -- ToDo: wasteful: we do this once for each constructor!
598 \subsubsection{AvailInfo}% ================
601 plusAvail (Avail n1) (Avail n2) = Avail n1
602 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
605 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
608 addAvail :: AvailEnv -> AvailInfo -> AvailEnv
609 addAvail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
611 emptyAvailEnv = emptyNameEnv
612 unitAvailEnv :: AvailInfo -> AvailEnv
613 unitAvailEnv a = unitNameEnv (availName a) a
615 plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
616 plusAvailEnv = plusNameEnv_C plusAvail
618 availEnvElts = nameEnvElts
620 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
621 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
623 availsToNameSet :: [AvailInfo] -> NameSet
624 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
626 availName :: AvailInfo -> Name
627 availName (Avail n) = n
628 availName (AvailTC n _) = n
630 availNames :: AvailInfo -> [Name]
631 availNames (Avail n) = [n]
632 availNames (AvailTC n ns) = ns
634 addSysAvails :: AvailInfo -> [Name] -> AvailInfo
635 addSysAvails avail [] = avail
636 addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
638 filterAvail :: RdrNameIE -- Wanted
639 -> AvailInfo -- Available
640 -> Maybe AvailInfo -- Resulting available;
641 -- Nothing if (any of the) wanted stuff isn't there
643 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
644 | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
645 | otherwise = Nothing
647 is_wanted name = nameOccName name `elem` wanted_occs
648 sub_names_ok = all (`elem` avail_occs) wanted_occs
649 avail_occs = map nameOccName ns
650 wanted_occs = map rdrNameOcc (want:wants)
652 filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns )
655 filterAvail (IEThingAbs _) avail@(Avail n) = Just avail -- Type synonyms
657 filterAvail (IEVar _) avail@(Avail n) = Just avail
658 filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
660 wanted n = nameOccName n == occ
662 -- The second equation happens if we import a class op, thus
664 -- where op is a class operation
666 filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail
667 -- We don't complain even if the IE says T(..), but
668 -- no constrs/class ops of T are available
669 -- Instead that's caught with a warning by the caller
671 filterAvail ie avail = Nothing
673 pprAvail :: AvailInfo -> SDoc
674 pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of
676 ns' -> parens (hsep (punctuate comma (map ppr ns')))
678 pprAvail (Avail n) = ppr n
684 %************************************************************************
686 \subsection{Free variable manipulation}
688 %************************************************************************
691 type FreeVars = NameSet
693 plusFV :: FreeVars -> FreeVars -> FreeVars
694 addOneFV :: FreeVars -> Name -> FreeVars
695 unitFV :: Name -> FreeVars
697 plusFVs :: [FreeVars] -> FreeVars
699 isEmptyFVs = isEmptyNameSet
700 emptyFVs = emptyNameSet
701 plusFVs = unionManyNameSets
702 plusFV = unionNameSets
704 -- No point in adding implicitly imported names to the free-var set
705 addOneFV s n = addOneToNameSet s n
706 unitFV n = unitNameSet n
709 mapFvRn f xs = mapRn f xs `thenRn` \ stuff ->
711 (ys, fvs_s) = unzip stuff
713 returnRn (ys, plusFVs fvs_s)
717 %************************************************************************
719 \subsection{Envt utility functions}
721 %************************************************************************
726 warnUnusedLocalBinds, warnUnusedImports, warnUnusedMatches :: [Name] -> RnM d ()
728 warnUnusedImports names
729 | not opt_WarnUnusedImports
730 = returnRn () -- Don't force names unless necessary
732 = warnUnusedBinds (const True) names
734 warnUnusedLocalBinds ns
735 | not opt_WarnUnusedBinds = returnRn ()
736 | otherwise = warnUnusedBinds (const True) ns
738 warnUnusedMatches names
739 | opt_WarnUnusedMatches = warnUnusedGroup (const True) names
740 | otherwise = returnRn ()
742 -------------------------
744 warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM d ()
745 warnUnusedBinds warn_when_local names
746 = mapRn_ (warnUnusedGroup warn_when_local) groups
748 -- Group by provenance
749 groups = equivClasses cmp names
750 name1 `cmp` name2 = getNameProvenance name1 `cmp_prov` getNameProvenance name2
752 cmp_prov (LocalDef _ _) (NonLocalDef _ _) = LT
753 cmp_prov (LocalDef loc1 _) (LocalDef loc2 _) = loc1 `compare` loc2
754 cmp_prov (NonLocalDef (UserImport m1 loc1 _) _)
755 (NonLocalDef (UserImport m2 loc2 _) _) =
756 (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2)
757 cmp_prov (NonLocalDef _ _) (LocalDef _ _) = GT
758 -- In-scope NonLocalDefs must have UserImport info on them
760 -------------------------
762 -- NOTE: the function passed to warnUnusedGroup is
763 -- now always (const True) so we should be able to
764 -- simplify the code slightly. I'm leaving it there
765 -- for now just in case I havn't realised why it was there.
766 -- Looks highly bogus to me. SLPJ Dec 99
768 warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d ()
769 warnUnusedGroup emit_warning names
770 | null filtered_names = returnRn ()
771 | not (emit_warning is_local) = returnRn ()
773 = pushSrcLocRn def_loc $
775 sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))]
777 filtered_names = filter reportable names
778 name1 = head filtered_names
779 (is_local, def_loc, msg)
780 = case getNameProvenance name1 of
781 LocalDef loc _ -> (True, loc, text "Defined but not used")
782 NonLocalDef (UserImport mod loc _) _ ->
783 (True, loc, text "Imported from" <+> quotes (ppr mod) <+>
785 other -> (False, getSrcLoc name1, text "Strangely defined but not used")
787 reportable name = case occNameUserString (nameOccName name) of
790 -- Haskell 98 encourages compilers to suppress warnings about
791 -- unused names in a pattern if they start with "_".
795 addNameClashErrRn rdr_name (name1:names)
796 = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
797 ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
799 msg1 = ptext SLIT("either") <+> mk_ref name1
800 msgs = [ptext SLIT(" or") <+> mk_ref name | name <- names]
801 mk_ref name = quotes (ppr name) <> comma <+> pprNameProvenance name
803 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
804 = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
805 4 (vcat [ppr how_in_scope1,
808 shadowedNameWarn shadow
809 = hsep [ptext SLIT("This binding for"),
811 ptext SLIT("shadows an existing binding")]
814 = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
816 flavour = occNameFlavour (rdrNameOcc name)
818 qualNameErr descriptor (name,loc)
820 addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
825 dupNamesErr descriptor ((name,loc) : dup_things)
827 addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
829 (ptext SLIT("in") <+> descriptor))