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, 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 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 (InlineSig var guide locn)
 265       = pushSrcLocRn4 locn            (
 266         lookupValue var     `thenRn4` \ new_var ->
 267         returnRn4 (InlineSig new_var guide locn)
 268         )
 269     rn_uprag (DeforestSig var locn)
 270       = pushSrcLocRn4 locn            (
 271         lookupValue var            `thenRn4` \ new_var ->
 272         returnRn4 (DeforestSig new_var locn)
 273         )
 274     rn_uprag (MagicUnfoldingSig var str locn)
 275       = pushSrcLocRn4 locn                (
 276         lookupValue var     `thenRn4` \ new_var ->
 277         returnRn4 (MagicUnfoldingSig new_var str locn)
 278         )
 279 \end{code}
 280
 281 %*********************************************************
 282 %*                                                      *
 283 \subsection{@SPECIALIZE instance@ user-pragmas}
 284 %*                                                      *
 285 %*********************************************************
 286
 287 \begin{code}
 288 rnInstSpecSig4 :: ProtoNameSpecialisedInstanceSig
 289                 -> Rn4M RenamedSpecialisedInstanceSig
 290
 291 rnInstSpecSig4 (InstSpecSig clas ty src_loc)
 292   = pushSrcLocRn4 src_loc                 (
 293     let  tyvars = extractMonoTyNames eqProtoName ty  in
 294     mkTyVarNamesEnv src_loc tyvars      `thenRn4` \ (tv_env,_) ->
 295     lookupClass clas                    `thenRn4` \ new_clas ->
 296     rnMonoType4 False tv_env ty         `thenRn4` \ new_ty ->
 297     returnRn4 (InstSpecSig new_clas new_ty src_loc)
 298     )
 299 \end{code}
 300
 301 %*********************************************************
 302 %*                                                      *
 303 \subsection{Default declarations}
 304 %*                                                      *
 305 %*********************************************************
 306
 307 @rnDefaultDecl4@ uses the `global name function' to create a new set
 308 of default declarations in which local names have been replaced by
 309 their original names, reporting any unknown names.
 310
 311 \begin{code}
 312 rnDefaultDecl4 :: ProtoNameDefaultDecl -> Rn4M RenamedDefaultDecl
 313
 314 rnDefaultDecl4 (DefaultDecl tys src_loc)
 315   = pushSrcLocRn4 src_loc                                (
 316     mapRn4 (rnMonoType4 False nullTyVarNamesEnv) tys `thenRn4` \ tys' ->
 317     returnRn4 (DefaultDecl tys' src_loc)
 318     )
 319 \end{code}
 320
 321 %*************************************************************************
 322 %*                                                                      *
 323 \subsection{Type signatures from interfaces}
 324 %*                                                                      *
 325 %*************************************************************************
 326
 327 Non-interface type signatures (which may include user-pragmas) are
 328 handled with @Binds@.
 329
 330 @ClassOpSigs@ are dealt with in class declarations.
 331
 332 \begin{code}
 333 rnIntSig4 :: ProtoNameSig -> Rn4M RenamedSig
 334
 335 rnIntSig4 (Sig name ty pragma src_loc)
 336   = pushSrcLocRn4 src_loc                             (
 337     lookupValue name                            `thenRn4` \ new_name ->
 338     rnPolyType4 False True nullTyVarNamesEnv ty `thenRn4` \ new_ty   ->
 339     recoverQuietlyRn4 NoGenPragmas (
 340         rnGenPragmas4 pragma
 341     )                                       `thenRn4` \ new_pragma ->
 342     returnRn4 (Sig new_name new_ty new_pragma src_loc)
 343     )
 344 \end{code}
 345
 346 %*************************************************************************
 347 %*                                                                      *
 348 \subsection{Fixity declarations}
 349 %*                                                                      *
 350 %*************************************************************************
 351
 352 \begin{code}
 353 rnFixes4 :: [ProtoNameFixityDecl]  -> Rn4M [RenamedFixityDecl]
 354
 355 rnFixes4 fixities
 356   = mapRn4 rn_fixity fixities `thenRn4` \ fixes_maybe ->
 357     returnRn4 (catMaybes fixes_maybe)
 358   where
 359     rn_fixity (InfixL name i)
 360       = lookupFixityOp name `thenRn4` \ res ->
 361         returnRn4 (
 362           case res of
 363             Just name2 ->  Just (InfixL name2 i)
 364             Nothing    ->  Nothing
 365         )
 366
 367     rn_fixity (InfixR name i)
 368       = lookupFixityOp name     `thenRn4` \ res ->
 369         returnRn4 (
 370           case res of
 371             Just name2 ->  Just (InfixR name2 i)
 372             Nothing    ->  Nothing
 373         )
 374
 375     rn_fixity (InfixN name i)
 376       = lookupFixityOp name     `thenRn4` \ res ->
 377         returnRn4 (
 378           case res of
 379             Just name2 ->  Just (InfixN name2 i)
 380             Nothing    ->  Nothing
 381         )
 382 \end{code}
 383
 384 %*********************************************************
 385 %*                                                      *
 386 \subsection{Support code to rename types}
 387 %*                                                      *
 388 %*********************************************************
 389
 390 \begin{code}
 391 rnPolyType4 :: Bool             -- True <=> "invisible" tycons (in pragmas) allowed
 392             -> Bool             -- True <=> snaffle tyvars from ty and
 393                                 --  stuff them in tyvar env; True for
 394                                 --  signatures and things; False for type
 395                                 --  synonym defns and things.
 396             -> TyVarNamesEnv
 397             -> ProtoNamePolyType
 398             -> Rn4M RenamedPolyType
 399
 400 rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (UnoverloadedTy ty)
 401   = rn_poly_help invisibles_allowed snaffle_tyvars tv_env [] ty `thenRn4` \ (_, new_ty) ->
 402     returnRn4 (UnoverloadedTy new_ty)
 403
 404 rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (OverloadedTy ctxt ty)
 405   = rn_poly_help invisibles_allowed snaffle_tyvars tv_env ctxt ty `thenRn4` \ (new_ctxt, new_ty) ->
 406     returnRn4 (OverloadedTy new_ctxt new_ty)
 407
 408 rnPolyType4 invisibles_allowed snaffle_tyvars tv_env (ForAllTy tvs ty)
 409   = getSrcLocRn4                `thenRn4` \ src_loc ->
 410     mkTyVarNamesEnv src_loc tvs `thenRn4` \ (tvenv2, new_tvs) ->
 411     let
 412         new_tvenv = catTyVarNamesEnvs tvenv2 tv_env
 413     in
 414     rnMonoType4 invisibles_allowed new_tvenv ty `thenRn4` \ new_ty ->
 415     returnRn4 (ForAllTy new_tvs new_ty)
 416
 417 ------------
 418 rn_poly_help invisibles_allowed snaffle_tyvars tv_env ctxt ty
 419   = getSrcLocRn4                `thenRn4` \ src_loc ->
 420     let
 421         -- ToDo: this randomly-grabbing-tyvar names out
 422         -- of the type seems a little weird to me
 423         -- (WDP 94/11)
 424
 425         new_tyvars
 426           = extractMonoTyNames eqProtoName ty
 427             `minus_list` domTyVarNamesEnv tv_env
 428     in
 429     mkTyVarNamesEnv src_loc new_tyvars  `thenRn4` \ (tv_env2, _) ->
 430     let
 431         tv_env3 = if snaffle_tyvars
 432                   then catTyVarNamesEnvs tv_env2 tv_env
 433                   else tv_env -- leave it alone
 434     in
 435     rnContext4 tv_env3 ctxt             `thenRn4` \ new_ctxt ->
 436     rnMonoType4 invisibles_allowed tv_env3 ty
 437                                         `thenRn4` \ new_ty ->
 438     returnRn4 (new_ctxt, new_ty)
 439   where
 440     minus_list xs ys = [ x | x <- xs, not (x `elemProtoNames` ys)]
 441 \end{code}
 442
 443 \begin{code}
 444 rnMonoType4 :: Bool             -- allowed to look at invisible tycons
 445             -> TyVarNamesEnv
 446             -> ProtoNameMonoType
 447             -> Rn4M RenamedMonoType
 448
 449 rnMonoType4 invisibles_allowed  tv_env (MonoTyVar tyvar)
 450   = lookupTyVarName tv_env tyvar        `thenRn4` \ tyvar' ->
 451     returnRn4 (MonoTyVar tyvar')
 452
 453 rnMonoType4 invisibles_allowed  tv_env (ListMonoTy ty)
 454   = rnMonoType4 invisibles_allowed tv_env ty    `thenRn4` \ ty' ->
 455     returnRn4 (ListMonoTy ty')
 456
 457 rnMonoType4 invisibles_allowed  tv_env (FunMonoTy ty1 ty2)
 458   = andRn4 FunMonoTy (rnMonoType4 invisibles_allowed tv_env ty1)
 459                      (rnMonoType4 invisibles_allowed tv_env ty2)
 460
 461 rnMonoType4 invisibles_allowed  tv_env (TupleMonoTy tys)
 462   = mapRn4 (rnPolyType4 invisibles_allowed False tv_env) tys `thenRn4` \ tys' ->
 463     returnRn4 (TupleMonoTy tys')
 464
 465 rnMonoType4 invisibles_allowed tv_env (MonoTyCon name tys)
 466   = let
 467         lookup_fn = if invisibles_allowed
 468                     then lookupTyConEvenIfInvisible
 469                     else lookupTyCon
 470     in
 471     lookup_fn name                      `thenRn4` \ tycon_name' ->
 472     mapRn4 (rnMonoType4 invisibles_allowed tv_env) tys  `thenRn4` \ tys' ->
 473     returnRn4 (MonoTyCon tycon_name' tys')
 474
 475 -- for unfoldings only:
 476
 477 rnMonoType4 invisibles_allowed tv_env (MonoTyVarTemplate name)
 478   = --pprTrace "rnMonoType4:MonoTyVarTemplate:" (ppAbove (ppr PprDebug name) (ppr PprDebug tv_env)) (
 479     lookupTyVarName tv_env name         `thenRn4` \ new_name ->
 480     returnRn4 (MonoTyVarTemplate new_name)
 481     --)
 482
 483 rnMonoType4 invisibles_allowed tv_env (MonoDict clas ty)
 484   = lookupClass clas            `thenRn4` \ new_clas ->
 485     rnMonoType4 invisibles_allowed tv_env ty    `thenRn4` \ new_ty ->
 486     returnRn4 (MonoDict new_clas new_ty)
 487
 488 #ifdef DPH
 489 rnMonoType4 invisibles_allowed tv_env (MonoTyProc tys ty)
 490   = mapRn4 (rnMonoType4 invisibles_allowed  tv_env) tys `thenRn4` \ tys' ->
 491     rnMonoType4 invisibles_allowed   tv_env ty          `thenRn4` \ ty'  ->
 492     returnRn4 (MonoTyProc tys' ty')
 493
 494 rnMonoType4 invisibles_allowed tv_env (MonoTyPod ty)
 495   = rnMonoType4 invisibles_allowed   tv_env ty  `thenRn4` \ ty'  ->
 496     returnRn4 (MonoTyPod ty')
 497 #endif {- Data Parallel Haskell -}
 498 \end{code}
 499
 500 \begin{code}
 501 rnContext4 :: TyVarNamesEnv -> ProtoNameContext -> Rn4M RenamedContext
 502
 503 rnContext4 tv_env ctxt
 504   = mapRn4 rn_ctxt ctxt
 505   where
 506     rn_ctxt (clas, tyvar)
 507      = lookupClass clas             `thenRn4` \ clas_name ->
 508        lookupTyVarName tv_env tyvar `thenRn4` \ tyvar_name ->
 509        returnRn4 (clas_name, tyvar_name)
 510 \end{code}
 511
 512 %*********************************************************
 513 %*                                                      *
 514 \subsection{Support code to rename various pragmas}
 515 %*                                                      *
 516 %*********************************************************
 517
 518 \begin{code}
 519 rnDataPragmas4 tv_env (DataPragmas cons specs)
 520   = rnConDecls4 tv_env True{-invisibles allowed-} cons `thenRn4` \ new_cons ->
 521     mapRn4 types_n_spec specs                          `thenRn4` \ new_specs ->
 522     returnRn4 (DataPragmas new_cons new_specs)
 523   where
 524     types_n_spec ty_maybes
 525       = mapRn4 (rn_ty_maybe nullTyVarNamesEnv) ty_maybes
 526 \end{code}
 527
 528 \begin{code}
 529 rnClassOpPragmas4 NoClassOpPragmas = returnRn4 NoClassOpPragmas
 530
 531 rnClassOpPragmas4 (ClassOpPragmas dsel defm)
 532   = recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 dsel) `thenRn4` \ new_dsel ->
 533     recoverQuietlyRn4 NoGenPragmas (rnGenPragmas4 defm) `thenRn4` \ new_defm ->
 534     returnRn4 (ClassOpPragmas new_dsel new_defm)
 535 \end{code}
 536
 537 \begin{code}
 538 rnClassPragmas4 NoClassPragmas = returnRn4 NoClassPragmas
 539
 540 rnClassPragmas4 (SuperDictPragmas sds)
 541   = mapRn4 rnGenPragmas4 sds    `thenRn4` \ new_sds ->
 542     returnRn4 (SuperDictPragmas new_sds)
 543 \end{code}
 544
 545 NB: In various cases around here, we don't @recoverQuietlyRn4@ around
 546 calls to @rnGenPragmas4@; not really worth it.
 547
 548 \begin{code}
 549 rnInstancePragmas4 _ _ NoInstancePragmas = returnRn4 NoInstancePragmas
 550
 551 rnInstancePragmas4 _ _ (SimpleInstancePragma dfun)
 552   = rnGenPragmas4 dfun  `thenRn4` \ new_dfun ->
 553     returnRn4 (SimpleInstancePragma new_dfun)
 554
 555 rnInstancePragmas4 clas tv_env (ConstantInstancePragma dfun constms)
 556   = recoverQuietlyRn4 NoGenPragmas (
 557         rnGenPragmas4 dfun
 558     )                           `thenRn4` \ new_dfun ->
 559     mapRn4 name_n_gen constms   `thenRn4` \ new_constms ->
 560     returnRn4 (ConstantInstancePragma new_dfun new_constms)
 561   where
 562     name_n_gen (op, gen)
 563       = lookupClassOp clas op   `thenRn4` \ new_op ->
 564         rnGenPragmas4 gen       `thenRn4` \ new_gen ->
 565         returnRn4 (new_op, new_gen)
 566
 567 rnInstancePragmas4 clas tv_env (SpecialisedInstancePragma dfun specs)
 568   = recoverQuietlyRn4 NoGenPragmas (
 569         rnGenPragmas4 dfun
 570     )                           `thenRn4` \ new_dfun ->
 571     mapRn4 types_n_spec specs   `thenRn4` \ new_specs ->
 572     returnRn4 (SpecialisedInstancePragma new_dfun new_specs)
 573   where
 574     types_n_spec (ty_maybes, dicts_to_ignore, inst)
 575       = mapRn4 (rn_ty_maybe tv_env) ty_maybes   `thenRn4` \ new_tys ->
 576         rnInstancePragmas4 clas tv_env inst     `thenRn4` \ new_inst ->
 577         returnRn4 (new_tys, dicts_to_ignore, new_inst)
 578 \end{code}
 579
 580 And some general pragma stuff: (Not sure what, if any, of this would
 581 benefit from a TyVarNamesEnv passed in.... [ToDo])
 582 \begin{code}
 583 rnGenPragmas4 NoGenPragmas = returnRn4 NoGenPragmas
 584
 585 rnGenPragmas4 (GenPragmas arity upd def strict unfold specs)
 586   = recoverQuietlyRn4 NoImpUnfolding (
 587         rn_unfolding  unfold
 588     )                           `thenRn4` \ new_unfold ->
 589     rn_strictness strict        `thenRn4` \ new_strict ->
 590     recoverQuietlyRn4 [] (
 591         mapRn4 types_n_gen specs
 592     )                           `thenRn4` \ new_specs ->
 593     returnRn4 (GenPragmas arity upd def new_strict new_unfold new_specs)
 594   where
 595     rn_unfolding NoImpUnfolding = returnRn4 NoImpUnfolding
 596
 597     rn_unfolding (ImpMagicUnfolding str) = returnRn4 (ImpMagicUnfolding str)
 598
 599     rn_unfolding (ImpUnfolding guidance core)
 600       = rn_core nullTyVarNamesEnv core  `thenRn4` \ new_core ->
 601         returnRn4 (ImpUnfolding guidance new_core)
 602
 603     ------------
 604     rn_strictness NoImpStrictness = returnRn4 NoImpStrictness
 605
 606     rn_strictness (ImpStrictness is_bot ww_info wrkr_info)
 607       = recoverQuietlyRn4 NoGenPragmas (
 608             rnGenPragmas4 wrkr_info
 609         )                       `thenRn4` \ new_wrkr_info ->
 610         returnRn4 (ImpStrictness is_bot ww_info new_wrkr_info)
 611
 612     -------------
 613     types_n_gen (ty_maybes, dicts_to_ignore, gen)
 614       = mapRn4 (rn_ty_maybe no_env) ty_maybes   `thenRn4` \ new_tys ->
 615         recoverQuietlyRn4 NoGenPragmas (
 616             rnGenPragmas4 gen
 617         )                               `thenRn4` \ new_gen ->
 618         returnRn4 (new_tys, dicts_to_ignore, new_gen)
 619       where
 620         no_env = nullTyVarNamesEnv
 621
 622 ------------
 623 rn_ty_maybe tv_env Nothing = returnRn4 Nothing
 624
 625 rn_ty_maybe tv_env (Just ty)
 626   = rnMonoType4 True{-invisibles OK-} tv_env ty  `thenRn4` \ new_ty ->
 627     returnRn4 (Just new_ty)
 628
 629 ------------
 630 rn_core tvenv (UfCoVar v)
 631   = rn_uf_id tvenv v    `thenRn4` \ vname ->
 632     returnRn4 (UfCoVar vname)
 633
 634 rn_core tvenv (UfCoLit lit)
 635   = returnRn4 (UfCoLit lit)
 636
 637 rn_core tvenv (UfCoCon con tys as)
 638   = lookupValueEvenIfInvisible con      `thenRn4` \ new_con ->
 639     mapRn4 (rn_core_type tvenv) tys     `thenRn4` \ new_tys ->
 640     mapRn4 (rn_atom tvenv) as           `thenRn4` \ new_as ->
 641     returnRn4 (UfCoCon new_con new_tys new_as)
 642
 643 rn_core tvenv (UfCoPrim op tys as)
 644   = rn_core_primop tvenv op             `thenRn4` \ new_op ->
 645     mapRn4 (rn_core_type tvenv) tys     `thenRn4` \ new_tys ->
 646     mapRn4 (rn_atom tvenv) as           `thenRn4` \ new_as ->
 647     returnRn4 (UfCoPrim new_op new_tys new_as)
 648
 649 rn_core tvenv (UfCoLam binders body)
 650   = mapRn4 (rn_binder tvenv) binders `thenRn4` \ new_binders ->
 651     let
 652         bs = [ b | (b, ty) <- new_binders ]
 653     in
 654     extendSS bs (rn_core tvenv body) `thenRn4` \ new_body ->
 655     returnRn4 (UfCoLam new_binders new_body)
 656
 657 rn_core tvenv (UfCoTyLam tv body)
 658   = getSrcLocRn4                        `thenRn4` \ src_loc ->
 659     mkTyVarNamesEnv src_loc [tv]        `thenRn4` \ (tvenv2, [new_tv]) ->
 660     let
 661         new_tvenv = catTyVarNamesEnvs tvenv2 tvenv
 662     in
 663     rn_core new_tvenv body              `thenRn4` \ new_body ->
 664     returnRn4 (UfCoTyLam new_tv new_body)
 665
 666 rn_core tvenv (UfCoApp fun arg)
 667   = rn_core tvenv fun   `thenRn4` \ new_fun ->
 668     rn_atom tvenv arg   `thenRn4` \ new_arg ->
 669     returnRn4 (UfCoApp new_fun new_arg)
 670
 671 rn_core tvenv (UfCoTyApp expr ty)
 672   = rn_core tvenv expr      `thenRn4` \ new_expr ->
 673     rn_core_type tvenv ty   `thenRn4` \ new_ty ->
 674     returnRn4 (UfCoTyApp new_expr new_ty)
 675
 676 rn_core tvenv (UfCoCase expr alts)
 677   = rn_core tvenv expr      `thenRn4` \ new_expr ->
 678     rn_alts       alts      `thenRn4` \ new_alts ->
 679     returnRn4 (UfCoCase new_expr new_alts)
 680   where
 681     rn_alts (UfCoAlgAlts alg_alts deflt)
 682       = mapRn4 rn_alg_alt alg_alts  `thenRn4` \ new_alts ->
 683         rn_deflt deflt              `thenRn4` \ new_deflt ->
 684         returnRn4 (UfCoAlgAlts new_alts new_deflt)
 685       where
 686         rn_alg_alt (con, params, rhs)
 687           = lookupValueEvenIfInvisible con  `thenRn4` \ new_con ->
 688             mapRn4 (rn_binder tvenv) params `thenRn4` \ new_params ->
 689             let
 690                 bs = [ b | (b, ty) <- new_params ]
 691             in
 692             extendSS bs (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
 693             returnRn4 (new_con, new_params, new_rhs)
 694
 695     rn_alts (UfCoPrimAlts prim_alts deflt)
 696       = mapRn4 rn_prim_alt prim_alts  `thenRn4` \ new_alts ->
 697         rn_deflt deflt                `thenRn4` \ new_deflt ->
 698         returnRn4 (UfCoPrimAlts new_alts new_deflt)
 699       where
 700         rn_prim_alt (lit, rhs)
 701           = rn_core tvenv rhs   `thenRn4` \ new_rhs ->
 702             returnRn4 (lit, new_rhs)
 703
 704     rn_deflt UfCoNoDefault = returnRn4 UfCoNoDefault
 705     rn_deflt (UfCoBindDefault b rhs)
 706       = rn_binder tvenv b                     `thenRn4` \ new_b@(binder, ty) ->
 707         extendSS [binder] (rn_core tvenv rhs) `thenRn4` \ new_rhs ->
 708         returnRn4 (UfCoBindDefault new_b new_rhs)
 709
 710 rn_core tvenv (UfCoLet bind body)
 711   = rn_bind bind                              `thenRn4` \ (new_bind, new_binders) ->
 712     extendSS new_binders (rn_core tvenv body) `thenRn4` \ new_body ->
 713     returnRn4 (UfCoLet new_bind new_body)
 714   where
 715     rn_bind (UfCoNonRec b rhs)
 716       = rn_binder tvenv b       `thenRn4` \ new_b@(binder, ty) ->
 717         rn_core   tvenv rhs     `thenRn4` \ new_rhs ->
 718         returnRn4 (UfCoNonRec new_b new_rhs, [binder])
 719
 720     rn_bind (UfCoRec pairs)
 721       = -- conjure up Names; we do this differently than
 722         -- elsewhere for Core, because of the recursion here;
 723         -- no deep issue.
 724         -- [BEFORE IT WAS "FIXED"... 94/05...]
 725         -- [Andy -- It *was* a 'deep' issue to me...]
 726         -- [Will -- Poor wee soul.]
 727
 728         getSrcLocRn4                        `thenRn4` \ locn ->
 729         namesFromProtoNames "core variable"
 730           [ (b, locn) | ((b,_),_) <- pairs] `thenRn4` \ binders ->
 731
 732         extendSS binders (mapRn4 rn_pair (pairs `zip` binders)) `thenRn4` \ new_pairs ->
 733         returnRn4 (UfCoRec new_pairs, binders)
 734       where
 735         rn_pair (((b, ty), rhs), new_b)
 736           = rn_core_type tvenv ty       `thenRn4` \ new_ty ->
 737             rn_core      tvenv rhs      `thenRn4` \ new_rhs ->
 738             returnRn4 ((new_b, new_ty), new_rhs)
 739
 740 rn_core tvenv (UfCoSCC uf_cc body)
 741   = rn_cc uf_cc         `thenRn4` \ new_cc ->
 742     rn_core tvenv body  `thenRn4` \ new_body ->
 743     returnRn4 (UfCoSCC new_cc new_body)
 744   where
 745     rn_cc (UfAutoCC id m g is_dupd is_caf)
 746       = rn_uf_id tvenv id       `thenRn4` \ new_id ->
 747         returnRn4 (UfAutoCC new_id m g is_dupd is_caf)
 748
 749     rn_cc (UfDictCC id m g is_caf is_dupd)
 750       = rn_uf_id tvenv id       `thenRn4` \ new_id ->
 751         returnRn4 (UfDictCC new_id m g is_dupd is_caf)
 752
 753     -- the rest are boring:
 754     rn_cc (UfPreludeDictsCC d) = returnRn4 (UfPreludeDictsCC d)
 755     rn_cc (UfAllDictsCC m g d) = returnRn4 (UfAllDictsCC m g d)
 756     rn_cc (UfUserCC n m g d c) = returnRn4 (UfUserCC n m g d c)
 757
 758 ------------
 759 rn_core_primop tvenv (UfCCallOp str is_casm may_gc arg_tys res_ty)
 760   = mapRn4 (rn_core_type tvenv) arg_tys `thenRn4` \ new_arg_tys ->
 761     rn_core_type tvenv res_ty           `thenRn4` \ new_res_ty  ->
 762     returnRn4 (UfCCallOp str is_casm may_gc new_arg_tys new_res_ty)
 763 rn_core_primop tvenv (UfOtherOp op)
 764   = returnRn4 (UfOtherOp op)
 765
 766 ------------
 767 rn_uf_id tvenv (BoringUfId v)
 768   = lookupValueEvenIfInvisible v    `thenRn4` \ vname ->
 769     returnRn4 (BoringUfId vname)
 770
 771 rn_uf_id tvenv (SuperDictSelUfId c sc)
 772   = lookupClass{-EvenIfInvisible-} c    `thenRn4` \ new_c ->
 773     lookupClass{-EvenIfInvisible-} sc   `thenRn4` \ new_sc ->
 774     returnRn4 (SuperDictSelUfId new_c new_sc)
 775
 776 rn_uf_id tvenv (ClassOpUfId c op)
 777   = lookupClass{-EvenIfInvisible-} c            `thenRn4` \ new_c ->
 778     lookupClassOp{-EvenIfInvisible-} new_c op   `thenRn4` \ new_op ->
 779     returnRn4 (ClassOpUfId new_c new_op)
 780
 781 rn_uf_id tvenv (DictFunUfId c ty)
 782   = lookupClass{-EvenIfInvisible-} c    `thenRn4` \ new_c ->
 783     rn_core_type tvenv ty               `thenRn4` \ new_ty ->
 784     returnRn4 (DictFunUfId new_c new_ty)
 785
 786 rn_uf_id tvenv (ConstMethodUfId c op ty)
 787   = lookupClass{-EvenIfInvisible-} c          `thenRn4` \ new_c ->
 788     lookupClassOp{-EvenIfInvisible-} new_c op `thenRn4` \ new_op ->
 789     rn_core_type tvenv ty                     `thenRn4` \ new_ty ->
 790     returnRn4 (ConstMethodUfId new_c new_op new_ty)
 791
 792 rn_uf_id tvenv (DefaultMethodUfId c op)
 793   = lookupClass{-EvenIfInvisible-} c            `thenRn4` \ new_c ->
 794     lookupClassOp{-EvenIfInvisible-} new_c op   `thenRn4` \ new_op ->
 795     returnRn4 (DefaultMethodUfId new_c new_op)
 796
 797 rn_uf_id tvenv (SpecUfId unspec ty_maybes)
 798   = rn_uf_id tvenv unspec                `thenRn4` \ new_unspec ->
 799     mapRn4 (rn_ty_maybe tvenv) ty_maybes `thenRn4` \ new_ty_maybes ->
 800     returnRn4 (SpecUfId new_unspec new_ty_maybes)
 801
 802 rn_uf_id tvenv (WorkerUfId unwrkr)
 803   = rn_uf_id tvenv unwrkr       `thenRn4` \ new_unwrkr ->
 804     returnRn4 (WorkerUfId new_unwrkr)
 805
 806 ------------
 807 rn_binder tvenv (b, ty)
 808   = getSrcLocRn4                        `thenRn4` \ src_loc ->
 809     namesFromProtoNames "binder in core unfolding" [(b, src_loc)]
 810                                         `thenRn4` \ [new_b] ->
 811     rn_core_type tvenv ty               `thenRn4` \ new_ty ->
 812     returnRn4 (new_b, new_ty)
 813
 814 ------------
 815 rn_atom tvenv (UfCoLitAtom l) = returnRn4 (UfCoLitAtom l)
 816 rn_atom tvenv (UfCoVarAtom v)
 817   = rn_uf_id tvenv v                    `thenRn4` \ vname ->
 818     returnRn4 (UfCoVarAtom vname)
 819
 820 ------------
 821 rn_core_type_maybe tvenv Nothing = returnRn4 Nothing
 822 rn_core_type_maybe tvenv (Just ty)
 823   = rn_core_type tvenv ty `thenRn4` \ new_ty ->
 824     returnRn4 (Just new_ty)
 825
 826 ------------
 827 rn_core_type tvenv ty
 828   = rnPolyType4 True{-invisible tycons OK-} False tvenv ty
 829 \end{code}