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