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 ( rnSource, rnPolyType ) where
  10
  11 import Ubiq
  12 import RnLoop           -- *check* the RnPass/RnExpr/RnBinds loop-breaking
  13
  14 import HsSyn
  15 import HsPragmas
  16 import RdrHsSyn
  17 import RnHsSyn
  18 import RnMonad
  19 import RnBinds          ( rnTopBinds, rnMethodBinds )
  20
  21 import Bag              ( emptyBag, unitBag, consBag, unionManyBags, listToBag, bagToList )
  22 import Class            ( derivableClassKeys )
  23 import ListSetOps       ( unionLists, minusList )
  24 import Maybes           ( maybeToBool, catMaybes )
  25 import Name             ( Name, isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName )
  26 import Pretty
  27 import SrcLoc           ( SrcLoc )
  28 import Unique           ( Unique )
  29 import UniqFM           ( addListToUFM, listToUFM )
  30 import UniqSet          ( UniqSet(..) )
  31 import Util             ( isIn, isn'tIn, sortLt, panic, assertPanic )
  32
  33 \end{code}
  34
  35 rnSource `renames' the source module and export list.
  36 It simultaneously performs dependency analysis and precedence parsing.
  37 It also does the following error checks:
  38 \begin{enumerate}
  39 \item
  40 Checks that tyvars are used properly. This includes checking
  41 for undefined tyvars, and tyvars in contexts that are ambiguous.
  42 \item
  43 Checks that all variable occurences are defined.
  44 \item
  45 Checks the (..) etc constraints in the export list.
  46 \end{enumerate}
  47
  48
  49 \begin{code}
  50 rnSource :: [Module]
  51          -> Bag (Module,(RnName,ExportFlag))    -- unqualified imports from module
  52          -> Bag RenamedFixityDecl               -- fixity info for imported names
  53          -> RdrNameHsModule
  54          -> RnM s (RenamedHsModule,
  55                    Name -> ExportFlag,          -- export info
  56                    Bag (RnName, RdrName))       -- occurrence info
  57
  58 rnSource imp_mods unqual_imps imp_fixes
  59         (HsModule mod version exports _ fixes
  60            ty_decls specdata_sigs class_decls
  61            inst_decls specinst_sigs defaults
  62            binds _ src_loc)
  63
  64   = pushSrcLocRn src_loc $
  65
  66     rnExports (mod:imp_mods) unqual_imps exports        `thenRn` \ exported_fn ->
  67     rnFixes fixes                                       `thenRn` \ src_fixes ->
  68     let
  69         pair_name inf@(InfixL n _) = (n, inf)
  70         pair_name inf@(InfixR n _) = (n, inf)
  71         pair_name inf@(InfixN n _) = (n, inf)
  72
  73         imp_fixes_fm = listToUFM (map pair_name (bagToList imp_fixes))
  74         all_fixes_fm = addListToUFM imp_fixes_fm (map pair_name src_fixes)
  75     in
  76     setExtraRn all_fixes_fm $
  77
  78     mapRn rnTyDecl      ty_decls        `thenRn` \ new_ty_decls ->
  79     mapRn rnSpecDataSig specdata_sigs   `thenRn` \ new_specdata_sigs ->
  80     mapRn rnClassDecl   class_decls     `thenRn` \ new_class_decls ->
  81     mapRn rnInstDecl    inst_decls      `thenRn` \ new_inst_decls ->
  82     mapRn rnSpecInstSig specinst_sigs   `thenRn` \ new_specinst_sigs ->
  83     rnDefaultDecl       defaults        `thenRn` \ new_defaults ->
  84     rnTopBinds binds                    `thenRn` \ new_binds ->
  85
  86     getOccurrenceUpRn                   `thenRn` \ occ_info ->
  87
  88     returnRn (
  89               HsModule mod version
  90                 trashed_exports trashed_imports src_fixes
  91                 new_ty_decls new_specdata_sigs new_class_decls
  92                 new_inst_decls new_specinst_sigs new_defaults
  93                 new_binds [] src_loc,
  94               exported_fn,
  95               occ_info
  96              )
  97   where
  98     trashed_exports = trace "rnSource:trashed_exports" Nothing
  99     trashed_imports = trace "rnSource:trashed_imports" []
 100 \end{code}
 101
 102
 103 %*********************************************************
 104 %*                                                      *
 105 \subsection{Export list}
 106 %*                                                      *
 107 %*********************************************************
 108
 109 \begin{code}
 110 rnExports :: [Module]
 111           -> Bag (Module,(RnName,ExportFlag))
 112           -> Maybe [RdrNameIE]
 113           -> RnM s (Name -> ExportFlag)
 114
 115 rnExports mods unqual_imps Nothing
 116   = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
 117
 118 rnExports mods unqual_imps (Just exps)
 119   = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
 120     let
 121         exp_mods  = catMaybes mod_maybes
 122         exp_names = unionManyBags exp_bags
 123
 124         -- check for duplicate names
 125         -- check for duplicate modules
 126
 127         -- check for duplicate local names
 128         -- add in module contents checking for duplicate local names
 129
 130         -- build export flag lookup function
 131         exp_fn n = if isLocallyDefined n then ExportAll else NotExported
 132     in
 133     returnRn exp_fn
 134
 135 rnIE mods (IEVar name)
 136   = lookupValue name    `thenRn` \ rn ->
 137     checkIEVar rn       `thenRn` \ exps ->
 138     returnRn (Nothing, exps)
 139   where
 140     checkIEVar (RnName n)         = returnRn (unitBag (n,ExportAbs))
 141     checkIEVar (RnUnbound _)      = returnRn emptyBag
 142     checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
 143                                     failButContinueRn emptyBag (classOpExportErr rn src_loc)
 144     checkIEVar rn                 = panic "checkIEVar"
 145
 146 rnIE mods (IEThingAbs name)
 147   = lookupTyConOrClass name     `thenRn` \ rn ->
 148     checkIEAbs rn               `thenRn` \ exps ->
 149     returnRn (Nothing, exps)
 150   where
 151     checkIEAbs (RnSyn n)     = returnRn (unitBag (n,ExportAbs))
 152     checkIEAbs (RnData n _)  = returnRn (unitBag (n,ExportAbs))
 153     checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs))
 154     checkIEAbs (RnUnbound _) = returnRn emptyBag
 155     checkIEAbs rn            = panic "checkIEAbs"
 156
 157 rnIE mods (IEThingAll name)
 158   = lookupTyConOrClass name     `thenRn` \ rn ->
 159     checkIEAll rn               `thenRn` \ exps ->
 160     returnRn (Nothing, exps)
 161   where
 162     checkIEAll (RnData n cons) = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
 163     checkIEAll (RnClass n ops) = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
 164     checkIEAll (RnUnbound _)   = returnRn emptyBag
 165     checkIEAll rn@(RnSyn _)    = getSrcLocRn `thenRn` \ src_loc ->
 166                                  warnAndContinueRn emptyBag (synAllExportErr rn src_loc)
 167     checkIEAll rn              = panic "checkIEAll"
 168
 169     exp_all n = (n, ExportAll)
 170
 171 rnIE mods (IEThingWith name names)
 172   = lookupTyConOrClass name     `thenRn` \ rn ->
 173     mapRn lookupValue names     `thenRn` \ rns ->
 174     checkIEWith rn rns          `thenRn` \ exps ->
 175     returnRn (Nothing, exps)
 176   where
 177     checkIEWith rn@(RnData n cons) rns
 178                  | same_names cons rns = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
 179                  | otherwise           = rnWithErr "constructrs" rn cons rns
 180     checkIEWith rn@(RnClass n ops) rns
 181                  | same_names ops rns  = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
 182                  | otherwise           = rnWithErr "class ops" rn ops rns
 183     checkIEWith (RnUnbound _)      rns = returnRn emptyBag
 184     checkIEWith rn@(RnSyn _)       rns = getSrcLocRn `thenRn` \ src_loc ->
 185                                          failButContinueRn emptyBag (synAllExportErr rn src_loc)
 186     checkIEWith rn                 rns = panic "checkIEWith"
 187
 188     exp_all n = (n, ExportAll)
 189
 190     same_names has rns
 191       = all (not.isRnUnbound) rns &&
 192         sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
 193
 194     rnWithErr str rn has rns
 195       = getSrcLocRn `thenRn` \ src_loc ->
 196         failButContinueRn emptyBag (withExportErr str rn has rns src_loc)
 197
 198 rnIE mods (IEModuleContents mod)
 199   | isIn "IEModule" mod mods = returnRn (Just mod, emptyBag)
 200   | otherwise                = getSrcLocRn `thenRn` \ src_loc ->
 201                                failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc)
 202 \end{code}
 203
 204 %*********************************************************
 205 %*                                                      *
 206 \subsection{Type declarations}
 207 %*                                                      *
 208 %*********************************************************
 209
 210 @rnTyDecl@ uses the `global name function' to create a new type
 211 declaration in which local names have been replaced by their original
 212 names, reporting any unknown names.
 213
 214 Renaming type variables is a pain. Because they now contain uniques,
 215 it is necessary to pass in an association list which maps a parsed
 216 tyvar to its Name representation. In some cases (type signatures of
 217 values), it is even necessary to go over the type first in order to
 218 get the set of tyvars used by it, make an assoc list, and then go over
 219 it again to rename the tyvars! However, we can also do some scoping
 220 checks at the same time.
 221
 222 \begin{code}
 223 rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
 224
 225 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
 226   = pushSrcLocRn src_loc $
 227     lookupTyCon tycon                  `thenRn` \ tycon' ->
 228     mkTyVarNamesEnv src_loc tyvars     `thenRn` \ (tv_env, tyvars') ->
 229     rnContext tv_env context           `thenRn` \ context' ->
 230     rnConDecls tv_env condecls         `thenRn` \ condecls' ->
 231     rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
 232     ASSERT(isNoDataPragmas pragmas)
 233     returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
 234
 235 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
 236   = pushSrcLocRn src_loc $
 237     lookupTyCon tycon                 `thenRn` \ tycon' ->
 238     mkTyVarNamesEnv src_loc tyvars    `thenRn` \ (tv_env, tyvars') ->
 239     rnContext tv_env context          `thenRn` \ context' ->
 240     rnConDecls tv_env condecl         `thenRn` \ condecl' ->
 241     rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
 242     ASSERT(isNoDataPragmas pragmas)
 243     returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
 244
 245 rnTyDecl (TySynonym name tyvars ty src_loc)
 246   = pushSrcLocRn src_loc $
 247     lookupTyCon name                `thenRn` \ name' ->
 248     mkTyVarNamesEnv src_loc tyvars  `thenRn` \ (tv_env, tyvars') ->
 249     rnMonoType tv_env ty            `thenRn` \ ty' ->
 250     returnRn (TySynonym name' tyvars' ty' src_loc)
 251
 252 rn_derivs tycon2 locn Nothing -- derivs not specified
 253   = returnRn Nothing
 254
 255 rn_derivs tycon2 locn (Just ds)
 256   = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
 257     returnRn (Just derivs)
 258   where
 259     rn_deriv tycon2 locn clas
 260       = lookupClass clas            `thenRn` \ clas_name ->
 261         addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
 262                    (derivingNonStdClassErr clas locn)
 263                                     `thenRn_`
 264         returnRn clas_name
 265       where
 266         not_elem = isn'tIn "rn_deriv"
 267 \end{code}
 268
 269 @rnConDecls@ uses the `global name function' to create a new
 270 constructor in which local names have been replaced by their original
 271 names, reporting any unknown names.
 272
 273 \begin{code}
 274 rnConDecls :: TyVarNamesEnv
 275            -> [RdrNameConDecl]
 276            -> RnM_Fixes s [RenamedConDecl]
 277
 278 rnConDecls tv_env con_decls
 279   = mapRn rn_decl con_decls
 280   where
 281     rn_decl (ConDecl name tys src_loc)
 282       = pushSrcLocRn src_loc $
 283         lookupValue name        `thenRn` \ new_name ->
 284         mapRn rn_bang_ty tys    `thenRn` \ new_tys  ->
 285         returnRn (ConDecl new_name new_tys src_loc)
 286
 287     rn_decl (ConOpDecl ty1 op ty2 src_loc)
 288       = pushSrcLocRn src_loc $
 289         lookupValue op          `thenRn` \ new_op  ->
 290         rn_bang_ty ty1          `thenRn` \ new_ty1 ->
 291         rn_bang_ty ty2          `thenRn` \ new_ty2 ->
 292         returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
 293
 294     rn_decl (NewConDecl name ty src_loc)
 295       = pushSrcLocRn src_loc $
 296         lookupValue name        `thenRn` \ new_name ->
 297         rn_mono_ty ty           `thenRn` \ new_ty  ->
 298         returnRn (NewConDecl new_name new_ty src_loc)
 299
 300     rn_decl (RecConDecl con fields src_loc)
 301       = panic "rnConDecls:RecConDecl"
 302
 303     ----------
 304     rn_mono_ty = rnMonoType tv_env
 305
 306     rn_bang_ty (Banged ty)
 307       = rn_mono_ty ty `thenRn` \ new_ty ->
 308         returnRn (Banged new_ty)
 309     rn_bang_ty (Unbanged ty)
 310       = rn_mono_ty ty `thenRn` \ new_ty ->
 311         returnRn (Unbanged new_ty)
 312 \end{code}
 313
 314 %*********************************************************
 315 %*                                                      *
 316 \subsection{SPECIALIZE data pragmas}
 317 %*                                                      *
 318 %*********************************************************
 319
 320 \begin{code}
 321 rnSpecDataSig :: RdrNameSpecDataSig
 322               -> RnM_Fixes s RenamedSpecDataSig
 323
 324 rnSpecDataSig (SpecDataSig tycon ty src_loc)
 325   = pushSrcLocRn src_loc $
 326     let
 327         tyvars = extractMonoTyNames ty
 328     in
 329     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 330     lookupTyCon tycon                   `thenRn` \ tycon' ->
 331     rnMonoType tv_env ty                `thenRn` \ ty' ->
 332     returnRn (SpecDataSig tycon' ty' src_loc)
 333 \end{code}
 334
 335 %*********************************************************
 336 %*                                                      *
 337 \subsection{Class declarations}
 338 %*                                                      *
 339 %*********************************************************
 340
 341 @rnClassDecl@ uses the `global name function' to create a new
 342 class declaration in which local names have been replaced by their
 343 original names, reporting any unknown names.
 344
 345 \begin{code}
 346 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
 347
 348 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
 349   = pushSrcLocRn src_loc $
 350     mkTyVarNamesEnv src_loc [tyvar]     `thenRn` \ (tv_env, [tyvar']) ->
 351     rnContext tv_env context            `thenRn` \ context' ->
 352     lookupClass cname                   `thenRn` \ cname' ->
 353     mapRn (rn_op cname' tv_env) sigs    `thenRn` \ sigs' ->
 354     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 355     ASSERT(isNoClassPragmas pragmas)
 356     returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
 357   where
 358     rn_op clas tv_env (ClassOpSig op ty pragmas locn)
 359       = pushSrcLocRn locn $
 360         lookupClassOp clas op           `thenRn` \ op_name ->
 361         rnPolyType tv_env ty            `thenRn` \ new_ty  ->
 362
 363 {-
 364 *** Please check here that tyvar' appears in new_ty ***
 365 *** (used to be in tcClassSig, but it's better here)
 366 ***         not_elem = isn'tIn "tcClassSigs"
 367 ***         -- Check that the class type variable is mentioned
 368 ***     checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
 369 ***             (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
 370 -}
 371
 372         ASSERT(isNoClassOpPragmas pragmas)
 373         returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
 374 \end{code}
 375
 376
 377 %*********************************************************
 378 %*                                                      *
 379 \subsection{Instance declarations}
 380 %*                                                      *
 381 %*********************************************************
 382
 383
 384 @rnInstDecl@ uses the `global name function' to create a new of
 385 instance declaration in which local names have been replaced by their
 386 original names, reporting any unknown names.
 387
 388 \begin{code}
 389 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
 390
 391 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
 392   = pushSrcLocRn src_loc $
 393     lookupClass cname                   `thenRn` \ cname' ->
 394
 395     rnPolyType [] ty                    `thenRn` \ ty' ->
 396         -- [] tv_env ensures that tyvars will be foralled
 397
 398     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 399     mapRn (rn_uprag cname') uprags      `thenRn` \ new_uprags ->
 400
 401     ASSERT(isNoInstancePragmas pragmas)
 402     returnRn (InstDecl cname' ty' mbinds'
 403                        from_here modname new_uprags noInstancePragmas src_loc)
 404   where
 405     rn_uprag class_name (SpecSig op ty using locn)
 406       = pushSrcLocRn src_loc $
 407         lookupClassOp class_name op     `thenRn` \ op_name ->
 408         rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
 409         rn_using using                  `thenRn` \ new_using ->
 410         returnRn (SpecSig op_name new_ty new_using locn)
 411
 412     rn_uprag class_name (InlineSig op locn)
 413       = pushSrcLocRn locn $
 414         lookupClassOp class_name op     `thenRn` \ op_name ->
 415         returnRn (InlineSig op_name locn)
 416
 417     rn_uprag class_name (DeforestSig op locn)
 418       = pushSrcLocRn locn $
 419         lookupClassOp class_name op     `thenRn` \ op_name ->
 420         returnRn (DeforestSig op_name locn)
 421
 422     rn_uprag class_name (MagicUnfoldingSig op str locn)
 423       = pushSrcLocRn locn $
 424         lookupClassOp class_name op     `thenRn` \ op_name ->
 425         returnRn (MagicUnfoldingSig op_name str locn)
 426
 427     rn_using Nothing
 428       = returnRn Nothing
 429     rn_using (Just v)
 430       = lookupValue v   `thenRn` \ new_v ->
 431         returnRn (Just new_v)
 432 \end{code}
 433
 434 %*********************************************************
 435 %*                                                      *
 436 \subsection{@SPECIALIZE instance@ user-pragmas}
 437 %*                                                      *
 438 %*********************************************************
 439
 440 \begin{code}
 441 rnSpecInstSig :: RdrNameSpecInstSig
 442               -> RnM_Fixes s RenamedSpecInstSig
 443
 444 rnSpecInstSig (SpecInstSig clas ty src_loc)
 445   = pushSrcLocRn src_loc $
 446     let
 447         tyvars = extractMonoTyNames ty
 448     in
 449     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 450     lookupClass clas                    `thenRn` \ new_clas ->
 451     rnMonoType tv_env ty                `thenRn` \ new_ty ->
 452     returnRn (SpecInstSig new_clas new_ty src_loc)
 453 \end{code}
 454
 455 %*********************************************************
 456 %*                                                      *
 457 \subsection{Default declarations}
 458 %*                                                      *
 459 %*********************************************************
 460
 461 @rnDefaultDecl@ uses the `global name function' to create a new set
 462 of default declarations in which local names have been replaced by
 463 their original names, reporting any unknown names.
 464
 465 \begin{code}
 466 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
 467
 468 rnDefaultDecl [] = returnRn []
 469 rnDefaultDecl [DefaultDecl tys src_loc]
 470   = pushSrcLocRn src_loc $
 471     mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
 472     returnRn [DefaultDecl tys' src_loc]
 473 rnDefaultDecl defs@(d:ds)
 474   = addErrRn (dupDefaultDeclErr defs) `thenRn_`
 475     rnDefaultDecl [d]
 476 \end{code}
 477
 478 %*************************************************************************
 479 %*                                                                      *
 480 \subsection{Fixity declarations}
 481 %*                                                                      *
 482 %*************************************************************************
 483
 484 \begin{code}
 485 rnFixes :: [RdrNameFixityDecl]  -> RnM s [RenamedFixityDecl]
 486
 487 rnFixes fixities
 488   = mapRn rn_fixity fixities    `thenRn` \ fixes_maybe ->
 489     returnRn (catMaybes fixes_maybe)
 490   where
 491     rn_fixity fix@(InfixL name i)
 492       = rn_fixity_pieces InfixL name i fix
 493     rn_fixity fix@(InfixR name i)
 494       = rn_fixity_pieces InfixR name i fix
 495     rn_fixity fix@(InfixN name i)
 496       = rn_fixity_pieces InfixN name i fix
 497
 498     rn_fixity_pieces mk_fixity name i fix
 499       = lookupValueMaybe name   `thenRn` \ maybe_res ->
 500         case maybe_res of
 501           Just res | isLocallyDefined res
 502             -> returnRn (Just (mk_fixity res i))
 503           _ -> failButContinueRn Nothing (undefinedFixityDeclErr fix)
 504
 505 \end{code}
 506
 507 %*********************************************************
 508 %*                                                      *
 509 \subsection{Support code to rename types}
 510 %*                                                      *
 511 %*********************************************************
 512
 513 \begin{code}
 514 rnPolyType :: TyVarNamesEnv
 515            -> RdrNamePolyType
 516            -> RnM_Fixes s RenamedPolyType
 517
 518 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
 519   = rn_poly_help tv_env tvs ctxt ty
 520
 521 rnPolyType tv_env poly_ty@(HsPreForAllTy ctxt ty)
 522   = rn_poly_help tv_env forall_tyvars ctxt ty
 523   where
 524     mentioned_tyvars = extract_poly_ty_names poly_ty
 525     forall_tyvars    = mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
 526
 527 ------------
 528 extract_poly_ty_names (HsPreForAllTy ctxt ty)
 529   = extractCtxtTyNames ctxt
 530     `unionLists`
 531     extractMonoTyNames ty
 532
 533 ------------
 534 rn_poly_help :: TyVarNamesEnv
 535              -> [RdrName]
 536              -> RdrNameContext
 537              -> RdrNameMonoType
 538              -> RnM_Fixes s RenamedPolyType
 539
 540 rn_poly_help tv_env tyvars ctxt ty
 541   = getSrcLocRn                                 `thenRn` \ src_loc ->
 542     mkTyVarNamesEnv src_loc tyvars              `thenRn` \ (tv_env1, new_tyvars) ->
 543     let
 544         tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
 545     in
 546     rnContext tv_env2 ctxt                      `thenRn` \ new_ctxt ->
 547     rnMonoType tv_env2 ty       `thenRn` \ new_ty ->
 548     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
 549 \end{code}
 550
 551 \begin{code}
 552 rnMonoType :: TyVarNamesEnv
 553            -> RdrNameMonoType
 554            -> RnM_Fixes s RenamedMonoType
 555
 556 rnMonoType tv_env (MonoTyVar tyvar)
 557   = lookupTyVarName tv_env tyvar        `thenRn` \ tyvar' ->
 558     returnRn (MonoTyVar tyvar')
 559
 560 rnMonoType tv_env (MonoListTy ty)
 561   = rnMonoType tv_env ty        `thenRn` \ ty' ->
 562     returnRn (MonoListTy ty')
 563
 564 rnMonoType tv_env (MonoFunTy ty1 ty2)
 565   = andRn MonoFunTy (rnMonoType tv_env ty1)
 566                     (rnMonoType tv_env ty2)
 567
 568 rnMonoType  tv_env (MonoTupleTy tys)
 569   = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
 570     returnRn (MonoTupleTy tys')
 571
 572 rnMonoType tv_env (MonoTyApp name tys)
 573   = let
 574         lookup_fn = if isAvarid (getLocalName name)
 575                     then lookupTyVarName tv_env
 576                     else lookupTyCon
 577     in
 578     lookup_fn name                                      `thenRn` \ name' ->
 579     mapRn (rnMonoType tv_env) tys       `thenRn` \ tys' ->
 580     returnRn (MonoTyApp name' tys')
 581 \end{code}
 582
 583 \begin{code}
 584 rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
 585
 586 rnContext tv_env ctxt
 587   = mapRn rn_ctxt ctxt
 588   where
 589     rn_ctxt (clas, tyvar)
 590      = lookupClass clas             `thenRn` \ clas_name ->
 591        lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
 592        returnRn (clas_name, tyvar_name)
 593 \end{code}
 594
 595
 596 \begin{code}
 597 classOpExportErr op locn sty
 598   = ppHang (ppStr "Class operation can only be exported with class:")
 599          4 (ppCat [ppr sty op, ppr sty locn])
 600
 601 synAllExportErr syn locn sty
 602   = ppHang (ppStr "Type synonym should be exported abstractly:")
 603          4 (ppCat [ppr sty syn, ppr sty locn])
 604
 605 withExportErr str rn has rns locn sty
 606   = ppHang (ppBesides [ppStr "Inconsistent list of ", ppStr str, ppStr ": ", ppr sty locn])
 607          4 (ppAbove (ppCat [ppStr "expected:", ppInterleave ppComma (map (ppr sty) has)])
 608                     (ppCat [ppStr "found:   ", ppInterleave ppComma (map (ppr sty) rns)]))
 609
 610 badModExportErr mod locn sty
 611   = ppHang (ppStr "Unknown module in export list:")
 612          4 (ppCat [ppStr "module", ppPStr mod, ppr sty locn])
 613
 614 derivingNonStdClassErr clas locn sty
 615   = ppHang (ppStr "Non-standard class in deriving:")
 616          4 (ppCat [ppr sty clas, ppr sty locn])
 617
 618 dupDefaultDeclErr defs sty
 619   = ppHang (ppStr "Duplicate default declarations:")
 620          4 (ppAboves (map pp_def_loc defs))
 621   where
 622     pp_def_loc (DefaultDecl _ src_loc) = ppr sty src_loc
 623
 624 undefinedFixityDeclErr decl sty
 625   = ppHang (ppStr "Fixity declaration for unknown operator:")
 626          4 (ppr sty decl)
 627 \end{code}