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         SYN_IE(RnMonad), SYN_IE(RnM), SYN_IE(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, SYN_IE(ImplicitEnv), emptyImplicitEnv,
  20         rnGetUnique, rnGetUniques,
  21
  22         newLocalNames,
  23         lookupValue, lookupConstr, lookupField, lookupClassOp,
  24         lookupTyCon, lookupClass, lookupTyConOrClass,
  25         extendSS2, extendSS,
  26
  27         SYN_IE(TyVarNamesEnv), mkTyVarNamesEnv, domTyVarNamesEnv,
  28         lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
  29
  30         fixIO
  31     ) where
  32
  33 IMP_Ubiq(){-uitous-}
  34 IMPORT_1_3(GHCbase(fixIO))
  35
  36 import SST
  37
  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
  47                         )
  48
  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)
  53                         )
  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,
  58                           getOccName, pprNonSym
  59                         )
  60 import PrelInfo         ( builtinNameInfo, 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 )
  70 import Util
  71
  72 infixr 9 `thenRn`, `thenRn_`
  73 \end{code}
  74
  75 \begin{code}
  76 type RnM s r       = RnMonad () s r
  77 type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
  78
  79 type RnMonad x s r = RnDown x s -> SST s r
  80
  81 data RnDown x s
  82   = RnDown
  83         x
  84         Module                          -- Module name
  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
  90                        Bag Error))
  91
  92 data RnMode s
  93  = RnSource (MutableVar s (Bag (RnName, RdrName)))
  94         -- Renaming source; returning occurences
  95
  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.
 100
 101 type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName RnName)
 102 emptyImplicitEnv :: ImplicitEnv
 103 emptyImplicitEnv = (emptyFM, emptyFM)
 104
 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
 109 #else
 110 # define REAL_WORLD _RealWorld
 111 #endif
 112
 113 initRn :: Bool          -- True => Source; False => Iface
 114        -> Module
 115        -> RnEnv
 116        -> UniqSupply
 117        -> RnM REAL_WORLD r
 118        -> (r, Bag Error, Bag Warning)
 119
 120 initRn source mod env us do_rn
 121   = runSST (
 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 ->
 126         let
 127             mode = if source then
 128                        RnSource occ_var
 129                    else
 130                        case builtinNameInfo of { (wiredin_fm, key_fm, _) ->
 131                        RnIface wiredin_fm key_fm imp_var }
 132
 133             rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
 134         in
 135         -- do the buisness
 136         do_rn rn_down                           `thenSST` \ res ->
 137
 138         -- grab errors and return
 139         readMutVarSST errs_var                  `thenSST` \ (warns,errs) ->
 140         returnSST (res, errs, warns)
 141     )
 142
 143 {-# INLINE thenRn #-}
 144 {-# INLINE thenRn_ #-}
 145 {-# INLINE returnRn #-}
 146 {-# INLINE andRn #-}
 147
 148 returnRn :: a -> RnMonad x s a
 149 thenRn   :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b
 150 thenRn_  :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b
 151 andRn    :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a
 152 mapRn    :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b]
 153 mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c])
 154
 155 returnRn v down  = returnSST v
 156 thenRn m k down  = m down `thenSST` \ r -> k r down
 157 thenRn_ m k down = m down `thenSST_` k down
 158
 159 andRn combiner m1 m2 down
 160   = m1 down `thenSST` \ res1 ->
 161     m2 down `thenSST` \ res2 ->
 162     returnSST (combiner res1 res2)
 163
 164 mapRn f []     = returnRn []
 165 mapRn f (x:xs)
 166   = f x         `thenRn` \ r ->
 167     mapRn f xs  `thenRn` \ rs ->
 168     returnRn (r:rs)
 169
 170 mapAndUnzipRn f [] = returnRn ([],[])
 171 mapAndUnzipRn f (x:xs)
 172   = f x                 `thenRn` \ (r1,  r2)  ->
 173     mapAndUnzipRn f xs  `thenRn` \ (rs1, rs2) ->
 174     returnRn (r1:rs1, r2:rs2)
 175
 176 mapAndUnzip3Rn f [] = returnRn ([],[],[])
 177 mapAndUnzip3Rn f (x:xs)
 178   = f x                 `thenRn` \ (r1,  r2,  r3)  ->
 179     mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) ->
 180     returnRn (r1:rs1, r2:rs2, r3:rs3)
 181 \end{code}
 182
 183 For errors and warnings ...
 184 \begin{code}
 185 failButContinueRn :: a -> Error -> RnMonad x s a
 186 failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var)
 187   = readMutVarSST  errs_var                             `thenSST`  \ (warns,errs) ->
 188     writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
 189     returnSST res
 190
 191 warnAndContinueRn :: a -> Warning -> RnMonad x s a
 192 warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var)
 193   = readMutVarSST  errs_var                              `thenSST`  \ (warns,errs) ->
 194     writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
 195     returnSST res
 196
 197 addErrRn :: Error -> RnMonad x s ()
 198 addErrRn err = failButContinueRn () err
 199
 200 addErrIfRn :: Bool -> Error -> RnMonad x s ()
 201 addErrIfRn True err  = addErrRn err
 202 addErrIfRn False err = returnRn ()
 203
 204 addWarnRn :: Warning -> RnMonad x s ()
 205 addWarnRn warn = warnAndContinueRn () warn
 206
 207 addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
 208 addWarnIfRn True warn  = addWarnRn warn
 209 addWarnIfRn False warn = returnRn ()
 210 \end{code}
 211
 212
 213 \begin{code}
 214 getRnEnv :: RnMonad x s RnEnv
 215 getRnEnv (RnDown _ _ _ _ env _ _)
 216   = returnSST env
 217
 218 setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
 219 setExtraRn x m (RnDown _ mod locn mode env us errs)
 220   = m (RnDown x mod locn mode env us errs)
 221
 222 getExtraRn :: RnMonad x s x
 223 getExtraRn (RnDown x _ _ _ _ _ _)
 224   = returnSST x
 225
 226 getModuleRn :: RnMonad x s Module
 227 getModuleRn (RnDown _ mod _ _ _ _ _)
 228   = returnSST mod
 229
 230 pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a
 231 pushSrcLocRn locn m (RnDown x mod _ mode env us errs)
 232   = m (RnDown x mod locn mode env us errs)
 233
 234 getSrcLocRn :: RnMonad x s SrcLoc
 235 getSrcLocRn (RnDown _ _ locn _ _ _ _)
 236   = returnSST locn
 237
 238 getSourceRn :: RnMonad x s Bool
 239 getSourceRn (RnDown _ _ _ (RnSource _)    _ _ _) = returnSST True
 240 getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
 241
 242 getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
 243 getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
 244   = readMutVarSST occ_var
 245 getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _)
 246   = panic "getOccurrenceUpRn:RnIface"
 247
 248 getImplicitUpRn :: RnMonad x s ImplicitEnv
 249 getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
 250   = readMutVarSST imp_var
 251 getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
 252   = panic "getImplicitUpRn:RnIface"
 253 \end{code}
 254
 255 \begin{code}
 256 rnGetUnique :: RnMonad x s Unique
 257 rnGetUnique (RnDown _ _ _ _ _ us_var _)
 258   = get_unique us_var
 259
 260 rnGetUniques :: Int -> RnMonad x s [Unique]
 261 rnGetUniques n (RnDown _ _ _ _ _ us_var _)
 262   = get_uniques n us_var
 263
 264
 265 get_unique us_var
 266   = readMutVarSST us_var                        `thenSST` \ uniq_supply ->
 267     let
 268       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 269       uniq                      = getUnique uniq_s
 270     in
 271     writeMutVarSST us_var new_uniq_supply       `thenSST_`
 272     returnSST uniq
 273
 274 get_uniques n us_var
 275   = readMutVarSST us_var                        `thenSST` \ uniq_supply ->
 276     let
 277       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 278       uniqs                     = getUniques n uniq_s
 279     in
 280     writeMutVarSST us_var new_uniq_supply       `thenSST_`
 281     returnSST uniqs
 282
 283 snoc_bag_var add bag_var
 284   = readMutVarSST bag_var       `thenSST` \ bag ->
 285     writeMutVarSST bag_var (bag `snocBag` add)
 286
 287 \end{code}
 288
 289 *********************************************************
 290 *                                                       *
 291 \subsection{Making new names}
 292 *                                                       *
 293 *********************************************************
 294
 295 @newLocalNames@ takes a bunch of RdrNames, which are defined together
 296 in a group (eg a pattern or set of bindings), checks they are
 297 unqualified and distinct, and creates new Names for them.
 298
 299 \begin{code}
 300 newLocalNames :: String                 -- Documentation string
 301               -> [(RdrName, SrcLoc)]
 302               -> RnMonad x s [RnName]
 303
 304 newLocalNames str names_w_loc
 305   = mapRn (addErrRn . qualNameErr str) quals    `thenRn_`
 306     mapRn (addErrRn . dupNamesErr str) dups     `thenRn_`
 307     mkLocalNames these
 308   where
 309     quals = filter (isQual.fst) names_w_loc
 310     (these, dups) = removeDups cmp_fst names_w_loc
 311     cmp_fst (a,_) (b,_) = cmp a b
 312 \end{code}
 313
 314 \begin{code}
 315 mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
 316 mkLocalNames names_w_locs
 317   = rnGetUniques (length names_w_locs)  `thenRn` \ uniqs ->
 318     returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs)
 319   where
 320     new_local uniq (Unqual str, srcloc)
 321       = mkRnName (mkLocalName uniq str False{-emph names-} srcloc)
 322 \end{code}
 323
 324
 325 *********************************************************
 326 *                                                       *
 327 \subsection{Looking up values}
 328 *                                                       *
 329 *********************************************************
 330
 331 Action to look up a value depends on the RnMode.
 332 \begin{description}
 333 \item[RnSource:]
 334 Lookup value in RnEnv, recording occurrence for non-local values found.
 335 If not found report error and return Unbound name.
 336 \item[RnIface:]
 337 Lookup value in RnEnv. If not found lookup in implicit name env.
 338 If not found create new implicit name, adding it to the implicit env.
 339 \end{description}
 340
 341 \begin{code}
 342 lookupValue      :: RdrName -> RnMonad x s RnName
 343 lookupConstr     :: RdrName -> RnMonad x s RnName
 344 lookupField      :: RdrName -> RnMonad x s RnName
 345 lookupClassOp    :: RnName  -> RdrName -> RnMonad x s RnName
 346
 347 lookupValue rdr
 348   = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
 349
 350 lookupConstr rdr
 351   = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
 352
 353 lookupField rdr
 354   = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
 355
 356 lookupClassOp cls rdr
 357   = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
 358
 359 -- Note: the lookup checks are only performed when renaming source
 360
 361 lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
 362   = case lookup env rdr of
 363         Just name | check name -> succ name
 364                   | otherwise  -> fail
 365         Nothing                -> fail
 366
 367   where
 368     succ name = if isRnLocal name || isRnWired name then
 369                     returnSST name
 370                 else
 371                     snoc_bag_var (name,rdr) occ_var `thenSST_`
 372                     returnSST name
 373     fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
 374
 375 lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
 376   = case lookup env rdr of
 377       Just name -> returnSST name
 378       Nothing   -> case rdr of
 379                      Unqual n -> panic ("lookup_val:"++ _UNPK_ n)
 380                      Qual m n ->
 381                        lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n)
 382
 383 lookup_nonexisting_val (b_names,_) b_key imp_var us_var orig
 384   = case (lookupFM b_names orig) of
 385       Just xx -> returnSST xx
 386       Nothing -> lookup_or_create_implicit_val b_key imp_var us_var orig
 387
 388 lookup_or_create_implicit_val b_key imp_var us_var orig
 389   = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
 390     case (lookupFM implicit_val_fm orig) of
 391         Just implicit -> returnSST implicit
 392         Nothing ->
 393           (case (lookupFM b_key orig) of
 394                 Just (u,_) -> returnSST u
 395                 _          -> get_unique us_var
 396           )                                                     `thenSST` \ uniq ->
 397           let
 398               implicit   = mkRnImplicit (mkImplicitName uniq orig)
 399               new_val_fm = addToFM implicit_val_fm orig implicit
 400           in
 401           writeMutVarSST imp_var (new_val_fm, implicit_tc_fm)   `thenSST_`
 402           returnSST implicit
 403 \end{code}
 404
 405
 406 \begin{code}
 407 lookupTyCon   :: RdrName -> RnMonad x s RnName
 408 lookupClass   :: RdrName -> RnMonad x s RnName
 409
 410 lookupTyCon rdr
 411   = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
 412
 413 lookupClass rdr
 414   = lookup_tc rdr isRnClass mkRnImplicitClass "class"
 415
 416 lookupTyConOrClass rdr
 417   = lookup_tc rdr isRnTyConOrClass
 418               (panic "lookupTC:mk_implicit") "class or type constructor"
 419
 420 lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
 421   = case lookupTcRnEnv env rdr of
 422        Just name | check name -> succ name
 423                  | otherwise  -> fail
 424        Nothing                -> fail
 425   where
 426     succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
 427                 returnSST name
 428     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 429
 430 lookup_tc rdr@(Qual m n) check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
 431   = case lookupTcRnEnv env rdr of
 432         Just name | check name -> returnSST name
 433                   | otherwise  -> fail
 434         Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var (OrigName m n)
 435   where
 436     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 437
 438 lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var orig--@(OrigName m n)
 439   = --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]]) $
 440     case (lookupFM b_names orig) of
 441       Just xx -> returnSST xx
 442       Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
 443
 444 lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
 445   = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
 446     case (lookupFM implicit_tc_fm orig) of
 447         Just implicit | check implicit -> returnSST implicit
 448                       | otherwise      -> fail
 449         Nothing ->
 450           (case (lookupFM b_key orig) of
 451                 Just (u,_) -> returnSST u
 452                 _          -> get_unique us_var
 453           )                                                     `thenSST` \ uniq ->
 454           let
 455               implicit  = mk_implicit (mkImplicitName uniq orig)
 456               new_tc_fm = addToFM implicit_tc_fm orig 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 #if __GLASGOW_HASKELL__ >= 200
 551     -- can get it from GHCbase
 552 #else
 553 fixIO :: (a -> IO a) -> IO a
 554
 555 fixIO k s = let
 556                 result          = k loop s
 557                 (Right loop, _) = result
 558             in
 559             result
 560 #endif
 561 \end{code}
 562
 563 *********************************************************
 564 *                                                       *
 565 \subsection{Errors used in RnMonad}
 566 *                                                       *
 567 *********************************************************
 568
 569 \begin{code}
 570 unknownNameErr descriptor name locn
 571   = addShortErrLocLine locn $ \ sty ->
 572     ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name]
 573
 574 badClassOpErr clas op locn
 575   = addErrLoc locn "" $ \ sty ->
 576     ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `",
 577               ppr sty clas, ppStr "'"]
 578
 579 shadowedNameWarn locn shadow
 580   = addShortWarnLocLine locn $ \ sty ->
 581     ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow]
 582 \end{code}