ghc/compiler/rename/Rename4.lhs

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