2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[RnMonad]{The monad used by the renamer}
7 #include "HsVersions.h"
10 RnMonad(..), RnM(..), RnM_Fixes(..), RnDown, SST_R,
11 initRn, thenRn, thenRn_, andRn, returnRn,
12 mapRn, mapAndUnzipRn, mapAndUnzip3Rn,
14 addErrRn, addErrIfRn, addWarnRn, addWarnIfRn,
15 failButContinueRn, warnAndContinueRn,
16 setExtraRn, getExtraRn, getRnEnv,
17 getModuleRn, pushSrcLocRn, getSrcLocRn,
18 getSourceRn, getOccurrenceUpRn,
19 getImplicitUpRn, ImplicitEnv(..), emptyImplicitEnv,
20 rnGetUnique, rnGetUniques,
23 lookupValue, lookupConstr, lookupField, lookupClassOp,
24 lookupTyCon, lookupClass, lookupTyConOrClass,
27 TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
28 lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
37 import HsSyn ( FixityDecl )
38 import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit,
39 mkRnImplicitTyCon, mkRnImplicitClass,
40 isRnLocal, isRnWired, isRnTyCon, isRnClass,
41 isRnTyConOrClass, isRnConstr, isRnField,
42 isRnClassOp, RenamedFixityDecl(..) )
43 import RnUtils ( RnEnv(..), extendLocalRnEnv,
44 lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
45 unknownNameErr, badClassOpErr, qualNameErr,
46 dupNamesErr, shadowedNameWarn
49 import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
50 import CmdLineOpts ( opt_WarnNameShadowing )
51 import ErrUtils ( Error(..), Warning(..) )
52 import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM )
53 import Maybes ( assocMaybe )
54 import Name ( Module(..), RdrName(..), isQual,
55 Name, mkLocalName, mkImplicitName,
58 import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
59 import Pretty ( Pretty(..), PrettyRep )
60 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
61 import UniqFM ( UniqFM, emptyUFM )
62 import UniqSet ( UniqSet(..), mkUniqSet, minusUniqSet )
63 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
64 import Unique ( Unique )
67 infixr 9 `thenRn`, `thenRn_`
71 type RnM s r = RnMonad () s r
72 type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
74 type RnMonad x s r = RnDown x s -> SST s r
80 SrcLoc -- Source location
81 (RnMode s) -- Source or Iface
82 RnEnv -- Renaming environment
83 (MutableVar s UniqSupply) -- Unique supply
84 (MutableVar s (Bag Warning, -- Warnings and Errors
88 = RnSource (MutableVar s (Bag (RnName, RdrName)))
89 -- Renaming source; returning occurences
91 | RnIface BuiltinNames BuiltinKeys
92 (MutableVar s ImplicitEnv)
93 -- Renaming interface; creating and returning implicit names
94 -- ImplicitEnv: one map for Values and one for TyCons/Classes.
96 type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
97 emptyImplicitEnv :: ImplicitEnv
98 emptyImplicitEnv = (emptyFM, emptyFM)
100 -- With a builtin polymorphic type for _runSST the type for
101 -- initTc should use RnM s r instead of RnM _RealWorld r
103 initRn :: Bool -- True => Source; False => Iface
108 -> (r, Bag Error, Bag Warning)
110 initRn source mod env us do_rn
112 newMutVarSST emptyBag `thenSST` \ occ_var ->
113 newMutVarSST emptyImplicitEnv `thenSST` \ imp_var ->
114 newMutVarSST us `thenSST` \ us_var ->
115 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
117 mode = if source then
120 case builtinNameInfo of { (wiredin_fm, key_fm, _) ->
121 RnIface wiredin_fm key_fm imp_var }
123 rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
126 do_rn rn_down `thenSST` \ res ->
128 -- grab errors and return
129 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
130 returnSST (res, errs, warns)
133 {-# INLINE thenRn #-}
134 {-# INLINE thenRn_ #-}
135 {-# INLINE returnRn #-}
138 returnRn :: a -> RnMonad x s a
139 thenRn :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b
140 thenRn_ :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b
141 andRn :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a
142 mapRn :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b]
143 mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c])
145 returnRn v down = returnSST v
146 thenRn m k down = m down `thenSST` \ r -> k r down
147 thenRn_ m k down = m down `thenSST_` k down
149 andRn combiner m1 m2 down
150 = m1 down `thenSST` \ res1 ->
151 m2 down `thenSST` \ res2 ->
152 returnSST (combiner res1 res2)
154 mapRn f [] = returnRn []
156 = f x `thenRn` \ r ->
157 mapRn f xs `thenRn` \ rs ->
160 mapAndUnzipRn f [] = returnRn ([],[])
161 mapAndUnzipRn f (x:xs)
162 = f x `thenRn` \ (r1, r2) ->
163 mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
164 returnRn (r1:rs1, r2:rs2)
166 mapAndUnzip3Rn f [] = returnRn ([],[],[])
167 mapAndUnzip3Rn f (x:xs)
168 = f x `thenRn` \ (r1, r2, r3) ->
169 mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
170 returnRn (r1:rs1, r2:rs2, r3:rs3)
173 For errors and warnings ...
175 failButContinueRn :: a -> Error -> RnMonad x s a
176 failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var)
177 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
178 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
181 warnAndContinueRn :: a -> Warning -> RnMonad x s a
182 warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var)
183 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
184 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
187 addErrRn :: Error -> RnMonad x s ()
188 addErrRn err = failButContinueRn () err
190 addErrIfRn :: Bool -> Error -> RnMonad x s ()
191 addErrIfRn True err = addErrRn err
192 addErrIfRn False err = returnRn ()
194 addWarnRn :: Warning -> RnMonad x s ()
195 addWarnRn warn = warnAndContinueRn () warn
197 addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
198 addWarnIfRn True warn = addWarnRn warn
199 addWarnIfRn False warn = returnRn ()
204 getRnEnv :: RnMonad x s RnEnv
205 getRnEnv (RnDown _ _ _ _ env _ _)
208 setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
209 setExtraRn x m (RnDown _ mod locn mode env us errs)
210 = m (RnDown x mod locn mode env us errs)
212 getExtraRn :: RnMonad x s x
213 getExtraRn (RnDown x _ _ _ _ _ _)
216 getModuleRn :: RnMonad x s Module
217 getModuleRn (RnDown _ mod _ _ _ _ _)
220 pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a
221 pushSrcLocRn locn m (RnDown x mod _ mode env us errs)
222 = m (RnDown x mod locn mode env us errs)
224 getSrcLocRn :: RnMonad x s SrcLoc
225 getSrcLocRn (RnDown _ _ locn _ _ _ _)
228 getSourceRn :: RnMonad x s Bool
229 getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True
230 getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
232 getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
233 getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
234 = readMutVarSST occ_var
235 getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _)
236 = panic "getOccurrenceUpRn:RnIface"
238 getImplicitUpRn :: RnMonad x s ImplicitEnv
239 getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
240 = readMutVarSST imp_var
241 getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
242 = panic "getImplicitUpRn:RnIface"
246 rnGetUnique :: RnMonad x s Unique
247 rnGetUnique (RnDown _ _ _ _ _ us_var _)
250 rnGetUniques :: Int -> RnMonad x s [Unique]
251 rnGetUniques n (RnDown _ _ _ _ _ us_var _)
252 = get_uniques n us_var
256 = readMutVarSST us_var `thenSST` \ uniq_supply ->
258 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
259 uniq = getUnique uniq_s
261 writeMutVarSST us_var new_uniq_supply `thenSST_`
265 = readMutVarSST us_var `thenSST` \ uniq_supply ->
267 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
268 uniqs = getUniques n uniq_s
270 writeMutVarSST us_var new_uniq_supply `thenSST_`
273 snoc_bag_var add bag_var
274 = readMutVarSST bag_var `thenSST` \ bag ->
275 writeMutVarSST bag_var (bag `snocBag` add)
279 *********************************************************
281 \subsection{Making new names}
283 *********************************************************
285 @newLocalNames@ takes a bunch of RdrNames, which are defined together
286 in a group (eg a pattern or set of bindings), checks they are
287 unqualified and distinct, and creates new Names for them.
290 newLocalNames :: String -- Documentation string
291 -> [(RdrName, SrcLoc)]
292 -> RnMonad x s [RnName]
294 newLocalNames str names_w_loc
295 = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
296 mapRn (addErrRn . dupNamesErr str) dups `thenRn_`
299 quals = filter (isQual.fst) names_w_loc
300 (these, dups) = removeDups cmp_fst names_w_loc
301 cmp_fst (a,_) (b,_) = cmp a b
305 mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
306 mkLocalNames names_w_locs
307 = rnGetUniques (length names_w_locs) `thenRn` \ uniqs ->
308 returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs)
310 new_local uniq (Unqual str, srcloc)
311 = mkRnName (mkLocalName uniq str srcloc)
315 *********************************************************
317 \subsection{Looking up values}
319 *********************************************************
321 Action to look up a value depends on the RnMode.
324 Lookup value in RnEnv, recording occurrence for non-local values found.
325 If not found report error and return Unbound name.
327 Lookup value in RnEnv. If not found lookup in implicit name env.
328 If not found create new implicit name, adding it to the implicit env.
332 lookupValue :: RdrName -> RnMonad x s RnName
333 lookupConstr :: RdrName -> RnMonad x s RnName
334 lookupField :: RdrName -> RnMonad x s RnName
335 lookupClassOp :: RnName -> RdrName -> RnMonad x s RnName
338 = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
341 = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
344 = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
346 lookupClassOp cls rdr
347 = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
349 -- Note: the lookup checks are only performed when renaming source
351 lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
352 = case lookup env rdr of
353 Just name | check name -> succ name
358 succ name = if isRnLocal name || isRnWired name then
361 snoc_bag_var (name,rdr) occ_var `thenSST_`
363 fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
365 lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
366 = case lookup env rdr of
367 Just name -> returnSST name
368 Nothing -> lookup_nonexisting_val b_names b_key imp_var us_var rdr
370 lookup_nonexisting_val (b_names,_) b_key imp_var us_var rdr
372 Qual _ _ -> -- builtin things *don't* have Qual names
373 lookup_or_create_implicit_val b_key imp_var us_var rdr
375 Unqual n -> case (lookupFM b_names n) of
376 Nothing -> lookup_or_create_implicit_val b_key imp_var us_var rdr
377 Just xx -> returnSST xx
379 lookup_or_create_implicit_val b_key imp_var us_var rdr
380 = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
381 case lookupFM implicit_val_fm rdr of
382 Just implicit -> returnSST implicit
385 Qual _ _ -> get_unique us_var
386 Unqual n -> case (lookupFM b_key n) of
387 Just (u,_) -> returnSST u
388 _ -> get_unique us_var
389 ) `thenSST` \ uniq ->
391 implicit = mkRnImplicit (mkImplicitName uniq rdr)
392 new_val_fm = addToFM implicit_val_fm rdr implicit
394 writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
400 lookupTyCon :: RdrName -> RnMonad x s RnName
401 lookupClass :: RdrName -> RnMonad x s RnName
404 = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
407 = lookup_tc rdr isRnClass mkRnImplicitClass "class"
409 lookupTyConOrClass rdr
410 = lookup_tc rdr isRnTyConOrClass
411 (panic "lookupTC:mk_implicit") "class or type constructor"
413 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
414 = case lookupTcRnEnv env rdr of
415 Just name | check name -> succ name
419 succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
421 fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
423 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
424 = case lookupTcRnEnv env rdr of
425 Just name | check name -> returnSST name
427 Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var rdr
429 fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
431 lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr
433 Qual _ _ -> -- builtin things *don't* have Qual names
434 lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
436 Unqual n -> case (lookupFM b_names n) of
437 Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
438 Just xx -> returnSST xx
440 lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
441 = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
442 case lookupFM implicit_tc_fm rdr of
443 Just implicit | check implicit -> returnSST implicit
447 Qual _ _ -> get_unique us_var
448 Unqual n -> case (lookupFM b_key n) of
449 Just (u,_) -> returnSST u
450 _ -> get_unique us_var
451 ) `thenSST` \ uniq ->
453 implicit = mk_implicit (mkImplicitName uniq rdr)
454 new_tc_fm = addToFM implicit_tc_fm rdr implicit
456 writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
461 @extendSS@ extends the scope; @extendSS2@ also removes the newly bound
462 free vars from the result.
465 extendSS :: [RnName] -- Newly bound names
469 extendSS binders m down@(RnDown x mod locn mode env us errs)
470 = (mapRn (addErrRn . shadowedNameWarn locn) dups `thenRn_`
471 m) (RnDown x mod locn mode new_env us errs)
473 (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders
475 extendSS2 :: [RnName] -- Newly bound names
476 -> RnMonad x s (a, UniqSet RnName)
477 -> RnMonad x s (a, UniqSet RnName)
480 = extendSS binders m `thenRn` \ (r, fvs) ->
481 returnRn (r, fvs `minusUniqSet` (mkUniqSet binders))
484 The free var set returned by @(extendSS binders m)@ is that returned
485 by @m@, {\em minus} binders.
488 *********************************************************
490 \subsection{TyVarNamesEnv}
492 *********************************************************
495 type TyVarNamesEnv = [(RdrName, RnName)]
497 nullTyVarNamesEnv :: TyVarNamesEnv
498 nullTyVarNamesEnv = []
500 catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
501 catTyVarNamesEnvs e1 e2 = e1 ++ e2
503 domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName]
504 domTyVarNamesEnv env = map fst env
507 @mkTyVarNamesEnv@ checks for duplicates, and complains if so.
512 -> [RdrName] -- The type variables
513 -> RnMonad x s (TyVarNamesEnv,[RnName]) -- Environment and renamed tyvars
515 mkTyVarNamesEnv src_loc tyvars
516 = newLocalNames "type variable"
517 (tyvars `zip` repeat src_loc) `thenRn` \ rn_tyvars ->
519 -- rn_tyvars may not be in the same order as tyvars, so we need some
520 -- jiggery pokery to build the right tyvar env, and return the
521 -- renamed tyvars in the original order.
522 let tv_occ_name_pairs = map tv_occ_name_pair rn_tyvars
523 tv_env = map (lookup_occ_name tv_occ_name_pairs) tyvars
524 rn_tyvars_in_orig_order = map snd tv_env
526 returnRn (tv_env, rn_tyvars_in_orig_order)
528 tv_occ_name_pair :: RnName -> (RdrName, RnName)
529 tv_occ_name_pair rn_name = (getOccName rn_name, rn_name)
531 lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName)
532 lookup_occ_name pairs tyvar_occ
533 = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ)
537 lookupTyVarName :: TyVarNamesEnv -> RdrName -> RnMonad x s RnName
538 lookupTyVarName env occ
539 = case (assocMaybe env occ) of
540 Just name -> returnRn name
541 Nothing -> getSrcLocRn `thenRn` \ loc ->
542 failButContinueRn (mkRnUnbound occ)
543 (unknownNameErr "type variable" occ loc)
548 fixIO :: (a -> IO a) -> IO a
551 (Right loop, _) = result