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, addShortWarnLocLine )
  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]                    -- imported modules
  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 = (fixDeclName 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 n)           = getSrcLocRn `thenRn` \ src_loc ->
 197                                         warnAndContinueRn (unitBag (n, ExportAbs))
 198                                             (synAllExportErr False{-warning-} rn src_loc)
 199     checkIEAll rn                     = returnRn emptyBag
 200
 201     exp_all n = (n, ExportAll)
 202
 203 rnIE mods (IEThingWith name names)
 204   = lookupTyConOrClass name     `thenRn` \ rn ->
 205     mapRn lookupValue names     `thenRn` \ rns ->
 206     checkIEWith rn rns          `thenRn` \ exps ->
 207     checkImportAll rn           `thenRn_`
 208     returnRn (Nothing, exps)
 209   where
 210     checkIEWith rn@(RnData n cons fields) rns
 211         | same_names (cons++fields) rns
 212         = returnRn (consBag (exp_all n) (listToBag (map exp_all cons)))
 213         | otherwise
 214         = rnWithErr "constructrs (and fields)" rn (cons++fields) rns
 215     checkIEWith rn@(RnClass n ops) rns
 216         | same_names ops rns
 217         = returnRn (consBag (exp_all n) (listToBag (map exp_all ops)))
 218         | otherwise
 219         = rnWithErr "class ops" rn ops rns
 220     checkIEWith rn@(RnSyn _) rns
 221         = getSrcLocRn `thenRn` \ src_loc ->
 222           failButContinueRn emptyBag (synAllExportErr True{-error-} rn src_loc)
 223     checkIEWith rn rns
 224         = returnRn emptyBag
 225
 226     exp_all n = (n, ExportAll)
 227
 228     same_names has rns
 229       = all (not.isRnUnbound) rns &&
 230         sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
 231
 232     rnWithErr str rn has rns
 233       = getSrcLocRn `thenRn` \ src_loc ->
 234         failButContinueRn emptyBag (withExportErr str rn has rns src_loc)
 235
 236 rnIE mods (IEModuleContents mod)
 237   | isIn "rnIE:IEModule" mod mods
 238   = returnRn (Just mod, emptyBag)
 239   | otherwise
 240   = getSrcLocRn `thenRn` \ src_loc ->
 241     failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc)
 242
 243
 244 checkImportAll rn
 245   = case nameImportFlag (getName rn) of
 246       ExportAll -> returnRn ()
 247       exp       -> getSrcLocRn `thenRn` \ src_loc ->
 248                    addErrRn (importAllErr rn src_loc)
 249 \end{code}
 250
 251 %*********************************************************
 252 %*                                                      *
 253 \subsection{Type declarations}
 254 %*                                                      *
 255 %*********************************************************
 256
 257 @rnTyDecl@ uses the `global name function' to create a new type
 258 declaration in which local names have been replaced by their original
 259 names, reporting any unknown names.
 260
 261 Renaming type variables is a pain. Because they now contain uniques,
 262 it is necessary to pass in an association list which maps a parsed
 263 tyvar to its Name representation. In some cases (type signatures of
 264 values), it is even necessary to go over the type first in order to
 265 get the set of tyvars used by it, make an assoc list, and then go over
 266 it again to rename the tyvars! However, we can also do some scoping
 267 checks at the same time.
 268
 269 \begin{code}
 270 rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
 271
 272 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
 273   = pushSrcLocRn src_loc $
 274     lookupTyCon tycon                  `thenRn` \ tycon' ->
 275     mkTyVarNamesEnv src_loc tyvars     `thenRn` \ (tv_env, tyvars') ->
 276     rnContext tv_env context           `thenRn` \ context' ->
 277     rnConDecls tv_env condecls         `thenRn` \ condecls' ->
 278     rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
 279     ASSERT(isNoDataPragmas pragmas)
 280     returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
 281
 282 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
 283   = pushSrcLocRn src_loc $
 284     lookupTyCon tycon                 `thenRn` \ tycon' ->
 285     mkTyVarNamesEnv src_loc tyvars    `thenRn` \ (tv_env, tyvars') ->
 286     rnContext tv_env context          `thenRn` \ context' ->
 287     rnConDecls tv_env condecl         `thenRn` \ condecl' ->
 288     rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
 289     ASSERT(isNoDataPragmas pragmas)
 290     returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
 291
 292 rnTyDecl (TySynonym name tyvars ty src_loc)
 293   = pushSrcLocRn src_loc $
 294     lookupTyCon name                `thenRn` \ name' ->
 295     mkTyVarNamesEnv src_loc tyvars  `thenRn` \ (tv_env, tyvars') ->
 296     rnMonoType tv_env ty            `thenRn` \ ty' ->
 297     returnRn (TySynonym name' tyvars' ty' src_loc)
 298
 299 rn_derivs tycon2 locn Nothing -- derivs not specified
 300   = returnRn Nothing
 301
 302 rn_derivs tycon2 locn (Just ds)
 303   = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
 304     returnRn (Just derivs)
 305   where
 306     rn_deriv tycon2 locn clas
 307       = lookupClass clas            `thenRn` \ clas_name ->
 308         addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
 309                    (derivingNonStdClassErr clas locn)
 310                                     `thenRn_`
 311         returnRn clas_name
 312       where
 313         not_elem = isn'tIn "rn_deriv"
 314 \end{code}
 315
 316 @rnConDecls@ uses the `global name function' to create a new
 317 constructor in which local names have been replaced by their original
 318 names, reporting any unknown names.
 319
 320 \begin{code}
 321 rnConDecls :: TyVarNamesEnv
 322            -> [RdrNameConDecl]
 323            -> RnM_Fixes s [RenamedConDecl]
 324
 325 rnConDecls tv_env con_decls
 326   = mapRn rn_decl con_decls
 327   where
 328     rn_decl (ConDecl name tys src_loc)
 329       = pushSrcLocRn src_loc $
 330         lookupConstr name       `thenRn` \ new_name ->
 331         mapRn rn_bang_ty tys    `thenRn` \ new_tys  ->
 332         returnRn (ConDecl new_name new_tys src_loc)
 333
 334     rn_decl (ConOpDecl ty1 op ty2 src_loc)
 335       = pushSrcLocRn src_loc $
 336         lookupConstr op         `thenRn` \ new_op  ->
 337         rn_bang_ty ty1          `thenRn` \ new_ty1 ->
 338         rn_bang_ty ty2          `thenRn` \ new_ty2 ->
 339         returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
 340
 341     rn_decl (NewConDecl name ty src_loc)
 342       = pushSrcLocRn src_loc $
 343         lookupConstr name       `thenRn` \ new_name ->
 344         rn_mono_ty ty           `thenRn` \ new_ty  ->
 345         returnRn (NewConDecl new_name new_ty src_loc)
 346
 347     rn_decl (RecConDecl name fields src_loc)
 348       = pushSrcLocRn src_loc $
 349         lookupConstr name       `thenRn` \ new_name ->
 350         mapRn rn_field fields   `thenRn` \ new_fields ->
 351         returnRn (RecConDecl new_name new_fields src_loc)
 352
 353     rn_field (names, ty)
 354       = mapRn lookupField names `thenRn` \ new_names ->
 355         rn_bang_ty ty           `thenRn` \ new_ty ->
 356         returnRn (new_names, new_ty)
 357
 358     rn_mono_ty = rnMonoType tv_env
 359     rn_poly_ty = rnPolyType tv_env
 360
 361     rn_bang_ty (Banged ty)
 362       = rn_poly_ty ty `thenRn` \ new_ty ->
 363         returnRn (Banged new_ty)
 364     rn_bang_ty (Unbanged ty)
 365       = rn_poly_ty ty `thenRn` \ new_ty ->
 366         returnRn (Unbanged new_ty)
 367 \end{code}
 368
 369 %*********************************************************
 370 %*                                                       *
 371 \subsection{SPECIALIZE data pragmas}
 372 %*                                                       *
 373 %*********************************************************
 374
 375 \begin{code}
 376 rnSpecDataSig :: RdrNameSpecDataSig
 377               -> RnM_Fixes s RenamedSpecDataSig
 378
 379 rnSpecDataSig (SpecDataSig tycon ty src_loc)
 380   = pushSrcLocRn src_loc $
 381     let
 382         tyvars = extractMonoTyNames is_tyvar_name ty
 383     in
 384     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 385     lookupTyCon tycon                   `thenRn` \ tycon' ->
 386     rnMonoType tv_env ty                `thenRn` \ ty' ->
 387     returnRn (SpecDataSig tycon' ty' src_loc)
 388
 389 is_tyvar_name n = isLexVarId (getLocalName n)
 390 \end{code}
 391
 392 %*********************************************************
 393 %*                                                      *
 394 \subsection{Class declarations}
 395 %*                                                      *
 396 %*********************************************************
 397
 398 @rnClassDecl@ uses the `global name function' to create a new
 399 class declaration in which local names have been replaced by their
 400 original names, reporting any unknown names.
 401
 402 \begin{code}
 403 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
 404
 405 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
 406   = pushSrcLocRn src_loc $
 407     mkTyVarNamesEnv src_loc [tyvar]     `thenRn` \ (tv_env, [tyvar']) ->
 408     rnContext tv_env context            `thenRn` \ context' ->
 409     lookupClass cname                   `thenRn` \ cname' ->
 410     mapRn (rn_op cname' tv_env) sigs    `thenRn` \ sigs' ->
 411     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 412     ASSERT(isNoClassPragmas pragmas)
 413     returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
 414   where
 415     rn_op clas tv_env (ClassOpSig op ty pragmas locn)
 416       = pushSrcLocRn locn $
 417         lookupClassOp clas op           `thenRn` \ op_name ->
 418         rnPolyType tv_env ty            `thenRn` \ new_ty  ->
 419
 420 {-
 421 *** Please check here that tyvar' appears in new_ty ***
 422 *** (used to be in tcClassSig, but it's better here)
 423 ***         not_elem = isn'tIn "tcClassSigs"
 424 ***         -- Check that the class type variable is mentioned
 425 ***     checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty)
 426 ***             (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_`
 427 -}
 428
 429         ASSERT(isNoClassOpPragmas pragmas)
 430         returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
 431 \end{code}
 432
 433
 434 %*********************************************************
 435 %*                                                      *
 436 \subsection{Instance declarations}
 437 %*                                                      *
 438 %*********************************************************
 439
 440
 441 @rnInstDecl@ uses the `global name function' to create a new of
 442 instance declaration in which local names have been replaced by their
 443 original names, reporting any unknown names.
 444
 445 \begin{code}
 446 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
 447
 448 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
 449   = pushSrcLocRn src_loc $
 450     lookupClass cname                   `thenRn` \ cname' ->
 451
 452     rnPolyType [] ty                    `thenRn` \ ty' ->
 453         -- [] tv_env ensures that tyvars will be foralled
 454
 455     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 456     mapRn (rn_uprag cname') uprags      `thenRn` \ new_uprags ->
 457
 458     ASSERT(isNoInstancePragmas pragmas)
 459     returnRn (InstDecl cname' ty' mbinds'
 460                        from_here modname new_uprags noInstancePragmas src_loc)
 461   where
 462     rn_uprag class_name (SpecSig op ty using locn)
 463       = pushSrcLocRn src_loc $
 464         lookupClassOp class_name op     `thenRn` \ op_name ->
 465         rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
 466         rn_using using                  `thenRn` \ new_using ->
 467         returnRn (SpecSig op_name new_ty new_using locn)
 468
 469     rn_uprag class_name (InlineSig op locn)
 470       = pushSrcLocRn locn $
 471         lookupClassOp class_name op     `thenRn` \ op_name ->
 472         returnRn (InlineSig op_name locn)
 473
 474     rn_uprag class_name (DeforestSig op locn)
 475       = pushSrcLocRn locn $
 476         lookupClassOp class_name op     `thenRn` \ op_name ->
 477         returnRn (DeforestSig op_name locn)
 478
 479     rn_uprag class_name (MagicUnfoldingSig op str locn)
 480       = pushSrcLocRn locn $
 481         lookupClassOp class_name op     `thenRn` \ op_name ->
 482         returnRn (MagicUnfoldingSig op_name str locn)
 483
 484     rn_using Nothing
 485       = returnRn Nothing
 486     rn_using (Just v)
 487       = lookupValue v   `thenRn` \ new_v ->
 488         returnRn (Just new_v)
 489 \end{code}
 490
 491 %*********************************************************
 492 %*                                                      *
 493 \subsection{@SPECIALIZE instance@ user-pragmas}
 494 %*                                                      *
 495 %*********************************************************
 496
 497 \begin{code}
 498 rnSpecInstSig :: RdrNameSpecInstSig
 499               -> RnM_Fixes s RenamedSpecInstSig
 500
 501 rnSpecInstSig (SpecInstSig clas ty src_loc)
 502   = pushSrcLocRn src_loc $
 503     let
 504         tyvars = extractMonoTyNames is_tyvar_name ty
 505     in
 506     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 507     lookupClass clas                    `thenRn` \ new_clas ->
 508     rnMonoType tv_env ty                `thenRn` \ new_ty ->
 509     returnRn (SpecInstSig new_clas new_ty src_loc)
 510 \end{code}
 511
 512 %*********************************************************
 513 %*                                                      *
 514 \subsection{Default declarations}
 515 %*                                                      *
 516 %*********************************************************
 517
 518 @rnDefaultDecl@ uses the `global name function' to create a new set
 519 of default declarations in which local names have been replaced by
 520 their original names, reporting any unknown names.
 521
 522 \begin{code}
 523 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
 524
 525 rnDefaultDecl [] = returnRn []
 526 rnDefaultDecl [DefaultDecl tys src_loc]
 527   = pushSrcLocRn src_loc $
 528     mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
 529     returnRn [DefaultDecl tys' src_loc]
 530 rnDefaultDecl defs@(d:ds)
 531   = addErrRn (dupDefaultDeclErr defs) `thenRn_`
 532     rnDefaultDecl [d]
 533 \end{code}
 534
 535 %*************************************************************************
 536 %*                                                                      *
 537 \subsection{Fixity declarations}
 538 %*                                                                      *
 539 %*************************************************************************
 540
 541 \begin{code}
 542 rnFixes :: [RdrNameFixityDecl]  -> RnM s [RenamedFixityDecl]
 543
 544 rnFixes fixities
 545   = getSrcLocRn `thenRn` \ src_loc ->
 546     let
 547         (_, dup_fixes) = removeDups cmp_fix fixities
 548         cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2
 549
 550         rn_fixity fix@(InfixL name i)
 551           = rn_fixity_pieces InfixL name i fix
 552         rn_fixity fix@(InfixR name i)
 553           = rn_fixity_pieces InfixR name i fix
 554         rn_fixity fix@(InfixN name i)
 555           = rn_fixity_pieces InfixN name i fix
 556
 557         rn_fixity_pieces mk_fixity name i fix
 558           = getRnEnv `thenRn` \ env ->
 559               case lookupGlobalRnEnv env name of
 560                 Just res | isLocallyDefined res
 561                   -> returnRn (Just (mk_fixity res i))
 562                 _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
 563     in
 564     mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
 565     mapRn rn_fixity fixities                              `thenRn` \ fixes_maybe ->
 566     returnRn (catMaybes fixes_maybe)
 567 \end{code}
 568
 569 %*********************************************************
 570 %*                                                      *
 571 \subsection{Support code to rename types}
 572 %*                                                      *
 573 %*********************************************************
 574
 575 \begin{code}
 576 rnPolyType :: TyVarNamesEnv
 577            -> RdrNamePolyType
 578            -> RnM_Fixes s RenamedPolyType
 579
 580 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
 581   = rn_poly_help tv_env tvs ctxt ty
 582
 583 rnPolyType tv_env (HsPreForAllTy ctxt ty)
 584   = rn_poly_help tv_env forall_tyvars ctxt ty
 585   where
 586     mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
 587     forall_tyvars    = {-
 588                        pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
 589                        pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
 590                        -}
 591                        mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
 592
 593 ------------
 594 rn_poly_help :: TyVarNamesEnv
 595              -> [RdrName]
 596              -> RdrNameContext
 597              -> RdrNameMonoType
 598              -> RnM_Fixes s RenamedPolyType
 599
 600 rn_poly_help tv_env tyvars ctxt ty
 601   = {-
 602     pprTrace "rnPolyType:"
 603         (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
 604                 ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
 605                 ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
 606                 ppStr ";ty=", ppr PprShowAll ty]) $
 607     -}
 608     getSrcLocRn                                 `thenRn` \ src_loc ->
 609     mkTyVarNamesEnv src_loc tyvars              `thenRn` \ (tv_env1, new_tyvars) ->
 610     let
 611         tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
 612     in
 613     rnContext tv_env2 ctxt      `thenRn` \ new_ctxt ->
 614     rnMonoType tv_env2 ty       `thenRn` \ new_ty ->
 615     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
 616 \end{code}
 617
 618 \begin{code}
 619 rnMonoType :: TyVarNamesEnv
 620            -> RdrNameMonoType
 621            -> RnM_Fixes s RenamedMonoType
 622
 623 rnMonoType tv_env (MonoTyVar tyvar)
 624   = lookupTyVarName tv_env tyvar        `thenRn` \ tyvar' ->
 625     returnRn (MonoTyVar tyvar')
 626
 627 rnMonoType tv_env (MonoListTy ty)
 628   = rnMonoType tv_env ty        `thenRn` \ ty' ->
 629     returnRn (MonoListTy ty')
 630
 631 rnMonoType tv_env (MonoFunTy ty1 ty2)
 632   = andRn MonoFunTy (rnMonoType tv_env ty1)
 633                     (rnMonoType tv_env ty2)
 634
 635 rnMonoType  tv_env (MonoTupleTy tys)
 636   = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
 637     returnRn (MonoTupleTy tys')
 638
 639 rnMonoType tv_env (MonoTyApp name tys)
 640   = let
 641         lookup_fn = if isLexVarId (getLocalName name)
 642                     then lookupTyVarName tv_env
 643                     else lookupTyCon
 644     in
 645     lookup_fn name                      `thenRn` \ name' ->
 646     mapRn (rnMonoType tv_env) tys       `thenRn` \ tys' ->
 647     returnRn (MonoTyApp name' tys')
 648 \end{code}
 649
 650 \begin{code}
 651 rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext
 652
 653 rnContext tv_env ctxt
 654   = mapRn rn_ctxt ctxt
 655   where
 656     rn_ctxt (clas, tyvar)
 657      = lookupClass clas             `thenRn` \ clas_name ->
 658        lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
 659        returnRn (clas_name, tyvar_name)
 660 \end{code}
 661
 662
 663 \begin{code}
 664 dupNameExportWarn locn names@((n,_):_)
 665   = addShortWarnLocLine locn (\ sty ->
 666     ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"])
 667
 668 dupLocalsExportErr locn locals@((str,_):_)
 669   = addErrLoc locn "exported names have same local name" (\ sty ->
 670     ppInterleave ppSP (map (pprNonSym sty . snd) locals))
 671
 672 classOpExportErr op locn
 673   = addShortErrLocLine locn (\ sty ->
 674     ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"])
 675
 676 synAllExportErr is_error syn locn
 677   = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn (\ sty ->
 678     ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"])
 679
 680 withExportErr str rn has rns locn
 681   = addErrLoc locn "" (\ sty ->
 682     ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"],
 683                ppCat [ppStr "    expected:", ppInterleave ppComma (map (ppr sty) has)],
 684                ppCat [ppStr "    found:   ", ppInterleave ppComma (map (ppr sty) rns)] ])
 685
 686 importAllErr rn locn
 687   = addShortErrLocLine locn (\ sty ->
 688     ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"])
 689
 690 badModExportErr mod locn
 691   = addShortErrLocLine locn (\ sty ->
 692     ppCat [ ppStr "unknown module in export list: module", ppPStr mod])
 693
 694 emptyModExportWarn locn mod
 695   = addShortWarnLocLine locn (\ sty ->
 696     ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"])
 697
 698 dupModExportWarn locn mods@(mod:_)
 699   = addShortWarnLocLine locn (\ sty ->
 700     ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"])
 701
 702 derivingNonStdClassErr clas locn
 703   = addShortErrLocLine locn (\ sty ->
 704     ppCat [ppStr "non-standard class in deriving:", ppr sty clas])
 705
 706 dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
 707   = ppAboves (item1 : map dup_item dup_things)
 708   where
 709     item1
 710       = addShortErrLocLine locn1 (\ sty -> ppStr "multiple default declarations") sty
 711
 712     dup_item (DefaultDecl _ locn)
 713       = addShortErrLocLine locn (\ sty -> ppStr "here was another default declaration") sty
 714
 715 undefinedFixityDeclErr locn decl
 716   = addErrLoc locn "fixity declaration for unknown operator" (\ sty ->
 717     ppr sty decl)
 718
 719 dupFixityDeclErr locn dups
 720   = addErrLoc locn "multiple fixity declarations for same operator" (\ sty ->
 721     ppAboves (map (ppr sty) dups))
 722 \end{code}