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 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, thenCmp, 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 "constructors (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 src_loc 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 src_loc 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 src_loc context        `thenRn` \ context' ->
 434     lookupClass cname                       `thenRn` \ cname' ->
 435     mapRn (rn_op cname' tyvar' 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 clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn)
 441       = pushSrcLocRn locn $
 442         lookupClassOp clas op           `thenRn` \ op_name ->
 443         rnPolyType tv_env ty            `thenRn` \ new_ty  ->
 444         let
 445             (HsForAllTy tvs ctxt op_ty) = new_ty
 446             ctxt_tvs = extractCtxtTyNames ctxt
 447             op_tvs   = extractMonoTyNames is_tyvar_name op_ty
 448         in
 449         -- check that class tyvar appears in op_ty
 450         ( if isIn "rn_op" clas_tyvar op_tvs
 451           then returnRn ()
 452           else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn)
 453         ) `thenRn_`
 454
 455         -- check that class tyvar *doesn't* appear in the sig's context
 456         ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs
 457           then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn)
 458           else returnRn ()
 459         ) `thenRn_`
 460
 461         ASSERT(isNoClassOpPragmas pragmas)
 462         returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
 463 \end{code}
 464
 465
 466 %*********************************************************
 467 %*                                                      *
 468 \subsection{Instance declarations}
 469 %*                                                      *
 470 %*********************************************************
 471
 472
 473 @rnInstDecl@ uses the `global name function' to create a new of
 474 instance declaration in which local names have been replaced by their
 475 original names, reporting any unknown names.
 476
 477 \begin{code}
 478 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
 479
 480 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
 481   = pushSrcLocRn src_loc $
 482     lookupClass cname                   `thenRn` \ cname' ->
 483
 484     rnPolyType [] ty                    `thenRn` \ ty' ->
 485         -- [] tv_env ensures that tyvars will be foralled
 486
 487     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 488     mapRn (rn_uprag cname') uprags      `thenRn` \ new_uprags ->
 489
 490     ASSERT(isNoInstancePragmas pragmas)
 491     returnRn (InstDecl cname' ty' mbinds'
 492                        from_here modname new_uprags noInstancePragmas src_loc)
 493   where
 494     rn_uprag class_name (SpecSig op ty using locn)
 495       = pushSrcLocRn src_loc $
 496         lookupClassOp class_name op     `thenRn` \ op_name ->
 497         rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
 498         rn_using using                  `thenRn` \ new_using ->
 499         returnRn (SpecSig op_name new_ty new_using locn)
 500
 501     rn_uprag class_name (InlineSig op locn)
 502       = pushSrcLocRn locn $
 503         lookupClassOp class_name op     `thenRn` \ op_name ->
 504         returnRn (InlineSig op_name locn)
 505
 506     rn_uprag class_name (DeforestSig op locn)
 507       = pushSrcLocRn locn $
 508         lookupClassOp class_name op     `thenRn` \ op_name ->
 509         returnRn (DeforestSig op_name locn)
 510
 511     rn_uprag class_name (MagicUnfoldingSig op str locn)
 512       = pushSrcLocRn locn $
 513         lookupClassOp class_name op     `thenRn` \ op_name ->
 514         returnRn (MagicUnfoldingSig op_name str locn)
 515
 516     rn_using Nothing
 517       = returnRn Nothing
 518     rn_using (Just v)
 519       = lookupValue v   `thenRn` \ new_v ->
 520         returnRn (Just new_v)
 521 \end{code}
 522
 523 %*********************************************************
 524 %*                                                      *
 525 \subsection{@SPECIALIZE instance@ user-pragmas}
 526 %*                                                      *
 527 %*********************************************************
 528
 529 \begin{code}
 530 rnSpecInstSig :: RdrNameSpecInstSig
 531               -> RnM_Fixes s RenamedSpecInstSig
 532
 533 rnSpecInstSig (SpecInstSig clas ty src_loc)
 534   = pushSrcLocRn src_loc $
 535     let
 536         tyvars = extractMonoTyNames is_tyvar_name ty
 537     in
 538     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 539     lookupClass clas                    `thenRn` \ new_clas ->
 540     rnMonoType tv_env ty                `thenRn` \ new_ty ->
 541     returnRn (SpecInstSig new_clas new_ty src_loc)
 542 \end{code}
 543
 544 %*********************************************************
 545 %*                                                      *
 546 \subsection{Default declarations}
 547 %*                                                      *
 548 %*********************************************************
 549
 550 @rnDefaultDecl@ uses the `global name function' to create a new set
 551 of default declarations in which local names have been replaced by
 552 their original names, reporting any unknown names.
 553
 554 \begin{code}
 555 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
 556
 557 rnDefaultDecl [] = returnRn []
 558 rnDefaultDecl [DefaultDecl tys src_loc]
 559   = pushSrcLocRn src_loc $
 560     mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
 561     returnRn [DefaultDecl tys' src_loc]
 562 rnDefaultDecl defs@(d:ds)
 563   = addErrRn (dupDefaultDeclErr defs) `thenRn_`
 564     rnDefaultDecl [d]
 565 \end{code}
 566
 567 %*************************************************************************
 568 %*                                                                      *
 569 \subsection{Fixity declarations}
 570 %*                                                                      *
 571 %*************************************************************************
 572
 573 \begin{code}
 574 rnFixes :: [RdrNameFixityDecl]  -> RnM s [RenamedFixityDecl]
 575
 576 rnFixes fixities
 577   = getSrcLocRn `thenRn` \ src_loc ->
 578     let
 579         (_, dup_fixes) = removeDups cmp_fix fixities
 580         cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2
 581
 582         rn_fixity fix@(InfixL name i)
 583           = rn_fixity_pieces InfixL name i fix
 584         rn_fixity fix@(InfixR name i)
 585           = rn_fixity_pieces InfixR name i fix
 586         rn_fixity fix@(InfixN name i)
 587           = rn_fixity_pieces InfixN name i fix
 588
 589         rn_fixity_pieces mk_fixity name i fix
 590           = getRnEnv `thenRn` \ env ->
 591               case lookupGlobalRnEnv env name of
 592                 Just res | isLocallyDefined res
 593                   -> returnRn (Just (mk_fixity res i))
 594                 _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
 595     in
 596     mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
 597     mapRn rn_fixity fixities                              `thenRn` \ fixes_maybe ->
 598     returnRn (catMaybes fixes_maybe)
 599 \end{code}
 600
 601 %*********************************************************
 602 %*                                                      *
 603 \subsection{Support code to rename types}
 604 %*                                                      *
 605 %*********************************************************
 606
 607 \begin{code}
 608 rnPolyType :: TyVarNamesEnv
 609            -> RdrNamePolyType
 610            -> RnM_Fixes s RenamedPolyType
 611
 612 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
 613   = rn_poly_help tv_env tvs ctxt ty
 614
 615 rnPolyType tv_env (HsPreForAllTy ctxt ty)
 616   = rn_poly_help tv_env forall_tyvars ctxt ty
 617   where
 618     mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
 619     forall_tyvars    = {-
 620                        pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
 621                        pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
 622                        -}
 623                        mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
 624
 625 ------------
 626 rn_poly_help :: TyVarNamesEnv
 627              -> [RdrName]
 628              -> RdrNameContext
 629              -> RdrNameMonoType
 630              -> RnM_Fixes s RenamedPolyType
 631
 632 rn_poly_help tv_env tyvars ctxt ty
 633   = {-
 634     pprTrace "rnPolyType:"
 635         (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
 636                 ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
 637                 ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
 638                 ppStr ";ty=", ppr PprShowAll ty]) $
 639     -}
 640     getSrcLocRn                         `thenRn` \ src_loc ->
 641     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env1, new_tyvars) ->
 642     let
 643         tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
 644     in
 645     rnContext tv_env2 src_loc ctxt      `thenRn` \ new_ctxt ->
 646     rnMonoType tv_env2 ty               `thenRn` \ new_ty ->
 647     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
 648 \end{code}
 649
 650 \begin{code}
 651 rnMonoType :: TyVarNamesEnv
 652            -> RdrNameMonoType
 653            -> RnM_Fixes s RenamedMonoType
 654
 655 rnMonoType tv_env (MonoTyVar tyvar)
 656   = lookupTyVarName tv_env tyvar        `thenRn` \ tyvar' ->
 657     returnRn (MonoTyVar tyvar')
 658
 659 rnMonoType tv_env (MonoListTy ty)
 660   = rnMonoType tv_env ty        `thenRn` \ ty' ->
 661     returnRn (MonoListTy ty')
 662
 663 rnMonoType tv_env (MonoFunTy ty1 ty2)
 664   = andRn MonoFunTy (rnMonoType tv_env ty1)
 665                     (rnMonoType tv_env ty2)
 666
 667 rnMonoType  tv_env (MonoTupleTy tys)
 668   = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
 669     returnRn (MonoTupleTy tys')
 670
 671 rnMonoType tv_env (MonoTyApp name tys)
 672   = let
 673         lookup_fn = if isLexVarId (getLocalName name)
 674                     then lookupTyVarName tv_env
 675                     else lookupTyCon
 676     in
 677     lookup_fn name                      `thenRn` \ name' ->
 678     mapRn (rnMonoType tv_env) tys       `thenRn` \ tys' ->
 679     returnRn (MonoTyApp name' tys')
 680 \end{code}
 681
 682 \begin{code}
 683 rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext
 684
 685 rnContext tv_env locn ctxt
 686   = mapRn rn_ctxt ctxt  `thenRn` \ result ->
 687     let
 688         (_, dup_asserts) = removeDups cmp_assert result
 689     in
 690     -- If this isn't an error, then it ought to be:
 691     mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_`
 692     returnRn result
 693   where
 694     rn_ctxt (clas, tyvar)
 695       = lookupClass clas             `thenRn` \ clas_name ->
 696         lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
 697         returnRn (clas_name, tyvar_name)
 698
 699     cmp_assert (c1,tv1) (c2,tv2)
 700       = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2)
 701 \end{code}
 702
 703
 704 \begin{code}
 705 dupNameExportWarn locn names@((n,_):_)
 706   = addShortWarnLocLine locn $ \ sty ->
 707     ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]
 708
 709 dupLocalsExportErr locn locals@((str,_):_)
 710   = addErrLoc locn "exported names have same local name" $ \ sty ->
 711     ppInterleave ppSP (map (pprNonSym sty . snd) locals)
 712
 713 classOpExportErr op locn
 714   = addShortErrLocLine locn $ \ sty ->
 715     ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"]
 716
 717 synAllExportErr is_error syn locn
 718   = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn $ \ sty ->
 719     ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]
 720
 721 withExportErr str rn has rns locn
 722   = addErrLoc locn "" $ \ sty ->
 723     ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"],
 724                ppCat [ppStr "    expected:", ppInterleave ppComma (map (ppr sty) has)],
 725                ppCat [ppStr "    found:   ", ppInterleave ppComma (map (ppr sty) rns)] ]
 726
 727 importAllErr rn locn
 728   = addShortErrLocLine locn $ \ sty ->
 729     ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]
 730
 731 badModExportErr mod locn
 732   = addShortErrLocLine locn $ \ sty ->
 733     ppCat [ ppStr "unknown module in export list: module", ppPStr mod]
 734
 735 emptyModExportWarn locn mod
 736   = addShortWarnLocLine locn $ \ sty ->
 737     ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]
 738
 739 dupModExportWarn locn mods@(mod:_)
 740   = addShortWarnLocLine locn $ \ sty ->
 741     ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]
 742
 743 derivingNonStdClassErr clas locn
 744   = addShortErrLocLine locn $ \ sty ->
 745     ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
 746
 747 dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
 748   = ppAboves (item1 : map dup_item dup_things)
 749   where
 750     item1
 751       = addShortErrLocLine locn1 (\ sty ->
 752         ppStr "multiple default declarations") sty
 753
 754     dup_item (DefaultDecl _ locn)
 755       = addShortErrLocLine locn (\ sty ->
 756         ppStr "here was another default declaration") sty
 757
 758 undefinedFixityDeclErr locn decl
 759   = addErrLoc locn "fixity declaration for unknown operator" $ \ sty ->
 760     ppr sty decl
 761
 762 dupFixityDeclErr locn dups
 763   = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty ->
 764     ppAboves (map (ppr sty) dups)
 765
 766 classTyVarNotInOpTyErr clas_tyvar sig locn
 767   = addShortErrLocLine locn $ \ sty ->
 768     ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
 769          4 (ppr sty sig)
 770
 771 classTyVarInOpCtxtErr clas_tyvar sig locn
 772   = addShortErrLocLine locn $ \ sty ->
 773     ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"])
 774          4 (ppr sty sig)
 775
 776 dupClassAssertWarn ctxt locn dups
 777   = addShortWarnLocLine locn $ \ sty ->
 778     ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
 779          4 (ppr sty ctxt)
 780 \end{code}