2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[RnMonad]{The monad used by the renamer}
7 #include "HsVersions.h"
10 SYN_IE(RnMonad), SYN_IE(RnM), SYN_IE(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, SYN_IE(ImplicitEnv), emptyImplicitEnv,
20 rnGetUnique, rnGetUniques,
23 lookupValue, lookupConstr, lookupField, lookupClassOp,
24 lookupTyCon, lookupClass, lookupTyConOrClass,
27 SYN_IE(TyVarNamesEnv), mkTyVarNamesEnv, domTyVarNamesEnv,
28 lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
34 IMPORT_1_3(GHCbase(fixIO))
38 import HsSyn ( FixityDecl )
39 import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit,
40 mkRnImplicitTyCon, mkRnImplicitClass,
41 isRnLocal, isRnWired, isRnTyCon, isRnClass,
42 isRnTyConOrClass, isRnConstr, isRnField,
43 isRnClassOp, RenamedFixityDecl(..) )
44 import RnUtils ( SYN_IE(RnEnv), extendLocalRnEnv,
45 lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
46 qualNameErr, dupNamesErr
49 import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
50 import CmdLineOpts ( opt_WarnNameShadowing )
51 import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
52 SYN_IE(Error), SYN_IE(Warning)
54 import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, fmToList{-ToDo:rm-} )
55 import Maybes ( assocMaybe )
56 import Name ( SYN_IE(Module), RdrName(..), isQual,
57 OrigName(..), Name, mkLocalName, mkImplicitName,
60 import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
61 import PrelMods ( pRELUDE )
62 import PprStyle{-ToDo:rm-}
63 import Outputable{-ToDo:rm-}
64 import Pretty--ToDo:rm ( SYN_IE(Pretty), PrettyRep )
65 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
66 import UniqFM ( UniqFM, emptyUFM )
67 import UniqSet ( SYN_IE(UniqSet), mkUniqSet, minusUniqSet )
68 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
69 import Unique ( Unique )
72 infixr 9 `thenRn`, `thenRn_`
76 type RnM s r = RnMonad () s r
77 type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
79 type RnMonad x s r = RnDown x s -> SST s r
85 SrcLoc -- Source location
86 (RnMode s) -- Source or Iface
87 RnEnv -- Renaming environment
88 (MutableVar s UniqSupply) -- Unique supply
89 (MutableVar s (Bag Warning, -- Warnings and Errors
93 = RnSource (MutableVar s (Bag (RnName, RdrName)))
94 -- Renaming source; returning occurences
96 | RnIface BuiltinNames BuiltinKeys
97 (MutableVar s ImplicitEnv)
98 -- Renaming interface; creating and returning implicit names
99 -- ImplicitEnv: one map for Values and one for TyCons/Classes.
101 type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName RnName)
102 emptyImplicitEnv :: ImplicitEnv
103 emptyImplicitEnv = (emptyFM, emptyFM)
105 -- With a builtin polymorphic type for runSST the type for
106 -- initTc should use RnM s r instead of RnM RealWorld r
107 #if __GLASGOW_HASKELL__ >= 200
108 # define REAL_WORLD GHCbuiltins.RealWorld
110 # define REAL_WORLD _RealWorld
113 initRn :: Bool -- True => Source; False => Iface
118 -> (r, Bag Error, Bag Warning)
120 initRn source mod env us do_rn
122 newMutVarSST emptyBag `thenSST` \ occ_var ->
123 newMutVarSST emptyImplicitEnv `thenSST` \ imp_var ->
124 newMutVarSST us `thenSST` \ us_var ->
125 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
127 mode = if source then
130 RnIface builtinNameMaps builtinKeysMap imp_var
132 rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
135 do_rn rn_down `thenSST` \ res ->
137 -- grab errors and return
138 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
139 returnSST (res, errs, warns)
142 {-# INLINE thenRn #-}
143 {-# INLINE thenRn_ #-}
144 {-# INLINE returnRn #-}
147 returnRn :: a -> RnMonad x s a
148 thenRn :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b
149 thenRn_ :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b
150 andRn :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a
151 mapRn :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b]
152 mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c])
154 returnRn v down = returnSST v
155 thenRn m k down = m down `thenSST` \ r -> k r down
156 thenRn_ m k down = m down `thenSST_` k down
158 andRn combiner m1 m2 down
159 = m1 down `thenSST` \ res1 ->
160 m2 down `thenSST` \ res2 ->
161 returnSST (combiner res1 res2)
163 mapRn f [] = returnRn []
165 = f x `thenRn` \ r ->
166 mapRn f xs `thenRn` \ rs ->
169 mapAndUnzipRn f [] = returnRn ([],[])
170 mapAndUnzipRn f (x:xs)
171 = f x `thenRn` \ (r1, r2) ->
172 mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) ->
173 returnRn (r1:rs1, r2:rs2)
175 mapAndUnzip3Rn f [] = returnRn ([],[],[])
176 mapAndUnzip3Rn f (x:xs)
177 = f x `thenRn` \ (r1, r2, r3) ->
178 mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
179 returnRn (r1:rs1, r2:rs2, r3:rs3)
182 For errors and warnings ...
184 failButContinueRn :: a -> Error -> RnMonad x s a
185 failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var)
186 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
187 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
190 warnAndContinueRn :: a -> Warning -> RnMonad x s a
191 warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var)
192 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
193 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
196 addErrRn :: Error -> RnMonad x s ()
197 addErrRn err = failButContinueRn () err
199 addErrIfRn :: Bool -> Error -> RnMonad x s ()
200 addErrIfRn True err = addErrRn err
201 addErrIfRn False err = returnRn ()
203 addWarnRn :: Warning -> RnMonad x s ()
204 addWarnRn warn = warnAndContinueRn () warn
206 addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
207 addWarnIfRn True warn = addWarnRn warn
208 addWarnIfRn False warn = returnRn ()
213 getRnEnv :: RnMonad x s RnEnv
214 getRnEnv (RnDown _ _ _ _ env _ _)
217 setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
218 setExtraRn x m (RnDown _ mod locn mode env us errs)
219 = m (RnDown x mod locn mode env us errs)
221 getExtraRn :: RnMonad x s x
222 getExtraRn (RnDown x _ _ _ _ _ _)
225 getModuleRn :: RnMonad x s Module
226 getModuleRn (RnDown _ mod _ _ _ _ _)
229 pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a
230 pushSrcLocRn locn m (RnDown x mod _ mode env us errs)
231 = m (RnDown x mod locn mode env us errs)
233 getSrcLocRn :: RnMonad x s SrcLoc
234 getSrcLocRn (RnDown _ _ locn _ _ _ _)
237 getSourceRn :: RnMonad x s Bool
238 getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True
239 getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
241 getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
242 getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
243 = readMutVarSST occ_var
244 getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _)
245 = panic "getOccurrenceUpRn:RnIface"
247 getImplicitUpRn :: RnMonad x s ImplicitEnv
248 getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
249 = readMutVarSST imp_var
250 getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
251 = panic "getImplicitUpRn:RnIface"
255 rnGetUnique :: RnMonad x s Unique
256 rnGetUnique (RnDown _ _ _ _ _ us_var _)
259 rnGetUniques :: Int -> RnMonad x s [Unique]
260 rnGetUniques n (RnDown _ _ _ _ _ us_var _)
261 = get_uniques n us_var
265 = readMutVarSST us_var `thenSST` \ uniq_supply ->
267 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
268 uniq = getUnique uniq_s
270 writeMutVarSST us_var new_uniq_supply `thenSST_`
274 = readMutVarSST us_var `thenSST` \ uniq_supply ->
276 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
277 uniqs = getUniques n uniq_s
279 writeMutVarSST us_var new_uniq_supply `thenSST_`
282 snoc_bag_var add bag_var
283 = readMutVarSST bag_var `thenSST` \ bag ->
284 writeMutVarSST bag_var (bag `snocBag` add)
288 *********************************************************
290 \subsection{Making new names}
292 *********************************************************
294 @newLocalNames@ takes a bunch of RdrNames, which are defined together
295 in a group (eg a pattern or set of bindings), checks they are
296 unqualified and distinct, and creates new Names for them.
299 newLocalNames :: String -- Documentation string
300 -> [(RdrName, SrcLoc)]
301 -> RnMonad x s [RnName]
303 newLocalNames str names_w_loc
304 = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
305 mapRn (addErrRn . dupNamesErr str) dups `thenRn_`
308 quals = filter (isQual.fst) names_w_loc
309 (these, dups) = removeDups cmp_fst names_w_loc
310 cmp_fst (a,_) (b,_) = cmp a b
314 mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
315 mkLocalNames names_w_locs
316 = rnGetUniques (length names_w_locs) `thenRn` \ uniqs ->
317 returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs)
319 new_local uniq (Unqual str, srcloc)
320 = mkRnName (mkLocalName uniq str False{-emph names-} srcloc)
324 *********************************************************
326 \subsection{Looking up values}
328 *********************************************************
330 Action to look up a value depends on the RnMode.
333 Lookup value in RnEnv, recording occurrence for non-local values found.
334 If not found report error and return Unbound name.
336 Lookup value in RnEnv. If not found lookup in implicit name env.
337 If not found create new implicit name, adding it to the implicit env.
341 lookupValue :: RdrName -> RnMonad x s RnName
342 lookupConstr :: RdrName -> RnMonad x s RnName
343 lookupField :: RdrName -> RnMonad x s RnName
344 lookupClassOp :: RnName -> RdrName -> RnMonad x s RnName
347 = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
350 = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
353 = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
355 lookupClassOp cls rdr
356 = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
358 -- Note: the lookup checks are only performed when renaming source
360 lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
361 = case lookup env rdr of
362 Just name | check name -> succ name
367 succ name = if isRnLocal name || isRnWired name then
370 snoc_bag_var (name,rdr) occ_var `thenSST_`
372 fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
374 lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
375 = case lookup env rdr of
376 Just name -> returnSST name
377 Nothing -> case rdr of
378 Unqual n -> panic ("lookup_val:"++ _UNPK_ n)
380 lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n)
382 lookup_nonexisting_val (b_names,_) b_key imp_var us_var orig
383 = case (lookupFM b_names orig) of
384 Just xx -> returnSST xx
385 Nothing -> lookup_or_create_implicit_val b_key imp_var us_var orig
387 lookup_or_create_implicit_val b_key imp_var us_var orig
388 = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
389 case (lookupFM implicit_val_fm orig) of
390 Just implicit -> returnSST implicit
392 (case (lookupFM b_key orig) of
393 Just (u,_) -> returnSST u
394 _ -> get_unique us_var
395 ) `thenSST` \ uniq ->
397 implicit = mkRnImplicit (mkImplicitName uniq orig)
398 new_val_fm = addToFM implicit_val_fm orig implicit
400 writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
406 lookupTyCon :: RdrName -> RnMonad x s RnName
407 lookupClass :: RdrName -> RnMonad x s RnName
410 = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
413 = lookup_tc rdr isRnClass mkRnImplicitClass "class"
415 lookupTyConOrClass rdr
416 = lookup_tc rdr isRnTyConOrClass
417 (panic "lookupTC:mk_implicit") "class or type constructor"
419 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
420 = case lookupTcRnEnv env rdr of
421 Just name | check name -> succ name
425 succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
427 fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
429 lookup_tc rdr@(Qual m n) check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
430 = case lookupTcRnEnv env rdr of
431 Just name | check name -> returnSST name
433 Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var (OrigName m n)
435 fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
437 lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var orig--@(OrigName m n)
438 = --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]]) $
439 case (lookupFM b_names orig) of
440 Just xx -> returnSST xx
441 Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
443 lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
444 = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
445 case (lookupFM implicit_tc_fm orig) of
446 Just implicit | check implicit -> returnSST implicit
449 (case (lookupFM b_key orig) of
450 Just (u,_) -> returnSST u
451 _ -> get_unique us_var
452 ) `thenSST` \ uniq ->
454 implicit = mk_implicit (mkImplicitName uniq orig)
455 new_tc_fm = addToFM implicit_tc_fm orig 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 #if __GLASGOW_HASKELL__ >= 200
550 -- can get it from GHCbase
552 fixIO :: (a -> IO a) -> IO a
556 (Right loop, _) = result
562 *********************************************************
564 \subsection{Errors used in RnMonad}
566 *********************************************************
569 unknownNameErr descriptor name locn
570 = addShortErrLocLine locn $ \ sty ->
571 ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name]
573 badClassOpErr clas op locn
574 = addErrLoc locn "" $ \ sty ->
575 ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `",
576 ppr sty clas, ppStr "'"]
578 shadowedNameWarn locn shadow
579 = addShortWarnLocLine locn $ \ sty ->
580 ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow]