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 qualNameErr, dupNamesErr
48 import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
49 import CmdLineOpts ( opt_WarnNameShadowing )
50 import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
51 Error(..), Warning(..)
53 import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, fmToList{-ToDo:rm-} )
54 import Maybes ( assocMaybe )
55 import Name ( Module(..), RdrName(..), isQual,
56 OrigName(..), Name, mkLocalName, mkImplicitName,
59 import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
60 import PrelMods ( pRELUDE )
61 import PprStyle{-ToDo:rm-}
62 import Outputable{-ToDo:rm-}
63 import Pretty--ToDo:rm ( Pretty(..), PrettyRep )
64 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
65 import UniqFM ( UniqFM, emptyUFM )
66 import UniqSet ( UniqSet(..), mkUniqSet, minusUniqSet )
67 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
68 import Unique ( Unique )
71 infixr 9 `thenRn`, `thenRn_`
75 type RnM s r = RnMonad () s r
76 type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
78 type RnMonad x s r = RnDown x s -> SST s r
84 SrcLoc -- Source location
85 (RnMode s) -- Source or Iface
86 RnEnv -- Renaming environment
87 (MutableVar s UniqSupply) -- Unique supply
88 (MutableVar s (Bag Warning, -- Warnings and Errors
92 = RnSource (MutableVar s (Bag (RnName, RdrName)))
93 -- Renaming source; returning occurences
95 | RnIface BuiltinNames BuiltinKeys
96 (MutableVar s ImplicitEnv)
97 -- Renaming interface; creating and returning implicit names
98 -- ImplicitEnv: one map for Values and one for TyCons/Classes.
100 type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName RnName)
101 emptyImplicitEnv :: ImplicitEnv
102 emptyImplicitEnv = (emptyFM, emptyFM)
104 -- With a builtin polymorphic type for _runSST the type for
105 -- initTc should use RnM s r instead of RnM _RealWorld r
107 initRn :: Bool -- True => Source; False => Iface
112 -> (r, Bag Error, Bag Warning)
114 initRn source mod env us do_rn
116 newMutVarSST emptyBag `thenSST` \ occ_var ->
117 newMutVarSST emptyImplicitEnv `thenSST` \ imp_var ->
118 newMutVarSST us `thenSST` \ us_var ->
119 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
121 mode = if source then
124 case builtinNameInfo of { (wiredin_fm, key_fm, _) ->
125 RnIface wiredin_fm key_fm imp_var }
127 rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
130 do_rn rn_down `thenSST` \ res ->
132 -- grab errors and return
133 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
134 returnSST (res, errs, warns)
137 {-# INLINE thenRn #-}
138 {-# INLINE thenRn_ #-}
139 {-# INLINE returnRn #-}
142 returnRn :: a -> RnMonad x s a
143 thenRn :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b
144 thenRn_ :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b
145 andRn :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a
146 mapRn :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b]
147 mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c])
149 returnRn v down = returnSST v
150 thenRn m k down = m down `thenSST` \ r -> k r down
151 thenRn_ m k down = m down `thenSST_` k down
153 andRn combiner m1 m2 down
154 = m1 down `thenSST` \ res1 ->
155 m2 down `thenSST` \ res2 ->
156 returnSST (combiner res1 res2)
158 mapRn f [] = returnRn []
160 = f x `thenRn` \ r ->
161 mapRn f xs `thenRn` \ rs ->
164 mapAndUnzipRn f [] = returnRn ([],[])
165 mapAndUnzipRn f (x:xs)
166 = f x `thenRn` \ (r1, r2) ->
167 mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
168 returnRn (r1:rs1, r2:rs2)
170 mapAndUnzip3Rn f [] = returnRn ([],[],[])
171 mapAndUnzip3Rn f (x:xs)
172 = f x `thenRn` \ (r1, r2, r3) ->
173 mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
174 returnRn (r1:rs1, r2:rs2, r3:rs3)
177 For errors and warnings ...
179 failButContinueRn :: a -> Error -> RnMonad x s a
180 failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var)
181 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
182 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
185 warnAndContinueRn :: a -> Warning -> RnMonad x s a
186 warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var)
187 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
188 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
191 addErrRn :: Error -> RnMonad x s ()
192 addErrRn err = failButContinueRn () err
194 addErrIfRn :: Bool -> Error -> RnMonad x s ()
195 addErrIfRn True err = addErrRn err
196 addErrIfRn False err = returnRn ()
198 addWarnRn :: Warning -> RnMonad x s ()
199 addWarnRn warn = warnAndContinueRn () warn
201 addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
202 addWarnIfRn True warn = addWarnRn warn
203 addWarnIfRn False warn = returnRn ()
208 getRnEnv :: RnMonad x s RnEnv
209 getRnEnv (RnDown _ _ _ _ env _ _)
212 setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
213 setExtraRn x m (RnDown _ mod locn mode env us errs)
214 = m (RnDown x mod locn mode env us errs)
216 getExtraRn :: RnMonad x s x
217 getExtraRn (RnDown x _ _ _ _ _ _)
220 getModuleRn :: RnMonad x s Module
221 getModuleRn (RnDown _ mod _ _ _ _ _)
224 pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a
225 pushSrcLocRn locn m (RnDown x mod _ mode env us errs)
226 = m (RnDown x mod locn mode env us errs)
228 getSrcLocRn :: RnMonad x s SrcLoc
229 getSrcLocRn (RnDown _ _ locn _ _ _ _)
232 getSourceRn :: RnMonad x s Bool
233 getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True
234 getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
236 getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
237 getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
238 = readMutVarSST occ_var
239 getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _)
240 = panic "getOccurrenceUpRn:RnIface"
242 getImplicitUpRn :: RnMonad x s ImplicitEnv
243 getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
244 = readMutVarSST imp_var
245 getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
246 = panic "getImplicitUpRn:RnIface"
250 rnGetUnique :: RnMonad x s Unique
251 rnGetUnique (RnDown _ _ _ _ _ us_var _)
254 rnGetUniques :: Int -> RnMonad x s [Unique]
255 rnGetUniques n (RnDown _ _ _ _ _ us_var _)
256 = get_uniques n us_var
260 = readMutVarSST us_var `thenSST` \ uniq_supply ->
262 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
263 uniq = getUnique uniq_s
265 writeMutVarSST us_var new_uniq_supply `thenSST_`
269 = readMutVarSST us_var `thenSST` \ uniq_supply ->
271 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
272 uniqs = getUniques n uniq_s
274 writeMutVarSST us_var new_uniq_supply `thenSST_`
277 snoc_bag_var add bag_var
278 = readMutVarSST bag_var `thenSST` \ bag ->
279 writeMutVarSST bag_var (bag `snocBag` add)
283 *********************************************************
285 \subsection{Making new names}
287 *********************************************************
289 @newLocalNames@ takes a bunch of RdrNames, which are defined together
290 in a group (eg a pattern or set of bindings), checks they are
291 unqualified and distinct, and creates new Names for them.
294 newLocalNames :: String -- Documentation string
295 -> [(RdrName, SrcLoc)]
296 -> RnMonad x s [RnName]
298 newLocalNames str names_w_loc
299 = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
300 mapRn (addErrRn . dupNamesErr str) dups `thenRn_`
303 quals = filter (isQual.fst) names_w_loc
304 (these, dups) = removeDups cmp_fst names_w_loc
305 cmp_fst (a,_) (b,_) = cmp a b
309 mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
310 mkLocalNames names_w_locs
311 = rnGetUniques (length names_w_locs) `thenRn` \ uniqs ->
312 returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs)
314 new_local uniq (Unqual str, srcloc)
315 = mkRnName (mkLocalName uniq str False{-emph names-} srcloc)
319 *********************************************************
321 \subsection{Looking up values}
323 *********************************************************
325 Action to look up a value depends on the RnMode.
328 Lookup value in RnEnv, recording occurrence for non-local values found.
329 If not found report error and return Unbound name.
331 Lookup value in RnEnv. If not found lookup in implicit name env.
332 If not found create new implicit name, adding it to the implicit env.
336 lookupValue :: RdrName -> RnMonad x s RnName
337 lookupConstr :: RdrName -> RnMonad x s RnName
338 lookupField :: RdrName -> RnMonad x s RnName
339 lookupClassOp :: RnName -> RdrName -> RnMonad x s RnName
342 = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
345 = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
348 = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
350 lookupClassOp cls rdr
351 = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
353 -- Note: the lookup checks are only performed when renaming source
355 lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
356 = case lookup env rdr of
357 Just name | check name -> succ name
362 succ name = if isRnLocal name || isRnWired name then
365 snoc_bag_var (name,rdr) occ_var `thenSST_`
367 fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
369 lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
370 = case lookup env rdr of
371 Just name -> returnSST name
372 Nothing -> case rdr of
373 Unqual n -> panic ("lookup_val:"++ _UNPK_ n)
375 lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n)
377 lookup_nonexisting_val (b_names,_) b_key imp_var us_var orig
378 = case (lookupFM b_names orig) of
379 Just xx -> returnSST xx
380 Nothing -> lookup_or_create_implicit_val b_key imp_var us_var orig
382 lookup_or_create_implicit_val b_key imp_var us_var orig
383 = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
384 case (lookupFM implicit_val_fm orig) of
385 Just implicit -> returnSST implicit
387 (case (lookupFM b_key orig) of
388 Just (u,_) -> returnSST u
389 _ -> get_unique us_var
390 ) `thenSST` \ uniq ->
392 implicit = mkRnImplicit (mkImplicitName uniq orig)
393 new_val_fm = addToFM implicit_val_fm orig 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@(Qual m n) 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 (OrigName m n)
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 orig--@(OrigName m n)
433 = --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $
434 case (lookupFM b_names orig) of
435 Just xx -> returnSST xx
436 Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
438 lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
439 = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
440 case (lookupFM implicit_tc_fm orig) of
441 Just implicit | check implicit -> returnSST implicit
444 (case (lookupFM b_key orig) of
445 Just (u,_) -> returnSST u
446 _ -> get_unique us_var
447 ) `thenSST` \ uniq ->
449 implicit = mk_implicit (mkImplicitName uniq orig)
450 new_tc_fm = addToFM implicit_tc_fm orig implicit
452 writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
457 @extendSS@ extends the scope; @extendSS2@ also removes the newly bound
458 free vars from the result.
461 extendSS :: [RnName] -- Newly bound names
465 extendSS binders m down@(RnDown x mod locn mode env us errs)
466 = (mapRn (addErrRn . shadowedNameWarn locn) dups `thenRn_`
467 m) (RnDown x mod locn mode new_env us errs)
469 (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders
471 extendSS2 :: [RnName] -- Newly bound names
472 -> RnMonad x s (a, UniqSet RnName)
473 -> RnMonad x s (a, UniqSet RnName)
476 = extendSS binders m `thenRn` \ (r, fvs) ->
477 returnRn (r, fvs `minusUniqSet` (mkUniqSet binders))
480 The free var set returned by @(extendSS binders m)@ is that returned
481 by @m@, {\em minus} binders.
484 *********************************************************
486 \subsection{TyVarNamesEnv}
488 *********************************************************
491 type TyVarNamesEnv = [(RdrName, RnName)]
493 nullTyVarNamesEnv :: TyVarNamesEnv
494 nullTyVarNamesEnv = []
496 catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
497 catTyVarNamesEnvs e1 e2 = e1 ++ e2
499 domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName]
500 domTyVarNamesEnv env = map fst env
503 @mkTyVarNamesEnv@ checks for duplicates, and complains if so.
508 -> [RdrName] -- The type variables
509 -> RnMonad x s (TyVarNamesEnv,[RnName]) -- Environment and renamed tyvars
511 mkTyVarNamesEnv src_loc tyvars
512 = newLocalNames "type variable"
513 (tyvars `zip` repeat src_loc) `thenRn` \ rn_tyvars ->
515 -- rn_tyvars may not be in the same order as tyvars, so we need some
516 -- jiggery pokery to build the right tyvar env, and return the
517 -- renamed tyvars in the original order.
518 let tv_occ_name_pairs = map tv_occ_name_pair rn_tyvars
519 tv_env = map (lookup_occ_name tv_occ_name_pairs) tyvars
520 rn_tyvars_in_orig_order = map snd tv_env
522 returnRn (tv_env, rn_tyvars_in_orig_order)
524 tv_occ_name_pair :: RnName -> (RdrName, RnName)
525 tv_occ_name_pair rn_name = (getOccName rn_name, rn_name)
527 lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName)
528 lookup_occ_name pairs tyvar_occ
529 = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ)
533 lookupTyVarName :: TyVarNamesEnv -> RdrName -> RnMonad x s RnName
534 lookupTyVarName env occ
535 = case (assocMaybe env occ) of
536 Just name -> returnRn name
537 Nothing -> getSrcLocRn `thenRn` \ loc ->
538 failButContinueRn (mkRnUnbound occ)
539 (unknownNameErr "type variable" occ loc)
544 fixIO :: (a -> IO a) -> IO a
547 (Right loop, _) = result
552 *********************************************************
554 \subsection{Errors used in RnMonad}
556 *********************************************************
559 unknownNameErr descriptor name locn
560 = addShortErrLocLine locn $ \ sty ->
561 ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name]
563 badClassOpErr clas op locn
564 = addErrLoc locn "" $ \ sty ->
565 ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `",
566 ppr sty clas, ppStr "'"]
568 shadowedNameWarn locn shadow
569 = addShortWarnLocLine locn $ \ sty ->
570 ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow]