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