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