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 PrelMods ( pRELUDE )
60 import Pretty ( Pretty(..), PrettyRep )
61 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
62 import UniqFM ( UniqFM, emptyUFM )
63 import UniqSet ( UniqSet(..), mkUniqSet, minusUniqSet )
64 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
65 import Unique ( Unique )
68 infixr 9 `thenRn`, `thenRn_`
72 type RnM s r = RnMonad () s r
73 type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
75 type RnMonad x s r = RnDown x s -> SST s r
81 SrcLoc -- Source location
82 (RnMode s) -- Source or Iface
83 RnEnv -- Renaming environment
84 (MutableVar s UniqSupply) -- Unique supply
85 (MutableVar s (Bag Warning, -- Warnings and Errors
89 = RnSource (MutableVar s (Bag (RnName, RdrName)))
90 -- Renaming source; returning occurences
92 | RnIface BuiltinNames BuiltinKeys
93 (MutableVar s ImplicitEnv)
94 -- Renaming interface; creating and returning implicit names
95 -- ImplicitEnv: one map for Values and one for TyCons/Classes.
97 type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
98 emptyImplicitEnv :: ImplicitEnv
99 emptyImplicitEnv = (emptyFM, emptyFM)
101 -- With a builtin polymorphic type for _runSST the type for
102 -- initTc should use RnM s r instead of RnM _RealWorld r
104 initRn :: Bool -- True => Source; False => Iface
109 -> (r, Bag Error, Bag Warning)
111 initRn source mod env us do_rn
113 newMutVarSST emptyBag `thenSST` \ occ_var ->
114 newMutVarSST emptyImplicitEnv `thenSST` \ imp_var ->
115 newMutVarSST us `thenSST` \ us_var ->
116 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
118 mode = if source then
121 case builtinNameInfo of { (wiredin_fm, key_fm, _) ->
122 RnIface wiredin_fm key_fm imp_var }
124 rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
127 do_rn rn_down `thenSST` \ res ->
129 -- grab errors and return
130 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
131 returnSST (res, errs, warns)
134 {-# INLINE thenRn #-}
135 {-# INLINE thenRn_ #-}
136 {-# INLINE returnRn #-}
139 returnRn :: a -> RnMonad x s a
140 thenRn :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b
141 thenRn_ :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b
142 andRn :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a
143 mapRn :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b]
144 mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c])
146 returnRn v down = returnSST v
147 thenRn m k down = m down `thenSST` \ r -> k r down
148 thenRn_ m k down = m down `thenSST_` k down
150 andRn combiner m1 m2 down
151 = m1 down `thenSST` \ res1 ->
152 m2 down `thenSST` \ res2 ->
153 returnSST (combiner res1 res2)
155 mapRn f [] = returnRn []
157 = f x `thenRn` \ r ->
158 mapRn f xs `thenRn` \ rs ->
161 mapAndUnzipRn f [] = returnRn ([],[])
162 mapAndUnzipRn f (x:xs)
163 = f x `thenRn` \ (r1, r2) ->
164 mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
165 returnRn (r1:rs1, r2:rs2)
167 mapAndUnzip3Rn f [] = returnRn ([],[],[])
168 mapAndUnzip3Rn f (x:xs)
169 = f x `thenRn` \ (r1, r2, r3) ->
170 mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
171 returnRn (r1:rs1, r2:rs2, r3:rs3)
174 For errors and warnings ...
176 failButContinueRn :: a -> Error -> RnMonad x s a
177 failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var)
178 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
179 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
182 warnAndContinueRn :: a -> Warning -> RnMonad x s a
183 warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var)
184 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
185 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
188 addErrRn :: Error -> RnMonad x s ()
189 addErrRn err = failButContinueRn () err
191 addErrIfRn :: Bool -> Error -> RnMonad x s ()
192 addErrIfRn True err = addErrRn err
193 addErrIfRn False err = returnRn ()
195 addWarnRn :: Warning -> RnMonad x s ()
196 addWarnRn warn = warnAndContinueRn () warn
198 addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
199 addWarnIfRn True warn = addWarnRn warn
200 addWarnIfRn False warn = returnRn ()
205 getRnEnv :: RnMonad x s RnEnv
206 getRnEnv (RnDown _ _ _ _ env _ _)
209 setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
210 setExtraRn x m (RnDown _ mod locn mode env us errs)
211 = m (RnDown x mod locn mode env us errs)
213 getExtraRn :: RnMonad x s x
214 getExtraRn (RnDown x _ _ _ _ _ _)
217 getModuleRn :: RnMonad x s Module
218 getModuleRn (RnDown _ mod _ _ _ _ _)
221 pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a
222 pushSrcLocRn locn m (RnDown x mod _ mode env us errs)
223 = m (RnDown x mod locn mode env us errs)
225 getSrcLocRn :: RnMonad x s SrcLoc
226 getSrcLocRn (RnDown _ _ locn _ _ _ _)
229 getSourceRn :: RnMonad x s Bool
230 getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True
231 getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
233 getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
234 getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
235 = readMutVarSST occ_var
236 getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _)
237 = panic "getOccurrenceUpRn:RnIface"
239 getImplicitUpRn :: RnMonad x s ImplicitEnv
240 getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
241 = readMutVarSST imp_var
242 getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
243 = panic "getImplicitUpRn:RnIface"
247 rnGetUnique :: RnMonad x s Unique
248 rnGetUnique (RnDown _ _ _ _ _ us_var _)
251 rnGetUniques :: Int -> RnMonad x s [Unique]
252 rnGetUniques n (RnDown _ _ _ _ _ us_var _)
253 = get_uniques n us_var
257 = readMutVarSST us_var `thenSST` \ uniq_supply ->
259 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
260 uniq = getUnique uniq_s
262 writeMutVarSST us_var new_uniq_supply `thenSST_`
266 = readMutVarSST us_var `thenSST` \ uniq_supply ->
268 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
269 uniqs = getUniques n uniq_s
271 writeMutVarSST us_var new_uniq_supply `thenSST_`
274 snoc_bag_var add bag_var
275 = readMutVarSST bag_var `thenSST` \ bag ->
276 writeMutVarSST bag_var (bag `snocBag` add)
280 *********************************************************
282 \subsection{Making new names}
284 *********************************************************
286 @newLocalNames@ takes a bunch of RdrNames, which are defined together
287 in a group (eg a pattern or set of bindings), checks they are
288 unqualified and distinct, and creates new Names for them.
291 newLocalNames :: String -- Documentation string
292 -> [(RdrName, SrcLoc)]
293 -> RnMonad x s [RnName]
295 newLocalNames str names_w_loc
296 = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
297 mapRn (addErrRn . dupNamesErr str) dups `thenRn_`
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 "mkLocalNames" new_local uniqs names_w_locs)
311 new_local uniq (Unqual str, srcloc)
312 = mkRnName (mkLocalName uniq str False{-emph names-} 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
372 = let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
373 in case (lookupFM b_names str_mod) of
374 Nothing -> lookup_or_create_implicit_val b_key imp_var us_var rdr
375 Just xx -> returnSST xx
377 lookup_or_create_implicit_val b_key imp_var us_var rdr
378 = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
379 case lookupFM implicit_val_fm rdr of
380 Just implicit -> returnSST implicit
382 (let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
383 in case (lookupFM b_key str_mod) of
384 Just (u,_) -> returnSST u
385 _ -> get_unique us_var
386 ) `thenSST` \ uniq ->
388 implicit = mkRnImplicit (mkImplicitName uniq rdr)
389 new_val_fm = addToFM implicit_val_fm rdr implicit
391 writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
397 lookupTyCon :: RdrName -> RnMonad x s RnName
398 lookupClass :: RdrName -> RnMonad x s RnName
401 = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
404 = lookup_tc rdr isRnClass mkRnImplicitClass "class"
406 lookupTyConOrClass rdr
407 = lookup_tc rdr isRnTyConOrClass
408 (panic "lookupTC:mk_implicit") "class or type constructor"
410 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
411 = case lookupTcRnEnv env rdr of
412 Just name | check name -> succ name
416 succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
418 fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
420 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
421 = case lookupTcRnEnv env rdr of
422 Just name | check name -> returnSST name
424 Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var rdr
426 fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
428 lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr
429 = let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
430 in case (lookupFM b_names str_mod) of
431 Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
432 Just xx -> returnSST xx
434 lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
435 = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
436 case lookupFM implicit_tc_fm rdr of
437 Just implicit | check implicit -> returnSST implicit
440 (let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) }
441 in case (lookupFM b_key str_mod) of
442 Just (u,_) -> returnSST u
443 _ -> get_unique us_var
444 ) `thenSST` \ uniq ->
446 implicit = mk_implicit (mkImplicitName uniq rdr)
447 new_tc_fm = addToFM implicit_tc_fm rdr implicit
449 writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
454 @extendSS@ extends the scope; @extendSS2@ also removes the newly bound
455 free vars from the result.
458 extendSS :: [RnName] -- Newly bound names
462 extendSS binders m down@(RnDown x mod locn mode env us errs)
463 = (mapRn (addErrRn . shadowedNameWarn locn) dups `thenRn_`
464 m) (RnDown x mod locn mode new_env us errs)
466 (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders
468 extendSS2 :: [RnName] -- Newly bound names
469 -> RnMonad x s (a, UniqSet RnName)
470 -> RnMonad x s (a, UniqSet RnName)
473 = extendSS binders m `thenRn` \ (r, fvs) ->
474 returnRn (r, fvs `minusUniqSet` (mkUniqSet binders))
477 The free var set returned by @(extendSS binders m)@ is that returned
478 by @m@, {\em minus} binders.
481 *********************************************************
483 \subsection{TyVarNamesEnv}
485 *********************************************************
488 type TyVarNamesEnv = [(RdrName, RnName)]
490 nullTyVarNamesEnv :: TyVarNamesEnv
491 nullTyVarNamesEnv = []
493 catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
494 catTyVarNamesEnvs e1 e2 = e1 ++ e2
496 domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName]
497 domTyVarNamesEnv env = map fst env
500 @mkTyVarNamesEnv@ checks for duplicates, and complains if so.
505 -> [RdrName] -- The type variables
506 -> RnMonad x s (TyVarNamesEnv,[RnName]) -- Environment and renamed tyvars
508 mkTyVarNamesEnv src_loc tyvars
509 = newLocalNames "type variable"
510 (tyvars `zip` repeat src_loc) `thenRn` \ rn_tyvars ->
512 -- rn_tyvars may not be in the same order as tyvars, so we need some
513 -- jiggery pokery to build the right tyvar env, and return the
514 -- renamed tyvars in the original order.
515 let tv_occ_name_pairs = map tv_occ_name_pair rn_tyvars
516 tv_env = map (lookup_occ_name tv_occ_name_pairs) tyvars
517 rn_tyvars_in_orig_order = map snd tv_env
519 returnRn (tv_env, rn_tyvars_in_orig_order)
521 tv_occ_name_pair :: RnName -> (RdrName, RnName)
522 tv_occ_name_pair rn_name = (getOccName rn_name, rn_name)
524 lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName)
525 lookup_occ_name pairs tyvar_occ
526 = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ)
530 lookupTyVarName :: TyVarNamesEnv -> RdrName -> RnMonad x s RnName
531 lookupTyVarName env occ
532 = case (assocMaybe env occ) of
533 Just name -> returnRn name
534 Nothing -> getSrcLocRn `thenRn` \ loc ->
535 failButContinueRn (mkRnUnbound occ)
536 (unknownNameErr "type variable" occ loc)
541 fixIO :: (a -> IO a) -> IO a
544 (Right loop, _) = result