ghc/compiler/rename/RnSource.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnSource]{Main pass of renamer}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module RnSource ( rnDecl, rnHsType ) where
  10
  11 IMP_Ubiq()
  12 IMPORT_DELOOPER(RnLoop)         -- *check* the RnPass/RnExpr/RnBinds loop-breaking
  13
  14 import HsSyn
  15 import HsDecls          ( HsIdInfo(..) )
  16 import HsPragmas
  17 import HsTypes          ( getTyVarName )
  18 import RdrHsSyn
  19 import RnHsSyn
  20 import HsCore
  21
  22 import RnBinds          ( rnTopBinds, rnMethodBinds )
  23 import RnEnv            ( bindTyVarsRn, lookupRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
  24                           lookupOptionalOccRn, newDfunName,
  25                           listType_RDR, tupleType_RDR )
  26 import RnMonad
  27
  28 import Name             ( Name, isLocallyDefined, isTvOcc, pprNonSym,
  29                           Provenance,
  30                           SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet,
  31                           elemNameSet
  32                         )
  33 import ErrUtils         ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
  34 import FiniteMap        ( emptyFM, lookupFM, addListToFM_C )
  35 import Id               ( GenId{-instance NamedThing-} )
  36 import IdInfo           ( IdInfo, StrictnessInfo(..), FBTypeInfo, DemandInfo, ArgUsageInfo )
  37 import SpecEnv          ( SpecEnv )
  38 import CoreUnfold       ( Unfolding(..), SimpleUnfolding )
  39 import MagicUFs         ( MagicUnfoldingFun )
  40 import PrelInfo         ( derivingOccurrences, evalClass_RDR, numClass_RDR )
  41 import ListSetOps       ( unionLists, minusList )
  42 import Maybes           ( maybeToBool, catMaybes )
  43 import Bag              ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
  44 import Outputable       ( Outputable(..){-instances-} )
  45 --import PprStyle       -- ToDo:rm
  46 import Pretty
  47 import SrcLoc           ( SrcLoc )
  48 -- import TyCon         ( TyCon{-instance NamedThing-} )
  49 import Unique           ( Unique )
  50 import UniqSet          ( SYN_IE(UniqSet) )
  51 import UniqFM           ( UniqFM, lookupUFM )
  52 import Util             ( isIn, isn'tIn, thenCmp, removeDups, cmpPString,
  53                           panic, assertPanic{- , pprTrace ToDo:rm-} )
  54 \end{code}
  55
  56 rnDecl `renames' declarations.
  57 It simultaneously performs dependency analysis and precedence parsing.
  58 It also does the following error checks:
  59 \begin{enumerate}
  60 \item
  61 Checks that tyvars are used properly. This includes checking
  62 for undefined tyvars, and tyvars in contexts that are ambiguous.
  63 \item
  64 Checks that all variable occurences are defined.
  65 \item
  66 Checks the (..) etc constraints in the export list.
  67 \end{enumerate}
  68
  69
  70 %*********************************************************
  71 %*                                                      *
  72 \subsection{Value declarations}
  73 %*                                                      *
  74 %*********************************************************
  75
  76 \begin{code}
  77 rnDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
  78
  79 rnDecl (ValD binds) = rnTopBinds binds  `thenRn` \ new_binds ->
  80                       returnRn (ValD new_binds)
  81
  82
  83 rnDecl (SigD (IfaceSig name ty id_infos loc))
  84   = pushSrcLocRn loc $
  85     lookupRn name               `thenRn` \ name' ->
  86     rnHsType ty                 `thenRn` \ ty' ->
  87     mapRn rnIdInfo id_infos     `thenRn` \ id_infos' ->
  88     returnRn (SigD (IfaceSig name' ty' id_infos' loc))
  89 \end{code}
  90
  91 %*********************************************************
  92 %*                                                      *
  93 \subsection{Type declarations}
  94 %*                                                      *
  95 %*********************************************************
  96
  97 @rnTyDecl@ uses the `global name function' to create a new type
  98 declaration in which local names have been replaced by their original
  99 names, reporting any unknown names.
 100
 101 Renaming type variables is a pain. Because they now contain uniques,
 102 it is necessary to pass in an association list which maps a parsed
 103 tyvar to its Name representation. In some cases (type signatures of
 104 values), it is even necessary to go over the type first in order to
 105 get the set of tyvars used by it, make an assoc list, and then go over
 106 it again to rename the tyvars! However, we can also do some scoping
 107 checks at the same time.
 108
 109 \begin{code}
 110 rnDecl (TyD (TyData context tycon tyvars condecls derivings pragmas src_loc))
 111   = pushSrcLocRn src_loc $
 112     lookupRn tycon                              `thenRn` \ tycon' ->
 113     bindTyVarsRn "data declaration" tyvars      $ \ tyvars' ->
 114     rnContext context                           `thenRn` \ context' ->
 115     mapRn rnConDecl condecls                    `thenRn` \ condecls' ->
 116     rnDerivs derivings                          `thenRn` \ derivings' ->
 117     ASSERT(isNoDataPragmas pragmas)
 118     returnRn (TyD (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc))
 119
 120 rnDecl (TyD (TyNew context tycon tyvars condecl derivings pragmas src_loc))
 121   = pushSrcLocRn src_loc $
 122     lookupRn tycon                              `thenRn` \ tycon' ->
 123     bindTyVarsRn "newtype declaration" tyvars   $ \ tyvars' ->
 124     rnContext context                           `thenRn` \ context' ->
 125     rnConDecl condecl                           `thenRn` \ condecl' ->
 126     rnDerivs derivings                          `thenRn` \ derivings' ->
 127     ASSERT(isNoDataPragmas pragmas)
 128     returnRn (TyD (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc))
 129
 130 rnDecl (TyD (TySynonym name tyvars ty src_loc))
 131   = pushSrcLocRn src_loc $
 132     lookupRn name                               `thenRn` \ name' ->
 133     bindTyVarsRn "type declaration" tyvars      $ \ tyvars' ->
 134     rnHsType ty                                 `thenRn` \ ty' ->
 135     returnRn (TyD (TySynonym name' tyvars' ty' src_loc))
 136 \end{code}
 137
 138 %*********************************************************
 139 %*                                                      *
 140 \subsection{Class declarations}
 141 %*                                                      *
 142 %*********************************************************
 143
 144 @rnClassDecl@ uses the `global name function' to create a new
 145 class declaration in which local names have been replaced by their
 146 original names, reporting any unknown names.
 147
 148 \begin{code}
 149 rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
 150   = pushSrcLocRn src_loc $
 151     bindTyVarsRn "class declaration" [tyvar]            $ \ [tyvar'] ->
 152     rnContext context                                   `thenRn` \ context' ->
 153     lookupRn cname                                      `thenRn` \ cname' ->
 154     mapRn (rn_op cname' (getTyVarName tyvar')) sigs     `thenRn` \ sigs' ->
 155     rnMethodBinds mbinds                                `thenRn` \ mbinds' ->
 156     ASSERT(isNoClassPragmas pragmas)
 157     returnRn (ClD (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc))
 158   where
 159     rn_op clas clas_tyvar sig@(ClassOpSig op ty pragmas locn)
 160       = pushSrcLocRn locn $
 161         lookupRn op                     `thenRn` \ op_name ->
 162         rnHsType ty                     `thenRn` \ new_ty  ->
 163         let
 164             (ctxt, op_ty) = case new_ty of
 165                                 HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty)
 166                                 other                     -> ([], new_ty)
 167             ctxt_fvs  = extractCtxtTyNames ctxt
 168             op_ty_fvs = extractHsTyNames op_ty          -- Includes tycons/classes but we
 169                                                         -- don't care about that
 170         in
 171         -- check that class tyvar appears in op_ty
 172         checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
 173                 (classTyVarNotInOpTyErr clas_tyvar sig)
 174                                                          `thenRn_`
 175
 176         -- check that class tyvar *doesn't* appear in the sig's context
 177         checkRn (not (clas_tyvar `elemNameSet` ctxt_fvs))
 178                 (classTyVarInOpCtxtErr clas_tyvar sig)
 179                                                          `thenRn_`
 180
 181         ASSERT(isNoClassOpPragmas pragmas)
 182         returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
 183 \end{code}
 184
 185
 186 %*********************************************************
 187 %*                                                      *
 188 \subsection{Instance declarations}
 189 %*                                                      *
 190 %*********************************************************
 191
 192 \begin{code}
 193 rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_name src_loc))
 194   = pushSrcLocRn src_loc $
 195     rnHsType inst_ty                    `thenRn` \ inst_ty' ->
 196     rnMethodBinds mbinds                `thenRn` \ mbinds' ->
 197     mapRn rn_uprag uprags               `thenRn` \ new_uprags ->
 198     rn_dfun maybe_dfun_name             `thenRn` \ dfun_name' ->
 199
 200     returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name' src_loc))
 201   where
 202     rn_dfun Nothing  = newDfunName src_loc      `thenRn` \ n' ->
 203                        returnRn (Just n')
 204     rn_dfun (Just n) = lookupOccRn n            `thenRn` \ n' ->
 205                                 -- The dfun is not optional, because we use its version number
 206                                 -- to identify the version of the instance declaration
 207                        returnRn (Just n')
 208
 209     rn_uprag (SpecSig op ty using locn)
 210       = pushSrcLocRn src_loc $
 211         lookupRn op                     `thenRn` \ op_name ->
 212         rnHsType ty                     `thenRn` \ new_ty ->
 213         rn_using using                  `thenRn` \ new_using ->
 214         returnRn (SpecSig op_name new_ty new_using locn)
 215
 216     rn_uprag (InlineSig op locn)
 217       = pushSrcLocRn locn $
 218         lookupRn op                     `thenRn` \ op_name ->
 219         returnRn (InlineSig op_name locn)
 220
 221     rn_uprag (DeforestSig op locn)
 222       = pushSrcLocRn locn $
 223         lookupRn op                     `thenRn` \ op_name ->
 224         returnRn (DeforestSig op_name locn)
 225
 226     rn_uprag (MagicUnfoldingSig op str locn)
 227       = pushSrcLocRn locn $
 228         lookupRn op                     `thenRn` \ op_name ->
 229         returnRn (MagicUnfoldingSig op_name str locn)
 230
 231     rn_using Nothing  = returnRn Nothing
 232     rn_using (Just v) = lookupOccRn v   `thenRn` \ new_v ->
 233                         returnRn (Just new_v)
 234 \end{code}
 235
 236 %*********************************************************
 237 %*                                                      *
 238 \subsection{Default declarations}
 239 %*                                                      *
 240 %*********************************************************
 241
 242 \begin{code}
 243 rnDecl (DefD (DefaultDecl tys src_loc))
 244   = pushSrcLocRn src_loc $
 245     mapRn rnHsType tys                  `thenRn` \ tys' ->
 246     lookupImplicitOccRn numClass_RDR    `thenRn_`
 247     returnRn (DefD (DefaultDecl tys' src_loc))
 248 \end{code}
 249
 250 %*********************************************************
 251 %*                                                      *
 252 \subsection{Support code for type/data declarations}
 253 %*                                                      *
 254 %*********************************************************
 255
 256 \begin{code}
 257 rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name])
 258
 259 rnDerivs Nothing -- derivs not specified
 260   = lookupImplicitOccRn evalClass_RDR           `thenRn_`
 261     returnRn Nothing
 262
 263 rnDerivs (Just ds)
 264   = lookupImplicitOccRn evalClass_RDR           `thenRn_`
 265     mapRn rn_deriv ds `thenRn` \ derivs ->
 266     returnRn (Just derivs)
 267   where
 268     rn_deriv clas
 269       = lookupOccRn clas            `thenRn` \ clas_name ->
 270
 271                 -- Now add extra "occurrences" for things that
 272                 -- the deriving mechanism will later need in order to
 273                 -- generate code for this class.
 274         case lookupUFM derivingOccurrences clas_name of
 275                 Nothing -> addErrRn (derivingNonStdClassErr clas_name)  `thenRn_`
 276                            returnRn clas_name
 277
 278                 Just occs -> mapRn lookupImplicitOccRn occs     `thenRn_`
 279                              returnRn clas_name
 280 \end{code}
 281
 282 \begin{code}
 283 rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
 284
 285 rnConDecl (ConDecl name tys src_loc)
 286   = pushSrcLocRn src_loc $
 287     lookupRn name               `thenRn` \ new_name ->
 288     mapRn rnBangTy tys          `thenRn` \ new_tys  ->
 289     returnRn (ConDecl new_name new_tys src_loc)
 290
 291 rnConDecl (ConOpDecl ty1 op ty2 src_loc)
 292   = pushSrcLocRn src_loc $
 293     lookupRn op                 `thenRn` \ new_op  ->
 294     rnBangTy ty1                `thenRn` \ new_ty1 ->
 295     rnBangTy ty2                `thenRn` \ new_ty2 ->
 296     returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
 297
 298 rnConDecl (NewConDecl name ty src_loc)
 299   = pushSrcLocRn src_loc $
 300     lookupRn name               `thenRn` \ new_name ->
 301     rnHsType ty                 `thenRn` \ new_ty  ->
 302     returnRn (NewConDecl new_name new_ty src_loc)
 303
 304 rnConDecl (RecConDecl name fields src_loc)
 305   = pushSrcLocRn src_loc $
 306     lookupRn name               `thenRn` \ new_name ->
 307     mapRn rnField fields        `thenRn` \ new_fields ->
 308     returnRn (RecConDecl new_name new_fields src_loc)
 309
 310 rnField (names, ty)
 311   = mapRn lookupRn names        `thenRn` \ new_names ->
 312     rnBangTy ty                 `thenRn` \ new_ty ->
 313     returnRn (new_names, new_ty)
 314
 315 rnBangTy (Banged ty)
 316   = rnHsType ty `thenRn` \ new_ty ->
 317     returnRn (Banged new_ty)
 318
 319 rnBangTy (Unbanged ty)
 320   = rnHsType ty `thenRn` \ new_ty ->
 321     returnRn (Unbanged new_ty)
 322 \end{code}
 323
 324
 325 %*********************************************************
 326 %*                                                      *
 327 \subsection{Support code to rename types}
 328 %*                                                      *
 329 %*********************************************************
 330
 331 \begin{code}
 332 rnHsType :: RdrNameHsType -> RnMS s RenamedHsType
 333
 334 rnHsType (HsForAllTy tvs ctxt ty)
 335   = rn_poly_help tvs ctxt ty
 336
 337 rnHsType full_ty@(HsPreForAllTy ctxt ty)
 338   = getNameEnv          `thenRn` \ name_env ->
 339     let
 340         mentioned_tyvars = extractHsTyVars full_ty
 341         forall_tyvars    = filter not_in_scope mentioned_tyvars
 342         not_in_scope tv  = case lookupFM name_env tv of
 343                                     Nothing -> True
 344                                     Just _  -> False
 345     in
 346     rn_poly_help (map UserTyVar forall_tyvars) ctxt ty
 347
 348 rnHsType (MonoTyVar tyvar)
 349   = lookupOccRn tyvar           `thenRn` \ tyvar' ->
 350     returnRn (MonoTyVar tyvar')
 351
 352 rnHsType (MonoFunTy ty1 ty2)
 353   = andRn MonoFunTy (rnHsType ty1) (rnHsType ty2)
 354
 355 rnHsType (MonoListTy _ ty)
 356   = lookupImplicitOccRn listType_RDR            `thenRn` \ tycon_name ->
 357     rnHsType ty                                 `thenRn` \ ty' ->
 358     returnRn (MonoListTy tycon_name ty')
 359
 360 rnHsType (MonoTupleTy _ tys)
 361   = lookupImplicitOccRn (tupleType_RDR (length tys))    `thenRn` \ tycon_name ->
 362     mapRn rnHsType tys                                  `thenRn` \ tys' ->
 363     returnRn (MonoTupleTy tycon_name tys')
 364
 365 rnHsType (MonoTyApp name tys)
 366   = lookupOccRn name            `thenRn` \ name' ->
 367     mapRn rnHsType tys          `thenRn` \ tys' ->
 368     returnRn (MonoTyApp name' tys')
 369
 370 rnHsType (MonoDictTy clas ty)
 371   = lookupOccRn clas            `thenRn` \ clas' ->
 372     rnHsType ty                 `thenRn` \ ty' ->
 373     returnRn (MonoDictTy clas' ty')
 374
 375
 376 rn_poly_help :: [HsTyVar RdrName]               -- Universally quantified tyvars
 377              -> RdrNameContext
 378              -> RdrNameHsType
 379              -> RnMS s RenamedHsType
 380
 381 rn_poly_help tyvars ctxt ty
 382   = bindTyVarsRn "type signature" tyvars                $ \ new_tyvars ->
 383     rnContext ctxt                                      `thenRn` \ new_ctxt ->
 384     rnHsType ty                                         `thenRn` \ new_ty ->
 385     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
 386 \end{code}
 387
 388
 389 \begin{code}
 390 rnContext :: RdrNameContext -> RnMS s RenamedContext
 391
 392 rnContext  ctxt
 393   = mapRn rn_ctxt ctxt  `thenRn` \ result ->
 394     let
 395         (_, dup_asserts) = removeDups cmp_assert result
 396     in
 397     -- If this isn't an error, then it ought to be:
 398     mapRn (addWarnRn . dupClassAssertWarn result) dup_asserts `thenRn_`
 399     returnRn result
 400   where
 401     rn_ctxt (clas, ty)
 402       = lookupOccRn clas        `thenRn` \ clas_name ->
 403         rnHsType ty             `thenRn` \ ty' ->
 404         returnRn (clas_name, ty')
 405
 406     cmp_assert (c1,ty1) (c2,ty2)
 407       = (c1 `cmp` c2) `thenCmp` (cmpHsType cmp ty1 ty2)
 408 \end{code}
 409
 410
 411 %*********************************************************
 412 %*                                                      *
 413 \subsection{IdInfo}
 414 %*                                                      *
 415 %*********************************************************
 416
 417 \begin{code}
 418 rnIdInfo (HsStrictness strict)
 419   = rnStrict strict     `thenRn` \ strict' ->
 420     returnRn (HsStrictness strict')
 421
 422 rnIdInfo (HsUnfold expr)        = rnCoreExpr expr       `thenRn` \ expr' ->
 423                                   returnRn (HsUnfold expr')
 424 rnIdInfo (HsArity arity)        = returnRn (HsArity arity)
 425 rnIdInfo (HsUpdate update)      = returnRn (HsUpdate update)
 426 rnIdInfo (HsFBType fb)          = returnRn (HsFBType fb)
 427 rnIdInfo (HsArgUsage au)        = returnRn (HsArgUsage au)
 428 rnIdInfo (HsDeforest df)        = returnRn (HsDeforest df)
 429
 430 rnStrict (StrictnessInfo demands (Just worker))
 431   = lookupOptionalOccRn worker          `thenRn` \ worker' ->
 432     returnRn (StrictnessInfo demands (Just worker'))
 433
 434 -- Boring, but necessary for the type checker.
 435 rnStrict (StrictnessInfo demands Nothing) = returnRn (StrictnessInfo demands Nothing)
 436 rnStrict BottomGuaranteed                 = returnRn BottomGuaranteed
 437 rnStrict NoStrictnessInfo                 = returnRn NoStrictnessInfo
 438 \end{code}
 439
 440 UfCore expressions.
 441
 442 \begin{code}
 443 rnCoreExpr (UfVar v)
 444   = lookupOptionalOccRn v       `thenRn` \ v' ->
 445     returnRn (UfVar v')
 446
 447 rnCoreExpr (UfLit lit) = returnRn (UfLit lit)
 448
 449 rnCoreExpr (UfCon con args)
 450   = lookupOptionalOccRn con             `thenRn` \ con' ->
 451     mapRn rnCoreArg args        `thenRn` \ args' ->
 452     returnRn (UfCon con' args')
 453
 454 rnCoreExpr (UfPrim prim args)
 455   = rnCorePrim prim             `thenRn` \ prim' ->
 456     mapRn rnCoreArg args        `thenRn` \ args' ->
 457     returnRn (UfPrim prim' args')
 458
 459 rnCoreExpr (UfApp fun arg)
 460   = rnCoreExpr fun              `thenRn` \ fun' ->
 461     rnCoreArg arg               `thenRn` \ arg' ->
 462     returnRn (UfApp fun' arg')
 463
 464 rnCoreExpr (UfCase scrut alts)
 465   = rnCoreExpr scrut            `thenRn` \ scrut' ->
 466     rnCoreAlts alts             `thenRn` \ alts' ->
 467     returnRn (UfCase scrut' alts')
 468
 469 rnCoreExpr (UfSCC cc expr)
 470   = rnCoreExpr expr             `thenRn` \ expr' ->
 471     returnRn  (UfSCC cc expr')
 472
 473 rnCoreExpr(UfCoerce coercion ty body)
 474   = rnCoercion coercion         `thenRn` \ coercion' ->
 475     rnHsType ty                 `thenRn` \ ty' ->
 476     rnCoreExpr body             `thenRn` \ body' ->
 477     returnRn (UfCoerce coercion' ty' body')
 478
 479 rnCoreExpr (UfLam bndr body)
 480   = rnCoreBndr bndr             $ \ bndr' ->
 481     rnCoreExpr body             `thenRn` \ body' ->
 482     returnRn (UfLam bndr' body')
 483
 484 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 485   = rnCoreExpr rhs              `thenRn` \ rhs' ->
 486     rnCoreBndr bndr             $ \ bndr' ->
 487     rnCoreExpr body             `thenRn` \ body' ->
 488     returnRn (UfLet (UfNonRec bndr' rhs') body')
 489
 490 rnCoreExpr (UfLet (UfRec pairs) body)
 491   = rnCoreBndrs bndrs           $ \ bndrs' ->
 492     mapRn rnCoreExpr rhss       `thenRn` \ rhss' ->
 493     rnCoreExpr body             `thenRn` \ body' ->
 494     returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
 495   where
 496     (bndrs, rhss) = unzip pairs
 497 \end{code}
 498
 499 \begin{code}
 500 rnCoreBndr (UfValBinder name ty) thing_inside
 501   = rnHsType ty                 `thenRn` \ ty' ->
 502     bindLocalsRn "unfolding value" [name] $ \ [name'] ->
 503     thing_inside (UfValBinder name' ty')
 504
 505 rnCoreBndr (UfTyBinder name kind) thing_inside
 506   = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] ->
 507     thing_inside (UfTyBinder name' kind)
 508
 509 rnCoreBndr (UfUsageBinder name) thing_inside
 510   = bindLocalsRn "unfolding usage" [name] $ \ [name'] ->
 511     thing_inside (UfUsageBinder name')
 512
 513 rnCoreBndrs bndrs thing_inside          -- Expect them all to be ValBinders
 514   = mapRn rnHsType tys                  `thenRn` \ tys' ->
 515     bindLocalsRn "unfolding value" names $ \ names' ->
 516     thing_inside (zipWith UfValBinder names' tys')
 517   where
 518     names = map (\ (UfValBinder name _) -> name) bndrs
 519     tys   = map (\ (UfValBinder _   ty) -> ty)   bndrs
 520 \end{code}
 521
 522 \begin{code}
 523 rnCoreArg (UfVarArg v)   = lookupOptionalOccRn v        `thenRn` \ v' -> returnRn (UfVarArg v')
 524 rnCoreArg (UfUsageArg u) = lookupOptionalOccRn u        `thenRn` \ u' -> returnRn (UfUsageArg u')
 525 rnCoreArg (UfTyArg ty)   = rnHsType ty                  `thenRn` \ ty' -> returnRn (UfTyArg ty')
 526 rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit)
 527
 528 rnCoreAlts (UfAlgAlts alts deflt)
 529   = mapRn rn_alt alts           `thenRn` \ alts' ->
 530     rnCoreDefault deflt         `thenRn` \ deflt' ->
 531     returnRn (UfAlgAlts alts' deflt')
 532   where
 533     rn_alt (con, bndrs, rhs) =  lookupOptionalOccRn con `thenRn` \ con' ->
 534                                 rnCoreBndrs bndrs       $ \ bndrs' ->
 535                                 rnCoreExpr rhs          `thenRn` \ rhs' ->
 536                                 returnRn (con', bndrs', rhs')
 537
 538 rnCoreAlts (UfPrimAlts alts deflt)
 539   = mapRn rn_alt alts           `thenRn` \ alts' ->
 540     rnCoreDefault deflt         `thenRn` \ deflt' ->
 541     returnRn (UfPrimAlts alts' deflt')
 542   where
 543     rn_alt (lit, rhs) = rnCoreExpr rhs          `thenRn` \ rhs' ->
 544                         returnRn (lit, rhs')
 545
 546 rnCoreDefault UfNoDefault = returnRn UfNoDefault
 547 rnCoreDefault (UfBindDefault bndr rhs) = rnCoreBndr bndr        $ \ bndr' ->
 548                                          rnCoreExpr rhs         `thenRn` \ rhs' ->
 549                                          returnRn (UfBindDefault bndr' rhs')
 550
 551 rnCoercion (UfIn  n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfIn  n')
 552 rnCoercion (UfOut n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfOut n')
 553
 554 rnCorePrim (UfOtherOp op)
 555   = lookupOptionalOccRn op      `thenRn` \ op' ->
 556     returnRn (UfOtherOp op')
 557
 558 rnCorePrim (UfCCallOp str casm gc arg_tys res_ty)
 559   = mapRn rnHsType arg_tys      `thenRn` \ arg_tys' ->
 560     rnHsType res_ty             `thenRn` \ res_ty' ->
 561     returnRn (UfCCallOp str casm gc arg_tys' res_ty')
 562 \end{code}
 563
 564 %*********************************************************
 565 %*                                                      *
 566 \subsection{Errors}
 567 %*                                                      *
 568 %*********************************************************
 569
 570 \begin{code}
 571 derivingNonStdClassErr clas sty
 572   = ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
 573
 574 classTyVarNotInOpTyErr clas_tyvar sig sty
 575   = ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
 576          4 (ppr sty sig)
 577
 578 classTyVarInOpCtxtErr clas_tyvar sig sty
 579   = ppHang (ppBesides [ ppStr "Class type variable `", ppr sty clas_tyvar,
 580                         ppStr "' present in method's local overloading context:"])
 581          4 (ppr sty sig)
 582
 583 dupClassAssertWarn ctxt dups sty
 584   = ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
 585          4 (ppr sty ctxt)
 586 \end{code}
 587
 588
 589
 590
 591
 592 ===================     OLD STUFF    ======================
 593
 594 %*********************************************************
 595 %*                                                       *
 596 \subsection{SPECIALIZE data pragmas}
 597 %*                                                       *
 598 %*********************************************************
 599
 600 \begin{pseudocode}
 601 rnSpecDataSig :: RdrNameSpecDataSig
 602               -> RnMS s RenamedSpecDataSig
 603
 604 rnSpecDataSig (SpecDataSig tycon ty src_loc)
 605   = pushSrcLocRn src_loc $
 606     let
 607         tyvars = filter extractHsTyNames ty
 608     in
 609     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 610     lookupOccRn tycon                   `thenRn` \ tycon' ->
 611     rnHsType tv_env ty          `thenRn` \ ty' ->
 612     returnRn (SpecDataSig tycon' ty' src_loc)
 613
 614 \end{pseudocode}
 615
 616 %*********************************************************
 617 %*                                                      *
 618 \subsection{@SPECIALIZE instance@ user-pragmas}
 619 %*                                                      *
 620 %*********************************************************
 621
 622 \begin{pseudocode}
 623 rnSpecInstSig :: RdrNameSpecInstSig
 624               -> RnMS s RenamedSpecInstSig
 625
 626 rnSpecInstSig (SpecInstSig clas ty src_loc)
 627   = pushSrcLocRn src_loc $
 628     let
 629         tyvars = extractHsTyNames is_tyvar_name ty
 630     in
 631     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 632     lookupOccRn clas                    `thenRn` \ new_clas ->
 633     rnHsType tv_env ty          `thenRn` \ new_ty ->
 634     returnRn (SpecInstSig new_clas new_ty src_loc)
 635 \end{pseudocode}