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, negateNameWarn )
48 import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
49 import CmdLineOpts ( opt_WarnNameShadowing )
50 import ErrUtils ( Error(..), Warning(..) )
51 import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM )
52 import Maybes ( assocMaybe )
53 import Name ( Module(..), RdrName(..), isQual,
54 Name, mkLocalName, mkImplicitName,
57 import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
58 import Pretty ( Pretty(..), PrettyRep )
59 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
60 import UniqFM ( UniqFM, emptyUFM )
61 import UniqSet ( UniqSet(..), mkUniqSet, minusUniqSet )
62 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
63 import Unique ( Unique )
66 infixr 9 `thenRn`, `thenRn_`
70 type RnM s r = RnMonad () s r
71 type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
73 type RnMonad x s r = RnDown x s -> SST s r
79 SrcLoc -- Source location
80 (RnMode s) -- Source or Iface
81 RnEnv -- Renaming environment
82 (MutableVar s UniqSupply) -- Unique supply
83 (MutableVar s (Bag Warning, -- Warnings and Errors
87 = RnSource (MutableVar s (Bag (RnName, RdrName)))
88 -- Renaming source; returning occurences
90 | RnIface BuiltinNames BuiltinKeys
91 (MutableVar s ImplicitEnv)
92 -- Renaming interface; creating and returning implicit names
93 -- ImplicitEnv: one map for Values and one for TyCons/Classes.
95 type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
96 emptyImplicitEnv :: ImplicitEnv
97 emptyImplicitEnv = (emptyFM, emptyFM)
99 -- With a builtin polymorphic type for _runSST the type for
100 -- initTc should use RnM s r instead of RnM _RealWorld r
102 initRn :: Bool -- True => Source; False => Iface
107 -> (r, Bag Error, Bag Warning)
109 initRn source mod env us do_rn
111 newMutVarSST emptyBag `thenSST` \ occ_var ->
112 newMutVarSST emptyImplicitEnv `thenSST` \ imp_var ->
113 newMutVarSST us `thenSST` \ us_var ->
114 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
116 mode = if source then
119 case builtinNameInfo of { (wiredin_fm, key_fm, _) ->
120 RnIface wiredin_fm key_fm imp_var }
122 rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
125 do_rn rn_down `thenSST` \ res ->
127 -- grab errors and return
128 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
129 returnSST (res, errs, warns)
132 {-# INLINE thenRn #-}
133 {-# INLINE thenRn_ #-}
134 {-# INLINE returnRn #-}
137 returnRn :: a -> RnMonad x s a
138 thenRn :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b
139 thenRn_ :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b
140 andRn :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a
141 mapRn :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b]
142 mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c])
144 returnRn v down = returnSST v
145 thenRn m k down = m down `thenSST` \ r -> k r down
146 thenRn_ m k down = m down `thenSST_` k down
148 andRn combiner m1 m2 down
149 = m1 down `thenSST` \ res1 ->
150 m2 down `thenSST` \ res2 ->
151 returnSST (combiner res1 res2)
153 mapRn f [] = returnRn []
155 = f x `thenRn` \ r ->
156 mapRn f xs `thenRn` \ rs ->
159 mapAndUnzipRn f [] = returnRn ([],[])
160 mapAndUnzipRn f (x:xs)
161 = f x `thenRn` \ (r1, r2) ->
162 mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
163 returnRn (r1:rs1, r2:rs2)
165 mapAndUnzip3Rn f [] = returnRn ([],[],[])
166 mapAndUnzip3Rn f (x:xs)
167 = f x `thenRn` \ (r1, r2, r3) ->
168 mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
169 returnRn (r1:rs1, r2:rs2, r3:rs3)
172 For errors and warnings ...
174 failButContinueRn :: a -> Error -> RnMonad x s a
175 failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var)
176 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
177 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
180 warnAndContinueRn :: a -> Warning -> RnMonad x s a
181 warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var)
182 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
183 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
186 addErrRn :: Error -> RnMonad x s ()
187 addErrRn err = failButContinueRn () err
189 addErrIfRn :: Bool -> Error -> RnMonad x s ()
190 addErrIfRn True err = addErrRn err
191 addErrIfRn False err = returnRn ()
193 addWarnRn :: Warning -> RnMonad x s ()
194 addWarnRn warn = warnAndContinueRn () warn
196 addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
197 addWarnIfRn True warn = addWarnRn warn
198 addWarnIfRn False warn = returnRn ()
203 getRnEnv :: RnMonad x s RnEnv
204 getRnEnv (RnDown _ _ _ _ env _ _)
207 setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
208 setExtraRn x m (RnDown _ mod locn mode env us errs)
209 = m (RnDown x mod locn mode env us errs)
211 getExtraRn :: RnMonad x s x
212 getExtraRn (RnDown x _ _ _ _ _ _)
215 getModuleRn :: RnMonad x s Module
216 getModuleRn (RnDown _ mod _ _ _ _ _)
219 pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a
220 pushSrcLocRn locn m (RnDown x mod _ mode env us errs)
221 = m (RnDown x mod locn mode env us errs)
223 getSrcLocRn :: RnMonad x s SrcLoc
224 getSrcLocRn (RnDown _ _ locn _ _ _ _)
227 getSourceRn :: RnMonad x s Bool
228 getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True
229 getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
231 getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
232 getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
233 = readMutVarSST occ_var
234 getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _)
235 = panic "getOccurrenceUpRn:RnIface"
237 getImplicitUpRn :: RnMonad x s ImplicitEnv
238 getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
239 = readMutVarSST imp_var
240 getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
241 = panic "getImplicitUpRn:RnIface"
245 rnGetUnique :: RnMonad x s Unique
246 rnGetUnique (RnDown _ _ _ _ _ us_var _)
249 rnGetUniques :: Int -> RnMonad x s [Unique]
250 rnGetUniques n (RnDown _ _ _ _ _ us_var _)
251 = get_uniques n us_var
255 = readMutVarSST us_var `thenSST` \ uniq_supply ->
257 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
258 uniq = getUnique uniq_s
260 writeMutVarSST us_var new_uniq_supply `thenSST_`
264 = readMutVarSST us_var `thenSST` \ uniq_supply ->
266 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
267 uniqs = getUniques n uniq_s
269 writeMutVarSST us_var new_uniq_supply `thenSST_`
272 snoc_bag_var add bag_var
273 = readMutVarSST bag_var `thenSST` \ bag ->
274 writeMutVarSST bag_var (bag `snocBag` add)
278 *********************************************************
280 \subsection{Making new names}
282 *********************************************************
284 @newLocalNames@ takes a bunch of RdrNames, which are defined together
285 in a group (eg a pattern or set of bindings), checks they are
286 unqualified and distinct, and creates new Names for them.
289 newLocalNames :: String -- Documentation string
290 -> [(RdrName, SrcLoc)]
291 -> RnMonad x s [RnName]
293 newLocalNames str names_w_loc
294 = mapRn (addWarnRn . negateNameWarn) negs `thenRn_`
295 mapRn (addErrRn . qualNameErr str) quals `thenRn_`
296 mapRn (addErrRn . dupNamesErr str) dups `thenRn_`
299 negs = filter ((== Unqual SLIT("negate")).fst) names_w_loc
300 quals = filter (isQual.fst) names_w_loc
301 (these, dups) = removeDups cmp_fst names_w_loc
302 cmp_fst (a,_) (b,_) = cmp a b
306 mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
307 mkLocalNames names_w_locs
308 = rnGetUniques (length names_w_locs) `thenRn` \ uniqs ->
309 returnRn (zipWithEqual new_local uniqs names_w_locs)
311 new_local uniq (Unqual str, srcloc)
312 = mkRnName (mkLocalName uniq str srcloc)
316 *********************************************************
318 \subsection{Looking up values}
320 *********************************************************
322 Action to look up a value depends on the RnMode.
325 Lookup value in RnEnv, recording occurrence for non-local values found.
326 If not found report error and return Unbound name.
328 Lookup value in RnEnv. If not found lookup in implicit name env.
329 If not found create new implicit name, adding it to the implicit env.
333 lookupValue :: RdrName -> RnMonad x s RnName
334 lookupConstr :: RdrName -> RnMonad x s RnName
335 lookupField :: RdrName -> RnMonad x s RnName
336 lookupClassOp :: RnName -> RdrName -> RnMonad x s RnName
339 = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
342 = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
345 = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
347 lookupClassOp cls rdr
348 = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
350 -- Note: the lookup checks are only performed when renaming source
352 lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
353 = case lookup env rdr of
354 Just name | check name -> succ name
359 succ name = if isRnLocal name || isRnWired name then
362 snoc_bag_var (name,rdr) occ_var `thenSST_`
364 fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
366 lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
367 = case lookup env rdr of
368 Just name -> returnSST name
369 Nothing -> lookup_nonexisting_val b_names b_key imp_var us_var rdr
371 lookup_nonexisting_val (b_names,_) b_key imp_var us_var rdr
373 Qual _ _ -> -- builtin things *don't* have Qual names
374 lookup_or_create_implicit_val b_key imp_var us_var rdr
376 Unqual n -> case (lookupFM b_names n) of
377 Nothing -> lookup_or_create_implicit_val b_key imp_var us_var rdr
378 Just xx -> returnSST xx
380 lookup_or_create_implicit_val b_key imp_var us_var rdr
381 = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
382 case lookupFM implicit_val_fm rdr of
383 Just implicit -> returnSST implicit
386 Qual _ _ -> get_unique us_var
387 Unqual n -> case (lookupFM b_key n) of
388 Just (u,_) -> returnSST u
389 _ -> get_unique us_var
390 ) `thenSST` \ uniq ->
392 implicit = mkRnImplicit (mkImplicitName uniq rdr)
393 new_val_fm = addToFM implicit_val_fm rdr implicit
395 writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
401 lookupTyCon :: RdrName -> RnMonad x s RnName
402 lookupClass :: RdrName -> RnMonad x s RnName
405 = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
408 = lookup_tc rdr isRnClass mkRnImplicitClass "class"
410 lookupTyConOrClass rdr
411 = lookup_tc rdr isRnTyConOrClass
412 (panic "lookupTC:mk_implicit") "class or type constructor"
414 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
415 = case lookupTcRnEnv env rdr of
416 Just name | check name -> succ name
420 succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
422 fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
424 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
425 = case lookupTcRnEnv env rdr of
426 Just name | check name -> returnSST name
428 Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var rdr
430 fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
432 lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr
434 Qual _ _ -> -- builtin things *don't* have Qual names
435 lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
437 Unqual n -> case (lookupFM b_names n) of
438 Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
439 Just xx -> returnSST xx
441 lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
442 = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
443 case lookupFM implicit_tc_fm rdr of
444 Just implicit | check implicit -> returnSST implicit
448 Qual _ _ -> get_unique us_var
449 Unqual n -> case (lookupFM b_key n) of
450 Just (u,_) -> returnSST u
451 _ -> get_unique us_var
452 ) `thenSST` \ uniq ->
454 implicit = mk_implicit (mkImplicitName uniq rdr)
455 new_tc_fm = addToFM implicit_tc_fm rdr implicit
457 writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
462 @extendSS@ extends the scope; @extendSS2@ also removes the newly bound
463 free vars from the result.
466 extendSS :: [RnName] -- Newly bound names
470 extendSS binders m down@(RnDown x mod locn mode env us errs)
471 = (mapRn (addErrRn . shadowedNameWarn locn) dups `thenRn_`
472 m) (RnDown x mod locn mode new_env us errs)
474 (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders
476 extendSS2 :: [RnName] -- Newly bound names
477 -> RnMonad x s (a, UniqSet RnName)
478 -> RnMonad x s (a, UniqSet RnName)
481 = extendSS binders m `thenRn` \ (r, fvs) ->
482 returnRn (r, fvs `minusUniqSet` (mkUniqSet binders))
485 The free var set returned by @(extendSS binders m)@ is that returned
486 by @m@, {\em minus} binders.
489 *********************************************************
491 \subsection{TyVarNamesEnv}
493 *********************************************************
496 type TyVarNamesEnv = [(RdrName, RnName)]
498 nullTyVarNamesEnv :: TyVarNamesEnv
499 nullTyVarNamesEnv = []
501 catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
502 catTyVarNamesEnvs e1 e2 = e1 ++ e2
504 domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName]
505 domTyVarNamesEnv env = map fst env
508 @mkTyVarNamesEnv@ checks for duplicates, and complains if so.
513 -> [RdrName] -- The type variables
514 -> RnMonad x s (TyVarNamesEnv,[RnName]) -- Environment and renamed tyvars
516 mkTyVarNamesEnv src_loc tyvars
517 = newLocalNames "type variable"
518 (tyvars `zip` repeat src_loc) `thenRn` \ rn_tyvars ->
520 -- rn_tyvars may not be in the same order as tyvars, so we need some
521 -- jiggery pokery to build the right tyvar env, and return the
522 -- renamed tyvars in the original order.
523 let tv_occ_name_pairs = map tv_occ_name_pair rn_tyvars
524 tv_env = map (lookup_occ_name tv_occ_name_pairs) tyvars
525 rn_tyvars_in_orig_order = map snd tv_env
527 returnRn (tv_env, rn_tyvars_in_orig_order)
529 tv_occ_name_pair :: RnName -> (RdrName, RnName)
530 tv_occ_name_pair rn_name = (getOccName rn_name, rn_name)
532 lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName)
533 lookup_occ_name pairs tyvar_occ
534 = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ)
538 lookupTyVarName :: TyVarNamesEnv -> RdrName -> RnMonad x s RnName
539 lookupTyVarName env occ
540 = case (assocMaybe env occ) of
541 Just name -> returnRn name
542 Nothing -> getSrcLocRn `thenRn` \ loc ->
543 failButContinueRn (mkRnUnbound occ)
544 (unknownNameErr "type variable" occ loc)
549 fixIO :: (a -> IO a) -> IO a
552 (Right loop, _) = result