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