2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[RnEnv]{Environment manipulation for the renamer monad}
7 #include "HsVersions.h"
9 module RnEnv where -- Export everything
13 import CmdLineOpts ( opt_WarnNameShadowing )
15 import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameIE),
16 rdrNameOcc, ieOcc, isQual, qual
18 import HsTypes ( getTyVarName, replaceTyVarName )
20 import Name ( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..),
21 occNameString, occNameFlavour,
22 SYN_IE(NameSet), emptyNameSet, addListToNameSet,
23 mkLocalName, mkGlobalName, modAndOcc, isLocallyDefinedName,
24 isWiredInName, nameOccName, setNameProvenance, isVarOcc,
25 pprProvenance, pprOccName, pprModule, pprNonSymOcc, pprNameProvenance
27 import TyCon ( TyCon )
28 import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon )
30 import Unique ( Unique, unboundKey )
31 import Maybes ( maybeToBool )
33 import SrcLoc ( SrcLoc, noSrcLoc )
35 import PprStyle ( PprStyle(..) )
36 import Util ( panic, removeDups, pprTrace, assertPanic )
41 %*********************************************************
43 \subsection{Making new names}
45 %*********************************************************
48 newGlobalName :: Module -> OccName -> RnM s d Name
50 = -- First check the cache
51 getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
52 let key = (mod,occ) in
53 case lookupFM cache key of
55 -- A hit in the cache! Return it, but change the src loc
56 -- of the thing we've found if this is a second definition site
57 -- (that is, if loc /= NoSrcLoc)
58 Just name -> returnRn name
60 -- Miss in the cache, so build a new original name,
61 -- and put it in the cache
64 (us', us1) = splitUniqSupply us
66 name = mkGlobalName uniq mod occ VanillaDefn Implicit
67 cache' = addToFM cache key name
69 setNameSupplyRn (us', inst_ns, cache') `thenRn_`
72 newLocallyDefinedGlobalName :: Module -> OccName
73 -> (Name -> ExportFlag) -> SrcLoc
75 newLocallyDefinedGlobalName mod occ rec_exp_fn loc
76 = -- First check the cache
77 getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
79 -- We are at the binding site for a locally-defined thing, so
80 -- you might think it can't be in the cache, but it can if it's a
81 -- wired in thing. In that case we need to use the correct unique etc...
82 -- so all we do is replace its provenance.
83 -- If it's not in the cache we put it there with the correct provenance.
84 -- The idea is that, after all this, the cache
85 -- will contain a Name with the correct Provenance (i.e. Local)
87 provenance = LocalDef (rec_exp_fn new_name) loc
88 (us', us1) = splitUniqSupply us
91 new_name = case lookupFM cache key of
92 Just name -> setNameProvenance name provenance
93 Nothing -> mkGlobalName uniq mod occ VanillaDefn provenance
94 new_cache = addToFM cache key new_name
96 setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
99 -- newSysName is used to create the names for
100 -- a) default methods
101 -- These are never mentioned explicitly in source code (hence no point in looking
102 -- them up in the NameEnv), but when reading an interface file
103 -- we may want to slurp in their pragma info. In the source file itself we
104 -- need to create these names too so that we export them into the inferface file for this module.
106 newSysName :: OccName -> ExportFlag -> SrcLoc -> RnMS s Name
107 newSysName occ export_flag loc
108 = getModeRn `thenRn` \ mode ->
109 getModuleRn `thenRn` \ mod_name ->
111 SourceMode -> newLocallyDefinedGlobalName
115 InterfaceMode -> newGlobalName mod_name occ
117 -- newDfunName is a variant, specially for dfuns.
118 -- When renaming derived definitions we are in *interface* mode (because we can trip
119 -- over original names), but we still want to make the Dfun locally-defined.
120 -- So we can't use whether or not we're in source mode to decide the locally-defined question.
121 newDfunName :: Maybe RdrName -> SrcLoc -> RnMS s Name
122 newDfunName Nothing src_loc -- Local instance decls have a "Nothing"
123 = getModuleRn `thenRn` \ mod_name ->
124 newInstUniq `thenRn` \ inst_uniq ->
126 dfun_occ = VarOcc (_PK_ ("$d" ++ show inst_uniq))
128 newLocallyDefinedGlobalName mod_name dfun_occ
129 (\_ -> Exported) src_loc
131 newDfunName (Just n) src_loc -- Imported ones have "Just n"
132 = getModuleRn `thenRn` \ mod_name ->
133 newGlobalName mod_name (rdrNameOcc n)
136 newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
137 newLocalNames rdr_names
138 = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
141 (us', us1) = splitUniqSupply us
142 uniqs = getUniques n us1
143 locals = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
144 | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs
147 setNameSupplyRn (us', inst_ns, cache) `thenRn_`
150 -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
151 -- during compiler debugging.
152 mkUnboundName :: RdrName -> Name
153 mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
155 isUnboundName :: Name -> Bool
156 isUnboundName name = uniqueOf name == unboundKey
160 bindLocatedLocalsRn :: String -- Documentation string for error message
161 -> [(RdrName,SrcLoc)]
162 -> ([Name] -> RnMS s a)
164 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
165 = -- Check for use of qualified names
166 mapRn (qualNameErr doc_str) quals `thenRn_`
167 -- Check for dupicated names in a binding group
168 mapRn (dupNamesErr doc_str) dups `thenRn_`
170 getNameEnv `thenRn` \ name_env ->
171 (if opt_WarnNameShadowing
173 mapRn (check_shadow name_env) rdr_names_w_loc
178 newLocalNames rdr_names_w_loc `thenRn` \ names ->
180 new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names)
182 setNameEnv new_name_env (enclosed_scope names)
184 quals = filter (isQual.fst) rdr_names_w_loc
185 (these, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc
186 check_shadow name_env (rdr_name,loc)
187 = case lookupFM name_env rdr_name of
188 Nothing -> returnRn ()
189 Just name -> pushSrcLocRn loc $
190 addWarnRn (shadowedNameWarn rdr_name)
192 bindLocalsRn doc_str rdr_names enclosed_scope
193 = getSrcLocRn `thenRn` \ loc ->
194 bindLocatedLocalsRn doc_str (rdr_names `zip` repeat loc) enclosed_scope
196 bindTyVarsRn doc_str tyvar_names enclosed_scope
197 = getSrcLocRn `thenRn` \ loc ->
199 located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names]
201 bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
202 enclosed_scope (zipWith replaceTyVarName tyvar_names names)
206 %*********************************************************
208 \subsection{Looking up names}
210 %*********************************************************
212 Looking up a name in the RnEnv.
215 lookupRn :: NameEnv -> RdrName -> RnMS s Name
216 lookupRn name_env rdr_name
217 = case lookupFM name_env rdr_name of
220 Just name -> returnRn name
223 Nothing -> getModeRn `thenRn` \ mode ->
225 -- Not found when processing source code; so fail
226 SourceMode -> failWithRn (mkUnboundName rdr_name)
227 (unknownNameErr rdr_name)
229 -- Not found when processing an imported declaration,
230 -- so we create a new name for the purpose
234 Qual mod_name occ -> newGlobalName mod_name occ
236 -- An Unqual is allowed; interface files contain
237 -- unqualified names for locally-defined things, such as
238 -- constructors of a data type.
239 Unqual occ -> getModuleRn `thenRn ` \ mod_name ->
240 newGlobalName mod_name occ
243 lookupBndrRn rdr_name
244 = getNameEnv `thenRn` \ name_env ->
245 lookupRn name_env rdr_name
247 -- Just like lookupRn except that we record the occurrence too
248 -- Perhaps surprisingly, even wired-in names are recorded.
249 -- Why? So that we know which wired-in names are referred to when
250 -- deciding which instance declarations to import.
251 lookupOccRn :: RdrName -> RnMS s Name
253 = getNameEnv `thenRn` \ name_env ->
254 lookupRn name_env rdr_name `thenRn` \ name ->
255 addOccurrenceName Compulsory name
257 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
258 -- environment. It's used for record field names only.
259 lookupGlobalOccRn :: RdrName -> RnMS s Name
260 lookupGlobalOccRn rdr_name
261 = getGlobalNameEnv `thenRn` \ name_env ->
262 lookupRn name_env rdr_name `thenRn` \ name ->
263 addOccurrenceName Compulsory name
265 -- lookupOptionalOccRn is similar, but it's used in places where
266 -- we don't *have* to find a definition for the thing.
267 lookupOptionalOccRn :: RdrName -> RnMS s Name
268 lookupOptionalOccRn rdr_name
269 = getNameEnv `thenRn` \ name_env ->
270 lookupRn name_env rdr_name `thenRn` \ name ->
271 addOccurrenceName Optional name
275 -- lookupImplicitOccRn takes an RdrName representing an *original* name, and
276 -- adds it to the occurrence pool so that it'll be loaded later. This is
277 -- used when language constructs (such as monad comprehensions, overloaded literals,
278 -- or deriving clauses) require some stuff to be loaded that isn't explicitly
279 -- mentioned in the code.
281 -- This doesn't apply in interface mode, where everything is explicit, but
282 -- we don't check for this case: it does no harm to record an "extra" occurrence
283 -- and lookupImplicitOccRn isn't used much in interface mode (it's only the
284 -- Nothing clause of rnDerivs that calls it at all I think).
286 -- For List and Tuple types it's important to get the correct
287 -- isLocallyDefined flag, which is used in turn when deciding
288 -- whether there are any instance decls in this module are "special".
289 -- The name cache should have the correct provenance, though.
291 lookupImplicitOccRn :: RdrName -> RnMS s Name
292 lookupImplicitOccRn (Qual mod occ)
293 = newGlobalName mod occ `thenRn` \ name ->
294 addOccurrenceName Compulsory name
296 addImplicitOccRn :: Name -> RnM s d Name
297 addImplicitOccRn name = addOccurrenceName Compulsory name
299 addImplicitOccsRn :: [Name] -> RnM s d ()
300 addImplicitOccsRn names = addOccurrenceNames Compulsory names
302 listType_RDR = qual (modAndOcc listType_name)
303 tupleType_RDR n = qual (modAndOcc (tupleType_name n))
305 charType_name = getName charTyCon
306 listType_name = getName listTyCon
307 tupleType_name n = getName (tupleTyCon n)
311 lookupFixity :: RdrName -> RnMS s Fixity
312 lookupFixity rdr_name
313 = getFixityEnv `thenRn` \ fixity_env ->
314 returnRn (lookupFixityEnv fixity_env rdr_name)
319 %************************************************************************
321 \subsection{Envt utility functions}
323 %************************************************************************
325 =============== RnEnv ================
327 plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2)
328 = plusNameEnvRn n1 n2 `thenRn` \ n ->
329 plusFixityEnvRn f1 f2 `thenRn` \ f ->
333 =============== NameEnv ================
335 plusNameEnvRn :: NameEnv -> NameEnv -> RnM s d NameEnv
337 = mapRn (addErrRn.nameClashErr) (conflictsFM (/=) n1 n2) `thenRn_`
338 returnRn (n1 `plusFM` n2)
340 addOneToNameEnvRn :: NameEnv -> RdrName -> Name -> RnM s d NameEnv
341 addOneToNameEnvRn env rdr_name name
342 = mapRn (addErrRn.nameClashErr) (conflictFM (/=) env rdr_name name) `thenRn_`
343 returnRn (addToFM env rdr_name name)
345 lookupNameEnv :: NameEnv -> RdrName -> Maybe Name
346 lookupNameEnv = lookupFM
349 =============== FixityEnv ================
351 plusFixityEnvRn f1 f2
352 = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2) `thenRn_`
353 returnRn (f1 `plusFM` f2)
355 addOneToFixityEnvRn env rdr_name fixity
356 = mapRn (addErrRn.fixityClashErr) (conflictFM bad_fix env rdr_name fixity) `thenRn_`
357 returnRn (addToFM env rdr_name fixity)
359 lookupFixityEnv env rdr_name
360 = case lookupFM env rdr_name of
361 Just (fixity,_) -> fixity
362 Nothing -> Fixity 9 InfixL -- Default case
364 bad_fix :: (Fixity, Provenance) -> (Fixity, Provenance) -> Bool
365 bad_fix (f1,_) (f2,_) = f1 /= f2
367 pprFixityProvenance :: PprStyle -> (Fixity,Provenance) -> Pretty
368 pprFixityProvenance sty (fixity, prov) = pprProvenance sty prov
373 =============== Avails ================
375 emptyModuleAvails :: ModuleAvails
376 plusModuleAvails :: ModuleAvails -> ModuleAvails -> ModuleAvails
377 lookupModuleAvails :: ModuleAvails -> Module -> Maybe [AvailInfo]
379 emptyModuleAvails = emptyFM
380 plusModuleAvails = plusFM_C (++)
381 lookupModuleAvails = lookupFM
385 =============== AvailInfo ================
387 plusAvail (Avail n1) (Avail n2) = Avail n1
388 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n1 (nub (ns1 ++ ns2))
389 plusAvail a NotAvailable = a
390 plusAvail NotAvailable a = a
392 addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
393 addAvailToNameSet names avail = addListToNameSet names (availNames avail)
395 availsToNameSet :: [AvailInfo] -> NameSet
396 availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
398 availName :: AvailInfo -> Name
399 availName (Avail n) = n
400 availName (AvailTC n _) = n
402 availNames :: AvailInfo -> [Name]
403 availNames NotAvailable = []
404 availNames (Avail n) = [n]
405 availNames (AvailTC n ns) = ns
407 -- availEntityNames is used to extract the names that can appear on their own in
408 -- an export or import list. For class decls, class methods can appear on their
409 -- own, thus import A( op )
410 -- but constructors cannot; thus
412 -- means import type T from B, not constructor T.
414 availEntityNames :: AvailInfo -> [Name]
415 availEntityNames NotAvailable = []
416 availEntityNames (Avail n) = [n]
417 availEntityNames (AvailTC n ns) = n : filter (isVarOcc . nameOccName) ns
419 filterAvail :: RdrNameIE -- Wanted
420 -> AvailInfo -- Available
421 -> AvailInfo -- Resulting available;
422 -- NotAvailable if wanted stuff isn't there
424 filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns)
425 | sub_names_ok = AvailTC n (filter is_wanted ns)
426 | otherwise = pprTrace "filterAvail" (ppCat [ppr PprDebug ie, pprAvail PprDebug avail]) $
429 is_wanted name = nameOccName name `elem` wanted_occs
430 sub_names_ok = all (`elem` avail_occs) wanted_occs
431 avail_occs = map nameOccName ns
432 wanted_occs = map rdrNameOcc (want:wants)
434 filterAvail (IEThingAbs _) (AvailTC n ns)
435 | n `elem` ns = AvailTC n [n]
437 filterAvail (IEThingAbs _) avail@(Avail n) = avail -- Type synonyms
439 filterAvail (IEVar _) avail@(Avail n) = avail
440 filterAvail (IEVar v) avail@(AvailTC n ns) = AvailTC n (filter wanted ns)
442 wanted n = nameOccName n == occ
444 -- The second equation happens if we import a class op, thus
446 -- where op is a class operation
448 filterAvail (IEThingAll _) avail@(AvailTC _ _) = avail
450 filterAvail ie avail = NotAvailable
453 hideAvail :: RdrNameIE -- Hide this
454 -> AvailInfo -- Available
455 -> AvailInfo -- Resulting available;
456 -- Don't complain about hiding non-existent things; that's done elsewhere
458 hideAvail ie NotAvailable
461 hideAvail ie (Avail n)
462 | not (ieOcc ie == nameOccName n) = Avail n -- No match
463 | otherwise = NotAvailable -- Names match
465 hideAvail ie (AvailTC n ns)
466 | not (ieOcc ie == nameOccName n) -- No match
467 = case ie of -- But in case we are faced with ...hiding( (+) )
468 -- we filter the "ns" anyhow
469 IEVar op -> AvailTC n (filter keep ns)
471 op_occ = rdrNameOcc op
472 keep n = nameOccName n /= op_occ
474 other -> AvailTC n ns
476 | otherwise -- Names match
478 IEThingAbs _ -> AvailTC n (filter (/= n) ns)
479 IEThingAll _ -> NotAvailable
480 IEThingWith hide hides -> AvailTC n (filter keep ns)
482 keep n = nameOccName n `notElem` hide_occs
483 hide_occs = map rdrNameOcc (hide : hides)
486 -- pprAvail gets given the OccName of the "host" thing
487 pprAvail sty NotAvailable = ppPStr SLIT("NotAvailable")
488 pprAvail sty (AvailTC n ns) = ppCat [pprOccName sty (nameOccName n),
490 ppInterleave ppComma (map (pprOccName sty.nameOccName) ns),
492 pprAvail sty (Avail n) = pprOccName sty (nameOccName n)
498 %************************************************************************
500 \subsection{Finite map utilities}
502 %************************************************************************
505 Generally useful function on finite maps to check for overlap.
509 => (b->b->Bool) -- False <=> no conflict; you can pick either
510 -> FiniteMap a b -> FiniteMap a b
512 conflictsFM bad fm1 fm2
513 = filter (\(a,(b1,b2)) -> bad b1 b2)
514 (fmToList (intersectFM_C (\b1 b2 -> (b1,b2)) fm1 fm2))
518 -> FiniteMap a b -> a -> b
520 conflictFM bad fm key elt
521 = case lookupFM fm key of
522 Just elt' | bad elt elt' -> [(key,(elt,elt'))]
527 %************************************************************************
529 \subsection{Envt utility functions}
531 %************************************************************************
535 nameClashErr (rdr_name, (name1,name2)) sty
536 = ppHang (ppCat [ppPStr SLIT("Conflicting definitions for: "), ppr sty rdr_name])
537 4 (ppAboves [pprNameProvenance sty name1,
538 pprNameProvenance sty name2])
540 fixityClashErr (rdr_name, (fp1,fp2)) sty
541 = ppHang (ppCat [ppPStr SLIT("Conflicting fixities for: "), ppr sty rdr_name])
542 4 (ppAboves [pprFixityProvenance sty fp1,
543 pprFixityProvenance sty fp2])
545 shadowedNameWarn shadow sty
546 = ppBesides [ppPStr SLIT("This binding for"),
547 ppQuote (ppr sty shadow),
548 ppPStr SLIT("shadows an existing binding")]
550 unknownNameErr name sty
551 = ppSep [ppStr flavour, ppPStr SLIT("not in scope:"), ppr sty name]
553 flavour = occNameFlavour (rdrNameOcc name)
555 qualNameErr descriptor (name,loc)
557 addErrRn (\sty -> ppBesides [ppPStr SLIT("invalid use of qualified "),
558 ppStr descriptor, ppPStr SLIT(": "),
559 pprNonSymOcc sty (rdrNameOcc name) ])
561 dupNamesErr descriptor ((name,loc) : dup_things)
563 addErrRn (\sty -> ppBesides [ppPStr SLIT("duplicate bindings of `"),
564 ppr sty name, ppPStr SLIT("' in "),