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, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where
  10
  11 IMP_Ubiq()
  12 IMPORT_DELOOPER(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 import RnUtils          ( lookupGlobalRnEnv, lubExportFlag )
  21
  22 import Bag              ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
  23 import Class            ( derivableClassKeys )
  24 import CmdLineOpts      ( opt_CompilingPrelude )
  25 import ErrUtils         ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
  26 import FiniteMap        ( emptyFM, lookupFM, addListToFM_C )
  27 import ListSetOps       ( unionLists, minusList )
  28 import Maybes           ( maybeToBool, catMaybes )
  29 import Name             ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
  30                           nameImportFlag, RdrName, pprNonSym, Name )
  31 import Outputable       -- ToDo:rm
  32 import PprStyle         -- ToDo:rm
  33 import Pretty
  34 import SrcLoc           ( SrcLoc )
  35 import Unique           ( Unique )
  36 import UniqFM           ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM )
  37 import UniqSet          ( UniqSet(..) )
  38 import Util             ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString,
  39                           assertPanic, pprTrace{-ToDo:rm-} )
  40 \end{code}
  41
  42 rnSource `renames' the source module and export list.
  43 It simultaneously performs dependency analysis and precedence parsing.
  44 It also does the following error checks:
  45 \begin{enumerate}
  46 \item
  47 Checks that tyvars are used properly. This includes checking
  48 for undefined tyvars, and tyvars in contexts that are ambiguous.
  49 \item
  50 Checks that all variable occurences are defined.
  51 \item
  52 Checks the (..) etc constraints in the export list.
  53 \end{enumerate}
  54
  55
  56 \begin{code}
  57 rnSource :: [Module]                    -- imported modules
  58          -> Bag (Module,RnName)         -- unqualified imports from module
  59          -> Bag RenamedFixityDecl       -- fixity info for imported names
  60          -> RdrNameHsModule
  61          -> RnM s (RenamedHsModule,
  62                    Name -> ExportFlag,          -- export info
  63                    Bag (RnName, RdrName))       -- occurrence info
  64
  65 rnSource imp_mods unqual_imps imp_fixes
  66         (HsModule mod version exports _ fixes
  67            ty_decls specdata_sigs class_decls
  68            inst_decls specinst_sigs defaults
  69            binds _ src_loc)
  70
  71   = pushSrcLocRn src_loc $
  72
  73     rnExports (mod:imp_mods) unqual_imps exports        `thenRn` \ exported_fn ->
  74     rnFixes fixes                                       `thenRn` \ src_fixes ->
  75     let
  76         all_fixes     = src_fixes ++ bagToList imp_fixes
  77         all_fixes_fm  = listToUFM (map pair_name all_fixes)
  78
  79         pair_name inf = (fixDeclName inf, inf)
  80     in
  81     setExtraRn all_fixes_fm $
  82
  83     mapRn rnTyDecl      ty_decls        `thenRn` \ new_ty_decls ->
  84     mapRn rnSpecDataSig specdata_sigs   `thenRn` \ new_specdata_sigs ->
  85     mapRn rnClassDecl   class_decls     `thenRn` \ new_class_decls ->
  86     mapRn rnInstDecl    inst_decls      `thenRn` \ new_inst_decls ->
  87     mapRn rnSpecInstSig specinst_sigs   `thenRn` \ new_specinst_sigs ->
  88     rnDefaultDecl       defaults        `thenRn` \ new_defaults ->
  89     rnTopBinds binds                    `thenRn` \ new_binds ->
  90
  91     getOccurrenceUpRn                   `thenRn` \ occ_info ->
  92
  93     returnRn (
  94               HsModule mod version
  95                 trashed_exports trashed_imports all_fixes
  96                 new_ty_decls new_specdata_sigs new_class_decls
  97                 new_inst_decls new_specinst_sigs new_defaults
  98                 new_binds [] src_loc,
  99               exported_fn,
 100               occ_info
 101              )
 102   where
 103     trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
 104     trashed_imports = {-trace "rnSource:trashed_imports"-} []
 105 \end{code}
 106
 107
 108 %*********************************************************
 109 %*                                                      *
 110 \subsection{Export list}
 111 %*                                                      *
 112 %*********************************************************
 113
 114 \begin{code}
 115 rnExports :: [Module]
 116           -> Bag (Module,RnName)
 117           -> Maybe [RdrNameIE]
 118           -> RnM s (Name -> ExportFlag)
 119
 120 rnExports mods unqual_imps Nothing
 121   = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
 122
 123 rnExports mods unqual_imps (Just exps)
 124   = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
 125     let
 126         (tc_bags, val_bags) = unzip exp_bags
 127         tc_names  = bagToList (unionManyBags tc_bags)
 128         val_names = bagToList (unionManyBags val_bags)
 129         exp_mods  = catMaybes mod_maybes
 130
 131         -- Warn for duplicate names and modules
 132         (_, dup_tc_names)  = removeDups cmp_fst tc_names
 133         (_, dup_val_names) = removeDups cmp_fst val_names
 134         cmp_fst (x,_) (y,_) = x `cmp` y
 135
 136         (uniq_mods, dup_mods) = removeDups cmpPString exp_mods
 137
 138         -- Get names for exported modules
 139
 140         (mod_tcs, mod_vals, empty_mods)
 141           = case mapAndUnzip3 get_mod_names uniq_mods of
 142               (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys)
 143
 144         (unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps)
 145
 146         get_mod_names mod
 147           = (tcs, vals, empty_mod)
 148           where
 149             tcs  = [(getName rn, nameImportFlag (getName rn))
 150                    | (mod',rn) <- unqual_tcs, mod == mod']
 151             vals = [(getName rn, nameImportFlag (getName rn))
 152                    | (mod',rn) <- unqual_vals, mod == mod']
 153             empty_mod = if null tcs && null vals
 154                         then Just mod
 155                         else Nothing
 156
 157         -- Build finite map of exported names to export flag
 158         tc_map0  = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names)
 159         tc_map   = addListToUFM_C lub_expflag tc_map0  (map pair_fst mod_tcs)
 160
 161         val_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst val_names)
 162         val_map  = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals)
 163
 164         pair_fst p@(f,_) = (f,p)
 165         lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2)
 166
 167         -- Check for exporting of duplicate local names
 168         tc_locals  = [(getLocalName n, n) | (n,_) <- eltsUFM tc_map]
 169         val_locals = [(getLocalName n, n) | (n,_) <- eltsUFM val_map]
 170         (_, dup_tc_locals)  = removeDups cmp_local tc_locals
 171         (_, dup_val_locals) = removeDups cmp_local val_locals
 172         cmp_local (x,_) (y,_) = x `cmpPString` y
 173
 174         -- Build export flag function
 175         final_exp_map = plusUFM tc_map val_map
 176         exp_fn n = case lookupUFM final_exp_map n of
 177                      Nothing       -> NotExported
 178                      Just (_,flag) -> flag
 179     in
 180     getSrcLocRn                                                         `thenRn` \ src_loc ->
 181     mapRn (addWarnRn . dupNameExportWarn  src_loc) dup_tc_names         `thenRn_`
 182     mapRn (addWarnRn . dupNameExportWarn  src_loc) dup_val_names        `thenRn_`
 183     mapRn (addWarnRn . dupModExportWarn   src_loc) dup_mods             `thenRn_`
 184     mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods           `thenRn_`
 185     mapRn (addErrRn  . dupLocalsExportErr src_loc) dup_tc_locals        `thenRn_`
 186     mapRn (addErrRn  . dupLocalsExportErr src_loc) dup_val_locals       `thenRn_`
 187     returnRn exp_fn
 188
 189
 190 rnIE mods (IEVar name)
 191   = lookupValue name    `thenRn` \ rn ->
 192     checkIEVar rn       `thenRn` \ exps ->
 193     returnRn (Nothing, exps)
 194   where
 195     checkIEVar (RnName n)         = returnRn (emptyBag, unitBag (n,ExportAll))
 196     checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
 197                                     failButContinueRn (emptyBag, emptyBag) (classOpExportErr rn src_loc)
 198     checkIEVar rn                 = returnRn (emptyBag, emptyBag)
 199
 200 rnIE mods (IEThingAbs name)
 201   = lookupTyConOrClass name     `thenRn` \ rn ->
 202     checkIEAbs rn               `thenRn` \ exps ->
 203     returnRn (Nothing, exps)
 204   where
 205     checkIEAbs (RnSyn n)      = returnRn (unitBag (n,ExportAbs), emptyBag)
 206     checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs), emptyBag)
 207     checkIEAbs (RnClass n _)  = returnRn (unitBag (n,ExportAbs), emptyBag)
 208     checkIEAbs rn             = returnRn (emptyBag, emptyBag)
 209
 210 rnIE mods (IEThingAll name)
 211   = lookupTyConOrClass name     `thenRn` \ rn ->
 212     checkIEAll rn               `thenRn` \ exps ->
 213     checkImportAll rn           `thenRn_`
 214     returnRn (Nothing, exps)
 215   where
 216     checkIEAll (RnData n cons fields) = returnRn (unitBag (exp_all n), listToBag (map exp_all cons)
 217                                                                          `unionBags`
 218                                                                        listToBag (map exp_all fields))
 219     checkIEAll (RnClass n ops)        = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
 220     checkIEAll rn@(RnSyn n)           = getSrcLocRn `thenRn` \ src_loc ->
 221                                         warnAndContinueRn (unitBag (n, ExportAbs), emptyBag)
 222                                             (synAllExportErr False{-warning-} rn src_loc)
 223     checkIEAll rn                     = returnRn (emptyBag, emptyBag)
 224
 225     exp_all n = (n, ExportAll)
 226
 227 rnIE mods (IEThingWith name names)
 228   = lookupTyConOrClass name     `thenRn` \ rn ->
 229     mapRn lookupValue names     `thenRn` \ rns ->
 230     checkIEWith rn rns          `thenRn` \ exps ->
 231     checkImportAll rn           `thenRn_`
 232     returnRn (Nothing, exps)
 233   where
 234     checkIEWith rn@(RnData n cons fields) rns
 235         | same_names (cons++fields) rns
 236         = returnRn (unitBag (exp_all n), listToBag (map exp_all cons)
 237                                            `unionBags`
 238                                          listToBag (map exp_all fields))
 239         | otherwise
 240         = rnWithErr "constructors (and fields)" rn (cons++fields) rns
 241     checkIEWith rn@(RnClass n ops) rns
 242         | same_names ops rns
 243         = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
 244         | otherwise
 245         = rnWithErr "class ops" rn ops rns
 246     checkIEWith rn@(RnSyn _) rns
 247         = getSrcLocRn `thenRn` \ src_loc ->
 248           failButContinueRn (emptyBag, emptyBag) (synAllExportErr True{-error-} rn src_loc)
 249     checkIEWith rn rns
 250         = returnRn (emptyBag, emptyBag)
 251
 252     exp_all n = (n, ExportAll)
 253
 254     same_names has rns
 255       = all (not.isRnUnbound) rns &&
 256         sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
 257
 258     rnWithErr str rn has rns
 259       = getSrcLocRn `thenRn` \ src_loc ->
 260         failButContinueRn (emptyBag, emptyBag) (withExportErr str rn has rns src_loc)
 261
 262 rnIE mods (IEModuleContents mod)
 263   | isIn "rnIE:IEModule" mod mods
 264   = returnRn (Just mod, (emptyBag, emptyBag))
 265   | otherwise
 266   = getSrcLocRn `thenRn` \ src_loc ->
 267     failButContinueRn (Nothing, (emptyBag, emptyBag)) (badModExportErr mod src_loc)
 268
 269
 270 checkImportAll rn
 271   = case nameImportFlag (getName rn) of
 272       ExportAll -> returnRn ()
 273       exp       -> getSrcLocRn `thenRn` \ src_loc ->
 274                    addErrRn (importAllErr rn src_loc)
 275 \end{code}
 276
 277 %*********************************************************
 278 %*                                                      *
 279 \subsection{Type declarations}
 280 %*                                                      *
 281 %*********************************************************
 282
 283 @rnTyDecl@ uses the `global name function' to create a new type
 284 declaration in which local names have been replaced by their original
 285 names, reporting any unknown names.
 286
 287 Renaming type variables is a pain. Because they now contain uniques,
 288 it is necessary to pass in an association list which maps a parsed
 289 tyvar to its Name representation. In some cases (type signatures of
 290 values), it is even necessary to go over the type first in order to
 291 get the set of tyvars used by it, make an assoc list, and then go over
 292 it again to rename the tyvars! However, we can also do some scoping
 293 checks at the same time.
 294
 295 \begin{code}
 296 rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
 297
 298 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
 299   = pushSrcLocRn src_loc $
 300     lookupTyCon tycon                  `thenRn` \ tycon' ->
 301     mkTyVarNamesEnv src_loc tyvars     `thenRn` \ (tv_env, tyvars') ->
 302     rnContext tv_env src_loc context   `thenRn` \ context' ->
 303     rnConDecls tv_env condecls         `thenRn` \ condecls' ->
 304     rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
 305     ASSERT(isNoDataPragmas pragmas)
 306     returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
 307
 308 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
 309   = pushSrcLocRn src_loc $
 310     lookupTyCon tycon                 `thenRn` \ tycon' ->
 311     mkTyVarNamesEnv src_loc tyvars    `thenRn` \ (tv_env, tyvars') ->
 312     rnContext tv_env src_loc context  `thenRn` \ context' ->
 313     rnConDecls tv_env condecl         `thenRn` \ condecl' ->
 314     rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
 315     ASSERT(isNoDataPragmas pragmas)
 316     returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
 317
 318 rnTyDecl (TySynonym name tyvars ty src_loc)
 319   = pushSrcLocRn src_loc $
 320     lookupTyCon name                `thenRn` \ name' ->
 321     mkTyVarNamesEnv src_loc tyvars  `thenRn` \ (tv_env, tyvars') ->
 322     rnMonoType tv_env ty            `thenRn` \ ty' ->
 323     returnRn (TySynonym name' tyvars' ty' src_loc)
 324
 325 rn_derivs tycon2 locn Nothing -- derivs not specified
 326   = returnRn Nothing
 327
 328 rn_derivs tycon2 locn (Just ds)
 329   = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
 330     returnRn (Just derivs)
 331   where
 332     rn_deriv tycon2 locn clas
 333       = lookupClass clas            `thenRn` \ clas_name ->
 334         addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
 335                    (derivingNonStdClassErr clas_name locn)
 336                                     `thenRn_`
 337         returnRn clas_name
 338       where
 339         not_elem = isn'tIn "rn_deriv"
 340 \end{code}
 341
 342 @rnConDecls@ uses the `global name function' to create a new
 343 constructor in which local names have been replaced by their original
 344 names, reporting any unknown names.
 345
 346 \begin{code}
 347 rnConDecls :: TyVarNamesEnv
 348            -> [RdrNameConDecl]
 349            -> RnM_Fixes s [RenamedConDecl]
 350
 351 rnConDecls tv_env con_decls
 352   = mapRn rn_decl con_decls
 353   where
 354     rn_decl (ConDecl name tys src_loc)
 355       = pushSrcLocRn src_loc $
 356         lookupConstr name       `thenRn` \ new_name ->
 357         mapRn rn_bang_ty tys    `thenRn` \ new_tys  ->
 358         returnRn (ConDecl new_name new_tys src_loc)
 359
 360     rn_decl (ConOpDecl ty1 op ty2 src_loc)
 361       = pushSrcLocRn src_loc $
 362         lookupConstr op         `thenRn` \ new_op  ->
 363         rn_bang_ty ty1          `thenRn` \ new_ty1 ->
 364         rn_bang_ty ty2          `thenRn` \ new_ty2 ->
 365         returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
 366
 367     rn_decl (NewConDecl name ty src_loc)
 368       = pushSrcLocRn src_loc $
 369         lookupConstr name       `thenRn` \ new_name ->
 370         rn_mono_ty ty           `thenRn` \ new_ty  ->
 371         returnRn (NewConDecl new_name new_ty src_loc)
 372
 373     rn_decl (RecConDecl name fields src_loc)
 374       = pushSrcLocRn src_loc $
 375         lookupConstr name       `thenRn` \ new_name ->
 376         mapRn rn_field fields   `thenRn` \ new_fields ->
 377         returnRn (RecConDecl new_name new_fields src_loc)
 378
 379     rn_field (names, ty)
 380       = mapRn lookupField names `thenRn` \ new_names ->
 381         rn_bang_ty ty           `thenRn` \ new_ty ->
 382         returnRn (new_names, new_ty)
 383
 384     rn_mono_ty = rnMonoType tv_env
 385     rn_poly_ty = rnPolyType tv_env
 386
 387     rn_bang_ty (Banged ty)
 388       = rn_poly_ty ty `thenRn` \ new_ty ->
 389         returnRn (Banged new_ty)
 390     rn_bang_ty (Unbanged ty)
 391       = rn_poly_ty ty `thenRn` \ new_ty ->
 392         returnRn (Unbanged new_ty)
 393 \end{code}
 394
 395 %*********************************************************
 396 %*                                                       *
 397 \subsection{SPECIALIZE data pragmas}
 398 %*                                                       *
 399 %*********************************************************
 400
 401 \begin{code}
 402 rnSpecDataSig :: RdrNameSpecDataSig
 403               -> RnM_Fixes s RenamedSpecDataSig
 404
 405 rnSpecDataSig (SpecDataSig tycon ty src_loc)
 406   = pushSrcLocRn src_loc $
 407     let
 408         tyvars = extractMonoTyNames is_tyvar_name ty
 409     in
 410     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 411     lookupTyCon tycon                   `thenRn` \ tycon' ->
 412     rnMonoType tv_env ty                `thenRn` \ ty' ->
 413     returnRn (SpecDataSig tycon' ty' src_loc)
 414
 415 is_tyvar_name n = isLexVarId (getLocalName n)
 416 \end{code}
 417
 418 %*********************************************************
 419 %*                                                      *
 420 \subsection{Class declarations}
 421 %*                                                      *
 422 %*********************************************************
 423
 424 @rnClassDecl@ uses the `global name function' to create a new
 425 class declaration in which local names have been replaced by their
 426 original names, reporting any unknown names.
 427
 428 \begin{code}
 429 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
 430
 431 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
 432   = pushSrcLocRn src_loc $
 433     mkTyVarNamesEnv src_loc [tyvar]         `thenRn` \ (tv_env, [tyvar']) ->
 434     rnContext tv_env src_loc context        `thenRn` \ context' ->
 435     lookupClass cname                       `thenRn` \ cname' ->
 436     mapRn (rn_op cname' tyvar' tv_env) sigs `thenRn` \ sigs' ->
 437     rnMethodBinds cname' mbinds             `thenRn` \ mbinds' ->
 438     ASSERT(isNoClassPragmas pragmas)
 439     returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
 440   where
 441     rn_op clas clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn)
 442       = pushSrcLocRn locn $
 443         lookupClassOp clas op           `thenRn` \ op_name ->
 444         rnPolyType tv_env ty            `thenRn` \ new_ty  ->
 445         let
 446             (HsForAllTy tvs ctxt op_ty) = new_ty
 447             ctxt_tvs = extractCtxtTyNames ctxt
 448             op_tvs   = extractMonoTyNames is_tyvar_name op_ty
 449         in
 450         -- check that class tyvar appears in op_ty
 451         ( if isIn "rn_op" clas_tyvar op_tvs
 452           then returnRn ()
 453           else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn)
 454         ) `thenRn_`
 455
 456         -- check that class tyvar *doesn't* appear in the sig's context
 457         ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs
 458           then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn)
 459           else returnRn ()
 460         ) `thenRn_`
 461
 462         ASSERT(isNoClassOpPragmas pragmas)
 463         returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
 464 \end{code}
 465
 466
 467 %*********************************************************
 468 %*                                                      *
 469 \subsection{Instance declarations}
 470 %*                                                      *
 471 %*********************************************************
 472
 473
 474 @rnInstDecl@ uses the `global name function' to create a new of
 475 instance declaration in which local names have been replaced by their
 476 original names, reporting any unknown names.
 477
 478 \begin{code}
 479 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
 480
 481 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
 482   = pushSrcLocRn src_loc $
 483     lookupClass cname                   `thenRn` \ cname' ->
 484
 485     rnPolyType [] ty                    `thenRn` \ ty' ->
 486         -- [] tv_env ensures that tyvars will be foralled
 487
 488     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 489     mapRn (rn_uprag cname') uprags      `thenRn` \ new_uprags ->
 490
 491     ASSERT(isNoInstancePragmas pragmas)
 492     returnRn (InstDecl cname' ty' mbinds'
 493                        from_here modname new_uprags noInstancePragmas src_loc)
 494   where
 495     rn_uprag class_name (SpecSig op ty using locn)
 496       = pushSrcLocRn src_loc $
 497         lookupClassOp class_name op     `thenRn` \ op_name ->
 498         rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
 499         rn_using using                  `thenRn` \ new_using ->
 500         returnRn (SpecSig op_name new_ty new_using locn)
 501
 502     rn_uprag class_name (InlineSig op locn)
 503       = pushSrcLocRn locn $
 504         lookupClassOp class_name op     `thenRn` \ op_name ->
 505         returnRn (InlineSig op_name locn)
 506
 507     rn_uprag class_name (DeforestSig op locn)
 508       = pushSrcLocRn locn $
 509         lookupClassOp class_name op     `thenRn` \ op_name ->
 510         returnRn (DeforestSig op_name locn)
 511
 512     rn_uprag class_name (MagicUnfoldingSig op str locn)
 513       = pushSrcLocRn locn $
 514         lookupClassOp class_name op     `thenRn` \ op_name ->
 515         returnRn (MagicUnfoldingSig op_name str locn)
 516
 517     rn_using Nothing
 518       = returnRn Nothing
 519     rn_using (Just v)
 520       = lookupValue v   `thenRn` \ new_v ->
 521         returnRn (Just new_v)
 522 \end{code}
 523
 524 %*********************************************************
 525 %*                                                      *
 526 \subsection{@SPECIALIZE instance@ user-pragmas}
 527 %*                                                      *
 528 %*********************************************************
 529
 530 \begin{code}
 531 rnSpecInstSig :: RdrNameSpecInstSig
 532               -> RnM_Fixes s RenamedSpecInstSig
 533
 534 rnSpecInstSig (SpecInstSig clas ty src_loc)
 535   = pushSrcLocRn src_loc $
 536     let
 537         tyvars = extractMonoTyNames is_tyvar_name ty
 538     in
 539     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 540     lookupClass clas                    `thenRn` \ new_clas ->
 541     rnMonoType tv_env ty                `thenRn` \ new_ty ->
 542     returnRn (SpecInstSig new_clas new_ty src_loc)
 543 \end{code}
 544
 545 %*********************************************************
 546 %*                                                      *
 547 \subsection{Default declarations}
 548 %*                                                      *
 549 %*********************************************************
 550
 551 @rnDefaultDecl@ uses the `global name function' to create a new set
 552 of default declarations in which local names have been replaced by
 553 their original names, reporting any unknown names.
 554
 555 \begin{code}
 556 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
 557
 558 rnDefaultDecl [] = returnRn []
 559 rnDefaultDecl [DefaultDecl tys src_loc]
 560   = pushSrcLocRn src_loc $
 561     mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
 562     returnRn [DefaultDecl tys' src_loc]
 563 rnDefaultDecl defs@(d:ds)
 564   = addErrRn (dupDefaultDeclErr defs) `thenRn_`
 565     rnDefaultDecl [d]
 566 \end{code}
 567
 568 %*************************************************************************
 569 %*                                                                      *
 570 \subsection{Fixity declarations}
 571 %*                                                                      *
 572 %*************************************************************************
 573
 574 \begin{code}
 575 rnFixes :: [RdrNameFixityDecl]  -> RnM s [RenamedFixityDecl]
 576
 577 rnFixes fixities
 578   = getSrcLocRn `thenRn` \ src_loc ->
 579     let
 580         (_, dup_fixes) = removeDups cmp_fix fixities
 581         cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2
 582
 583         rn_fixity fix@(InfixL name i)
 584           = rn_fixity_pieces InfixL name i fix
 585         rn_fixity fix@(InfixR name i)
 586           = rn_fixity_pieces InfixR name i fix
 587         rn_fixity fix@(InfixN name i)
 588           = rn_fixity_pieces InfixN name i fix
 589
 590         rn_fixity_pieces mk_fixity name i fix
 591           = getRnEnv `thenRn` \ env ->
 592               case lookupGlobalRnEnv env name of
 593                 Just res | isLocallyDefined res || opt_CompilingPrelude
 594                   -- the opt_CompilingPrelude thing is a *HACK* to get (:)'s
 595                   -- fixity decl to go through.  It has a builtin name, which
 596                   -- doesn't respond to isLocallyDefined...  sigh.
 597                   -> returnRn (Just (mk_fixity res i))
 598                 _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
 599     in
 600     mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
 601     mapRn rn_fixity fixities                              `thenRn` \ fixes_maybe ->
 602     returnRn (catMaybes fixes_maybe)
 603 \end{code}
 604
 605 %*********************************************************
 606 %*                                                      *
 607 \subsection{Support code to rename types}
 608 %*                                                      *
 609 %*********************************************************
 610
 611 \begin{code}
 612 rnPolyType :: TyVarNamesEnv
 613            -> RdrNamePolyType
 614            -> RnM_Fixes s RenamedPolyType
 615
 616 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
 617   = rn_poly_help tv_env tvs ctxt ty
 618
 619 rnPolyType tv_env (HsPreForAllTy ctxt ty)
 620   = rn_poly_help tv_env forall_tyvars ctxt ty
 621   where
 622     mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
 623     forall_tyvars    = {-
 624                        pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
 625                        pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
 626                        -}
 627                        mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
 628
 629 ------------
 630 rn_poly_help :: TyVarNamesEnv
 631              -> [RdrName]
 632              -> RdrNameContext
 633              -> RdrNameMonoType
 634              -> RnM_Fixes s RenamedPolyType
 635
 636 rn_poly_help tv_env tyvars ctxt ty
 637   = {-
 638     pprTrace "rnPolyType:"
 639         (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
 640                 ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
 641                 ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
 642                 ppStr ";ty=", ppr PprShowAll ty]) $
 643     -}
 644     getSrcLocRn                         `thenRn` \ src_loc ->
 645     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env1, new_tyvars) ->
 646     let
 647         tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
 648     in
 649     rnContext tv_env2 src_loc ctxt      `thenRn` \ new_ctxt ->
 650     rnMonoType tv_env2 ty               `thenRn` \ new_ty ->
 651     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
 652 \end{code}
 653
 654 \begin{code}
 655 rnMonoType :: TyVarNamesEnv
 656            -> RdrNameMonoType
 657            -> RnM_Fixes s RenamedMonoType
 658
 659 rnMonoType tv_env (MonoTyVar tyvar)
 660   = lookupTyVarName tv_env tyvar        `thenRn` \ tyvar' ->
 661     returnRn (MonoTyVar tyvar')
 662
 663 rnMonoType tv_env (MonoListTy ty)
 664   = rnMonoType tv_env ty        `thenRn` \ ty' ->
 665     returnRn (MonoListTy ty')
 666
 667 rnMonoType tv_env (MonoFunTy ty1 ty2)
 668   = andRn MonoFunTy (rnMonoType tv_env ty1)
 669                     (rnMonoType tv_env ty2)
 670
 671 rnMonoType  tv_env (MonoTupleTy tys)
 672   = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
 673     returnRn (MonoTupleTy tys')
 674
 675 rnMonoType tv_env (MonoTyApp name tys)
 676   = let
 677         lookup_fn = if isLexVarId (getLocalName name)
 678                     then lookupTyVarName tv_env
 679                     else lookupTyCon
 680     in
 681     lookup_fn name                      `thenRn` \ name' ->
 682     mapRn (rnMonoType tv_env) tys       `thenRn` \ tys' ->
 683     returnRn (MonoTyApp name' tys')
 684 \end{code}
 685
 686 \begin{code}
 687 rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext
 688
 689 rnContext tv_env locn ctxt
 690   = mapRn rn_ctxt ctxt  `thenRn` \ result ->
 691     let
 692         (_, dup_asserts) = removeDups cmp_assert result
 693     in
 694     -- If this isn't an error, then it ought to be:
 695     mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_`
 696     returnRn result
 697   where
 698     rn_ctxt (clas, tyvar)
 699       = lookupClass clas             `thenRn` \ clas_name ->
 700         lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
 701         returnRn (clas_name, tyvar_name)
 702
 703     cmp_assert (c1,tv1) (c2,tv2)
 704       = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2)
 705 \end{code}
 706
 707
 708 \begin{code}
 709 dupNameExportWarn locn names@((n,_):_)
 710   = addShortWarnLocLine locn $ \ sty ->
 711     ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]
 712
 713 dupLocalsExportErr locn locals@((str,_):_)
 714   = addErrLoc locn "exported names have same local name" $ \ sty ->
 715     ppInterleave ppSP (map (pprNonSym sty . snd) locals)
 716
 717 classOpExportErr op locn
 718   = addShortErrLocLine locn $ \ sty ->
 719     ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"]
 720
 721 synAllExportErr is_error syn locn
 722   = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn $ \ sty ->
 723     ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]
 724
 725 withExportErr str rn has rns locn
 726   = addErrLoc locn "" $ \ sty ->
 727     ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"],
 728                ppCat [ppStr "    expected:", ppInterleave ppComma (map (ppr sty) has)],
 729                ppCat [ppStr "    found:   ", ppInterleave ppComma (map (ppr sty) rns)] ]
 730
 731 importAllErr rn locn
 732   = addShortErrLocLine locn $ \ sty ->
 733     ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]
 734
 735 badModExportErr mod locn
 736   = addShortErrLocLine locn $ \ sty ->
 737     ppCat [ ppStr "unknown module in export list: module", ppPStr mod]
 738
 739 emptyModExportWarn locn mod
 740   = addShortWarnLocLine locn $ \ sty ->
 741     ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]
 742
 743 dupModExportWarn locn mods@(mod:_)
 744   = addShortWarnLocLine locn $ \ sty ->
 745     ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]
 746
 747 derivingNonStdClassErr clas locn
 748   = addShortErrLocLine locn $ \ sty ->
 749     ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
 750
 751 dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
 752   = ppAboves (item1 : map dup_item dup_things)
 753   where
 754     item1
 755       = addShortErrLocLine locn1 (\ sty ->
 756         ppStr "multiple default declarations") sty
 757
 758     dup_item (DefaultDecl _ locn)
 759       = addShortErrLocLine locn (\ sty ->
 760         ppStr "here was another default declaration") sty
 761
 762 undefinedFixityDeclErr locn decl
 763   = addErrLoc locn "fixity declaration for unknown operator" $ \ sty ->
 764     ppr sty decl
 765
 766 dupFixityDeclErr locn dups
 767   = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty ->
 768     ppAboves (map (ppr sty) dups)
 769
 770 classTyVarNotInOpTyErr clas_tyvar sig locn
 771   = addShortErrLocLine locn $ \ sty ->
 772     ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
 773          4 (ppr sty sig)
 774
 775 classTyVarInOpCtxtErr clas_tyvar sig locn
 776   = addShortErrLocLine locn $ \ sty ->
 777     ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"])
 778          4 (ppr sty sig)
 779
 780 dupClassAssertWarn ctxt locn dups
 781   = addShortWarnLocLine locn $ \ sty ->
 782     ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
 783          4 (ppr sty ctxt)
 784 \end{code}