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