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         ( 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
  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                        RnIface builtinNameMaps builtinKeysMap imp_var
 131
 132             rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
 133         in
 134         -- do the buisness
 135         do_rn rn_down                           `thenSST` \ res ->
 136
 137         -- grab errors and return
 138         readMutVarSST errs_var                  `thenSST` \ (warns,errs) ->
 139         returnSST (res, errs, warns)
 140     )
 141
 142 {-# INLINE thenRn #-}
 143 {-# INLINE thenRn_ #-}
 144 {-# INLINE returnRn #-}
 145 {-# INLINE andRn #-}
 146
 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])
 153
 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
 157
 158 andRn combiner m1 m2 down
 159   = m1 down `thenSST` \ res1 ->
 160     m2 down `thenSST` \ res2 ->
 161     returnSST (combiner res1 res2)
 162
 163 mapRn f []     = returnRn []
 164 mapRn f (x:xs)
 165   = f x         `thenRn` \ r ->
 166     mapRn f xs  `thenRn` \ rs ->
 167     returnRn (r:rs)
 168
 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)
 174
 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)
 180 \end{code}
 181
 182 For errors and warnings ...
 183 \begin{code}
 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_`
 188     returnSST res
 189
 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_`
 194     returnSST res
 195
 196 addErrRn :: Error -> RnMonad x s ()
 197 addErrRn err = failButContinueRn () err
 198
 199 addErrIfRn :: Bool -> Error -> RnMonad x s ()
 200 addErrIfRn True err  = addErrRn err
 201 addErrIfRn False err = returnRn ()
 202
 203 addWarnRn :: Warning -> RnMonad x s ()
 204 addWarnRn warn = warnAndContinueRn () warn
 205
 206 addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
 207 addWarnIfRn True warn  = addWarnRn warn
 208 addWarnIfRn False warn = returnRn ()
 209 \end{code}
 210
 211
 212 \begin{code}
 213 getRnEnv :: RnMonad x s RnEnv
 214 getRnEnv (RnDown _ _ _ _ env _ _)
 215   = returnSST env
 216
 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)
 220
 221 getExtraRn :: RnMonad x s x
 222 getExtraRn (RnDown x _ _ _ _ _ _)
 223   = returnSST x
 224
 225 getModuleRn :: RnMonad x s Module
 226 getModuleRn (RnDown _ mod _ _ _ _ _)
 227   = returnSST mod
 228
 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)
 232
 233 getSrcLocRn :: RnMonad x s SrcLoc
 234 getSrcLocRn (RnDown _ _ locn _ _ _ _)
 235   = returnSST locn
 236
 237 getSourceRn :: RnMonad x s Bool
 238 getSourceRn (RnDown _ _ _ (RnSource _)    _ _ _) = returnSST True
 239 getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
 240
 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"
 246
 247 getImplicitUpRn :: RnMonad x s ImplicitEnv
 248 getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
 249   = readMutVarSST imp_var
 250 getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
 251   = panic "getImplicitUpRn:RnIface"
 252 \end{code}
 253
 254 \begin{code}
 255 rnGetUnique :: RnMonad x s Unique
 256 rnGetUnique (RnDown _ _ _ _ _ us_var _)
 257   = get_unique us_var
 258
 259 rnGetUniques :: Int -> RnMonad x s [Unique]
 260 rnGetUniques n (RnDown _ _ _ _ _ us_var _)
 261   = get_uniques n us_var
 262
 263
 264 get_unique us_var
 265   = readMutVarSST us_var                        `thenSST` \ uniq_supply ->
 266     let
 267       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 268       uniq                      = getUnique uniq_s
 269     in
 270     writeMutVarSST us_var new_uniq_supply       `thenSST_`
 271     returnSST uniq
 272
 273 get_uniques n us_var
 274   = readMutVarSST us_var                        `thenSST` \ uniq_supply ->
 275     let
 276       (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
 277       uniqs                     = getUniques n uniq_s
 278     in
 279     writeMutVarSST us_var new_uniq_supply       `thenSST_`
 280     returnSST uniqs
 281
 282 snoc_bag_var add bag_var
 283   = readMutVarSST bag_var       `thenSST` \ bag ->
 284     writeMutVarSST bag_var (bag `snocBag` add)
 285
 286 \end{code}
 287
 288 *********************************************************
 289 *                                                       *
 290 \subsection{Making new names}
 291 *                                                       *
 292 *********************************************************
 293
 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.
 297
 298 \begin{code}
 299 newLocalNames :: String                 -- Documentation string
 300               -> [(RdrName, SrcLoc)]
 301               -> RnMonad x s [RnName]
 302
 303 newLocalNames str names_w_loc
 304   = mapRn (addErrRn . qualNameErr str) quals    `thenRn_`
 305     mapRn (addErrRn . dupNamesErr str) dups     `thenRn_`
 306     mkLocalNames these
 307   where
 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
 311 \end{code}
 312
 313 \begin{code}
 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)
 318   where
 319     new_local uniq (Unqual str, srcloc)
 320       = mkRnName (mkLocalName uniq str False{-emph names-} srcloc)
 321 \end{code}
 322
 323
 324 *********************************************************
 325 *                                                       *
 326 \subsection{Looking up values}
 327 *                                                       *
 328 *********************************************************
 329
 330 Action to look up a value depends on the RnMode.
 331 \begin{description}
 332 \item[RnSource:]
 333 Lookup value in RnEnv, recording occurrence for non-local values found.
 334 If not found report error and return Unbound name.
 335 \item[RnIface:]
 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.
 338 \end{description}
 339
 340 \begin{code}
 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
 345
 346 lookupValue rdr
 347   = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
 348
 349 lookupConstr rdr
 350   = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
 351
 352 lookupField rdr
 353   = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
 354
 355 lookupClassOp cls rdr
 356   = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
 357
 358 -- Note: the lookup checks are only performed when renaming source
 359
 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
 363                   | otherwise  -> fail
 364         Nothing                -> fail
 365
 366   where
 367     succ name = if isRnLocal name || isRnWired name then
 368                     returnSST name
 369                 else
 370                     snoc_bag_var (name,rdr) occ_var `thenSST_`
 371                     returnSST name
 372     fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
 373
 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)
 379                      Qual m n ->
 380                        lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n)
 381
 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
 386
 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
 391         Nothing ->
 392           (case (lookupFM b_key orig) of
 393                 Just (u,_) -> returnSST u
 394                 _          -> get_unique us_var
 395           )                                                     `thenSST` \ uniq ->
 396           let
 397               implicit   = mkRnImplicit (mkImplicitName uniq orig)
 398               new_val_fm = addToFM implicit_val_fm orig implicit
 399           in
 400           writeMutVarSST imp_var (new_val_fm, implicit_tc_fm)   `thenSST_`
 401           returnSST implicit
 402 \end{code}
 403
 404
 405 \begin{code}
 406 lookupTyCon   :: RdrName -> RnMonad x s RnName
 407 lookupClass   :: RdrName -> RnMonad x s RnName
 408
 409 lookupTyCon rdr
 410   = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
 411
 412 lookupClass rdr
 413   = lookup_tc rdr isRnClass mkRnImplicitClass "class"
 414
 415 lookupTyConOrClass rdr
 416   = lookup_tc rdr isRnTyConOrClass
 417               (panic "lookupTC:mk_implicit") "class or type constructor"
 418
 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
 422                  | otherwise  -> fail
 423        Nothing                -> fail
 424   where
 425     succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
 426                 returnSST name
 427     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 428
 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
 432                   | otherwise  -> fail
 433         Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var (OrigName m n)
 434   where
 435     fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
 436
 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
 442
 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
 447                       | otherwise      -> fail
 448         Nothing ->
 449           (case (lookupFM b_key orig) of
 450                 Just (u,_) -> returnSST u
 451                 _          -> get_unique us_var
 452           )                                                     `thenSST` \ uniq ->
 453           let
 454               implicit  = mk_implicit (mkImplicitName uniq orig)
 455               new_tc_fm = addToFM implicit_tc_fm orig implicit
 456           in
 457           writeMutVarSST imp_var (implicit_val_fm, new_tc_fm)   `thenSST_`
 458           returnSST implicit
 459 \end{code}
 460
 461
 462 @extendSS@ extends the scope; @extendSS2@ also removes the newly bound
 463 free vars from the result.
 464
 465 \begin{code}
 466 extendSS :: [RnName]                            -- Newly bound names
 467          -> RnMonad x s a
 468          -> RnMonad x s a
 469
 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)
 473   where
 474     (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders
 475
 476 extendSS2 :: [RnName]                           -- Newly bound names
 477           -> RnMonad x s (a, UniqSet RnName)
 478           -> RnMonad x s (a, UniqSet RnName)
 479
 480 extendSS2 binders m
 481   = extendSS binders m `thenRn` \ (r, fvs) ->
 482     returnRn (r, fvs `minusUniqSet` (mkUniqSet binders))
 483 \end{code}
 484
 485 The free var set returned by @(extendSS binders m)@ is that returned
 486 by @m@, {\em minus} binders.
 487
 488
 489 *********************************************************
 490 *                                                       *
 491 \subsection{TyVarNamesEnv}
 492 *                                                       *
 493 *********************************************************
 494
 495 \begin{code}
 496 type TyVarNamesEnv = [(RdrName, RnName)]
 497
 498 nullTyVarNamesEnv :: TyVarNamesEnv
 499 nullTyVarNamesEnv = []
 500
 501 catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
 502 catTyVarNamesEnvs e1 e2 = e1 ++ e2
 503
 504 domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName]
 505 domTyVarNamesEnv env = map fst env
 506 \end{code}
 507
 508 @mkTyVarNamesEnv@ checks for duplicates, and complains if so.
 509
 510 \begin{code}
 511 mkTyVarNamesEnv
 512         :: SrcLoc
 513         -> [RdrName]                            -- The type variables
 514         -> RnMonad x s (TyVarNamesEnv,[RnName]) -- Environment and renamed tyvars
 515
 516 mkTyVarNamesEnv src_loc tyvars
 517   = newLocalNames "type variable"
 518          (tyvars `zip` repeat src_loc) `thenRn`  \ rn_tyvars ->
 519
 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
 526     in
 527     returnRn (tv_env, rn_tyvars_in_orig_order)
 528   where
 529     tv_occ_name_pair :: RnName -> (RdrName, RnName)
 530     tv_occ_name_pair rn_name = (getOccName rn_name, rn_name)
 531
 532     lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName)
 533     lookup_occ_name pairs tyvar_occ
 534       = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ)
 535 \end{code}
 536
 537 \begin{code}
 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)
 545 \end{code}
 546
 547
 548 \begin{code}
 549 #if __GLASGOW_HASKELL__ >= 200
 550     -- can get it from GHCbase
 551 #else
 552 fixIO :: (a -> IO a) -> IO a
 553
 554 fixIO k s = let
 555                 result          = k loop s
 556                 (Right loop, _) = result
 557             in
 558             result
 559 #endif
 560 \end{code}
 561
 562 *********************************************************
 563 *                                                       *
 564 \subsection{Errors used in RnMonad}
 565 *                                                       *
 566 *********************************************************
 567
 568 \begin{code}
 569 unknownNameErr descriptor name locn
 570   = addShortErrLocLine locn $ \ sty ->
 571     ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name]
 572
 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 "'"]
 577
 578 shadowedNameWarn locn shadow
 579   = addShortWarnLocLine locn $ \ sty ->
 580     ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow]
 581 \end{code}