ghc/compiler/rename/RnPass4.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnPass4]{Fourth of the renaming passes}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnPass4 ( rnModule, rnPolyType, rnGenPragmas ) where
  10
  11 import Ubiq{-uitous-}
  12 import RnLoop -- *check* the RnPass4/RnExpr4/RnBinds4 loop-breaking
  13
  14 import HsSyn
  15 import RdrHsSyn
  16 import RnHsSyn
  17 import HsPragmas        -- all of it
  18 import HsCore           -- all of it
  19 import RnMonad4
  20
  21 import Class            ( derivableClassKeys )
  22 import Maybes           ( maybeToBool, catMaybes )
  23 import Name             ( Name(..) )
  24 import Outputable       ( Outputable(..), isAvarid )
  25 import Pretty           ( ppHang, ppStr, ppCat, ppAboves )
  26 import ProtoName        ( eqProtoName, elemProtoNames, ProtoName{-instance-} )
  27 import RnBinds4         ( rnTopBinds, rnMethodBinds )
  28 import SrcLoc           ( SrcLoc{-instance-} )
  29 import Unique           ( Unique{-instances-} )
  30 import UniqSet          ( UniqSet(..) )
  31 import Util             ( isIn, panic, assertPanic )
  32 \end{code}
  33
  34 This pass `renames' the module+imported info, simultaneously
  35 performing dependency analysis. It also does the following error
  36 checks:
  37 \begin{enumerate}
  38 \item
  39 Checks that tyvars are used properly. This includes checking
  40 for undefined tyvars, and tyvars in contexts that are ambiguous.
  41 \item
  42 Checks that local variables are defined.
  43 \end{enumerate}
  44
  45 \begin{code}
  46 rnModule :: ProtoNameHsModule -> Rn4M RenamedHsModule
  47
  48 rnModule (HsModule mod_name exports _ fixes ty_decls specdata_sigs
  49             class_decls inst_decls specinst_sigs defaults
  50             binds int_sigs src_loc)
  51
  52   = pushSrcLocRn4 src_loc                         (
  53
  54     mapRn4 rnTyDecl         ty_decls        `thenRn4` \ new_ty_decls ->
  55     mapRn4 rnSpecDataSig    specdata_sigs   `thenRn4` \ new_specdata_sigs ->
  56     mapRn4 rnClassDecl      class_decls     `thenRn4` \ new_class_decls ->
  57     mapRn4 rnInstDecl       inst_decls      `thenRn4` \ new_inst_decls ->
  58     mapRn4 rnSpecInstSig    specinst_sigs   `thenRn4` \ new_specinst_sigs ->
  59     rnDefaultDecl           defaults        `thenRn4` \ new_defaults ->
  60     rnTopBinds binds                        `thenRn4` \ new_binds ->
  61     mapRn4 rnIntSig         int_sigs        `thenRn4` \ new_int_sigs ->
  62     rnFixes fixes                           `thenRn4` \ new_fixes ->
  63     rnExports exports                       `thenRn4` \ new_exports ->
  64
  65     returnRn4 (HsModule mod_name
  66                 new_exports [{-imports finally clobbered-}] new_fixes
  67                 new_ty_decls new_specdata_sigs new_class_decls
  68                 new_inst_decls new_specinst_sigs new_defaults
  69                 new_binds new_int_sigs src_loc)
  70     )
  71
  72 rnExports Nothing = returnRn4 Nothing
  73 rnExports (Just exp_list)
  74   = returnRn4 (Just (_trace "rnExports:trashing exports" []))
  75 \end{code}
  76
  77 %*********************************************************
  78 %*                                                      *
  79 \subsection{Type declarations}
  80 %*                                                      *
  81 %*********************************************************
  82
  83 @rnTyDecl@ uses the `global name function' to create a new type
  84 declaration in which local names have been replaced by their original
  85 names, reporting any unknown names.
  86
  87 Renaming type variables is a pain. Because they now contain uniques,
  88 it is necessary to pass in an association list which maps a parsed
  89 tyvar to its Name representation. In some cases (type signatures of
  90 values), it is even necessary to go over the type first in order to
  91 get the set of tyvars used by it, make an assoc list, and then go over
  92 it again to rename the tyvars! However, we can also do some scoping
  93 checks at the same time.
  94
  95 \begin{code}
  96 rnTyDecl :: ProtoNameTyDecl -> Rn4M RenamedTyDecl
  97
  98 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
  99   = pushSrcLocRn4 src_loc                       (
 100     lookupTyCon tycon                 `thenRn4` \ tycon' ->
 101     mkTyVarNamesEnv src_loc tyvars    `thenRn4` \ (tv_env, tyvars') ->
 102     rnContext tv_env context          `thenRn4` \ context' ->
 103     rnConDecls tv_env False condecls `thenRn4` \ condecls' ->
 104     rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' ->
 105     recoverQuietlyRn4 (DataPragmas [] []) (
 106         rnDataPragmas tv_env pragmas
 107     )                                 `thenRn4` \ pragmas' ->
 108     returnRn4 (TyData context' tycon' tyvars' condecls' derivings' pragmas' src_loc)
 109     )
 110
 111 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
 112   = pushSrcLocRn4 src_loc                       (
 113     lookupTyCon tycon                 `thenRn4` \ tycon' ->
 114     mkTyVarNamesEnv src_loc tyvars    `thenRn4` \ (tv_env, tyvars') ->
 115     rnContext tv_env context          `thenRn4` \ context' ->
 116     rnConDecls tv_env False condecl   `thenRn4` \ condecl' ->
 117     rn_derivs tycon' src_loc derivings `thenRn4` \ derivings' ->
 118     recoverQuietlyRn4 (DataPragmas [] []) (
 119         rnDataPragmas tv_env pragmas
 120     )                                 `thenRn4` \ pragmas' ->
 121     returnRn4 (TyNew context' tycon' tyvars' condecl' derivings' pragmas' src_loc)
 122     )
 123
 124 rnTyDecl (TySynonym name tyvars ty src_loc)
 125   = pushSrcLocRn4 src_loc                     (
 126     lookupTyCon name                `thenRn4` \ name' ->
 127     mkTyVarNamesEnv src_loc tyvars  `thenRn4` \ (tv_env, tyvars') ->
 128     rnMonoType False{-no invisible types-} tv_env ty
 129                                     `thenRn4` \ ty' ->
 130     returnRn4 (TySynonym name' tyvars' ty' src_loc)
 131     )
 132
 133 rn_derivs tycon2 locn Nothing -- derivs not specified
 134   = returnRn4 Nothing
 135
 136 rn_derivs tycon2 locn (Just ds)
 137   = mapRn4 (rn_deriv tycon2 locn) ds `thenRn4` \ derivs ->
 138     returnRn4 (Just derivs)
 139   where
 140     rn_deriv tycon2 locn clas
 141       = lookupClass clas            `thenRn4` \ clas_name ->
 142         case clas_name of
 143           ClassName key _ _ | key `is_elem` derivableClassKeys
 144             -> returnRn4 clas_name
 145           _ -> addErrRn4 (derivingNonStdClassErr clas locn) `thenRn4_`
 146                returnRn4 clas_name
 147       where
 148         is_elem = isIn "rn_deriv"
 149 \end{code}
 150
 151 @rnConDecls@ uses the `global name function' to create a new
 152 constructor in which local names have been replaced by their original
 153 names, reporting any unknown names.
 154
 155 \begin{code}
 156 rnConDecls :: TyVarNamesEnv
 157             -> Bool                 -- True <=> allowed to see invisible data-cons
 158             -> [ProtoNameConDecl]
 159             -> Rn4M [RenamedConDecl]
 160
 161 rnConDecls tv_env invisibles_allowed con_decls
 162   = mapRn4 rn_decl con_decls
 163   where
 164     lookup_fn
 165       = if invisibles_allowed
 166         then lookupValueEvenIfInvisible
 167         else lookupValue
 168
 169     rn_decl (ConDecl name tys src_loc)
 170       = pushSrcLocRn4 src_loc                     (
 171         lookup_fn name          `thenRn4` \ new_name ->
 172         mapRn4 rn_bang_ty tys   `thenRn4` \ new_tys  ->
 173         returnRn4 (ConDecl new_name new_tys src_loc)
 174         )
 175
 176     rn_decl (ConOpDecl ty1 op ty2 src_loc)
 177       = pushSrcLocRn4 src_loc                     (
 178         lookup_fn op    `thenRn4` \ new_op  ->
 179         rn_bang_ty ty1  `thenRn4` \ new_ty1 ->
 180         rn_bang_ty ty2  `thenRn4` \ new_ty2 ->
 181         returnRn4 (ConOpDecl new_ty1 new_op new_ty2 src_loc)
 182         )
 183
 184     rn_decl (NewConDecl name ty src_loc)
 185       = pushSrcLocRn4 src_loc                     (
 186         lookup_fn name          `thenRn4` \ new_name ->
 187         rn_mono_ty ty           `thenRn4` \ new_ty  ->
 188         returnRn4 (NewConDecl new_name new_ty src_loc)
 189         )
 190
 191     rn_decl (RecConDecl con fields src_loc)
 192       = panic "rnConDecls:RecConDecl"
 193
 194     ----------
 195     rn_mono_ty = rnMonoType invisibles_allowed tv_env
 196
 197     rn_bang_ty (Banged ty)
 198       = rn_mono_ty ty `thenRn4` \ new_ty ->
 199         returnRn4 (Banged new_ty)
 200     rn_bang_ty (Unbanged ty)
 201       = rn_mono_ty ty `thenRn4` \ new_ty ->
 202         returnRn4 (Unbanged new_ty)
 203 \end{code}
 204
 205 %*********************************************************
 206 %*                                                      *
 207 \subsection{SPECIALIZE data pragmas}
 208 %*                                                      *
 209 %*********************************************************
 210
 211 \begin{code}
 212 rnSpecDataSig :: ProtoNameSpecDataSig
 213               -> Rn4M RenamedSpecDataSig
 214
 215 rnSpecDataSig (SpecDataSig tycon ty src_loc)
 216   = pushSrcLocRn4 src_loc               (
 217     let
 218         tyvars = extractMonoTyNames eqProtoName ty
 219     in
 220     mkTyVarNamesEnv src_loc tyvars      `thenRn4` \ (tv_env,_) ->
 221     lookupTyCon tycon                   `thenRn4` \ tycon' ->
 222     rnMonoType False tv_env ty          `thenRn4` \ ty' ->
 223     returnRn4 (SpecDataSig tycon' ty' src_loc)
 224     )
 225 \end{code}
 226
 227 %*********************************************************
 228 %*                                                      *
 229 \subsection{Class declarations}
 230 %*                                                      *
 231 %*********************************************************
 232
 233 @rnClassDecl@ uses the `global name function' to create a new
 234 class declaration in which local names have been replaced by their
 235 original names, reporting any unknown names.
 236
 237 \begin{code}
 238 rnClassDecl :: ProtoNameClassDecl -> Rn4M RenamedClassDecl
 239
 240 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
 241   = pushSrcLocRn4 src_loc                         (
 242     mkTyVarNamesEnv src_loc [tyvar]     `thenRn4` \ (tv_env, [tyvar']) ->
 243     rnContext tv_env context            `thenRn4` \ context' ->
 244     lookupClass cname                   `thenRn4` \ cname' ->
 245     mapRn4 (rn_op cname' tv_env) sigs   `thenRn4` \ sigs' ->
 246     rnMethodBinds cname' mbinds         `thenRn4` \ mbinds' ->
 247     recoverQuietlyRn4 NoClassPragmas (
 248       rnClassPragmas pragmas
 249     )                                   `thenRn4` \ pragmas' ->
 250     returnRn4 (ClassDecl context' cname' tyvar' sigs' mbinds' pragmas' src_loc)
 251     )
 252   where
 253     rn_op clas tv_env (ClassOpSig op ty pragma locn)
 254       = pushSrcLocRn4 locn                    (
 255         lookupClassOp clas op           `thenRn4` \ op_name ->
 256         rnPolyType False tv_env ty      `thenRn4` \ new_ty  ->
 257
 258 {-
 259 *** Please check here that tyvar' appears in new_ty ***
 260 *** (used to be in tcClassSig, but it's better here)
 261 ***         not_elem = isn'tIn "tcClassSigs"
 262 ***         -- Check that the class type variable is mentioned
 263 ***     checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
 264 ***             (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
 265 -}
 266         recoverQuietlyRn4 NoClassOpPragmas (
 267             rnClassOpPragmas pragma
 268         )                               `thenRn4` \ new_pragma ->
 269         returnRn4 (ClassOpSig op_name new_ty new_pragma locn)
 270         )
 271 \end{code}
 272
 273
 274 %*********************************************************
 275 %*                                                      *
 276 \subsection{Instance declarations}
 277 %*                                                      *
 278 %*********************************************************
 279
 280
 281 @rnInstDecl@ uses the `global name function' to create a new of
 282 instance declaration in which local names have been replaced by their
 283 original names, reporting any unknown names.
 284
 285 \begin{code}
 286 rnInstDecl :: ProtoNameInstDecl -> Rn4M RenamedInstDecl
 287
 288 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
 289   = pushSrcLocRn4 src_loc                         (
 290     let
 291         tyvars = extract_poly_ty_names ty
 292     in
 293     mkTyVarNamesEnv src_loc tyvars      `thenRn4` \ (tv_env,_) ->
 294     lookupClass cname                   `thenRn4` \ cname' ->
 295
 296     rnPolyType False{-no invisibles-} [] ty
 297         -- The "[]" was tv_env, but that means the InstDecl's tyvars aren't
 298         -- pinned on the HsForAllType, which they should be.
 299         -- Urgh!  Improve in the new renamer!
 300
 301                                         `thenRn4` \ ty' ->
 302     rnMethodBinds cname' mbinds `thenRn4` \ mbinds' ->
 303     mapRn4 (rn_uprag cname') uprags     `thenRn4` \ new_uprags ->
 304     recoverQuietlyRn4 NoInstancePragmas (
 305         rnInstancePragmas cname' tv_env pragmas
 306     )                                   `thenRn4` \ new_pragmas ->
 307     returnRn4 (InstDecl cname' ty' mbinds'
 308                         from_here modname new_uprags new_pragmas src_loc)
 309     )
 310   where
 311     rn_uprag class_name (SpecSig op ty using locn)
 312       = ASSERT(not (maybeToBool using)) -- ToDo: SPEC method with explicit spec_id
 313         pushSrcLocRn4 src_loc                           (
 314         lookupClassOp class_name op             `thenRn4` \ op_name ->
 315         rnPolyType False nullTyVarNamesEnv ty   `thenRn4` \ new_ty ->
 316         returnRn4 (SpecSig op_name new_ty Nothing locn)
 317         )
 318     rn_uprag class_name (InlineSig op locn)
 319       = pushSrcLocRn4 locn              (
 320         lookupClassOp class_name op     `thenRn4` \ op_name ->
 321         returnRn4 (InlineSig op_name locn)
 322         )
 323     rn_uprag class_name (DeforestSig op locn)
 324       = pushSrcLocRn4 locn              (
 325         lookupClassOp class_name op     `thenRn4` \ op_name ->
 326         returnRn4 (DeforestSig op_name locn)
 327         )
 328     rn_uprag class_name (MagicUnfoldingSig op str locn)
 329       = pushSrcLocRn4 locn              (
 330         lookupClassOp class_name op     `thenRn4` \ op_name ->
 331         returnRn4 (MagicUnfoldingSig op_name str locn)
 332         )
 333 \end{code}
 334
 335 %*********************************************************
 336 %*                                                      *
 337 \subsection{@SPECIALIZE instance@ user-pragmas}
 338 %*                                                      *
 339 %*********************************************************
 340
 341 \begin{code}
 342 rnSpecInstSig :: ProtoNameSpecInstSig
 343               -> Rn4M RenamedSpecInstSig
 344
 345 rnSpecInstSig (SpecInstSig clas ty src_loc)
 346   = pushSrcLocRn4 src_loc                 (
 347     let  tyvars = extractMonoTyNames eqProtoName ty  in
 348     mkTyVarNamesEnv src_loc tyvars      `thenRn4` \ (tv_env,_) ->
 349     lookupClass clas                    `thenRn4` \ new_clas ->
 350     rnMonoType False tv_env ty          `thenRn4` \ new_ty ->
 351     returnRn4 (SpecInstSig new_clas new_ty src_loc)
 352     )
 353 \end{code}
 354
 355 %*********************************************************
 356 %*                                                      *
 357 \subsection{Default declarations}
 358 %*                                                      *
 359 %*********************************************************
 360
 361 @rnDefaultDecl@ uses the `global name function' to create a new set
 362 of default declarations in which local names have been replaced by
 363 their original names, reporting any unknown names.
 364
 365 \begin{code}
 366 rnDefaultDecl :: [ProtoNameDefaultDecl] -> Rn4M [RenamedDefaultDecl]
 367
 368 rnDefaultDecl [] = returnRn4 []
 369 rnDefaultDecl [DefaultDecl tys src_loc]
 370   = pushSrcLocRn4 src_loc $
 371     mapRn4 (rnMonoType False nullTyVarNamesEnv) tys `thenRn4` \ tys' ->
 372     returnRn4 [DefaultDecl tys' src_loc]
 373 rnDefaultDecl defs@(d:ds)
 374   = addErrRn4 (dupDefaultDeclErr defs) `thenRn4_`
 375     rnDefaultDecl [d]
 376 \end{code}
 377
 378 %*************************************************************************
 379 %*                                                                      *
 380 \subsection{Type signatures from interfaces}
 381 %*                                                                      *
 382 %*************************************************************************
 383
 384 Non-interface type signatures (which may include user-pragmas) are
 385 handled with @HsBinds@.
 386
 387 @ClassOpSigs@ are dealt with in class declarations.
 388
 389 \begin{code}
 390 rnIntSig :: ProtoNameSig -> Rn4M RenamedSig
 391
 392 rnIntSig (Sig name ty pragma src_loc)
 393   = pushSrcLocRn4 src_loc                             (
 394     lookupValue name                            `thenRn4` \ new_name ->
 395     rnPolyType False nullTyVarNamesEnv ty       `thenRn4` \ new_ty   ->
 396     recoverQuietlyRn4 NoGenPragmas (
 397         rnGenPragmas pragma
 398     )                                       `thenRn4` \ new_pragma ->
 399     returnRn4 (Sig new_name new_ty new_pragma src_loc)
 400     )
 401 \end{code}
 402
 403 %*************************************************************************
 404 %*                                                                      *
 405 \subsection{Fixity declarations}
 406 %*                                                                      *
 407 %*************************************************************************
 408
 409 \begin{code}
 410 rnFixes :: [ProtoNameFixityDecl]  -> Rn4M [RenamedFixityDecl]
 411
 412 rnFixes fixities
 413   = mapRn4 rn_fixity fixities `thenRn4` \ fixes_maybe ->
 414     returnRn4 (catMaybes fixes_maybe)
 415   where
 416     rn_fixity (InfixL name i)
 417       = lookupFixityOp name `thenRn4` \ res ->
 418         returnRn4 (
 419           case res of
 420             Just name2 ->  Just (InfixL name2 i)
 421             Nothing    ->  Nothing
 422         )
 423
 424     rn_fixity (InfixR name i)
 425       = lookupFixityOp name     `thenRn4` \ res ->
 426         returnRn4 (
 427           case res of
 428             Just name2 ->  Just (InfixR name2 i)
 429             Nothing    ->  Nothing
 430         )
 431
 432     rn_fixity (InfixN name i)
 433       = lookupFixityOp name     `thenRn4` \ res ->
 434         returnRn4 (
 435           case res of
 436             Just name2 ->  Just (InfixN name2 i)
 437             Nothing    ->  Nothing
 438         )
 439 \end{code}
 440
 441 %*********************************************************
 442 %*                                                      *
 443 \subsection{Support code to rename types}
 444 %*                                                      *
 445 %*********************************************************
 446
 447 \begin{code}
 448 rnPolyType :: Bool              -- True <=> "invisible" tycons (in pragmas) allowed
 449             -> TyVarNamesEnv
 450             -> ProtoNamePolyType
 451             -> Rn4M RenamedPolyType
 452
 453 rnPolyType invisibles_allowed tv_env (HsForAllTy tvs ctxt ty)
 454   = rn_poly_help invisibles_allowed tv_env tvs ctxt ty
 455
 456 rnPolyType invisibles_allowed tv_env poly_ty@(HsPreForAllTy ctxt ty)
 457   = rn_poly_help invisibles_allowed tv_env forall_tyvars ctxt ty
 458   where
 459     mentioned_tyvars = extract_poly_ty_names poly_ty
 460
 461     forall_tyvars = mentioned_tyvars `minus_list` domTyVarNamesEnv tv_env
 462
 463         -- URGH! Why is this here?  SLPJ
 464         -- Because we are doing very delicate comparisons
 465         -- (eqProtoName and all that); if we got rid of
 466         -- that, then we could use ListSetOps stuff.  WDP
 467     minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)]
 468
 469 ------------
 470 extract_poly_ty_names (HsPreForAllTy ctxt ty)
 471   = extractCtxtTyNames eqProtoName ctxt
 472     `union_list`
 473     extractMonoTyNames eqProtoName ty
 474   where
 475     -- see comment above
 476     union_list []     [] = []
 477     union_list []     b  = b
 478     union_list a      [] = a
 479     union_list (a:as) b
 480       | a `elemProtoNames` b = union_list as b
 481       | otherwise            = a : union_list as b
 482
 483 ------------
 484 rn_poly_help :: Bool
 485              -> TyVarNamesEnv
 486              -> [ProtoName]
 487              -> ProtoNameContext
 488              -> ProtoNameMonoType
 489              -> Rn4M RenamedPolyType
 490
 491 rn_poly_help invisibles_allowed tv_env tyvars ctxt ty
 492   = getSrcLocRn4                                `thenRn4` \ src_loc ->
 493     mkTyVarNamesEnv src_loc tyvars              `thenRn4` \ (tv_env1, new_tyvars) ->
 494     let
 495         tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
 496     in
 497     rnContext tv_env2 ctxt                      `thenRn4` \ new_ctxt ->
 498     rnMonoType invisibles_allowed tv_env2 ty    `thenRn4` \ new_ty ->
 499     returnRn4 (HsForAllTy new_tyvars new_ctxt new_ty)
 500 \end{code}
 501
 502 \begin{code}
 503 rnMonoType :: Bool              -- allowed to look at invisible tycons
 504             -> TyVarNamesEnv
 505             -> ProtoNameMonoType
 506             -> Rn4M RenamedMonoType
 507
 508 rnMonoType invisibles_allowed  tv_env (MonoTyVar tyvar)
 509   = lookupTyVarName tv_env tyvar        `thenRn4` \ tyvar' ->
 510     returnRn4 (MonoTyVar tyvar')
 511
 512 rnMonoType invisibles_allowed  tv_env (MonoListTy ty)
 513   = rnMonoType invisibles_allowed tv_env ty     `thenRn4` \ ty' ->
 514     returnRn4 (MonoListTy ty')
 515
 516 rnMonoType invisibles_allowed  tv_env (MonoFunTy ty1 ty2)
 517   = andRn4 MonoFunTy (rnMonoType invisibles_allowed tv_env ty1)
 518                      (rnMonoType invisibles_allowed tv_env ty2)
 519
 520 rnMonoType invisibles_allowed  tv_env (MonoTupleTy tys)
 521   = mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
 522     returnRn4 (MonoTupleTy tys')
 523
 524 rnMonoType invisibles_allowed tv_env (MonoTyApp name tys)
 525   = let
 526         lookup_fn = if isAvarid (getOccurrenceName name)
 527                     then lookupTyVarName tv_env
 528                     else if invisibles_allowed
 529                          then lookupTyConEvenIfInvisible
 530                          else lookupTyCon
 531     in
 532     lookup_fn name                                      `thenRn4` \ name' ->
 533     mapRn4 (rnMonoType invisibles_allowed tv_env) tys   `thenRn4` \ tys' ->
 534     returnRn4 (MonoTyApp name' tys')
 535
 536 -- for unfoldings only:
 537
 538 rnMonoType invisibles_allowed tv_env (MonoForAllTy tyvars_w_kinds ty)
 539   = getSrcLocRn4                                `thenRn4` \ src_loc ->
 540     mkTyVarNamesEnv src_loc tyvars              `thenRn4` \ (tv_env1, new_tyvars) ->
 541     let
 542         tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
 543     in
 544     rnMonoType invisibles_allowed tv_env2 ty    `thenRn4` \ ty' ->
 545     returnRn4 (MonoForAllTy (new_tyvars `zip` kinds) ty')
 546   where
 547     (tyvars, kinds) = unzip tyvars_w_kinds
 548
 549 rnMonoType invisibles_allowed tv_env (MonoDictTy clas ty)
 550   = lookupClass clas            `thenRn4` \ new_clas ->
 551     rnMonoType invisibles_allowed tv_env ty     `thenRn4` \ new_ty ->
 552     returnRn4 (MonoDictTy new_clas new_ty)
 553 \end{code}
 554
 555 \begin{code}
 556 rnContext :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext
 557
 558 rnContext tv_env ctxt
 559   = mapRn4 rn_ctxt ctxt
 560   where
 561     rn_ctxt (clas, tyvar)
 562      = lookupClass clas             `thenRn4` \ clas_name ->
 563        lookupTyVarName tv_env tyvar `thenRn4` \ tyvar_name ->
 564        returnRn4 (clas_name, tyvar_name)
 565 \end{code}
 566
 567 %*********************************************************
 568 %*                                                      *
 569 \subsection{Support code to rename various pragmas}
 570 %*                                                      *
 571 %*********************************************************
 572
 573 \begin{code}
 574 rnDataPragmas tv_env (DataPragmas cons specs)
 575   = rnConDecls tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons ->
 576     mapRn4 types_n_spec specs                          `thenRn4` \ new_specs ->
 577     returnRn4 (DataPragmas new_cons new_specs)
 578   where
 579     types_n_spec ty_maybes
 580       = mapRn4 (rn_ty_maybe nullTyVarNamesEnv) ty_maybes
 581 \end{code}
 582
 583 \begin{code}
 584 rnClassOpPragmas NoClassOpPragmas = returnRn4 NoClassOpPragmas
 585
 586 rnClassOpPragmas (ClassOpPragmas dsel defm)
 587   = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas dsel) `thenRn4` \ new_dsel ->
 588     recoverQuietlyRn4 NoGenPragmas (rnGenPragmas defm) `thenRn4` \ new_defm ->
 589     returnRn4 (ClassOpPragmas new_dsel new_defm)
 590 \end{code}
 591
 592 \begin{code}
 593 rnClassPragmas NoClassPragmas = returnRn4 NoClassPragmas
 594
 595 rnClassPragmas (SuperDictPragmas sds)
 596   = mapRn4 rnGenPragmas sds     `thenRn4` \ new_sds ->
 597     returnRn4 (SuperDictPragmas new_sds)
 598 \end{code}
 599
 600 NB: In various cases around here, we don't @recoverQuietlyRn4@ around
 601 calls to @rnGenPragmas@; not really worth it.
 602
 603 \begin{code}
 604 rnInstancePragmas _ _ NoInstancePragmas = returnRn4 NoInstancePragmas
 605
 606 rnInstancePragmas _ _ (SimpleInstancePragma dfun)
 607   = rnGenPragmas dfun   `thenRn4` \ new_dfun ->
 608     returnRn4 (SimpleInstancePragma new_dfun)
 609
 610 rnInstancePragmas clas tv_env (ConstantInstancePragma dfun constms)
 611   = recoverQuietlyRn4 NoGenPragmas (
 612         rnGenPragmas dfun
 613     )                           `thenRn4` \ new_dfun ->
 614     mapRn4 name_n_gen constms   `thenRn4` \ new_constms ->
 615     returnRn4 (ConstantInstancePragma new_dfun new_constms)
 616   where
 617     name_n_gen (op, gen)
 618       = lookupClassOp clas op   `thenRn4` \ new_op ->
 619         rnGenPragmas gen        `thenRn4` \ new_gen ->
 620         returnRn4 (new_op, new_gen)
 621
 622 rnInstancePragmas clas tv_env (SpecialisedInstancePragma dfun specs)
 623   = recoverQuietlyRn4 NoGenPragmas (
 624         rnGenPragmas dfun
 625     )                           `thenRn4` \ new_dfun ->
 626     mapRn4 types_n_spec specs   `thenRn4` \ new_specs ->
 627     returnRn4 (SpecialisedInstancePragma new_dfun new_specs)
 628   where
 629     types_n_spec (ty_maybes, dicts_to_ignore, inst)
 630       = mapRn4 (rn_ty_maybe tv_env) ty_maybes   `thenRn4` \ new_tys ->
 631         rnInstancePragmas clas tv_env inst      `thenRn4` \ new_inst ->
 632         returnRn4 (new_tys, dicts_to_ignore, new_inst)
 633 \end{code}
 634
 635 And some general pragma stuff: (Not sure what, if any, of this would
 636 benefit from a TyVarNamesEnv passed in.... [ToDo])
 637 \begin{code}
 638 rnGenPragmas :: ProtoNameGenPragmas -> Rn4M RenamedGenPragmas
 639
 640 rnGenPragmas NoGenPragmas = returnRn4 NoGenPragmas
 641
 642 rnGenPragmas (GenPragmas arity upd def strict unfold specs)
 643   = recoverQuietlyRn4 NoImpUnfolding (
 644         rn_unfolding  unfold
 645     )                           `thenRn4` \ new_unfold ->
 646     rn_strictness strict        `thenRn4` \ new_strict ->
 647     recoverQuietlyRn4 [] (
 648         mapRn4 types_n_gen specs
 649     )                           `thenRn4` \ new_specs ->
 650     returnRn4 (GenPragmas arity upd def new_strict new_unfold new_specs)
 651   where
 652     rn_unfolding NoImpUnfolding = returnRn4 NoImpUnfolding
 653
 654     rn_unfolding (ImpMagicUnfolding str) = returnRn4 (ImpMagicUnfolding str)
 655
 656     rn_unfolding (ImpUnfolding guidance core)
 657       = rn_core nullTyVarNamesEnv core  `thenRn4` \ new_core ->
 658         returnRn4 (ImpUnfolding guidance new_core)
 659
 660     ------------
 661     rn_strictness NoImpStrictness = returnRn4 NoImpStrictness
 662
 663     rn_strictness (ImpStrictness is_bot ww_info wrkr_info)
 664       = recoverQuietlyRn4 NoGenPragmas (
 665             rnGenPragmas wrkr_info
 666         )                       `thenRn4` \ new_wrkr_info ->
 667         returnRn4 (ImpStrictness is_bot ww_info new_wrkr_info)
 668
 669     -------------
 670     types_n_gen (ty_maybes, dicts_to_ignore, gen)
 671       = mapRn4 (rn_ty_maybe no_env) ty_maybes   `thenRn4` \ new_tys ->
 672         recoverQuietlyRn4 NoGenPragmas (
 673             rnGenPragmas gen
 674         )                               `thenRn4` \ new_gen ->
 675         returnRn4 (new_tys, dicts_to_ignore, new_gen)
 676       where
 677         no_env = nullTyVarNamesEnv
 678
 679 ------------
 680 rn_ty_maybe tv_env Nothing = returnRn4 Nothing
 681
 682 rn_ty_maybe tv_env (Just ty)
 683   = rnMonoType True{-invisibles OK-} tv_env ty  `thenRn4` \ new_ty ->
 684     returnRn4 (Just new_ty)
 685
 686 ------------
 687 rn_core tvenv (UfVar v)
 688   = rn_uf_id tvenv v    `thenRn4` \ vname ->
 689     returnRn4 (UfVar vname)
 690
 691 rn_core tvenv (UfLit lit)
 692   = returnRn4 (UfLit lit)
 693
 694 rn_core tvenv (UfCon con tys as)
 695   = lookupValueEvenIfInvisible con      `thenRn4` \ new_con ->
 696     mapRn4 (rn_core_type tvenv) tys     `thenRn4` \ new_tys ->
 697     mapRn4 (rn_atom tvenv) as           `thenRn4` \ new_as ->
 698     returnRn4 (UfCon new_con new_tys new_as)
 699
 700 rn_core tvenv (UfPrim op tys as)
 701   = rn_core_primop tvenv op             `thenRn4` \ new_op ->
 702     mapRn4 (rn_core_type tvenv) tys     `thenRn4` \ new_tys ->
 703     mapRn4 (rn_atom tvenv) as           `thenRn4` \ new_as ->
 704     returnRn4 (UfPrim new_op new_tys new_as)
 705
 706 rn_core tvenv (UfLam binder body)
 707   = rn_binder tvenv binder `thenRn4` \ (b,ty) ->
 708     extendSS [b] (rn_core tvenv body) `thenRn4` \ new_body ->
 709     returnRn4 (UfLam (b,ty) new_body)
 710
 711 rn_core tvenv (UfApp fun arg)
 712   = rn_core tvenv fun   `thenRn4` \ new_fun ->
 713     rn_atom tvenv arg   `thenRn4` \ new_arg ->
 714     returnRn4 (UfApp new_fun new_arg)
 715
 716 rn_core tvenv (UfCase expr alts)
 717   = rn_core tvenv expr      `thenRn4` \ new_expr ->
 718     rn_alts       alts      `thenRn4` \ new_alts ->
 719     returnRn4 (UfCase new_expr new_alts)
 720   where
 721     rn_alts (UfCoAlgAlts alg_alts deflt)
 722       = mapRn4 rn_alg_alt alg_alts  `thenRn4` \ new_alts ->
 723         rn_deflt deflt              `thenRn4` \ new_deflt ->
 724         returnRn4 (UfCoAlgAlts new_alts new_deflt)
 725       where
 726         rn_alg_alt (con, params, rhs)
 727           = lookupValueEvenIfInvisible con  `thenRn4` \ new_con ->
 728             mapRn4 (rn_binder tvenv) params `thenRn4` \ new_params ->
 729             let
 730                 bs = [ b | (b, ty) <- new_params ]
 731             in
 732             extendSS bs (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
 733             returnRn4 (new_con, new_params, new_rhs)
 734
 735     rn_alts (UfCoPrimAlts prim_alts deflt)
 736       = mapRn4 rn_prim_alt prim_alts  `thenRn4` \ new_alts ->
 737         rn_deflt deflt                `thenRn4` \ new_deflt ->
 738         returnRn4 (UfCoPrimAlts new_alts new_deflt)
 739       where
 740         rn_prim_alt (lit, rhs)
 741           = rn_core tvenv rhs   `thenRn4` \ new_rhs ->
 742             returnRn4 (lit, new_rhs)
 743
 744     rn_deflt UfCoNoDefault = returnRn4 UfCoNoDefault
 745     rn_deflt (UfCoBindDefault b rhs)
 746       = rn_binder tvenv b                     `thenRn4` \ new_b@(binder, ty) ->
 747         extendSS [binder] (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
 748         returnRn4 (UfCoBindDefault new_b new_rhs)
 749
 750 rn_core tvenv (UfLet bind body)
 751   = rn_bind bind                              `thenRn4` \ (new_bind, new_binders) ->
 752     extendSS new_binders (rn_core tvenv body) `thenRn4` \ new_body ->
 753     returnRn4 (UfLet new_bind new_body)
 754   where
 755     rn_bind (UfCoNonRec b rhs)
 756       = rn_binder tvenv b       `thenRn4` \ new_b@(binder, ty) ->
 757         rn_core   tvenv rhs     `thenRn4` \ new_rhs ->
 758         returnRn4 (UfCoNonRec new_b new_rhs, [binder])
 759
 760     rn_bind (UfCoRec pairs)
 761       = -- conjure up Names; we do this differently than
 762         -- elsewhere for Core, because of the recursion here;
 763         -- no deep issue.
 764         -- [BEFORE IT WAS "FIXED"... 94/05...]
 765         -- [Andy -- It *was* a 'deep' issue to me...]
 766         -- [Will -- Poor wee soul.]
 767
 768         getSrcLocRn4                        `thenRn4` \ locn ->
 769         namesFromProtoNames "core variable"
 770           [ (b, locn) | ((b,_),_) <- pairs] `thenRn4` \ binders ->
 771
 772         extendSS binders (mapRn4 rn_pair (pairs `zip` binders)) `thenRn4` \ new_pairs ->
 773         returnRn4 (UfCoRec new_pairs, binders)
 774       where
 775         rn_pair (((b, ty), rhs), new_b)
 776           = rn_core_type tvenv ty       `thenRn4` \ new_ty ->
 777             rn_core      tvenv rhs      `thenRn4` \ new_rhs ->
 778             returnRn4 ((new_b, new_ty), new_rhs)
 779
 780 rn_core tvenv (UfSCC uf_cc body)
 781   = rn_cc uf_cc         `thenRn4` \ new_cc ->
 782     rn_core tvenv body  `thenRn4` \ new_body ->
 783     returnRn4 (UfSCC new_cc new_body)
 784   where
 785     rn_cc (UfAutoCC id m g is_dupd is_caf)
 786       = rn_uf_id tvenv id       `thenRn4` \ new_id ->
 787         returnRn4 (UfAutoCC new_id m g is_dupd is_caf)
 788
 789     rn_cc (UfDictCC id m g is_caf is_dupd)
 790       = rn_uf_id tvenv id       `thenRn4` \ new_id ->
 791         returnRn4 (UfDictCC new_id m g is_dupd is_caf)
 792
 793     -- the rest are boring:
 794     rn_cc (UfPreludeDictsCC d) = returnRn4 (UfPreludeDictsCC d)
 795     rn_cc (UfAllDictsCC m g d) = returnRn4 (UfAllDictsCC m g d)
 796     rn_cc (UfUserCC n m g d c) = returnRn4 (UfUserCC n m g d c)
 797
 798 ------------
 799 rn_core_primop tvenv (UfCCallOp str is_casm may_gc arg_tys res_ty)
 800   = mapRn4 (rn_core_type tvenv) arg_tys `thenRn4` \ new_arg_tys ->
 801     rn_core_type tvenv res_ty           `thenRn4` \ new_res_ty  ->
 802     returnRn4 (UfCCallOp str is_casm may_gc new_arg_tys new_res_ty)
 803 rn_core_primop tvenv (UfOtherOp op)
 804   = returnRn4 (UfOtherOp op)
 805
 806 ------------
 807 rn_uf_id tvenv (BoringUfId v)
 808   = lookupValueEvenIfInvisible v    `thenRn4` \ vname ->
 809     returnRn4 (BoringUfId vname)
 810
 811 rn_uf_id tvenv (SuperDictSelUfId c sc)
 812   = lookupClass{-EvenIfInvisible-} c    `thenRn4` \ new_c ->
 813     lookupClass{-EvenIfInvisible-} sc   `thenRn4` \ new_sc ->
 814     returnRn4 (SuperDictSelUfId new_c new_sc)
 815
 816 rn_uf_id tvenv (ClassOpUfId c op)
 817   = lookupClass{-EvenIfInvisible-} c            `thenRn4` \ new_c ->
 818     lookupClassOp{-EvenIfInvisible-} new_c op   `thenRn4` \ new_op ->
 819     returnRn4 (ClassOpUfId new_c new_op)
 820
 821 rn_uf_id tvenv (DictFunUfId c ty)
 822   = lookupClass{-EvenIfInvisible-} c    `thenRn4` \ new_c ->
 823     rn_core_type tvenv ty               `thenRn4` \ new_ty ->
 824     returnRn4 (DictFunUfId new_c new_ty)
 825
 826 rn_uf_id tvenv (ConstMethodUfId c op ty)
 827   = lookupClass{-EvenIfInvisible-} c          `thenRn4` \ new_c ->
 828     lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op ->
 829     rn_core_type tvenv ty                     `thenRn4` \ new_ty ->
 830     returnRn4 (ConstMethodUfId new_c new_op new_ty)
 831
 832 rn_uf_id tvenv (DefaultMethodUfId c op)
 833   = lookupClass{-EvenIfInvisible-} c            `thenRn4` \ new_c ->
 834     lookupClassOp{-EvenIfInvisible-} new_c op   `thenRn4` \ new_op ->
 835     returnRn4 (DefaultMethodUfId new_c new_op)
 836
 837 rn_uf_id tvenv (SpecUfId unspec ty_maybes)
 838   = rn_uf_id tvenv unspec                `thenRn4` \ new_unspec ->
 839     mapRn4 (rn_ty_maybe tvenv) ty_maybes `thenRn4` \ new_ty_maybes ->
 840     returnRn4 (SpecUfId new_unspec new_ty_maybes)
 841
 842 rn_uf_id tvenv (WorkerUfId unwrkr)
 843   = rn_uf_id tvenv unwrkr       `thenRn4` \ new_unwrkr ->
 844     returnRn4 (WorkerUfId new_unwrkr)
 845
 846 ------------
 847 rn_binder tvenv (b, ty)
 848   = getSrcLocRn4                        `thenRn4` \ src_loc ->
 849     namesFromProtoNames "binder in core unfolding" [(b, src_loc)]
 850                                         `thenRn4` \ [new_b] ->
 851     rn_core_type tvenv ty               `thenRn4` \ new_ty ->
 852     returnRn4 (new_b, new_ty)
 853
 854 ------------
 855 rn_atom tvenv (UfCoLitAtom l) = returnRn4 (UfCoLitAtom l)
 856 rn_atom tvenv (UfCoVarAtom v)
 857   = rn_uf_id tvenv v                    `thenRn4` \ vname ->
 858     returnRn4 (UfCoVarAtom vname)
 859
 860 ------------
 861 rn_core_type_maybe tvenv Nothing = returnRn4 Nothing
 862 rn_core_type_maybe tvenv (Just ty)
 863   = rn_core_type tvenv ty `thenRn4` \ new_ty ->
 864     returnRn4 (Just new_ty)
 865
 866 ------------
 867 rn_core_type tvenv ty
 868   = rnPolyType True{-invisible tycons OK-} tvenv ty
 869 \end{code}
 870
 871
 872 \begin{code}
 873 derivingNonStdClassErr clas locn sty
 874   = ppHang (ppStr "Non-standard class in deriving")
 875          4 (ppCat [ppr sty clas, ppr sty locn])
 876
 877 dupDefaultDeclErr defs sty
 878   = ppHang (ppStr "Duplicate default declarations")
 879          4 (ppAboves (map pp_def_loc defs))
 880   where
 881     pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
 882 \end{code}