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, isRnDecl rn]
 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     rn_poly_ty = rnPolyType tv_env
 358
 359     rn_bang_ty (Banged ty)
 360       = rn_poly_ty ty `thenRn` \ new_ty ->
 361         returnRn (Banged new_ty)
 362     rn_bang_ty (Unbanged ty)
 363       = rn_poly_ty ty `thenRn` \ new_ty ->
 364         returnRn (Unbanged new_ty)
 365 \end{code}
 366
 367 %*********************************************************
 368 %*                                                       *
 369 \subsection{SPECIALIZE data pragmas}
 370 %*                                                       *
 371 %*********************************************************
 372
 373 \begin{code}
 374 rnSpecDataSig :: RdrNameSpecDataSig
 375               -> RnM_Fixes s RenamedSpecDataSig
 376
 377 rnSpecDataSig (SpecDataSig tycon ty src_loc)
 378   = pushSrcLocRn src_loc $
 379     let
 380         tyvars = extractMonoTyNames is_tyvar_name ty
 381     in
 382     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 383     lookupTyCon tycon                   `thenRn` \ tycon' ->
 384     rnMonoType tv_env ty                `thenRn` \ ty' ->
 385     returnRn (SpecDataSig tycon' ty' src_loc)
 386
 387 is_tyvar_name n = isLexVarId (getLocalName n)
 388 \end{code}
 389
 390 %*********************************************************
 391 %*                                                      *
 392 \subsection{Class declarations}
 393 %*                                                      *
 394 %*********************************************************
 395
 396 @rnClassDecl@ uses the `global name function' to create a new
 397 class declaration in which local names have been replaced by their
 398 original names, reporting any unknown names.
 399
 400 \begin{code}
 401 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
 402
 403 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
 404   = pushSrcLocRn src_loc $
 405     mkTyVarNamesEnv src_loc [tyvar]     `thenRn` \ (tv_env, [tyvar']) ->
 406     rnContext tv_env context            `thenRn` \ context' ->
 407     lookupClass cname                   `thenRn` \ cname' ->
 408     mapRn (rn_op cname' tv_env) sigs    `thenRn` \ sigs' ->
 409     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 410     ASSERT(isNoClassPragmas pragmas)
 411     returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
 412   where
 413     rn_op clas tv_env (ClassOpSig op ty pragmas locn)
 414       = pushSrcLocRn locn $
 415         lookupClassOp clas op           `thenRn` \ op_name ->
 416         rnPolyType tv_env ty            `thenRn` \ new_ty  ->
 417
 418 {-
 419 *** Please check here that tyvar' appears in new_ty ***
 420 *** (used to be in tcClassSig, but it's better here)
 421 ***         not_elem = isn'tIn "tcClassSigs"
 422 ***         -- Check that the class type variable is mentioned
 423 ***     checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
 424 ***             (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
 425 -}
 426
 427         ASSERT(isNoClassOpPragmas pragmas)
 428         returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
 429 \end{code}
 430
 431
 432 %*********************************************************
 433 %*                                                      *
 434 \subsection{Instance declarations}
 435 %*                                                      *
 436 %*********************************************************
 437
 438
 439 @rnInstDecl@ uses the `global name function' to create a new of
 440 instance declaration in which local names have been replaced by their
 441 original names, reporting any unknown names.
 442
 443 \begin{code}
 444 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
 445
 446 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
 447   = pushSrcLocRn src_loc $
 448     lookupClass cname                   `thenRn` \ cname' ->
 449
 450     rnPolyType [] ty                    `thenRn` \ ty' ->
 451         -- [] tv_env ensures that tyvars will be foralled
 452
 453     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 454     mapRn (rn_uprag cname') uprags      `thenRn` \ new_uprags ->
 455
 456     ASSERT(isNoInstancePragmas pragmas)
 457     returnRn (InstDecl cname' ty' mbinds'
 458                        from_here modname new_uprags noInstancePragmas src_loc)
 459   where
 460     rn_uprag class_name (SpecSig op ty using locn)
 461       = pushSrcLocRn src_loc $
 462         lookupClassOp class_name op     `thenRn` \ op_name ->
 463         rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
 464         rn_using using                  `thenRn` \ new_using ->
 465         returnRn (SpecSig op_name new_ty new_using locn)
 466
 467     rn_uprag class_name (InlineSig op locn)
 468       = pushSrcLocRn locn $
 469         lookupClassOp class_name op     `thenRn` \ op_name ->
 470         returnRn (InlineSig op_name locn)
 471
 472     rn_uprag class_name (DeforestSig op locn)
 473       = pushSrcLocRn locn $
 474         lookupClassOp class_name op     `thenRn` \ op_name ->
 475         returnRn (DeforestSig op_name locn)
 476
 477     rn_uprag class_name (MagicUnfoldingSig op str locn)
 478       = pushSrcLocRn locn $
 479         lookupClassOp class_name op     `thenRn` \ op_name ->
 480         returnRn (MagicUnfoldingSig op_name str locn)
 481
 482     rn_using Nothing
 483       = returnRn Nothing
 484     rn_using (Just v)
 485       = lookupValue v   `thenRn` \ new_v ->
 486         returnRn (Just new_v)
 487 \end{code}
 488
 489 %*********************************************************
 490 %*                                                      *
 491 \subsection{@SPECIALIZE instance@ user-pragmas}
 492 %*                                                      *
 493 %*********************************************************
 494
 495 \begin{code}
 496 rnSpecInstSig :: RdrNameSpecInstSig
 497               -> RnM_Fixes s RenamedSpecInstSig
 498
 499 rnSpecInstSig (SpecInstSig clas ty src_loc)
 500   = pushSrcLocRn src_loc $
 501     let
 502         tyvars = extractMonoTyNames is_tyvar_name ty
 503     in
 504     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 505     lookupClass clas                    `thenRn` \ new_clas ->
 506     rnMonoType tv_env ty                `thenRn` \ new_ty ->
 507     returnRn (SpecInstSig new_clas new_ty src_loc)
 508 \end{code}
 509
 510 %*********************************************************
 511 %*                                                      *
 512 \subsection{Default declarations}
 513 %*                                                      *
 514 %*********************************************************
 515
 516 @rnDefaultDecl@ uses the `global name function' to create a new set
 517 of default declarations in which local names have been replaced by
 518 their original names, reporting any unknown names.
 519
 520 \begin{code}
 521 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
 522
 523 rnDefaultDecl [] = returnRn []
 524 rnDefaultDecl [DefaultDecl tys src_loc]
 525   = pushSrcLocRn src_loc $
 526     mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
 527     returnRn [DefaultDecl tys' src_loc]
 528 rnDefaultDecl defs@(d:ds)
 529   = addErrRn (dupDefaultDeclErr defs) `thenRn_`
 530     rnDefaultDecl [d]
 531 \end{code}
 532
 533 %*************************************************************************
 534 %*                                                                      *
 535 \subsection{Fixity declarations}
 536 %*                                                                      *
 537 %*************************************************************************
 538
 539 \begin{code}
 540 rnFixes :: [RdrNameFixityDecl]  -> RnM s [RenamedFixityDecl]
 541
 542 rnFixes fixities
 543   = getSrcLocRn `thenRn` \ src_loc ->
 544     let
 545         (_, dup_fixes) = removeDups cmp_fix fixities
 546         cmp_fix fix1 fix2 = nameFixDecl fix1 `cmp` nameFixDecl fix2
 547
 548         rn_fixity fix@(InfixL name i)
 549           = rn_fixity_pieces InfixL name i fix
 550         rn_fixity fix@(InfixR name i)
 551           = rn_fixity_pieces InfixR name i fix
 552         rn_fixity fix@(InfixN name i)
 553           = rn_fixity_pieces InfixN name i fix
 554
 555         rn_fixity_pieces mk_fixity name i fix
 556           = getRnEnv `thenRn` \ env ->
 557               case lookupGlobalRnEnv env name of
 558                 Just res | isLocallyDefined res
 559                   -> returnRn (Just (mk_fixity res i))
 560                 _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
 561     in
 562     mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
 563     mapRn rn_fixity fixities                              `thenRn` \ fixes_maybe ->
 564     returnRn (catMaybes fixes_maybe)
 565
 566 nameFixDecl (InfixL name i) = name
 567 nameFixDecl (InfixR name i) = name
 568 nameFixDecl (InfixN name i) = name
 569 \end{code}
 570
 571 %*********************************************************
 572 %*                                                      *
 573 \subsection{Support code to rename types}
 574 %*                                                      *
 575 %*********************************************************
 576
 577 \begin{code}
 578 rnPolyType :: TyVarNamesEnv
 579            -> RdrNamePolyType
 580            -> RnM_Fixes s RenamedPolyType
 581
 582 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
 583   = rn_poly_help tv_env tvs ctxt ty
 584
 585 rnPolyType tv_env (HsPreForAllTy ctxt ty)
 586   = rn_poly_help tv_env forall_tyvars ctxt ty
 587   where
 588     mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
 589     forall_tyvars    = {-
 590                        pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
 591                        pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
 592                        -}
 593                        mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
 594
 595 ------------
 596 rn_poly_help :: TyVarNamesEnv
 597              -> [RdrName]
 598              -> RdrNameContext
 599              -> RdrNameMonoType
 600              -> RnM_Fixes s RenamedPolyType
 601
 602 rn_poly_help tv_env tyvars ctxt ty
 603   = {-
 604     pprTrace "rnPolyType:"
 605         (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
 606                 ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
 607                 ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
 608                 ppStr ";ty=", ppr PprShowAll ty]) $
 609     -}
 610     getSrcLocRn                                 `thenRn` \ src_loc ->
 611     mkTyVarNamesEnv src_loc tyvars              `thenRn` \ (tv_env1, new_tyvars) ->
 612     let
 613         tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
 614     in
 615     rnContext tv_env2 ctxt      `thenRn` \ new_ctxt ->
 616     rnMonoType tv_env2 ty       `thenRn` \ new_ty ->
 617     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
 618 \end{code}
 619
 620 \begin{code}
 621 rnMonoType :: TyVarNamesEnv
 622            -> RdrNameMonoType
 623            -> RnM_Fixes s RenamedMonoType
 624
 625 rnMonoType tv_env (MonoTyVar tyvar)
 626   = lookupTyVarName tv_env tyvar        `thenRn` \ tyvar' ->
 627     returnRn (MonoTyVar tyvar')
 628
 629 rnMonoType tv_env (MonoListTy ty)
 630   = rnMonoType tv_env ty        `thenRn` \ ty' ->
 631     returnRn (MonoListTy ty')
 632
 633 rnMonoType tv_env (MonoFunTy ty1 ty2)
 634   = andRn MonoFunTy (rnMonoType tv_env ty1)
 635                     (rnMonoType tv_env ty2)
 636
 637 rnMonoType  tv_env (MonoTupleTy tys)
 638   = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
 639     returnRn (MonoTupleTy tys')
 640
 641 rnMonoType tv_env (MonoTyApp name tys)
 642   = let
 643         lookup_fn = if isLexVarId (getLocalName name)
 644                     then lookupTyVarName tv_env
 645                     else lookupTyCon
 646     in
 647     lookup_fn name                      `thenRn` \ name' ->
 648     mapRn (rnMonoType tv_env) tys       `thenRn` \ tys' ->
 649     returnRn (MonoTyApp name' tys')
 650 \end{code}
 651
 652 \begin{code}
 653 rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
 654
 655 rnContext tv_env ctxt
 656   = mapRn rn_ctxt ctxt
 657   where
 658     rn_ctxt (clas, tyvar)
 659      = lookupClass clas             `thenRn` \ clas_name ->
 660        lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
 661        returnRn (clas_name, tyvar_name)
 662 \end{code}
 663
 664
 665 \begin{code}
 666 dupNameExportWarn locn names@((n,_):_)
 667   = addShortErrLocLine locn (\ sty ->
 668     ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"])
 669
 670 dupLocalsExportErr locn locals@((str,_):_)
 671   = addErrLoc locn "exported names have same local name" (\ sty ->
 672     ppInterleave ppSP (map (pprNonSym sty . snd) locals))
 673
 674 classOpExportErr op locn
 675   = addShortErrLocLine locn (\ sty ->
 676     ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"])
 677
 678 synAllExportErr syn locn
 679   = addShortErrLocLine locn (\ sty ->
 680     ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"])
 681
 682 withExportErr str rn has rns locn
 683   = addErrLoc locn "" (\ sty ->
 684     ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in export list for `", ppr sty rn, ppStr "'"],
 685                ppCat [ppStr "    expected:", ppInterleave ppComma (map (ppr sty) has)],
 686                ppCat [ppStr "    found:   ", ppInterleave ppComma (map (ppr sty) rns)] ])
 687
 688 importAllErr rn locn
 689   = addShortErrLocLine locn (\ sty ->
 690     ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"])
 691
 692 badModExportErr mod locn
 693   = addShortErrLocLine locn (\ sty ->
 694     ppCat [ ppStr "unknown module in export list:", ppPStr mod])
 695
 696 dupModExportWarn locn mods@(mod:_)
 697   = addShortErrLocLine locn (\ sty ->
 698     ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"])
 699
 700 emptyModExportWarn locn mod
 701   = addShortErrLocLine locn (\ sty ->
 702     ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"])
 703
 704 derivingNonStdClassErr clas locn
 705   = addShortErrLocLine locn (\ sty ->
 706     ppCat [ppStr "non-standard class in deriving:", ppr sty clas])
 707
 708 dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
 709   = ppAboves (item1 : map dup_item dup_things)
 710   where
 711     item1
 712       = addShortErrLocLine locn1 (\ sty -> ppStr "multiple default declarations") sty
 713
 714     dup_item (DefaultDecl _ locn)
 715       = addShortErrLocLine locn (\ sty -> ppStr "here was another default declaration") sty
 716
 717 undefinedFixityDeclErr locn decl
 718   = addErrLoc locn "fixity declaration for unknown operator" (\ sty ->
 719     ppr sty decl)
 720
 721 dupFixityDeclErr locn dups
 722   = addErrLoc locn "multiple fixity declarations for same operator" (\ sty ->
 723     ppAboves (map (ppr sty) dups))
 724 \end{code}