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 import 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                           unknownNameErr, badClassOpErr, qualNameErr,
  46                           dupNamesErr, shadowedNameWarn, negateNameWarn
  47                         )
  48
  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,
  56                           getOccName
  57                         )
  58 import PrelInfo         ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) )
  59 import Pretty           ( Pretty(..), PrettyRep )
  60 import SrcLoc           ( SrcLoc, mkUnknownSrcLoc )
  61 import UniqFM           ( UniqFM, emptyUFM )
  62 import UniqSet          ( UniqSet(..), mkUniqSet, minusUniqSet )
  63 import UniqSupply       ( UniqSupply, getUnique, getUniques, splitUniqSupply )
  64 import Unique           ( Unique )
  65 import Util
  66
  67 infixr 9 `thenRn`, `thenRn_`
  68 \end{code}
  69
  70 \begin{code}
  71 type RnM s r       = RnMonad () s r
  72 type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
  73
  74 type RnMonad x s r = RnDown x s -> SST s r
  75
  76 data RnDown x s
  77   = RnDown
  78         x
  79         Module                          -- Module name
  80         SrcLoc                          -- Source location
  81         (RnMode s)                      -- Source or Iface
  82         RnEnv                           -- Renaming environment
  83         (MutableVar s UniqSupply)       -- Unique supply
  84         (MutableVar s (Bag Warning,     -- Warnings and Errors
  85                        Bag Error))
  86
  87 data RnMode s
  88  = RnSource (MutableVar s (Bag (RnName, RdrName)))
  89         -- Renaming source; returning occurences
  90
  91  | RnIface  BuiltinNames BuiltinKeys
  92             (MutableVar s ImplicitEnv)
  93         -- Renaming interface; creating and returning implicit names
  94         -- ImplicitEnv: one map for Values and one for TyCons/Classes.
  95
  96 type ImplicitEnv = (FiniteMap RdrName RnName, FiniteMap RdrName RnName)
  97 emptyImplicitEnv :: ImplicitEnv
  98 emptyImplicitEnv = (emptyFM, emptyFM)
  99
 100 -- With a builtin polymorphic type for _runSST the type for
 101 -- initTc should use  RnM s r  instead of  RnM _RealWorld r
 102
 103 initRn :: Bool          -- True => Source; False => Iface
 104        -> Module
 105        -> RnEnv
 106        -> UniqSupply
 107        -> RnM _RealWorld r
 108        -> (r, Bag Error, Bag Warning)
 109
 110 initRn source mod env us do_rn
 111   = _runSST (
 112         newMutVarSST emptyBag                   `thenSST` \ occ_var ->
 113         newMutVarSST emptyImplicitEnv           `thenSST` \ imp_var ->
 114         newMutVarSST us                         `thenSST` \ us_var ->
 115         newMutVarSST (emptyBag,emptyBag)        `thenSST` \ errs_var ->
 116         let
 117             mode = if source then
 118                        RnSource occ_var
 119                    else
 120                        case builtinNameInfo of { (wiredin_fm, key_fm, _) ->
 121                        RnIface wiredin_fm key_fm imp_var }
 122
 123             rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
 124         in
 125         -- do the buisness
 126         do_rn rn_down                           `thenSST` \ res ->
 127
 128         -- grab errors and return
 129         readMutVarSST errs_var                  `thenSST` \ (warns,errs) ->
 130         returnSST (res, errs, warns)
 131     )
 132
 133 {-# INLINE thenRn #-}
 134 {-# INLINE thenRn_ #-}
 135 {-# INLINE returnRn #-}
 136 {-# INLINE andRn #-}
 137
 138 returnRn :: a -> RnMonad x s a
 139 thenRn   :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b
 140 thenRn_  :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b
 141 andRn    :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a
 142 mapRn    :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b]
 143 mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c])
 144
 145 returnRn v down  = returnSST v
 146 thenRn m k down  = m down `thenSST` \ r -> k r down
 147 thenRn_ m k down = m down `thenSST_` k down
 148
 149 andRn combiner m1 m2 down
 150   = m1 down `thenSST` \ res1 ->
 151     m2 down `thenSST` \ res2 ->
 152     returnSST (combiner res1 res2)
 153
 154 mapRn f []     = returnRn []
 155 mapRn f (x:xs)
 156   = f x         `thenRn` \ r ->
 157     mapRn f xs  `thenRn` \ rs ->
 158     returnRn (r:rs)
 159
 160 mapAndUnzipRn f [] = returnRn ([],[])
 161 mapAndUnzipRn f (x:xs)
 162   = f x                 `thenRn` \ (r1,  r2)  ->
 163     mapAndUnzipRn f xs  `thenRn` \ (rs1, rs2) ->
 164     returnRn (r1:rs1, r2:rs2)
 165
 166 mapAndUnzip3Rn f [] = returnRn ([],[],[])
 167 mapAndUnzip3Rn f (x:xs)
 168   = f x                 `thenRn` \ (r1,  r2,  r3)  ->
 169     mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
 170     returnRn (r1:rs1, r2:rs2, r3:rs3)
 171 \end{code}
 172
 173 For errors and warnings ...
 174 \begin{code}
 175 failButContinueRn :: a -> Error -> RnMonad x s a
 176 failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var)
 177   = readMutVarSST  errs_var                             `thenSST`  \ (warns,errs) ->
 178     writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
 179     returnSST res
 180
 181 warnAndContinueRn :: a -> Warning -> RnMonad x s a
 182 warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var)
 183   = readMutVarSST  errs_var                              `thenSST`  \ (warns,errs) ->
 184     writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
 185     returnSST res
 186
 187 addErrRn :: Error -> RnMonad x s ()
 188 addErrRn err = failButContinueRn () err
 189
 190 addErrIfRn :: Bool -> Error -> RnMonad x s ()
 191 addErrIfRn True err  = addErrRn err
 192 addErrIfRn False err = returnRn ()
 193
 194 addWarnRn :: Warning -> RnMonad x s ()
 195 addWarnRn warn = warnAndContinueRn () warn
 196
 197 addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
 198 addWarnIfRn True warn  = addWarnRn warn
 199 addWarnIfRn False warn = returnRn ()
 200 \end{code}
 201
 202
 203 \begin{code}
 204 getRnEnv :: RnMonad x s RnEnv
 205 getRnEnv (RnDown _ _ _ _ env _ _)
 206   = returnSST env
 207
 208 setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
 209 setExtraRn x m (RnDown _ mod locn mode env us errs)
 210   = m (RnDown x mod locn mode env us errs)
 211
 212 getExtraRn :: RnMonad x s x
 213 getExtraRn (RnDown x _ _ _ _ _ _)
 214   = returnSST x
 215
 216 getModuleRn :: RnMonad x s Module
 217 getModuleRn (RnDown _ mod _ _ _ _ _)
 218   = returnSST mod
 219
 220 pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a
 221 pushSrcLocRn locn m (RnDown x mod _ mode env us errs)
 222   = m (RnDown x mod locn mode env us errs)
 223
 224 getSrcLocRn :: RnMonad x s SrcLoc
 225 getSrcLocRn (RnDown _ _ locn _ _ _ _)
 226   = returnSST locn
 227
 228 getSourceRn :: RnMonad x s Bool
 229 getSourceRn (RnDown _ _ _ (RnSource _)    _ _ _) = returnSST True
 230 getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
 231
 232 getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
 233 getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
 234   = readMutVarSST occ_var
 235 getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _)
 236   = panic "getOccurrenceUpRn:RnIface"
 237
 238 getImplicitUpRn :: RnMonad x s ImplicitEnv
 239 getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
 240   = readMutVarSST imp_var
 241 getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
 242   = panic "getImplicitUpRn:RnIface"
 243 \end{code}
 244
 245 \begin{code}
 246 rnGetUnique :: RnMonad x s Unique
 247 rnGetUnique (RnDown _ _ _ _ _ us_var _)
 248   = get_unique us_var
 249
 250 rnGetUniques :: Int -> RnMonad x s [Unique]
 251 rnGetUniques n (RnDown _ _ _ _ _ us_var _)
 252   = get_uniques n us_var
 253
 254
 255 get_unique us_var
 256   = readMutVarSST us_var                        `thenSST` \ uniq_supply ->
 257     let
 258       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 259       uniq                      = getUnique uniq_s
 260     in
 261     writeMutVarSST us_var new_uniq_supply       `thenSST_`
 262     returnSST uniq
 263
 264 get_uniques n us_var
 265   = readMutVarSST us_var                        `thenSST` \ uniq_supply ->
 266     let
 267       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 268       uniqs                     = getUniques n uniq_s
 269     in
 270     writeMutVarSST us_var new_uniq_supply       `thenSST_`
 271     returnSST uniqs
 272
 273 snoc_bag_var add bag_var
 274   = readMutVarSST bag_var       `thenSST` \ bag ->
 275     writeMutVarSST bag_var (bag `snocBag` add)
 276
 277 \end{code}
 278
 279 *********************************************************
 280 *                                                       *
 281 \subsection{Making new names}
 282 *                                                       *
 283 *********************************************************
 284
 285 @newLocalNames@ takes a bunch of RdrNames, which are defined together
 286 in a group (eg a pattern or set of bindings), checks they are
 287 unqualified and distinct, and creates new Names for them.
 288
 289 \begin{code}
 290 newLocalNames :: String                 -- Documentation string
 291               -> [(RdrName, SrcLoc)]
 292               -> RnMonad x s [RnName]
 293
 294 newLocalNames str names_w_loc
 295   = mapRn (addWarnRn . negateNameWarn) negs     `thenRn_`
 296     mapRn (addErrRn . qualNameErr str) quals    `thenRn_`
 297     mapRn (addErrRn . dupNamesErr str) dups     `thenRn_`
 298     mkLocalNames these
 299   where
 300     negs  = filter ((== Unqual SLIT("negate")).fst) names_w_loc
 301     quals = filter (isQual.fst) names_w_loc
 302     (these, dups) = removeDups cmp_fst names_w_loc
 303     cmp_fst (a,_) (b,_) = cmp a b
 304 \end{code}
 305
 306 \begin{code}
 307 mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
 308 mkLocalNames names_w_locs
 309   = rnGetUniques (length names_w_locs)  `thenRn` \ uniqs ->
 310     returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs)
 311   where
 312     new_local uniq (Unqual str, srcloc)
 313       = mkRnName (mkLocalName uniq str srcloc)
 314 \end{code}
 315
 316
 317 *********************************************************
 318 *                                                       *
 319 \subsection{Looking up values}
 320 *                                                       *
 321 *********************************************************
 322
 323 Action to look up a value depends on the RnMode.
 324 \begin{description}
 325 \item[RnSource:]
 326 Lookup value in RnEnv, recording occurrence for non-local values found.
 327 If not found report error and return Unbound name.
 328 \item[RnIface:]
 329 Lookup value in RnEnv. If not found lookup in implicit name env.
 330 If not found create new implicit name, adding it to the implicit env.
 331 \end{description}
 332
 333 \begin{code}
 334 lookupValue      :: RdrName -> RnMonad x s RnName
 335 lookupConstr     :: RdrName -> RnMonad x s RnName
 336 lookupField      :: RdrName -> RnMonad x s RnName
 337 lookupClassOp    :: RnName  -> RdrName -> RnMonad x s RnName
 338
 339 lookupValue rdr
 340   = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
 341
 342 lookupConstr rdr
 343   = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
 344
 345 lookupField rdr
 346   = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
 347
 348 lookupClassOp cls rdr
 349   = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
 350
 351 -- Note: the lookup checks are only performed when renaming source
 352
 353 lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
 354   = case lookup env rdr of
 355         Just name | check name -> succ name
 356                   | otherwise  -> fail
 357         Nothing                -> fail
 358
 359   where
 360     succ name = if isRnLocal name || isRnWired name then
 361                     returnSST name
 362                 else
 363                     snoc_bag_var (name,rdr) occ_var `thenSST_`
 364                     returnSST name
 365     fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
 366
 367 lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
 368   = case lookup env rdr of
 369         Just name -> returnSST name
 370         Nothing   -> lookup_nonexisting_val b_names b_key imp_var us_var rdr
 371
 372 lookup_nonexisting_val (b_names,_) b_key imp_var us_var rdr
 373   = case rdr of
 374       Qual _ _ -> -- builtin things *don't* have Qual names
 375                   lookup_or_create_implicit_val b_key imp_var us_var rdr
 376
 377       Unqual n -> case (lookupFM b_names n) of
 378                     Nothing -> lookup_or_create_implicit_val b_key imp_var us_var rdr
 379                     Just xx -> returnSST xx
 380
 381 lookup_or_create_implicit_val b_key imp_var us_var rdr
 382   = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
 383     case lookupFM implicit_val_fm rdr of
 384         Just implicit -> returnSST implicit
 385         Nothing ->
 386           (case rdr of
 387              Qual _ _ -> get_unique us_var
 388              Unqual n -> case (lookupFM b_key n) of
 389                            Just (u,_) -> returnSST u
 390                            _          -> get_unique us_var
 391           )                                     `thenSST` \ uniq ->
 392           let
 393               implicit   = mkRnImplicit (mkImplicitName uniq rdr)
 394               new_val_fm = addToFM implicit_val_fm rdr implicit
 395           in
 396           writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
 397           returnSST implicit
 398 \end{code}
 399
 400
 401 \begin{code}
 402 lookupTyCon   :: RdrName -> RnMonad x s RnName
 403 lookupClass   :: RdrName -> RnMonad x s RnName
 404
 405 lookupTyCon rdr
 406   = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
 407
 408 lookupClass rdr
 409   = lookup_tc rdr isRnClass mkRnImplicitClass "class"
 410
 411 lookupTyConOrClass rdr
 412   = lookup_tc rdr isRnTyConOrClass
 413               (panic "lookupTC:mk_implicit") "class or type constructor"
 414
 415 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
 416   = case lookupTcRnEnv env rdr of
 417        Just name | check name -> succ name
 418                  | otherwise  -> fail
 419        Nothing                -> fail
 420   where
 421     succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
 422                 returnSST name
 423     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 424
 425 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
 426   = case lookupTcRnEnv env rdr of
 427         Just name | check name -> returnSST name
 428                   | otherwise  -> fail
 429         Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var rdr
 430   where
 431     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 432
 433 lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr
 434   = case rdr of
 435       Qual _ _ -> -- builtin things *don't* have Qual names
 436                   lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
 437
 438       Unqual n -> case (lookupFM b_names n) of
 439                     Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
 440                     Just xx -> returnSST xx
 441
 442 lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr
 443   = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
 444     case lookupFM implicit_tc_fm rdr of
 445         Just implicit | check implicit -> returnSST implicit
 446                       | otherwise      -> fail
 447         Nothing ->
 448           (case rdr of
 449              Qual _ _ -> get_unique us_var
 450              Unqual n -> case (lookupFM b_key n) of
 451                            Just (u,_) -> returnSST u
 452                            _          -> get_unique us_var
 453           )                                     `thenSST` \ uniq ->
 454           let
 455               implicit  = mk_implicit (mkImplicitName uniq rdr)
 456               new_tc_fm = addToFM implicit_tc_fm rdr implicit
 457           in
 458           writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
 459           returnSST implicit
 460 \end{code}
 461
 462
 463 @extendSS@ extends the scope; @extendSS2@ also removes the newly bound
 464 free vars from the result.
 465
 466 \begin{code}
 467 extendSS :: [RnName]                            -- Newly bound names
 468          -> RnMonad x s a
 469          -> RnMonad x s a
 470
 471 extendSS binders m down@(RnDown x mod locn mode env us errs)
 472   = (mapRn (addErrRn . shadowedNameWarn locn) dups `thenRn_`
 473      m) (RnDown x mod locn mode new_env us errs)
 474   where
 475     (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders
 476
 477 extendSS2 :: [RnName]                           -- Newly bound names
 478           -> RnMonad x s (a, UniqSet RnName)
 479           -> RnMonad x s (a, UniqSet RnName)
 480
 481 extendSS2 binders m
 482   = extendSS binders m `thenRn` \ (r, fvs) ->
 483     returnRn (r, fvs `minusUniqSet` (mkUniqSet binders))
 484 \end{code}
 485
 486 The free var set returned by @(extendSS binders m)@ is that returned
 487 by @m@, {\em minus} binders.
 488
 489
 490 *********************************************************
 491 *                                                       *
 492 \subsection{TyVarNamesEnv}
 493 *                                                       *
 494 *********************************************************
 495
 496 \begin{code}
 497 type TyVarNamesEnv = [(RdrName, RnName)]
 498
 499 nullTyVarNamesEnv :: TyVarNamesEnv
 500 nullTyVarNamesEnv = []
 501
 502 catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
 503 catTyVarNamesEnvs e1 e2 = e1 ++ e2
 504
 505 domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName]
 506 domTyVarNamesEnv env = map fst env
 507 \end{code}
 508
 509 @mkTyVarNamesEnv@ checks for duplicates, and complains if so.
 510
 511 \begin{code}
 512 mkTyVarNamesEnv
 513         :: SrcLoc
 514         -> [RdrName]                            -- The type variables
 515         -> RnMonad x s (TyVarNamesEnv,[RnName]) -- Environment and renamed tyvars
 516
 517 mkTyVarNamesEnv src_loc tyvars
 518   = newLocalNames "type variable"
 519          (tyvars `zip` repeat src_loc) `thenRn`  \ rn_tyvars ->
 520
 521          -- rn_tyvars may not be in the same order as tyvars, so we need some
 522          -- jiggery pokery to build the right tyvar env, and return the
 523          -- renamed tyvars in the original order.
 524     let tv_occ_name_pairs       = map tv_occ_name_pair rn_tyvars
 525         tv_env                  = map (lookup_occ_name tv_occ_name_pairs) tyvars
 526         rn_tyvars_in_orig_order = map snd tv_env
 527     in
 528     returnRn (tv_env, rn_tyvars_in_orig_order)
 529   where
 530     tv_occ_name_pair :: RnName -> (RdrName, RnName)
 531     tv_occ_name_pair rn_name = (getOccName rn_name, rn_name)
 532
 533     lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName)
 534     lookup_occ_name pairs tyvar_occ
 535       = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ)
 536 \end{code}
 537
 538 \begin{code}
 539 lookupTyVarName :: TyVarNamesEnv -> RdrName -> RnMonad x s RnName
 540 lookupTyVarName env occ
 541   = case (assocMaybe env occ) of
 542       Just name -> returnRn name
 543       Nothing   -> getSrcLocRn  `thenRn` \ loc ->
 544                    failButContinueRn (mkRnUnbound occ)
 545                        (unknownNameErr "type variable" occ loc)
 546 \end{code}
 547
 548
 549 \begin{code}
 550 fixIO :: (a -> IO a) -> IO a
 551 fixIO k s = let
 552                 result          = k loop s
 553                 (Right loop, _) = result
 554             in
 555             result
 556 \end{code}