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, isSystemName,
25 nameOccName, setNameModule, nameModule,
26 pprOccName, isLocallyDefined, nameUnique, nameOccName,
28 setNameProvenance, getNameProvenance, pprNameProvenance
31 import OccName ( OccName,
32 mkDFunOcc, occNameUserString, occNameString,
35 import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon )
36 import Type ( funTyCon )
37 import Module ( ModuleName, mkThisModule, mkVanillaModule, moduleName )
38 import TyCon ( TyCon )
40 import Unique ( Unique, Uniquable(..) )
41 import UniqFM ( emptyUFM, listToUFM, plusUFM_C )
43 import SrcLoc ( SrcLoc, noSrcLoc )
45 import Util ( removeDups, equivClasses, thenCmp )
47 import Maybes ( mapMaybe )
52 %*********************************************************
54 \subsection{Making new names}
56 %*********************************************************
59 newImportedGlobalName mod_name occ mod
60 = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
64 case lookupFM cache key of
65 Just name -> returnRn name
66 Nothing -> setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
69 (us', us1) = splitUniqSupply us
70 uniq = uniqFromSupply us1
71 name = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport False)
72 new_cache = addToFM cache key name
74 updateProvenances :: [Name] -> RnM d ()
75 updateProvenances names
76 = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
77 setNameSupplyRn (us, inst_ns, update cache names)
79 update cache [] = cache
80 update cache (name:names) = WARN( not (key `elemFM` cache), ppr name )
81 update (addToFM cache key name) names
83 key = (moduleName (nameModule name), nameOccName name)
85 newImportedBinder :: Module -> RdrName -> RnM d Name
86 newImportedBinder mod rdr_name
87 = ASSERT2( isUnqual rdr_name, ppr rdr_name )
88 newImportedGlobalName (moduleName mod) (rdrNameOcc rdr_name) mod
90 -- Make an imported global name, checking first to see if it's in the cache
91 mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name
92 mkImportedGlobalName mod_name occ
93 = lookupModuleRn mod_name `thenRn` \ mod ->
94 newImportedGlobalName mod_name occ mod --(mkVanillaModule mod_name)
96 mkImportedGlobalFromRdrName rdr_name
98 = mkImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
101 = -- An Unqual is allowed; interface files contain
102 -- unqualified names for locally-defined things, such as
103 -- constructors of a data type.
104 getModuleRn `thenRn ` \ mod_name ->
105 mkImportedGlobalName mod_name (rdrNameOcc rdr_name)
108 newLocalTopBinder :: Module -> OccName
109 -> (Name -> ExportFlag) -> SrcLoc
111 newLocalTopBinder mod occ rec_exp_fn loc
112 = -- First check the cache
113 getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
115 key = (moduleName mod,occ)
116 mk_prov name = LocalDef loc (rec_exp_fn name)
117 -- We must set the provenance of the thing in the cache
118 -- correctly, particularly whether or not it is locally defined.
120 -- Since newLocallyDefinedGlobalName is used only
121 -- at binding occurrences, we may as well get the provenance
122 -- dead right first time; hence the rec_exp_fn passed in
124 case lookupFM cache key of
126 -- A hit in the cache!
127 -- Overwrite whatever provenance is in the cache already;
128 -- this updates WiredIn things and known-key things,
129 -- which are there from the start, to LocalDef.
131 -- It also means that if there are two defns for the same thing
132 -- in a module, then each gets a separate SrcLoc
134 new_name = setNameProvenance name (mk_prov new_name)
135 new_cache = addToFM cache key new_name
137 setNameSupplyRn (us, inst_ns, new_cache) `thenRn_`
140 -- Miss in the cache!
141 -- Build a new original name, and put it in the cache
143 (us', us1) = splitUniqSupply us
144 uniq = uniqFromSupply us1
145 new_name = mkGlobalName uniq mod occ (mk_prov new_name)
146 new_cache = addToFM cache key new_name
148 setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
152 %*********************************************************
154 \subsection{Dfuns and default methods}
156 %*********************************************************
158 @newImplicitBinder@ is used for (a) dfuns
159 (b) default methods, defined in this module.
162 newImplicitBinder occ src_loc
163 = getModuleRn `thenRn` \ mod_name ->
164 newLocalTopBinder (mkThisModule mod_name) occ (\_ -> Exported) src_loc
167 Make a name for the dict fun for an instance decl
170 newDFunName :: (OccName, OccName) -> SrcLoc -> RnMS Name
171 newDFunName key@(cl_occ, tycon_occ) loc
172 = newInstUniq string `thenRn` \ inst_uniq ->
173 newImplicitBinder (mkDFunOcc string inst_uniq) loc
175 -- Any string that is somewhat unique will do
176 string = occNameString cl_occ ++ occNameString tycon_occ
180 getDFunKey :: RenamedHsType -> (OccName, OccName) -- Used to manufacture DFun names
181 getDFunKey (HsForAllTy _ _ ty) = getDFunKey ty
182 getDFunKey (MonoFunTy _ ty) = getDFunKey ty
183 getDFunKey (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty)
185 get_tycon_key (MonoTyVar tv) = nameOccName (getName tv)
186 get_tycon_key (MonoTyApp ty _) = get_tycon_key ty
187 get_tycon_key (MonoTupleTy tys True) = getOccName (tupleTyCon (length tys))
188 get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys))
189 get_tycon_key (MonoListTy _) = getOccName listTyCon
190 get_tycon_key (MonoFunTy _ _) = getOccName funTyCon
194 %*********************************************************
198 %*********************************************************
201 -------------------------------------
202 bindLocatedLocalsRn :: SDoc -- Documentation string for error message
203 -> [(RdrName,SrcLoc)]
204 -> ([Name] -> RnMS a)
206 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
207 = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
209 getLocalNameEnv `thenRn` \ name_env ->
210 (if opt_WarnNameShadowing
212 mapRn_ (check_shadow name_env) rdr_names_w_loc
217 getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
218 getModeRn `thenRn` \ mode ->
220 n = length rdr_names_w_loc
221 (us', us1) = splitUniqSupply us
222 uniqs = uniqsFromSupply n us1
223 names = [ mk_name uniq (rdrNameOcc rdr_name) loc
224 | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
226 mk_name = case mode of
227 SourceMode -> mkLocalName
228 InterfaceMode -> mkImportedLocalName
229 -- Keep track of whether the name originally came from
230 -- an interface file.
232 setNameSupplyRn (us', inst_ns, cache) `thenRn_`
235 new_name_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
237 setLocalNameEnv new_name_env (enclosed_scope names)
240 check_shadow name_env (rdr_name,loc)
241 = case lookupRdrEnv name_env rdr_name of
242 Nothing -> returnRn ()
243 Just name -> pushSrcLocRn loc $
244 addWarnRn (shadowedNameWarn rdr_name)
246 bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars))
247 -> RnMS (a, FreeVars)
248 -- A specialised variant when renaming stuff from interface
249 -- files (of which there is a lot)
251 -- * no checks for shadowing
253 -- * deal with free vars
254 bindCoreLocalFVRn rdr_name enclosed_scope
255 = getSrcLocRn `thenRn` \ loc ->
256 getLocalNameEnv `thenRn` \ name_env ->
257 getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
259 (us', us1) = splitUniqSupply us
260 uniq = uniqFromSupply us1
261 name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
263 setNameSupplyRn (us', inst_ns, cache) `thenRn_`
265 new_name_env = extendRdrEnv name_env rdr_name name
267 setLocalNameEnv new_name_env (enclosed_scope name) `thenRn` \ (result, fvs) ->
268 returnRn (result, delFromNameSet fvs name)
270 bindCoreLocalsFVRn [] thing_inside = thing_inside []
271 bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b $ \ name' ->
272 bindCoreLocalsFVRn bs $ \ names' ->
273 thing_inside (name':names')
275 -------------------------------------
276 bindLocalRn doc rdr_name enclosed_scope
277 = getSrcLocRn `thenRn` \ loc ->
278 bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) ->
282 bindLocalsRn doc rdr_names enclosed_scope
283 = getSrcLocRn `thenRn` \ loc ->
284 bindLocatedLocalsRn doc
285 (rdr_names `zip` repeat loc)
288 -- binLocalsFVRn is the same as bindLocalsRn
289 -- except that it deals with free vars
290 bindLocalsFVRn doc rdr_names enclosed_scope
291 = bindLocalsRn doc rdr_names $ \ names ->
292 enclosed_scope names `thenRn` \ (thing, fvs) ->
293 returnRn (thing, delListFromNameSet fvs names)
295 -------------------------------------
296 bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars)
297 bindUVarRn = bindLocalRn
299 -------------------------------------
300 extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
301 -- This tiresome function is used only in rnDecl on InstDecl
302 extendTyVarEnvFVRn tyvars enclosed_scope
303 = getLocalNameEnv `thenRn` \ env ->
305 tyvar_names = map getTyVarName tyvars
306 new_env = addListToRdrEnv env [ (mkRdrUnqual (getOccName name), name)
307 | name <- tyvar_names
310 setLocalNameEnv new_env enclosed_scope `thenRn` \ (thing, fvs) ->
311 returnRn (thing, delListFromNameSet fvs tyvar_names)
313 bindTyVarsRn :: SDoc -> [HsTyVar RdrName]
314 -> ([HsTyVar Name] -> RnMS a)
316 bindTyVarsRn doc_str tyvar_names enclosed_scope
317 = bindTyVars2Rn doc_str tyvar_names $ \ names tyvars ->
318 enclosed_scope tyvars
320 -- Gruesome name: return Names as well as HsTyVars
321 bindTyVars2Rn :: SDoc -> [HsTyVar RdrName]
322 -> ([Name] -> [HsTyVar Name] -> RnMS a)
324 bindTyVars2Rn doc_str tyvar_names enclosed_scope
325 = getSrcLocRn `thenRn` \ loc ->
327 located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names]
329 bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
330 enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
332 bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName]
333 -> ([HsTyVar Name] -> RnMS (a, FreeVars))
334 -> RnMS (a, FreeVars)
335 bindTyVarsFVRn doc_str rdr_names enclosed_scope
336 = bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
337 enclosed_scope tyvars `thenRn` \ (thing, fvs) ->
338 returnRn (thing, delListFromNameSet fvs names)
340 bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName]
341 -> ([Name] -> [HsTyVar Name] -> RnMS (a, FreeVars))
342 -> RnMS (a, FreeVars)
343 bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
344 = bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
345 enclosed_scope names tyvars `thenRn` \ (thing, fvs) ->
346 returnRn (thing, delListFromNameSet fvs names)
349 -------------------------------------
350 checkDupOrQualNames, checkDupNames :: SDoc
351 -> [(RdrName, SrcLoc)]
353 -- Works in any variant of the renamer monad
355 checkDupOrQualNames doc_str rdr_names_w_loc
356 = -- Check for use of qualified names
357 mapRn_ (qualNameErr doc_str) quals `thenRn_`
358 checkDupNames doc_str rdr_names_w_loc
360 quals = filter (isQual.fst) rdr_names_w_loc
362 checkDupNames doc_str rdr_names_w_loc
363 = -- Check for duplicated names in a binding group
364 mapRn_ (dupNamesErr doc_str) dups
366 (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
370 %*********************************************************
372 \subsection{Looking up names}
374 %*********************************************************
376 Looking up a name in the RnEnv.
379 lookupBndrRn rdr_name
380 = getNameEnvs `thenRn` \ (global_env, local_env) ->
383 case lookupRdrEnv local_env rdr_name of {
384 Just name -> returnRn name ;
387 getModeRn `thenRn` \ mode ->
389 InterfaceMode -> -- Look in the global name cache
390 mkImportedGlobalFromRdrName rdr_name
392 SourceMode -> -- Source mode, so look up a *qualified* version
393 -- of the name, so that we get the right one even
394 -- if there are many with the same occ name
395 -- There must *be* a binding
396 getModuleRn `thenRn` \ mod ->
397 case lookupRdrEnv global_env (qualifyRdrName mod rdr_name) of
398 Just (name:rest) -> ASSERT( null rest )
400 Nothing -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_name)
403 -- Just like lookupRn except that we record the occurrence too
404 -- Perhaps surprisingly, even wired-in names are recorded.
405 -- Why? So that we know which wired-in names are referred to when
406 -- deciding which instance declarations to import.
407 lookupOccRn :: RdrName -> RnMS Name
409 = getNameEnvs `thenRn` \ (global_env, local_env) ->
410 lookup_occ global_env local_env rdr_name
412 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
413 -- environment. It's used only for
414 -- record field names
415 -- class op names in class and instance decls
416 lookupGlobalOccRn :: RdrName -> RnMS Name
417 lookupGlobalOccRn rdr_name
418 = getNameEnvs `thenRn` \ (global_env, local_env) ->
419 lookup_global_occ global_env rdr_name
421 -- Look in both local and global env
422 lookup_occ global_env local_env rdr_name
423 = case lookupRdrEnv local_env rdr_name of
424 Just name -> returnRn name
425 Nothing -> lookup_global_occ global_env rdr_name
427 -- Look in global env only
428 lookup_global_occ global_env rdr_name
429 = case lookupRdrEnv global_env rdr_name of
430 Just [name] -> returnRn name
431 Just stuff@(name:_) -> addNameClashErrRn rdr_name stuff `thenRn_`
433 Nothing -> getModeRn `thenRn` \ mode ->
435 -- Not found when processing source code; so fail
436 SourceMode -> failWithRn (mkUnboundName rdr_name)
437 (unknownNameErr rdr_name)
439 -- Not found when processing an imported declaration,
440 -- so we create a new name for the purpose
441 InterfaceMode -> mkImportedGlobalFromRdrName rdr_name
444 @lookupImplicitOccRn@ takes an RdrName representing an {\em original} name,
445 and adds it to the occurrence pool so that it'll be loaded later.
446 This is used when language constructs
447 (such as monad comprehensions, overloaded literals, or deriving clauses)
448 require some stuff to be loaded that isn't explicitly mentioned in the code.
450 This doesn't apply in interface mode, where everything is explicit,
451 but we don't check for this case:
452 it does no harm to record an ``extra'' occurrence
453 and @lookupImplicitOccRn@ isn't used much in interface mode
454 (it's only the @Nothing@ clause of @rnDerivs@ that calls it at all I think).
456 \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
458 For List and Tuple types it's important to get the correct
459 @isLocallyDefined@ flag, which is used in turn when deciding
460 whether there are any instance decls in this module are ``special''.
461 The name cache should have the correct provenance, though.
464 lookupImplicitOccRn :: RdrName -> RnM d Name
465 lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name
468 @unQualInScope@ returns a function that takes a @Name@ and tells whether
469 its unqualified name is in scope. This is put as a boolean flag in
470 the @Name@'s provenance to guide whether or not to print the name qualified
474 unQualInScope :: GlobalRdrEnv -> Name -> Bool
478 lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
479 Just [name'] -> name == name'
483 %************************************************************************
485 \subsection{Envt utility functions}
487 %************************************************************************
489 \subsubsection{NameEnv}% ================
492 plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
493 plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
495 addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> Name -> GlobalRdrEnv
496 addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]
498 delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv
499 delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name
501 combine_globals :: [Name] -- Old
504 combine_globals ns_old ns_new -- ns_new is often short
505 = foldr add ns_old ns_new
507 add n ns | any (is_duplicate n) ns_old = map choose ns -- Eliminate duplicates
510 choose n' | n==n' && better_provenance n n' = n
514 -- a local thing over an imported thing
515 -- a user-imported thing over a non-user-imported thing
516 -- an explicitly-imported thing over an implicitly imported thing
517 better_provenance n1 n2
518 = case (getNameProvenance n1, getNameProvenance n2) of
519 (LocalDef _ _, _ ) -> True
520 (NonLocalDef (UserImport _ _ True) _, _ ) -> True
521 (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True
524 is_duplicate :: Name -> Name -> Bool
525 is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False
526 | otherwise = n1 == n2
528 We treat two bindings of a locally-defined name as a duplicate,
529 because they might be two separate, local defns and we want to report
530 and error for that, {\em not} eliminate a duplicate.
532 On the other hand, if you import the same name from two different
533 import statements, we {\em d}* want to eliminate the duplicate, not report
536 If a module imports itself then there might be a local defn and an imported
537 defn of the same name; in this case the names will compare as equal, but
538 will still have different provenances.
542 \subsubsection{ExportAvails}% ================
545 mkEmptyExportAvails :: ModuleName -> ExportAvails
546 mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
548 mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
549 mkExportAvails mod_name unqual_imp name_env avails
550 = (mod_avail_env, entity_avail_env)
552 mod_avail_env = unitFM mod_name unqual_avails
554 -- unqual_avails is the Avails that are visible in *unqualfied* form
555 -- (1.4 Report, Section 5.1.1)
557 -- import T hiding( f )
558 -- we delete f from avails
560 unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
561 | otherwise = mapMaybe prune avails
563 prune (Avail n) | unqual_in_scope n = Just (Avail n)
564 prune (Avail n) | otherwise = Nothing
565 prune (AvailTC n ns) | null uqs = Nothing
566 | otherwise = Just (AvailTC n uqs)
568 uqs = filter unqual_in_scope ns
570 unqual_in_scope n = unQualInScope name_env n
572 entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
573 name <- availNames avail]
575 plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
576 plusExportAvails (m1, e1) (m2, e2)
577 = (plusFM_C (++) m1 m2, plusUFM_C plusAvail e1 e2)
578 -- ToDo: wasteful: we do this once for each constructor!
582 \subsubsection{AvailInfo}% ================
585 plusAvail (Avail n1) (Avail n2) = Avail n1
586 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
589 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
592 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
593 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
595 availsToNameSet :: [AvailInfo] -> NameSet
596 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
598 availName :: AvailInfo -> Name
599 availName (Avail n) = n
600 availName (AvailTC n _) = n
602 availNames :: AvailInfo -> [Name]
603 availNames (Avail n) = [n]
604 availNames (AvailTC n ns) = ns
606 filterAvail :: RdrNameIE -- Wanted
607 -> AvailInfo -- Available
608 -> Maybe AvailInfo -- Resulting available;
609 -- Nothing if (any of the) wanted stuff isn't there
611 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
612 | sub_names_ok = Just (AvailTC n (filter is_wanted ns))
613 | otherwise = Nothing
615 is_wanted name = nameOccName name `elem` wanted_occs
616 sub_names_ok = all (`elem` avail_occs) wanted_occs
617 avail_occs = map nameOccName ns
618 wanted_occs = map rdrNameOcc (want:wants)
620 filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns )
623 filterAvail (IEThingAbs _) avail@(Avail n) = Just avail -- Type synonyms
625 filterAvail (IEVar _) avail@(Avail n) = Just avail
626 filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns))
628 wanted n = nameOccName n == occ
630 -- The second equation happens if we import a class op, thus
632 -- where op is a class operation
634 filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail
636 filterAvail ie avail = Nothing
639 -- In interfaces, pprAvail gets given the OccName of the "host" thing
640 pprAvail avail = getPprStyle $ \ sty ->
641 if ifaceStyle sty then
642 ppr_avail (pprOccName . nameOccName) avail
646 ppr_avail pp_name (AvailTC n ns) = hsep [
648 parens $ hsep $ punctuate comma $
651 ppr_avail pp_name (Avail n) = pp_name n
657 %************************************************************************
659 \subsection{Free variable manipulation}
661 %************************************************************************
664 type FreeVars = NameSet
666 plusFV :: FreeVars -> FreeVars -> FreeVars
667 addOneFV :: FreeVars -> Name -> FreeVars
668 unitFV :: Name -> FreeVars
670 plusFVs :: [FreeVars] -> FreeVars
672 isEmptyFVs = isEmptyNameSet
673 emptyFVs = emptyNameSet
674 plusFVs = unionManyNameSets
675 plusFV = unionNameSets
677 -- No point in adding implicitly imported names to the free-var set
678 addOneFV s n = addOneToNameSet s n
679 unitFV n = unitNameSet n
682 mapFvRn f xs = mapRn f xs `thenRn` \ stuff ->
684 (ys, fvs_s) = unzip stuff
686 returnRn (ys, plusFVs fvs_s)
690 %************************************************************************
692 \subsection{Envt utility functions}
694 %************************************************************************
698 warnUnusedLocalBinds, warnUnusedTopNames, warnUnusedMatches :: [Name] -> RnM d ()
700 warnUnusedTopNames names
701 | not opt_WarnUnusedBinds && not opt_WarnUnusedImports
702 = returnRn () -- Don't force ns unless necessary
704 = warnUnusedBinds (\ is_local -> not is_local) names
706 warnUnusedLocalBinds ns
707 | not opt_WarnUnusedBinds = returnRn ()
708 | otherwise = warnUnusedBinds (\ is_local -> is_local) ns
710 warnUnusedMatches names
711 | opt_WarnUnusedMatches = warnUnusedGroup (const True) names
712 | otherwise = returnRn ()
714 -------------------------
716 warnUnusedBinds :: (Bool -> Bool) -> [Name] -> RnM d ()
717 warnUnusedBinds warn_when_local names
718 = mapRn_ (warnUnusedGroup warn_when_local) groups
720 -- Group by provenance
721 groups = equivClasses cmp names
722 name1 `cmp` name2 = getNameProvenance name1 `cmp_prov` getNameProvenance name2
724 cmp_prov (LocalDef _ _) (NonLocalDef _ _) = LT
725 cmp_prov (LocalDef loc1 _) (LocalDef loc2 _) = loc1 `compare` loc2
726 cmp_prov (NonLocalDef (UserImport m1 loc1 _) _)
727 (NonLocalDef (UserImport m2 loc2 _) _) =
728 (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2)
729 cmp_prov (NonLocalDef _ _) (LocalDef _ _) = GT
730 -- In-scope NonLocalDefs must have UserImport info on them
732 -------------------------
734 warnUnusedGroup :: (Bool -> Bool) -> [Name] -> RnM d ()
735 warnUnusedGroup emit_warning names
736 | null filtered_names = returnRn ()
737 | not (emit_warning is_local) = returnRn ()
739 = pushSrcLocRn def_loc $
741 sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))]
743 filtered_names = filter reportable names
744 name1 = head filtered_names
745 (is_local, def_loc, msg)
746 = case getNameProvenance name1 of
747 LocalDef loc _ -> (True, loc, text "Defined but not used")
748 NonLocalDef (UserImport mod loc _) _ ->
749 (True, loc, text "Imported from" <+> quotes (ppr mod) <+>
751 other -> (False, getSrcLoc name1, text "Strangely defined but not used")
753 reportable name = case occNameUserString (nameOccName name) of
756 -- Haskell 98 encourages compilers to suppress warnings about
757 -- unused names in a pattern if they start with "_".
761 addNameClashErrRn rdr_name (name1:names)
762 = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name),
763 ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)])
765 msg1 = ptext SLIT("either") <+> mk_ref name1
766 msgs = [ptext SLIT(" or") <+> mk_ref name | name <- names]
767 mk_ref name = quotes (ppr name) <> comma <+> pprNameProvenance name
769 fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
770 = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
771 4 (vcat [ppr how_in_scope1,
774 shadowedNameWarn shadow
775 = hsep [ptext SLIT("This binding for"),
777 ptext SLIT("shadows an existing binding")]
780 = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)]
782 flavour = occNameFlavour (rdrNameOcc name)
784 qualNameErr descriptor (name,loc)
786 addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
791 dupNamesErr descriptor ((name,loc) : dup_things)
793 addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
795 (ptext SLIT("in") <+> descriptor))