2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[RenameMonad4]{The monad used by the fourth renamer pass}
7 #include "HsVersions.h"
11 initRn4, thenRn4, thenRn4_, andRn4, returnRn4, mapRn4, mapAndUnzipRn4,
12 addErrRn4, failButContinueRn4, recoverQuietlyRn4,
16 lookupValue, lookupValueEvenIfInvisible,
17 lookupClassOp, lookupFixityOp,
18 lookupTyCon, lookupTyConEvenIfInvisible,
23 TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
24 lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
27 Module, Bag, RenamedPat(..), InPat, Maybe, Name, Error(..),
28 Pretty(..), PprStyle, PrettyRep, ProtoName, GlobalSwitch,
29 GlobalNameFun(..), GlobalNameFuns(..), UniqSet(..), UniqFM, SrcLoc,
30 Unique, SplitUniqSupply
31 IF_ATTACK_PRAGMAS(COMMA splitUniqSupply)
34 IMPORT_Trace -- ToDo: rm (debugging)
40 import CmdLineOpts ( GlobalSwitch(..) )
41 import Errors ( dupNamesErr, unknownNameErr, shadowedNameErr,
42 badClassOpErr, Error(..)
44 import FiniteMap ( lookupFM, addToFM, addListToFM, emptyFM, FiniteMap )
45 import Maybes ( Maybe(..), assocMaybe )
46 import Name ( isTyConName, isClassName, isClassOpName,
47 isUnboundName, invisibleName
49 import NameTypes ( mkShortName, ShortName )
50 import ProtoName -- lots of stuff
51 import RenameAuxFuns -- oh, why not ... all of it
52 import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
58 infixr 9 `thenRn4`, `thenRn4_`
61 %************************************************************************
63 \subsection[RenameMonad]{Plain @Rename@ monadery}
65 %************************************************************************
68 type ScopeStack = FiniteMap FAST_STRING Name
71 = (GlobalSwitch -> Bool)
77 -> (result, Bag Error)
79 #ifdef __GLASGOW_HASKELL__
81 {-# INLINE thenRn4 #-}
82 {-# INLINE thenLazilyRn4 #-}
83 {-# INLINE thenRn4_ #-}
84 {-# INLINE returnRn4 #-}
87 initRn4 :: (GlobalSwitch -> Bool)
91 -> (result, Bag Error)
93 initRn4 sw_chkr gnfs renamer init_us
94 = renamer sw_chkr gnfs emptyFM emptyBag init_us mkUnknownSrcLoc
96 thenRn4, thenLazilyRn4
97 :: Rn4M a -> (a -> Rn4M b) -> Rn4M b
98 thenRn4_ :: Rn4M a -> Rn4M b -> Rn4M b
99 andRn4 :: (a -> a -> a) -> Rn4M a -> Rn4M a -> Rn4M a
101 thenRn4 expr cont sw_chkr gnfs ss errs uniqs locn
102 = case (splitUniqSupply uniqs) of { (s1, s2) ->
103 case (expr sw_chkr gnfs ss errs s1 locn) of { (res1, errs1) ->
104 case (cont res1 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
107 thenLazilyRn4 expr cont sw_chkr gnfs ss errs uniqs locn
109 (s1, s2) = splitUniqSupply uniqs
110 (res1, errs1) = expr sw_chkr gnfs ss errs s1 locn
111 (res2, errs2) = cont res1 sw_chkr gnfs ss errs1 s2 locn
115 thenRn4_ expr cont sw_chkr gnfs ss errs uniqs locn
116 = case (splitUniqSupply uniqs) of { (s1, s2) ->
117 case (expr sw_chkr gnfs ss errs s1 locn) of { (_, errs1) ->
118 case (cont sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
121 andRn4 combiner m1 m2 sw_chkr gnfs ss errs us locn
122 = case (splitUniqSupply us) of { (s1, s2) ->
123 case (m1 sw_chkr gnfs ss errs s1 locn) of { (res1, errs1) ->
124 case (m2 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
125 (combiner res1 res2, errs2) }}}
127 returnRn4 :: a -> Rn4M a
128 returnRn4 result sw_chkr gnfs ss errs_so_far uniqs locn
129 = (result, errs_so_far)
131 failButContinueRn4 :: a -> Error -> Rn4M a
132 failButContinueRn4 res err sw_chkr gnfs ss errs_so_far uniqs locn
133 = (res, errs_so_far `snocBag` err)
135 addErrRn4 :: Error -> Rn4M ()
136 addErrRn4 err sw_chkr gnfs ss errs_so_far uniqs locn
137 = ((), errs_so_far `snocBag` err)
140 When we're looking at interface pragmas, we want to be able to recover
141 back to a ``I don't know anything pragmatic'' state if we encounter
142 some problem. @recoverQuietlyRn4@ is given a ``use-this-instead'' value,
143 as well as the action to perform. This code is intentionally very lazy,
144 returning a triple immediately, no matter what.
146 recoverQuietlyRn4 :: a -> Rn4M a -> Rn4M a
148 recoverQuietlyRn4 use_this_if_err action sw_chkr gnfs ss errs_so_far uniqs locn
151 = case (action sw_chkr gnfs ss emptyBag{-leav out errs-} uniqs locn) of
153 if isEmptyBag errs1 then -- all's well! (but retain incoming errs)
154 (result1, errs_so_far)
155 else -- give up; return *incoming* UniqueSupply...
157 if sw_chkr ShowPragmaNameErrs
158 then errs_so_far `unionBags` errs1
159 else errs_so_far) -- toss errs, otherwise
165 mapRn4 :: (a -> Rn4M b) -> [a] -> Rn4M [b]
167 mapRn4 f [] = returnRn4 []
169 = f x `thenRn4` \ r ->
170 mapRn4 f xs `thenRn4` \ rs ->
173 mapAndUnzipRn4 :: (a -> Rn4M (b,c)) -> [a] -> Rn4M ([b],[c])
175 mapAndUnzipRn4 f [] = returnRn4 ([],[])
176 mapAndUnzipRn4 f (x:xs)
177 = f x `thenRn4` \ (r1, r2) ->
178 mapAndUnzipRn4 f xs `thenRn4` \ (rs1, rs2) ->
179 returnRn4 (r1:rs1, r2:rs2)
183 pushSrcLocRn4 :: SrcLoc -> Rn4M a -> Rn4M a
184 pushSrcLocRn4 locn exp sw_chkr gnfs ss errs_so_far uniq_supply old_locn
185 = exp sw_chkr gnfs ss errs_so_far uniq_supply locn
187 getSrcLocRn4 :: Rn4M SrcLoc
189 getSrcLocRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn
190 = returnRn4 locn sw_chkr gnfs ss errs_so_far uniq_supply locn
192 getSwitchCheckerRn4 :: Rn4M (GlobalSwitch -> Bool)
194 getSwitchCheckerRn4 sw_chkr gnfs ss errs_so_far uniq_supply locn
195 = returnRn4 sw_chkr sw_chkr gnfs ss errs_so_far uniq_supply locn
199 getNextUniquesFromRn4 :: Int -> Rn4M [Unique]
200 getNextUniquesFromRn4 n sw_chkr gnfs ss errs_so_far us locn
201 = case (getSUniques n us) of { next_uniques ->
202 (next_uniques, errs_so_far) }
205 *********************************************************
207 \subsection{Making new names}
209 *********************************************************
211 @namesFromProtoNames@ takes a bunch of protonames, which are defined
212 together in a group (eg a pattern or set of bindings), checks they
213 are distinct, and creates new full names for them.
216 namesFromProtoNames :: String -- Documentation string
217 -> [(ProtoName, SrcLoc)]
220 namesFromProtoNames kind pnames_w_src_loc sw_chkr gnfs ss errs_so_far us locn
221 = (mapRn4 (addErrRn4 . dupNamesErr kind) dups `thenRn4_`
223 ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
225 (goodies, dups) = removeDups cmp pnames_w_src_loc
226 -- We want to compare their local names rather than their
227 -- full protonames. It probably doesn't matter here, but it
228 -- does in Rename3.lhs!
229 cmp (a, _) (b, _) = cmpByLocalName a b
232 @mkNewNames@ assumes the names are unique.
235 mkNewNames :: [(ProtoName, SrcLoc)] -> Rn4M [Name]
236 mkNewNames pnames_w_locs
237 = getNextUniquesFromRn4 (length pnames_w_locs) `thenRn4` \ uniqs ->
238 returnRn4 (zipWith new_short_name uniqs pnames_w_locs)
240 new_short_name uniq (Unk str, srcloc) -- gotta be an Unk...
241 = Short uniq (mkShortName str srcloc)
245 *********************************************************
247 \subsection{Local scope extension and lookup}
249 *********************************************************
251 If the input name is an @Imp@, @lookupValue@ looks it up in the GNF.
252 If it is an @Unk@, it looks it up first in the local environment
253 (scope stack), and if it isn't found there, then in the value GNF. If
254 it isn't found at all, @lookupValue@ adds an error message, and
255 returns an @Unbound@ name.
258 unboundName :: ProtoName -> Name
260 = Unbound (grab_string pn)
262 grab_string (Unk s) = s
263 grab_string (Imp _ _ _ s) = s
266 @lookupValue@ looks up a non-invisible value;
267 @lookupValueEvenIfInvisible@ gives a successful lookup even if the
268 value is not visible to the user (e.g., came out of a pragma).
269 @lookup_val@ is the help function to do the work.
272 lookupValue v {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
273 = (lookup_val v `thenLazilyRn4` \ name ->
274 if invisibleName name
275 then failButContinueRn4 (unboundName v) (unknownNameErr "value" v mkUnknownSrcLoc)
277 ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
279 lookupValueEvenIfInvisible v = lookup_val v
281 lookup_val :: ProtoName -> Rn4M Name
283 lookup_val pname@(Unk v) sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
284 = case (lookupFM ss v) of
285 Just name -> returnRn4 name sw_chkr gnfs ss a b locn
286 Nothing -> case (v_gnf pname) of
287 Just name -> returnRn4 name sw_chkr gnfs ss a b locn
288 Nothing -> failButContinueRn4 (unboundName pname)
289 (unknownNameErr "value" pname locn)
290 sw_chkr gnfs ss a b locn
292 -- If it ain't an Unk it must be in the global name fun; that includes
294 lookup_val pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
295 = case (v_gnf pname) of
296 Just name -> returnRn4 name sw_chkr gnfs ss a b locn
297 Nothing -> failButContinueRn4 (unboundName pname)
298 (unknownNameErr "value" pname locn)
299 sw_chkr gnfs ss a b locn
302 Looking up the operators in a fixity decl is done differently. We
303 want to simply drop any fixity decls which refer to operators which
304 aren't in scope. Unfortunately, such fixity decls {\em will} appear
305 because the parser collects *all* the fixity decls from {\em all} the
306 imported interfaces (regardless of selective import), and dumps them
307 together as the module fixity decls. This is really a bug. In
311 We won't complain about fixity decls for operators which aren't
314 We won't attach the right fixity to something which has been renamed.
317 We're not going to export Prelude-related fixities (ToDo: correctly),
318 so we nuke those, too.
321 lookupFixityOp (Prel _) sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 Nothing sw_chkr gnfs
322 lookupFixityOp pname sw_chkr gnfs@(v_gnf, tc_gnf) = returnRn4 (v_gnf pname) sw_chkr gnfs
326 lookupTyCon, lookupTyConEvenIfInvisible :: ProtoName -> Rn4M Name
327 -- The global name funs handle Prel things
329 lookupTyCon tc {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
330 = (lookup_tycon tc `thenLazilyRn4` \ name ->
331 if invisibleName name
332 then failButContinueRn4 (unboundName tc) (unknownNameErr "type constructor" tc mkUnknownSrcLoc)
334 ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
336 lookupTyConEvenIfInvisible tc = lookup_tycon tc
338 lookup_tycon (Prel name) sw_chkr gnfs ss a b locn = returnRn4 name sw_chkr gnfs ss a b locn
340 lookup_tycon pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
341 = case (tc_gnf pname) of
342 Just name | isTyConName name -> returnRn4 name sw_chkr gnfs ss a b locn
343 _ -> failButContinueRn4 (unboundName pname)
344 (unknownNameErr "type constructor" pname locn)
345 sw_chkr gnfs ss a b locn
349 lookupClass :: ProtoName -> Rn4M Name
351 lookupClass pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
352 = case (tc_gnf pname) of
353 Just name | isClassName name -> returnRn4 name sw_chkr gnfs ss a b locn
354 _ -> failButContinueRn4 (unboundName pname)
355 (unknownNameErr "class" pname locn)
356 sw_chkr gnfs ss a b locn
359 @lookupClassOp@ is used when looking up the lhs identifiers in a class
360 or instance decl. It checks that the name it finds really is a class
361 op, and that its class matches that of the class or instance decl
365 lookupClassOp :: Name -> ProtoName -> Rn4M Name
367 lookupClassOp class_name pname sw_chkr gnfs@(v_gnf, tc_gnf) ss a b locn
368 = case v_gnf pname of
369 Just op_name | isClassOpName class_name op_name
370 || isUnboundName class_name -- avoid spurious errors
371 -> returnRn4 op_name sw_chkr gnfs ss a b locn
373 other -> failButContinueRn4 (unboundName pname)
374 (badClassOpErr class_name pname locn)
375 sw_chkr gnfs ss a b locn
378 @extendSS@ extends the scope; @extendSS2@ also removes the newly bound
379 free vars from the result.
382 extendSS :: [Name] -- Newly bound names
386 extendSS binders expr sw_chkr gnfs ss errs us locn
387 = case (extend binders ss sw_chkr gnfs ss errs us locn) of { (new_ss, new_errs) ->
388 expr sw_chkr gnfs new_ss new_errs us locn }
390 extend :: [Name] -> ScopeStack -> Rn4M ScopeStack
393 = if (sw_chkr NameShadowingNotOK) then
395 else -- ignore shadowing; blast 'em in
397 addListToFM ss [ (getOccurrenceName x, n) | n@(Short _ x) <- names]
400 hard_way [] ss = returnRn4 ss
401 hard_way (name@(Short _ sname):names) ss
403 str = getOccurrenceName sname
405 (case (lookupFM ss str) of
406 Nothing -> returnRn4 (addToFM ss str name)
407 Just _ -> failButContinueRn4 ss (shadowedNameErr name locn)
409 ) `thenRn4` \ new_ss ->
410 hard_way names new_ss
412 extendSS2 :: [Name] -- Newly bound names
413 -> Rn4M (a, UniqSet Name)
414 -> Rn4M (a, UniqSet Name)
416 extendSS2 binders expr sw_chkr gnfs ss errs_so_far us locn
417 = case (extendSS binders expr sw_chkr gnfs ss errs_so_far us locn) of
418 ((e2, freevars), errs)
419 -> ((e2, freevars `minusUniqSet` (mkUniqSet binders)),
423 The free var set returned by @(extendSS binders m)@ is that returned
424 by @m@, {\em minus} binders.
426 *********************************************************
428 \subsection{mkTyVarNamesEnv}
430 *********************************************************
433 type TyVarNamesEnv = [(ProtoName, Name)]
435 nullTyVarNamesEnv :: TyVarNamesEnv
436 nullTyVarNamesEnv = []
438 catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
439 catTyVarNamesEnvs e1 e2 = e1 ++ e2
441 domTyVarNamesEnv :: TyVarNamesEnv -> [ProtoName]
442 domTyVarNamesEnv env = map fst env
445 @mkTyVarNamesEnv@ checks for duplicates, and complains if so.
450 -> [ProtoName] -- The type variables
451 -> Rn4M (TyVarNamesEnv,[Name]) -- Environment and renamed tyvars
453 mkTyVarNamesEnv src_loc tyvars {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
454 = (namesFromProtoNames "type variable"
455 (tyvars `zip` repeat src_loc) `thenRn4` \ tyvars2 ->
457 -- tyvars2 may not be in the same order as tyvars, so we need some
458 -- jiggery pokery to build the right tyvar env, and return the
459 -- renamed tyvars in the original order.
460 let tv_string_name_pairs = extend tyvars2 []
461 tv_env = map (lookup tv_string_name_pairs) tyvars
462 tyvars2_in_orig_order = map snd tv_env
464 returnRn4 (tv_env, tyvars2_in_orig_order)
465 ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
467 extend :: [Name] -> [(FAST_STRING, Name)] -> [(FAST_STRING, Name)]
469 extend (name@(Short _ sname):names) ss
470 = (getOccurrenceName sname, name) : extend names ss
472 lookup :: [(FAST_STRING, Name)] -> ProtoName -> (ProtoName, Name)
473 lookup pairs tyvar_pn
474 = (tyvar_pn, assoc "mkTyVarNamesEnv" pairs (getOccurrenceName tyvar_pn))
478 lookupTyVarName :: TyVarNamesEnv -> ProtoName -> Rn4M Name
479 lookupTyVarName env pname {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
480 = (case (assoc_maybe env pname) of
481 Just name -> returnRn4 name
482 Nothing -> getSrcLocRn4 `thenRn4` \ loc ->
483 failButContinueRn4 (unboundName pname)
484 (unknownNameErr "type variable" pname loc)
485 ) {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
487 assoc_maybe [] _ = Nothing
488 assoc_maybe ((tv,xxx) : tvs) key
489 = if tv `eqProtoName` key then Just xxx else assoc_maybe tvs key