ghc/compiler/rename/RnMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnMonad]{The monad used by the renamer}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnMonad (
  10         RnMonad(..), RnM(..), RnM_Fixes(..), RnDown, SST_R,
  11         initRn, thenRn, thenRn_, andRn, returnRn,
  12         mapRn, mapAndUnzipRn, mapAndUnzip3Rn,
  13
  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,
  21
  22         newLocalNames,
  23         lookupValue, lookupConstr, lookupField, lookupClassOp,
  24         lookupTyCon, lookupClass, lookupTyConOrClass,
  25         extendSS2, extendSS,
  26
  27         TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv,
  28         lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
  29
  30         fixIO
  31     ) where
  32
  33 IMP_Ubiq(){-uitous-}
  34
  35 import SST
  36
  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
  46                         )
  47
  48 import Bag              ( Bag, emptyBag, isEmptyBag, snocBag )
  49 import CmdLineOpts      ( opt_WarnNameShadowing )
  50 import ErrUtils         ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
  51                           Error(..), Warning(..)
  52                         )
  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,
  57                           getOccName, pprNonSym
  58                         )
  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 )
  69 import Util
  70
  71 infixr 9 `thenRn`, `thenRn_`
  72 \end{code}
  73
  74 \begin{code}
  75 type RnM s r       = RnMonad () s r
  76 type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
  77
  78 type RnMonad x s r = RnDown x s -> SST s r
  79
  80 data RnDown x s
  81   = RnDown
  82         x
  83         Module                          -- Module name
  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
  89                        Bag Error))
  90
  91 data RnMode s
  92  = RnSource (MutableVar s (Bag (RnName, RdrName)))
  93         -- Renaming source; returning occurences
  94
  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.
  99
 100 type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName RnName)
 101 emptyImplicitEnv :: ImplicitEnv
 102 emptyImplicitEnv = (emptyFM, emptyFM)
 103
 104 -- With a builtin polymorphic type for _runSST the type for
 105 -- initTc should use  RnM s r  instead of  RnM _RealWorld r
 106
 107 initRn :: Bool          -- True => Source; False => Iface
 108        -> Module
 109        -> RnEnv
 110        -> UniqSupply
 111        -> RnM _RealWorld r
 112        -> (r, Bag Error, Bag Warning)
 113
 114 initRn source mod env us do_rn
 115   = _runSST (
 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 ->
 120         let
 121             mode = if source then
 122                        RnSource occ_var
 123                    else
 124                        case builtinNameInfo of { (wiredin_fm, key_fm, _) ->
 125                        RnIface wiredin_fm key_fm imp_var }
 126
 127             rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
 128         in
 129         -- do the buisness
 130         do_rn rn_down                           `thenSST` \ res ->
 131
 132         -- grab errors and return
 133         readMutVarSST errs_var                  `thenSST` \ (warns,errs) ->
 134         returnSST (res, errs, warns)
 135     )
 136
 137 {-# INLINE thenRn #-}
 138 {-# INLINE thenRn_ #-}
 139 {-# INLINE returnRn #-}
 140 {-# INLINE andRn #-}
 141
 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])
 148
 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
 152
 153 andRn combiner m1 m2 down
 154   = m1 down `thenSST` \ res1 ->
 155     m2 down `thenSST` \ res2 ->
 156     returnSST (combiner res1 res2)
 157
 158 mapRn f []     = returnRn []
 159 mapRn f (x:xs)
 160   = f x         `thenRn` \ r ->
 161     mapRn f xs  `thenRn` \ rs ->
 162     returnRn (r:rs)
 163
 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)
 169
 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)
 175 \end{code}
 176
 177 For errors and warnings ...
 178 \begin{code}
 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_`
 183     returnSST res
 184
 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_`
 189     returnSST res
 190
 191 addErrRn :: Error -> RnMonad x s ()
 192 addErrRn err = failButContinueRn () err
 193
 194 addErrIfRn :: Bool -> Error -> RnMonad x s ()
 195 addErrIfRn True err  = addErrRn err
 196 addErrIfRn False err = returnRn ()
 197
 198 addWarnRn :: Warning -> RnMonad x s ()
 199 addWarnRn warn = warnAndContinueRn () warn
 200
 201 addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
 202 addWarnIfRn True warn  = addWarnRn warn
 203 addWarnIfRn False warn = returnRn ()
 204 \end{code}
 205
 206
 207 \begin{code}
 208 getRnEnv :: RnMonad x s RnEnv
 209 getRnEnv (RnDown _ _ _ _ env _ _)
 210   = returnSST env
 211
 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)
 215
 216 getExtraRn :: RnMonad x s x
 217 getExtraRn (RnDown x _ _ _ _ _ _)
 218   = returnSST x
 219
 220 getModuleRn :: RnMonad x s Module
 221 getModuleRn (RnDown _ mod _ _ _ _ _)
 222   = returnSST mod
 223
 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)
 227
 228 getSrcLocRn :: RnMonad x s SrcLoc
 229 getSrcLocRn (RnDown _ _ locn _ _ _ _)
 230   = returnSST locn
 231
 232 getSourceRn :: RnMonad x s Bool
 233 getSourceRn (RnDown _ _ _ (RnSource _)    _ _ _) = returnSST True
 234 getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
 235
 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"
 241
 242 getImplicitUpRn :: RnMonad x s ImplicitEnv
 243 getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
 244   = readMutVarSST imp_var
 245 getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
 246   = panic "getImplicitUpRn:RnIface"
 247 \end{code}
 248
 249 \begin{code}
 250 rnGetUnique :: RnMonad x s Unique
 251 rnGetUnique (RnDown _ _ _ _ _ us_var _)
 252   = get_unique us_var
 253
 254 rnGetUniques :: Int -> RnMonad x s [Unique]
 255 rnGetUniques n (RnDown _ _ _ _ _ us_var _)
 256   = get_uniques n us_var
 257
 258
 259 get_unique us_var
 260   = readMutVarSST us_var                        `thenSST` \ uniq_supply ->
 261     let
 262       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 263       uniq                      = getUnique uniq_s
 264     in
 265     writeMutVarSST us_var new_uniq_supply       `thenSST_`
 266     returnSST uniq
 267
 268 get_uniques n us_var
 269   = readMutVarSST us_var                        `thenSST` \ uniq_supply ->
 270     let
 271       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 272       uniqs                     = getUniques n uniq_s
 273     in
 274     writeMutVarSST us_var new_uniq_supply       `thenSST_`
 275     returnSST uniqs
 276
 277 snoc_bag_var add bag_var
 278   = readMutVarSST bag_var       `thenSST` \ bag ->
 279     writeMutVarSST bag_var (bag `snocBag` add)
 280
 281 \end{code}
 282
 283 *********************************************************
 284 *                                                       *
 285 \subsection{Making new names}
 286 *                                                       *
 287 *********************************************************
 288
 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.
 292
 293 \begin{code}
 294 newLocalNames :: String                 -- Documentation string
 295               -> [(RdrName, SrcLoc)]
 296               -> RnMonad x s [RnName]
 297
 298 newLocalNames str names_w_loc
 299   = mapRn (addErrRn . qualNameErr str) quals    `thenRn_`
 300     mapRn (addErrRn . dupNamesErr str) dups     `thenRn_`
 301     mkLocalNames these
 302   where
 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
 306 \end{code}
 307
 308 \begin{code}
 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)
 313   where
 314     new_local uniq (Unqual str, srcloc)
 315       = mkRnName (mkLocalName uniq str False{-emph names-} srcloc)
 316 \end{code}
 317
 318
 319 *********************************************************
 320 *                                                       *
 321 \subsection{Looking up values}
 322 *                                                       *
 323 *********************************************************
 324
 325 Action to look up a value depends on the RnMode.
 326 \begin{description}
 327 \item[RnSource:]
 328 Lookup value in RnEnv, recording occurrence for non-local values found.
 329 If not found report error and return Unbound name.
 330 \item[RnIface:]
 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.
 333 \end{description}
 334
 335 \begin{code}
 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
 340
 341 lookupValue rdr
 342   = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
 343
 344 lookupConstr rdr
 345   = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
 346
 347 lookupField rdr
 348   = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
 349
 350 lookupClassOp cls rdr
 351   = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
 352
 353 -- Note: the lookup checks are only performed when renaming source
 354
 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
 358                   | otherwise  -> fail
 359         Nothing                -> fail
 360
 361   where
 362     succ name = if isRnLocal name || isRnWired name then
 363                     returnSST name
 364                 else
 365                     snoc_bag_var (name,rdr) occ_var `thenSST_`
 366                     returnSST name
 367     fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
 368
 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)
 374                      Qual m n ->
 375                        lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n)
 376
 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
 381
 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
 386         Nothing ->
 387           (case (lookupFM b_key orig) of
 388                 Just (u,_) -> returnSST u
 389                 _          -> get_unique us_var
 390           )                                                     `thenSST` \ uniq ->
 391           let
 392               implicit   = mkRnImplicit (mkImplicitName uniq orig)
 393               new_val_fm = addToFM implicit_val_fm orig implicit
 394           in
 395           writeMutVarSST imp_var (new_val_fm, implicit_tc_fm)   `thenSST_`
 396           returnSST implicit
 397 \end{code}
 398
 399
 400 \begin{code}
 401 lookupTyCon   :: RdrName -> RnMonad x s RnName
 402 lookupClass   :: RdrName -> RnMonad x s RnName
 403
 404 lookupTyCon rdr
 405   = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
 406
 407 lookupClass rdr
 408   = lookup_tc rdr isRnClass mkRnImplicitClass "class"
 409
 410 lookupTyConOrClass rdr
 411   = lookup_tc rdr isRnTyConOrClass
 412               (panic "lookupTC:mk_implicit") "class or type constructor"
 413
 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
 417                  | otherwise  -> fail
 418        Nothing                -> fail
 419   where
 420     succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
 421                 returnSST name
 422     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 423
 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
 427                   | otherwise  -> fail
 428         Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var (OrigName m n)
 429   where
 430     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 431
 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
 437
 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
 442                       | otherwise      -> fail
 443         Nothing ->
 444           (case (lookupFM b_key orig) of
 445                 Just (u,_) -> returnSST u
 446                 _          -> get_unique us_var
 447           )                                                     `thenSST` \ uniq ->
 448           let
 449               implicit  = mk_implicit (mkImplicitName uniq orig)
 450               new_tc_fm = addToFM implicit_tc_fm orig implicit
 451           in
 452           writeMutVarSST imp_var (implicit_val_fm, new_tc_fm)   `thenSST_`
 453           returnSST implicit
 454 \end{code}
 455
 456
 457 @extendSS@ extends the scope; @extendSS2@ also removes the newly bound
 458 free vars from the result.
 459
 460 \begin{code}
 461 extendSS :: [RnName]                            -- Newly bound names
 462          -> RnMonad x s a
 463          -> RnMonad x s a
 464
 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)
 468   where
 469     (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders
 470
 471 extendSS2 :: [RnName]                           -- Newly bound names
 472           -> RnMonad x s (a, UniqSet RnName)
 473           -> RnMonad x s (a, UniqSet RnName)
 474
 475 extendSS2 binders m
 476   = extendSS binders m `thenRn` \ (r, fvs) ->
 477     returnRn (r, fvs `minusUniqSet` (mkUniqSet binders))
 478 \end{code}
 479
 480 The free var set returned by @(extendSS binders m)@ is that returned
 481 by @m@, {\em minus} binders.
 482
 483
 484 *********************************************************
 485 *                                                       *
 486 \subsection{TyVarNamesEnv}
 487 *                                                       *
 488 *********************************************************
 489
 490 \begin{code}
 491 type TyVarNamesEnv = [(RdrName, RnName)]
 492
 493 nullTyVarNamesEnv :: TyVarNamesEnv
 494 nullTyVarNamesEnv = []
 495
 496 catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
 497 catTyVarNamesEnvs e1 e2 = e1 ++ e2
 498
 499 domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName]
 500 domTyVarNamesEnv env = map fst env
 501 \end{code}
 502
 503 @mkTyVarNamesEnv@ checks for duplicates, and complains if so.
 504
 505 \begin{code}
 506 mkTyVarNamesEnv
 507         :: SrcLoc
 508         -> [RdrName]                            -- The type variables
 509         -> RnMonad x s (TyVarNamesEnv,[RnName]) -- Environment and renamed tyvars
 510
 511 mkTyVarNamesEnv src_loc tyvars
 512   = newLocalNames "type variable"
 513          (tyvars `zip` repeat src_loc) `thenRn`  \ rn_tyvars ->
 514
 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
 521     in
 522     returnRn (tv_env, rn_tyvars_in_orig_order)
 523   where
 524     tv_occ_name_pair :: RnName -> (RdrName, RnName)
 525     tv_occ_name_pair rn_name = (getOccName rn_name, rn_name)
 526
 527     lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName)
 528     lookup_occ_name pairs tyvar_occ
 529       = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ)
 530 \end{code}
 531
 532 \begin{code}
 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)
 540 \end{code}
 541
 542
 543 \begin{code}
 544 fixIO :: (a -> IO a) -> IO a
 545 fixIO k s = let
 546                 result          = k loop s
 547                 (Right loop, _) = result
 548             in
 549             result
 550 \end{code}
 551
 552 *********************************************************
 553 *                                                       *
 554 \subsection{Errors used in RnMonad}
 555 *                                                       *
 556 *********************************************************
 557
 558 \begin{code}
 559 unknownNameErr descriptor name locn
 560   = addShortErrLocLine locn $ \ sty ->
 561     ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name]
 562
 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 "'"]
 567
 568 shadowedNameWarn locn shadow
 569   = addShortWarnLocLine locn $ \ sty ->
 570     ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow]
 571 \end{code}