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     rnPolyType False{-no invisibles-} tv_env ty
 296                                         `thenRn4` \ ty' ->
 297     rnMethodBinds cname' mbinds `thenRn4` \ mbinds' ->
 298     mapRn4 (rn_uprag cname') uprags     `thenRn4` \ new_uprags ->
 299     recoverQuietlyRn4 NoInstancePragmas (
 300         rnInstancePragmas cname' tv_env pragmas
 301     )                                   `thenRn4` \ new_pragmas ->
 302     returnRn4 (InstDecl cname' ty' mbinds'
 303                         from_here modname new_uprags new_pragmas src_loc)
 304     )
 305   where
 306     rn_uprag class_name (SpecSig op ty using locn)
 307       = ASSERT(not (maybeToBool using)) -- ToDo: SPEC method with explicit spec_id
 308         pushSrcLocRn4 src_loc                           (
 309         lookupClassOp class_name op             `thenRn4` \ op_name ->
 310         rnPolyType False nullTyVarNamesEnv ty   `thenRn4` \ new_ty ->
 311         returnRn4 (SpecSig op_name new_ty Nothing locn)
 312         )
 313     rn_uprag class_name (InlineSig op locn)
 314       = pushSrcLocRn4 locn              (
 315         lookupClassOp class_name op     `thenRn4` \ op_name ->
 316         returnRn4 (InlineSig op_name locn)
 317         )
 318     rn_uprag class_name (DeforestSig op locn)
 319       = pushSrcLocRn4 locn              (
 320         lookupClassOp class_name op     `thenRn4` \ op_name ->
 321         returnRn4 (DeforestSig op_name locn)
 322         )
 323     rn_uprag class_name (MagicUnfoldingSig op str locn)
 324       = pushSrcLocRn4 locn              (
 325         lookupClassOp class_name op     `thenRn4` \ op_name ->
 326         returnRn4 (MagicUnfoldingSig op_name str locn)
 327         )
 328 \end{code}
 329
 330 %*********************************************************
 331 %*                                                      *
 332 \subsection{@SPECIALIZE instance@ user-pragmas}
 333 %*                                                      *
 334 %*********************************************************
 335
 336 \begin{code}
 337 rnSpecInstSig :: ProtoNameSpecInstSig
 338               -> Rn4M RenamedSpecInstSig
 339
 340 rnSpecInstSig (SpecInstSig clas ty src_loc)
 341   = pushSrcLocRn4 src_loc                 (
 342     let  tyvars = extractMonoTyNames eqProtoName ty  in
 343     mkTyVarNamesEnv src_loc tyvars      `thenRn4` \ (tv_env,_) ->
 344     lookupClass clas                    `thenRn4` \ new_clas ->
 345     rnMonoType False tv_env ty          `thenRn4` \ new_ty ->
 346     returnRn4 (SpecInstSig new_clas new_ty src_loc)
 347     )
 348 \end{code}
 349
 350 %*********************************************************
 351 %*                                                      *
 352 \subsection{Default declarations}
 353 %*                                                      *
 354 %*********************************************************
 355
 356 @rnDefaultDecl@ uses the `global name function' to create a new set
 357 of default declarations in which local names have been replaced by
 358 their original names, reporting any unknown names.
 359
 360 \begin{code}
 361 rnDefaultDecl :: [ProtoNameDefaultDecl] -> Rn4M [RenamedDefaultDecl]
 362
 363 rnDefaultDecl [] = returnRn4 []
 364 rnDefaultDecl [DefaultDecl tys src_loc]
 365   = pushSrcLocRn4 src_loc $
 366     mapRn4 (rnMonoType False nullTyVarNamesEnv) tys `thenRn4` \ tys' ->
 367     returnRn4 [DefaultDecl tys' src_loc]
 368 rnDefaultDecl defs@(d:ds)
 369   = addErrRn4 (dupDefaultDeclErr defs) `thenRn4_`
 370     rnDefaultDecl [d]
 371 \end{code}
 372
 373 %*************************************************************************
 374 %*                                                                      *
 375 \subsection{Type signatures from interfaces}
 376 %*                                                                      *
 377 %*************************************************************************
 378
 379 Non-interface type signatures (which may include user-pragmas) are
 380 handled with @HsBinds@.
 381
 382 @ClassOpSigs@ are dealt with in class declarations.
 383
 384 \begin{code}
 385 rnIntSig :: ProtoNameSig -> Rn4M RenamedSig
 386
 387 rnIntSig (Sig name ty pragma src_loc)
 388   = pushSrcLocRn4 src_loc                             (
 389     lookupValue name                            `thenRn4` \ new_name ->
 390     rnPolyType False nullTyVarNamesEnv ty       `thenRn4` \ new_ty   ->
 391     recoverQuietlyRn4 NoGenPragmas (
 392         rnGenPragmas pragma
 393     )                                       `thenRn4` \ new_pragma ->
 394     returnRn4 (Sig new_name new_ty new_pragma src_loc)
 395     )
 396 \end{code}
 397
 398 %*************************************************************************
 399 %*                                                                      *
 400 \subsection{Fixity declarations}
 401 %*                                                                      *
 402 %*************************************************************************
 403
 404 \begin{code}
 405 rnFixes :: [ProtoNameFixityDecl]  -> Rn4M [RenamedFixityDecl]
 406
 407 rnFixes fixities
 408   = mapRn4 rn_fixity fixities `thenRn4` \ fixes_maybe ->
 409     returnRn4 (catMaybes fixes_maybe)
 410   where
 411     rn_fixity (InfixL name i)
 412       = lookupFixityOp name `thenRn4` \ res ->
 413         returnRn4 (
 414           case res of
 415             Just name2 ->  Just (InfixL name2 i)
 416             Nothing    ->  Nothing
 417         )
 418
 419     rn_fixity (InfixR name i)
 420       = lookupFixityOp name     `thenRn4` \ res ->
 421         returnRn4 (
 422           case res of
 423             Just name2 ->  Just (InfixR name2 i)
 424             Nothing    ->  Nothing
 425         )
 426
 427     rn_fixity (InfixN name i)
 428       = lookupFixityOp name     `thenRn4` \ res ->
 429         returnRn4 (
 430           case res of
 431             Just name2 ->  Just (InfixN name2 i)
 432             Nothing    ->  Nothing
 433         )
 434 \end{code}
 435
 436 %*********************************************************
 437 %*                                                      *
 438 \subsection{Support code to rename types}
 439 %*                                                      *
 440 %*********************************************************
 441
 442 \begin{code}
 443 rnPolyType :: Bool              -- True <=> "invisible" tycons (in pragmas) allowed
 444             -> TyVarNamesEnv
 445             -> ProtoNamePolyType
 446             -> Rn4M RenamedPolyType
 447
 448 rnPolyType invisibles_allowed tv_env (HsForAllTy tvs ctxt ty)
 449   = rn_poly_help invisibles_allowed tv_env tvs ctxt ty
 450
 451 rnPolyType invisibles_allowed tv_env poly_ty@(HsPreForAllTy ctxt ty)
 452   = rn_poly_help invisibles_allowed tv_env forall_tyvars ctxt ty
 453   where
 454     mentioned_tyvars = extract_poly_ty_names poly_ty
 455
 456     forall_tyvars = mentioned_tyvars `minus_list` domTyVarNamesEnv tv_env
 457
 458         -- URGH! Why is this here?  SLPJ
 459         -- Because we are doing very delicate comparisons
 460         -- (eqProtoName and all that); if we got rid of
 461         -- that, then we could use ListSetOps stuff.  WDP
 462     minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)]
 463
 464 ------------
 465 extract_poly_ty_names (HsPreForAllTy ctxt ty)
 466   = extractCtxtTyNames eqProtoName ctxt
 467     `union_list`
 468     extractMonoTyNames eqProtoName ty
 469   where
 470     -- see comment above
 471     union_list []     [] = []
 472     union_list []     b  = b
 473     union_list a      [] = a
 474     union_list (a:as) b
 475       | a `elemProtoNames` b = union_list as b
 476       | otherwise            = a : union_list as b
 477
 478 ------------
 479 rn_poly_help :: Bool
 480              -> TyVarNamesEnv
 481              -> [ProtoName]
 482              -> ProtoNameContext
 483              -> ProtoNameMonoType
 484              -> Rn4M RenamedPolyType
 485
 486 rn_poly_help invisibles_allowed tv_env tyvars ctxt ty
 487   = getSrcLocRn4                                `thenRn4` \ src_loc ->
 488     mkTyVarNamesEnv src_loc tyvars              `thenRn4` \ (tv_env1, new_tyvars) ->
 489     let
 490         tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
 491     in
 492     rnContext tv_env2 ctxt                      `thenRn4` \ new_ctxt ->
 493     rnMonoType invisibles_allowed tv_env2 ty    `thenRn4` \ new_ty ->
 494     returnRn4 (HsForAllTy new_tyvars new_ctxt new_ty)
 495 \end{code}
 496
 497 \begin{code}
 498 rnMonoType :: Bool              -- allowed to look at invisible tycons
 499             -> TyVarNamesEnv
 500             -> ProtoNameMonoType
 501             -> Rn4M RenamedMonoType
 502
 503 rnMonoType invisibles_allowed  tv_env (MonoTyVar tyvar)
 504   = lookupTyVarName tv_env tyvar        `thenRn4` \ tyvar' ->
 505     returnRn4 (MonoTyVar tyvar')
 506
 507 rnMonoType invisibles_allowed  tv_env (MonoListTy ty)
 508   = rnMonoType invisibles_allowed tv_env ty     `thenRn4` \ ty' ->
 509     returnRn4 (MonoListTy ty')
 510
 511 rnMonoType invisibles_allowed  tv_env (MonoFunTy ty1 ty2)
 512   = andRn4 MonoFunTy (rnMonoType invisibles_allowed tv_env ty1)
 513                      (rnMonoType invisibles_allowed tv_env ty2)
 514
 515 rnMonoType invisibles_allowed  tv_env (MonoTupleTy tys)
 516   = mapRn4 (rnMonoType invisibles_allowed tv_env) tys `thenRn4` \ tys' ->
 517     returnRn4 (MonoTupleTy tys')
 518
 519 rnMonoType invisibles_allowed tv_env (MonoTyApp name tys)
 520   = let
 521         lookup_fn = if isAvarid (getOccurrenceName name)
 522                     then lookupTyVarName tv_env
 523                     else if invisibles_allowed
 524                          then lookupTyConEvenIfInvisible
 525                          else lookupTyCon
 526     in
 527     lookup_fn name                                      `thenRn4` \ name' ->
 528     mapRn4 (rnMonoType invisibles_allowed tv_env) tys   `thenRn4` \ tys' ->
 529     returnRn4 (MonoTyApp name' tys')
 530
 531 -- for unfoldings only:
 532
 533 rnMonoType invisibles_allowed tv_env (MonoForAllTy tyvars_w_kinds ty)
 534   = getSrcLocRn4                                `thenRn4` \ src_loc ->
 535     mkTyVarNamesEnv src_loc tyvars              `thenRn4` \ (tv_env1, new_tyvars) ->
 536     let
 537         tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
 538     in
 539     rnMonoType invisibles_allowed tv_env2 ty    `thenRn4` \ ty' ->
 540     returnRn4 (MonoForAllTy (new_tyvars `zip` kinds) ty')
 541   where
 542     (tyvars, kinds) = unzip tyvars_w_kinds
 543
 544 rnMonoType invisibles_allowed tv_env (MonoDictTy clas ty)
 545   = lookupClass clas            `thenRn4` \ new_clas ->
 546     rnMonoType invisibles_allowed tv_env ty     `thenRn4` \ new_ty ->
 547     returnRn4 (MonoDictTy new_clas new_ty)
 548 \end{code}
 549
 550 \begin{code}
 551 rnContext :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext
 552
 553 rnContext tv_env ctxt
 554   = mapRn4 rn_ctxt ctxt
 555   where
 556     rn_ctxt (clas, tyvar)
 557      = lookupClass clas             `thenRn4` \ clas_name ->
 558        lookupTyVarName tv_env tyvar `thenRn4` \ tyvar_name ->
 559        returnRn4 (clas_name, tyvar_name)
 560 \end{code}
 561
 562 %*********************************************************
 563 %*                                                      *
 564 \subsection{Support code to rename various pragmas}
 565 %*                                                      *
 566 %*********************************************************
 567
 568 \begin{code}
 569 rnDataPragmas tv_env (DataPragmas cons specs)
 570   = rnConDecls tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons ->
 571     mapRn4 types_n_spec specs                          `thenRn4` \ new_specs ->
 572     returnRn4 (DataPragmas new_cons new_specs)
 573   where
 574     types_n_spec ty_maybes
 575       = mapRn4 (rn_ty_maybe nullTyVarNamesEnv) ty_maybes
 576 \end{code}
 577
 578 \begin{code}
 579 rnClassOpPragmas NoClassOpPragmas = returnRn4 NoClassOpPragmas
 580
 581 rnClassOpPragmas (ClassOpPragmas dsel defm)
 582   = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas dsel) `thenRn4` \ new_dsel ->
 583     recoverQuietlyRn4 NoGenPragmas (rnGenPragmas defm) `thenRn4` \ new_defm ->
 584     returnRn4 (ClassOpPragmas new_dsel new_defm)
 585 \end{code}
 586
 587 \begin{code}
 588 rnClassPragmas NoClassPragmas = returnRn4 NoClassPragmas
 589
 590 rnClassPragmas (SuperDictPragmas sds)
 591   = mapRn4 rnGenPragmas sds     `thenRn4` \ new_sds ->
 592     returnRn4 (SuperDictPragmas new_sds)
 593 \end{code}
 594
 595 NB: In various cases around here, we don't @recoverQuietlyRn4@ around
 596 calls to @rnGenPragmas@; not really worth it.
 597
 598 \begin{code}
 599 rnInstancePragmas _ _ NoInstancePragmas = returnRn4 NoInstancePragmas
 600
 601 rnInstancePragmas _ _ (SimpleInstancePragma dfun)
 602   = rnGenPragmas dfun   `thenRn4` \ new_dfun ->
 603     returnRn4 (SimpleInstancePragma new_dfun)
 604
 605 rnInstancePragmas clas tv_env (ConstantInstancePragma dfun constms)
 606   = recoverQuietlyRn4 NoGenPragmas (
 607         rnGenPragmas dfun
 608     )                           `thenRn4` \ new_dfun ->
 609     mapRn4 name_n_gen constms   `thenRn4` \ new_constms ->
 610     returnRn4 (ConstantInstancePragma new_dfun new_constms)
 611   where
 612     name_n_gen (op, gen)
 613       = lookupClassOp clas op   `thenRn4` \ new_op ->
 614         rnGenPragmas gen        `thenRn4` \ new_gen ->
 615         returnRn4 (new_op, new_gen)
 616
 617 rnInstancePragmas clas tv_env (SpecialisedInstancePragma dfun specs)
 618   = recoverQuietlyRn4 NoGenPragmas (
 619         rnGenPragmas dfun
 620     )                           `thenRn4` \ new_dfun ->
 621     mapRn4 types_n_spec specs   `thenRn4` \ new_specs ->
 622     returnRn4 (SpecialisedInstancePragma new_dfun new_specs)
 623   where
 624     types_n_spec (ty_maybes, dicts_to_ignore, inst)
 625       = mapRn4 (rn_ty_maybe tv_env) ty_maybes   `thenRn4` \ new_tys ->
 626         rnInstancePragmas clas tv_env inst      `thenRn4` \ new_inst ->
 627         returnRn4 (new_tys, dicts_to_ignore, new_inst)
 628 \end{code}
 629
 630 And some general pragma stuff: (Not sure what, if any, of this would
 631 benefit from a TyVarNamesEnv passed in.... [ToDo])
 632 \begin{code}
 633 rnGenPragmas :: ProtoNameGenPragmas -> Rn4M RenamedGenPragmas
 634
 635 rnGenPragmas NoGenPragmas = returnRn4 NoGenPragmas
 636
 637 rnGenPragmas (GenPragmas arity upd def strict unfold specs)
 638   = recoverQuietlyRn4 NoImpUnfolding (
 639         rn_unfolding  unfold
 640     )                           `thenRn4` \ new_unfold ->
 641     rn_strictness strict        `thenRn4` \ new_strict ->
 642     recoverQuietlyRn4 [] (
 643         mapRn4 types_n_gen specs
 644     )                           `thenRn4` \ new_specs ->
 645     returnRn4 (GenPragmas arity upd def new_strict new_unfold new_specs)
 646   where
 647     rn_unfolding NoImpUnfolding = returnRn4 NoImpUnfolding
 648
 649     rn_unfolding (ImpMagicUnfolding str) = returnRn4 (ImpMagicUnfolding str)
 650
 651     rn_unfolding (ImpUnfolding guidance core)
 652       = rn_core nullTyVarNamesEnv core  `thenRn4` \ new_core ->
 653         returnRn4 (ImpUnfolding guidance new_core)
 654
 655     ------------
 656     rn_strictness NoImpStrictness = returnRn4 NoImpStrictness
 657
 658     rn_strictness (ImpStrictness is_bot ww_info wrkr_info)
 659       = recoverQuietlyRn4 NoGenPragmas (
 660             rnGenPragmas wrkr_info
 661         )                       `thenRn4` \ new_wrkr_info ->
 662         returnRn4 (ImpStrictness is_bot ww_info new_wrkr_info)
 663
 664     -------------
 665     types_n_gen (ty_maybes, dicts_to_ignore, gen)
 666       = mapRn4 (rn_ty_maybe no_env) ty_maybes   `thenRn4` \ new_tys ->
 667         recoverQuietlyRn4 NoGenPragmas (
 668             rnGenPragmas gen
 669         )                               `thenRn4` \ new_gen ->
 670         returnRn4 (new_tys, dicts_to_ignore, new_gen)
 671       where
 672         no_env = nullTyVarNamesEnv
 673
 674 ------------
 675 rn_ty_maybe tv_env Nothing = returnRn4 Nothing
 676
 677 rn_ty_maybe tv_env (Just ty)
 678   = rnMonoType True{-invisibles OK-} tv_env ty  `thenRn4` \ new_ty ->
 679     returnRn4 (Just new_ty)
 680
 681 ------------
 682 rn_core tvenv (UfVar v)
 683   = rn_uf_id tvenv v    `thenRn4` \ vname ->
 684     returnRn4 (UfVar vname)
 685
 686 rn_core tvenv (UfLit lit)
 687   = returnRn4 (UfLit lit)
 688
 689 rn_core tvenv (UfCon con tys as)
 690   = lookupValueEvenIfInvisible con      `thenRn4` \ new_con ->
 691     mapRn4 (rn_core_type tvenv) tys     `thenRn4` \ new_tys ->
 692     mapRn4 (rn_atom tvenv) as           `thenRn4` \ new_as ->
 693     returnRn4 (UfCon new_con new_tys new_as)
 694
 695 rn_core tvenv (UfPrim op tys as)
 696   = rn_core_primop tvenv op             `thenRn4` \ new_op ->
 697     mapRn4 (rn_core_type tvenv) tys     `thenRn4` \ new_tys ->
 698     mapRn4 (rn_atom tvenv) as           `thenRn4` \ new_as ->
 699     returnRn4 (UfPrim new_op new_tys new_as)
 700
 701 rn_core tvenv (UfLam binder body)
 702   = rn_binder tvenv binder `thenRn4` \ (b,ty) ->
 703     extendSS [b] (rn_core tvenv body) `thenRn4` \ new_body ->
 704     returnRn4 (UfLam (b,ty) new_body)
 705
 706 rn_core tvenv (UfApp fun arg)
 707   = rn_core tvenv fun   `thenRn4` \ new_fun ->
 708     rn_atom tvenv arg   `thenRn4` \ new_arg ->
 709     returnRn4 (UfApp new_fun new_arg)
 710
 711 rn_core tvenv (UfCase expr alts)
 712   = rn_core tvenv expr      `thenRn4` \ new_expr ->
 713     rn_alts       alts      `thenRn4` \ new_alts ->
 714     returnRn4 (UfCase new_expr new_alts)
 715   where
 716     rn_alts (UfCoAlgAlts alg_alts deflt)
 717       = mapRn4 rn_alg_alt alg_alts  `thenRn4` \ new_alts ->
 718         rn_deflt deflt              `thenRn4` \ new_deflt ->
 719         returnRn4 (UfCoAlgAlts new_alts new_deflt)
 720       where
 721         rn_alg_alt (con, params, rhs)
 722           = lookupValueEvenIfInvisible con  `thenRn4` \ new_con ->
 723             mapRn4 (rn_binder tvenv) params `thenRn4` \ new_params ->
 724             let
 725                 bs = [ b | (b, ty) <- new_params ]
 726             in
 727             extendSS bs (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
 728             returnRn4 (new_con, new_params, new_rhs)
 729
 730     rn_alts (UfCoPrimAlts prim_alts deflt)
 731       = mapRn4 rn_prim_alt prim_alts  `thenRn4` \ new_alts ->
 732         rn_deflt deflt                `thenRn4` \ new_deflt ->
 733         returnRn4 (UfCoPrimAlts new_alts new_deflt)
 734       where
 735         rn_prim_alt (lit, rhs)
 736           = rn_core tvenv rhs   `thenRn4` \ new_rhs ->
 737             returnRn4 (lit, new_rhs)
 738
 739     rn_deflt UfCoNoDefault = returnRn4 UfCoNoDefault
 740     rn_deflt (UfCoBindDefault b rhs)
 741       = rn_binder tvenv b                     `thenRn4` \ new_b@(binder, ty) ->
 742         extendSS [binder] (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
 743         returnRn4 (UfCoBindDefault new_b new_rhs)
 744
 745 rn_core tvenv (UfLet bind body)
 746   = rn_bind bind                              `thenRn4` \ (new_bind, new_binders) ->
 747     extendSS new_binders (rn_core tvenv body) `thenRn4` \ new_body ->
 748     returnRn4 (UfLet new_bind new_body)
 749   where
 750     rn_bind (UfCoNonRec b rhs)
 751       = rn_binder tvenv b       `thenRn4` \ new_b@(binder, ty) ->
 752         rn_core   tvenv rhs     `thenRn4` \ new_rhs ->
 753         returnRn4 (UfCoNonRec new_b new_rhs, [binder])
 754
 755     rn_bind (UfCoRec pairs)
 756       = -- conjure up Names; we do this differently than
 757         -- elsewhere for Core, because of the recursion here;
 758         -- no deep issue.
 759         -- [BEFORE IT WAS "FIXED"... 94/05...]
 760         -- [Andy -- It *was* a 'deep' issue to me...]
 761         -- [Will -- Poor wee soul.]
 762
 763         getSrcLocRn4                        `thenRn4` \ locn ->
 764         namesFromProtoNames "core variable"
 765           [ (b, locn) | ((b,_),_) <- pairs] `thenRn4` \ binders ->
 766
 767         extendSS binders (mapRn4 rn_pair (pairs `zip` binders)) `thenRn4` \ new_pairs ->
 768         returnRn4 (UfCoRec new_pairs, binders)
 769       where
 770         rn_pair (((b, ty), rhs), new_b)
 771           = rn_core_type tvenv ty       `thenRn4` \ new_ty ->
 772             rn_core      tvenv rhs      `thenRn4` \ new_rhs ->
 773             returnRn4 ((new_b, new_ty), new_rhs)
 774
 775 rn_core tvenv (UfSCC uf_cc body)
 776   = rn_cc uf_cc         `thenRn4` \ new_cc ->
 777     rn_core tvenv body  `thenRn4` \ new_body ->
 778     returnRn4 (UfSCC new_cc new_body)
 779   where
 780     rn_cc (UfAutoCC id m g is_dupd is_caf)
 781       = rn_uf_id tvenv id       `thenRn4` \ new_id ->
 782         returnRn4 (UfAutoCC new_id m g is_dupd is_caf)
 783
 784     rn_cc (UfDictCC id m g is_caf is_dupd)
 785       = rn_uf_id tvenv id       `thenRn4` \ new_id ->
 786         returnRn4 (UfDictCC new_id m g is_dupd is_caf)
 787
 788     -- the rest are boring:
 789     rn_cc (UfPreludeDictsCC d) = returnRn4 (UfPreludeDictsCC d)
 790     rn_cc (UfAllDictsCC m g d) = returnRn4 (UfAllDictsCC m g d)
 791     rn_cc (UfUserCC n m g d c) = returnRn4 (UfUserCC n m g d c)
 792
 793 ------------
 794 rn_core_primop tvenv (UfCCallOp str is_casm may_gc arg_tys res_ty)
 795   = mapRn4 (rn_core_type tvenv) arg_tys `thenRn4` \ new_arg_tys ->
 796     rn_core_type tvenv res_ty           `thenRn4` \ new_res_ty  ->
 797     returnRn4 (UfCCallOp str is_casm may_gc new_arg_tys new_res_ty)
 798 rn_core_primop tvenv (UfOtherOp op)
 799   = returnRn4 (UfOtherOp op)
 800
 801 ------------
 802 rn_uf_id tvenv (BoringUfId v)
 803   = lookupValueEvenIfInvisible v    `thenRn4` \ vname ->
 804     returnRn4 (BoringUfId vname)
 805
 806 rn_uf_id tvenv (SuperDictSelUfId c sc)
 807   = lookupClass{-EvenIfInvisible-} c    `thenRn4` \ new_c ->
 808     lookupClass{-EvenIfInvisible-} sc   `thenRn4` \ new_sc ->
 809     returnRn4 (SuperDictSelUfId new_c new_sc)
 810
 811 rn_uf_id tvenv (ClassOpUfId c op)
 812   = lookupClass{-EvenIfInvisible-} c            `thenRn4` \ new_c ->
 813     lookupClassOp{-EvenIfInvisible-} new_c op   `thenRn4` \ new_op ->
 814     returnRn4 (ClassOpUfId new_c new_op)
 815
 816 rn_uf_id tvenv (DictFunUfId c ty)
 817   = lookupClass{-EvenIfInvisible-} c    `thenRn4` \ new_c ->
 818     rn_core_type tvenv ty               `thenRn4` \ new_ty ->
 819     returnRn4 (DictFunUfId new_c new_ty)
 820
 821 rn_uf_id tvenv (ConstMethodUfId c op ty)
 822   = lookupClass{-EvenIfInvisible-} c          `thenRn4` \ new_c ->
 823     lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op ->
 824     rn_core_type tvenv ty                     `thenRn4` \ new_ty ->
 825     returnRn4 (ConstMethodUfId new_c new_op new_ty)
 826
 827 rn_uf_id tvenv (DefaultMethodUfId c op)
 828   = lookupClass{-EvenIfInvisible-} c            `thenRn4` \ new_c ->
 829     lookupClassOp{-EvenIfInvisible-} new_c op   `thenRn4` \ new_op ->
 830     returnRn4 (DefaultMethodUfId new_c new_op)
 831
 832 rn_uf_id tvenv (SpecUfId unspec ty_maybes)
 833   = rn_uf_id tvenv unspec                `thenRn4` \ new_unspec ->
 834     mapRn4 (rn_ty_maybe tvenv) ty_maybes `thenRn4` \ new_ty_maybes ->
 835     returnRn4 (SpecUfId new_unspec new_ty_maybes)
 836
 837 rn_uf_id tvenv (WorkerUfId unwrkr)
 838   = rn_uf_id tvenv unwrkr       `thenRn4` \ new_unwrkr ->
 839     returnRn4 (WorkerUfId new_unwrkr)
 840
 841 ------------
 842 rn_binder tvenv (b, ty)
 843   = getSrcLocRn4                        `thenRn4` \ src_loc ->
 844     namesFromProtoNames "binder in core unfolding" [(b, src_loc)]
 845                                         `thenRn4` \ [new_b] ->
 846     rn_core_type tvenv ty               `thenRn4` \ new_ty ->
 847     returnRn4 (new_b, new_ty)
 848
 849 ------------
 850 rn_atom tvenv (UfCoLitAtom l) = returnRn4 (UfCoLitAtom l)
 851 rn_atom tvenv (UfCoVarAtom v)
 852   = rn_uf_id tvenv v                    `thenRn4` \ vname ->
 853     returnRn4 (UfCoVarAtom vname)
 854
 855 ------------
 856 rn_core_type_maybe tvenv Nothing = returnRn4 Nothing
 857 rn_core_type_maybe tvenv (Just ty)
 858   = rn_core_type tvenv ty `thenRn4` \ new_ty ->
 859     returnRn4 (Just new_ty)
 860
 861 ------------
 862 rn_core_type tvenv ty
 863   = rnPolyType True{-invisible tycons OK-} tvenv ty
 864 \end{code}
 865
 866
 867 \begin{code}
 868 derivingNonStdClassErr clas locn sty
 869   = ppHang (ppStr "Non-standard class in deriving")
 870          4 (ppCat [ppr sty clas, ppr sty locn])
 871
 872 dupDefaultDeclErr defs sty
 873   = ppHang (ppStr "Duplicate default declarations")
 874          4 (ppAboves (map pp_def_loc defs))
 875   where
 876     pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
 877 \end{code}