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 IMP_Ubiq()
  12 IMPORT_DELOOPER(RnLoop)         -- *check* the RnPass/RnExpr/RnBinds loop-breaking
  13 IMPORT_1_3(List(partition))
  14
  15 import HsSyn
  16 import HsPragmas
  17 import RdrHsSyn
  18 import RnHsSyn
  19 import RnMonad
  20 import RnBinds          ( rnTopBinds, rnMethodBinds )
  21 import RnUtils          ( getLocalsFromRnEnv, lookupGlobalRnEnv, lubExportFlag )
  22
  23 import Bag              ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
  24 import Class            ( derivableClassKeys )
  25 import CmdLineOpts      ( opt_CompilingGhcInternals )
  26 import ErrUtils         ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
  27 import FiniteMap        ( emptyFM, lookupFM, addListToFM_C )
  28 import Id               ( GenId{-instance NamedThing-} )
  29 import ListSetOps       ( unionLists, minusList )
  30 import Maybes           ( maybeToBool, catMaybes )
  31 import Name             ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
  32                           nameImportFlag, RdrName, pprNonSym, Name )
  33 import Outputable       -- ToDo:rm
  34 import PprStyle         -- ToDo:rm
  35 import Pretty
  36 import SrcLoc           ( SrcLoc )
  37 import TyCon            ( tyConDataCons, TyCon{-instance NamedThing-} )
  38 import Unique           ( Unique )
  39 import UniqFM           ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM )
  40 import UniqSet          ( SYN_IE(UniqSet) )
  41 import Util             ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString,
  42                           panic, assertPanic, pprTrace{-ToDo:rm-} )
  43 \end{code}
  44
  45 rnSource `renames' the source module and export list.
  46 It simultaneously performs dependency analysis and precedence parsing.
  47 It also does the following error checks:
  48 \begin{enumerate}
  49 \item
  50 Checks that tyvars are used properly. This includes checking
  51 for undefined tyvars, and tyvars in contexts that are ambiguous.
  52 \item
  53 Checks that all variable occurences are defined.
  54 \item
  55 Checks the (..) etc constraints in the export list.
  56 \end{enumerate}
  57
  58
  59 \begin{code}
  60 rnSource :: [Module]                    -- imported modules
  61          -> Bag (Module,RnName)         -- unqualified imports from module
  62          -> Bag RenamedFixityDecl       -- fixity info for imported names
  63          -> RdrNameHsModule
  64          -> RnM s (RenamedHsModule,
  65                    Name -> ExportFlag,          -- export info
  66                    Bag (RnName, RdrName))       -- occurrence info
  67
  68 rnSource imp_mods unqual_imps imp_fixes
  69         (HsModule mod version exports _ fixes
  70            ty_decls specdata_sigs class_decls
  71            inst_decls specinst_sigs defaults
  72            binds _ src_loc)
  73
  74   = pushSrcLocRn src_loc $
  75
  76     rnExports (mod:imp_mods) unqual_imps exports        `thenRn` \ exported_fn ->
  77     rnFixes fixes                                       `thenRn` \ src_fixes ->
  78     let
  79         all_fixes     = src_fixes ++ bagToList imp_fixes
  80         all_fixes_fm  = listToUFM (map pair_name all_fixes)
  81
  82         pair_name inf = (fixDeclName inf, inf)
  83     in
  84     setExtraRn all_fixes_fm $
  85
  86     mapRn rnTyDecl      ty_decls        `thenRn` \ new_ty_decls ->
  87     mapRn rnSpecDataSig specdata_sigs   `thenRn` \ new_specdata_sigs ->
  88     mapRn rnClassDecl   class_decls     `thenRn` \ new_class_decls ->
  89     mapRn rnInstDecl    inst_decls      `thenRn` \ new_inst_decls ->
  90     mapRn rnSpecInstSig specinst_sigs   `thenRn` \ new_specinst_sigs ->
  91     rnDefaultDecl       defaults        `thenRn` \ new_defaults ->
  92     rnTopBinds binds                    `thenRn` \ new_binds ->
  93
  94     getOccurrenceUpRn                   `thenRn` \ occ_info ->
  95
  96     returnRn (
  97               HsModule mod version
  98                 trashed_exports trashed_imports all_fixes
  99                 new_ty_decls new_specdata_sigs new_class_decls
 100                 new_inst_decls new_specinst_sigs new_defaults
 101                 new_binds [] src_loc,
 102               exported_fn,
 103               occ_info
 104              )
 105   where
 106     trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
 107     trashed_imports = {-trace "rnSource:trashed_imports"-} []
 108 \end{code}
 109
 110
 111 %*********************************************************
 112 %*                                                      *
 113 \subsection{Export list}
 114 %*                                                      *
 115 %*********************************************************
 116
 117 \begin{code}
 118 rnExports :: [Module]
 119           -> Bag (Module,RnName)
 120           -> Maybe [RdrNameIE]
 121           -> RnM s (Name -> ExportFlag)
 122
 123 rnExports mods unqual_imps Nothing
 124   = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported)
 125
 126 rnExports mods unqual_imps (Just exps)
 127   = getModuleRn                    `thenRn` \ this_mod ->
 128     getRnEnv                       `thenRn` \ rn_env ->
 129     mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) ->
 130     let
 131         (tc_bags, val_bags) = unzip exp_bags
 132         tc_names  = bagToList (unionManyBags tc_bags)
 133         val_names = bagToList (unionManyBags val_bags)
 134         exp_mods  = catMaybes mod_maybes
 135
 136         -- Warn for duplicate names and modules
 137         (_, dup_tc_names)  = removeDups cmp_fst tc_names
 138         (_, dup_val_names) = removeDups cmp_fst val_names
 139         cmp_fst (x,_) (y,_) = x `cmp` y
 140
 141         (uniq_mods, dup_mods) = removeDups cmpPString exp_mods
 142         (expmods_this, expmods_imps) = partition (== this_mod) uniq_mods
 143
 144         -- Get names for module This_Mod export
 145         (this_tcs, this_vals)
 146           = if null expmods_this
 147             then ([], [])
 148             else getLocalsFromRnEnv rn_env
 149
 150         -- Get names for exported imported modules
 151         (mod_tcs, mod_vals, empty_mods)
 152           = case mapAndUnzip3 get_mod_names expmods_imps of
 153               (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys)
 154
 155         (unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps)
 156
 157         get_mod_names mod
 158           = (tcs, vals, empty_mod)
 159           where
 160             tcs  = [(getName rn, nameImportFlag (getName rn))
 161                    | (mod',rn) <- unqual_tcs, mod == mod']
 162             vals = [(getName rn, nameImportFlag (getName rn))
 163                    | (mod',rn) <- unqual_vals, mod == mod']
 164             empty_mod = if null tcs && null vals
 165                         then Just mod
 166                         else Nothing
 167
 168         -- Build finite map of exported names to export flag
 169         tc_map0  = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names)
 170         tc_map1  = addListToUFM_C lub_expflag tc_map0  (map pair_fst mod_tcs)
 171         tc_map   = addListToUFM_C lub_expflag tc_map1  (map (pair_fst.exp_all) this_tcs)
 172
 173         val_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst val_names)
 174         val_map1 = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals)
 175         val_map  = addListToUFM_C lub_expflag val_map1 (map (pair_fst.exp_all) this_vals)
 176
 177         pair_fst pr@(n,_) = (n,pr)
 178         exp_all rn = (getName rn, ExportAll)
 179         lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2)
 180
 181         -- Check for exporting of duplicate local names
 182         tc_locals  = [(getLocalName n, n) | (n,_) <- eltsUFM tc_map]
 183         val_locals = [(getLocalName n, n) | (n,_) <- eltsUFM val_map]
 184         (_, dup_tc_locals)  = removeDups cmp_local tc_locals
 185         (_, dup_val_locals) = removeDups cmp_local val_locals
 186         cmp_local (x,_) (y,_) = x `cmpPString` y
 187
 188         -- Build export flag function
 189         final_exp_map = plusUFM tc_map val_map
 190         exp_fn n = case lookupUFM final_exp_map n of
 191                       Nothing       -> NotExported
 192                       Just (_,flag) -> flag
 193     in
 194     getSrcLocRn                                                         `thenRn` \ src_loc ->
 195     mapRn (addWarnRn . dupNameExportWarn  src_loc) dup_tc_names         `thenRn_`
 196     mapRn (addWarnRn . dupNameExportWarn  src_loc) dup_val_names        `thenRn_`
 197     mapRn (addWarnRn . dupModExportWarn   src_loc) dup_mods             `thenRn_`
 198     mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods           `thenRn_`
 199     mapRn (addErrRn  . dupLocalsExportErr src_loc) dup_tc_locals        `thenRn_`
 200     mapRn (addErrRn  . dupLocalsExportErr src_loc) dup_val_locals       `thenRn_`
 201     returnRn exp_fn
 202
 203
 204 rnIE mods (IEVar name)
 205   = lookupValue name    `thenRn` \ rn ->
 206     checkIEVar rn       `thenRn` \ exps ->
 207     returnRn (Nothing, exps)
 208   where
 209     checkIEVar (RnName    n)      = returnRn (emptyBag, unitBag (n,ExportAll))
 210     checkIEVar (WiredInId i)      = returnRn (emptyBag, unitBag (getName i, ExportAll))
 211     checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc ->
 212                                     failButContinueRn (emptyBag, emptyBag) (classOpExportErr rn src_loc)
 213     checkIEVar rn@(RnField _ _)   = getSrcLocRn `thenRn` \ src_loc ->
 214                                     failButContinueRn (emptyBag, emptyBag) (fieldExportErr rn src_loc)
 215     checkIEVar rn                 = --pprTrace "rnIE:IEVar:panic? ToDo?:" (ppr PprDebug rn) $
 216                                     returnRn (emptyBag, emptyBag)
 217
 218 rnIE mods (IEThingAbs name)
 219   = lookupTyConOrClass name     `thenRn` \ rn ->
 220     checkIEAbs rn               `thenRn` \ exps ->
 221     returnRn (Nothing, exps)
 222   where
 223     checkIEAbs (RnSyn n)        = returnRn (unitBag (n,ExportAbs), emptyBag)
 224     checkIEAbs (RnData n _ _)   = returnRn (unitBag (n,ExportAbs), emptyBag)
 225     checkIEAbs (RnClass n _)    = returnRn (unitBag (n,ExportAbs), emptyBag)
 226     checkIEAbs (WiredInTyCon t) = returnRn (unitBag (getName t,ExportAbs), emptyBag)
 227     checkIEAbs rn               = --pprTrace "rnIE:IEAbs:panic? ToDo?:" (ppr PprDebug rn) $
 228                                   returnRn (emptyBag, emptyBag)
 229
 230 rnIE mods (IEThingAll name)
 231   = lookupTyConOrClass name     `thenRn` \ rn ->
 232     checkIEAll rn               `thenRn` \ exps ->
 233     checkImportAll rn           `thenRn_`
 234     returnRn (Nothing, exps)
 235   where
 236     checkIEAll (RnData n cons fields)
 237       = returnRn (unitBag (exp_all n),
 238             listToBag (map exp_all cons) `unionBags` listToBag (map exp_all fields))
 239
 240     checkIEAll (WiredInTyCon t)
 241       = returnRn (unitBag (exp_all (getName t)), listToBag (map exp_all cons))
 242       where
 243         cons   = map getName (tyConDataCons t)
 244
 245     checkIEAll (RnClass n ops)
 246       = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
 247     checkIEAll rn@(RnSyn n)
 248       = getSrcLocRn `thenRn` \ src_loc ->
 249         warnAndContinueRn (unitBag (n, ExportAbs), emptyBag)
 250                           (synAllExportErr False{-warning-} rn src_loc)
 251
 252     checkIEAll rn = pprTrace "rnIE:IEAll:panic? ToDo?:" (ppr PprDebug rn) $
 253                     returnRn (emptyBag, emptyBag)
 254
 255     exp_all n = (n, ExportAll)
 256
 257 rnIE mods (IEThingWith name names)
 258   = lookupTyConOrClass name     `thenRn` \ rn ->
 259     mapRn lookupValue names     `thenRn` \ rns ->
 260     checkIEWith rn rns          `thenRn` \ exps ->
 261     checkImportAll rn           `thenRn_`
 262     returnRn (Nothing, exps)
 263   where
 264     checkIEWith rn@(RnData n cons fields) rns
 265         | same_names (cons++fields) rns
 266         = returnRn (unitBag (exp_all n), listToBag (map exp_all cons)
 267                                            `unionBags`
 268                                          listToBag (map exp_all fields))
 269         | otherwise
 270         = rnWithErr "constructors (and fields)" rn (cons++fields) rns
 271     checkIEWith rn@(RnClass n ops) rns
 272         | same_names ops rns
 273         = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
 274         | otherwise
 275         = rnWithErr "class ops" rn ops rns
 276     checkIEWith rn@(RnSyn _) rns
 277         = getSrcLocRn `thenRn` \ src_loc ->
 278           failButContinueRn (emptyBag, emptyBag) (synAllExportErr True{-error-} rn src_loc)
 279     checkIEWith (WiredInTyCon _) rns = panic "RnSource.rnIE:checkIEWith:WiredInTyCon:ToDo (boring)"
 280     checkIEWith rn rns
 281         = pprTrace "rnIE:IEWith:panic? ToDo?:" (ppr PprDebug rn) $
 282           returnRn (emptyBag, emptyBag)
 283
 284     exp_all n = (n, ExportAll)
 285
 286     same_names has rns
 287       = all (not.isRnUnbound) rns &&
 288         sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
 289
 290     rnWithErr str rn has rns
 291       = getSrcLocRn `thenRn` \ src_loc ->
 292         failButContinueRn (emptyBag, emptyBag) (withExportErr str rn has rns src_loc)
 293
 294 rnIE mods (IEModuleContents mod)
 295   | isIn "rnIE:IEModule" mod mods
 296   = returnRn (Just mod, (emptyBag, emptyBag))
 297   | otherwise
 298   = getSrcLocRn `thenRn` \ src_loc ->
 299     failButContinueRn (Nothing, (emptyBag, emptyBag)) (badModExportErr mod src_loc)
 300
 301
 302 checkImportAll rn
 303   = case nameImportFlag (getName rn) of
 304       ExportAll -> returnRn ()
 305       exp       -> getSrcLocRn `thenRn` \ src_loc ->
 306                    addErrRn (importAllErr rn src_loc)
 307 \end{code}
 308
 309 %*********************************************************
 310 %*                                                      *
 311 \subsection{Type declarations}
 312 %*                                                      *
 313 %*********************************************************
 314
 315 @rnTyDecl@ uses the `global name function' to create a new type
 316 declaration in which local names have been replaced by their original
 317 names, reporting any unknown names.
 318
 319 Renaming type variables is a pain. Because they now contain uniques,
 320 it is necessary to pass in an association list which maps a parsed
 321 tyvar to its Name representation. In some cases (type signatures of
 322 values), it is even necessary to go over the type first in order to
 323 get the set of tyvars used by it, make an assoc list, and then go over
 324 it again to rename the tyvars! However, we can also do some scoping
 325 checks at the same time.
 326
 327 \begin{code}
 328 rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
 329
 330 rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
 331   = pushSrcLocRn src_loc $
 332     lookupTyCon tycon                  `thenRn` \ tycon' ->
 333     mkTyVarNamesEnv src_loc tyvars     `thenRn` \ (tv_env, tyvars') ->
 334     rnContext tv_env src_loc context   `thenRn` \ context' ->
 335     rnConDecls tv_env condecls         `thenRn` \ condecls' ->
 336     rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
 337     ASSERT(isNoDataPragmas pragmas)
 338     returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
 339
 340 rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
 341   = pushSrcLocRn src_loc $
 342     lookupTyCon tycon                 `thenRn` \ tycon' ->
 343     mkTyVarNamesEnv src_loc tyvars    `thenRn` \ (tv_env, tyvars') ->
 344     rnContext tv_env src_loc context  `thenRn` \ context' ->
 345     rnConDecls tv_env condecl         `thenRn` \ condecl' ->
 346     rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
 347     ASSERT(isNoDataPragmas pragmas)
 348     returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
 349
 350 rnTyDecl (TySynonym name tyvars ty src_loc)
 351   = pushSrcLocRn src_loc $
 352     lookupTyCon name                `thenRn` \ name' ->
 353     mkTyVarNamesEnv src_loc tyvars  `thenRn` \ (tv_env, tyvars') ->
 354     rnMonoType tv_env ty            `thenRn` \ ty' ->
 355     returnRn (TySynonym name' tyvars' ty' src_loc)
 356
 357 rn_derivs tycon2 locn Nothing -- derivs not specified
 358   = returnRn Nothing
 359
 360 rn_derivs tycon2 locn (Just ds)
 361   = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
 362     returnRn (Just derivs)
 363   where
 364     rn_deriv tycon2 locn clas
 365       = lookupClass clas            `thenRn` \ clas_name ->
 366         addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
 367                    (derivingNonStdClassErr clas_name locn)
 368                                     `thenRn_`
 369         returnRn clas_name
 370       where
 371         not_elem = isn'tIn "rn_deriv"
 372 \end{code}
 373
 374 @rnConDecls@ uses the `global name function' to create a new
 375 constructor in which local names have been replaced by their original
 376 names, reporting any unknown names.
 377
 378 \begin{code}
 379 rnConDecls :: TyVarNamesEnv
 380            -> [RdrNameConDecl]
 381            -> RnM_Fixes s [RenamedConDecl]
 382
 383 rnConDecls tv_env con_decls
 384   = mapRn rn_decl con_decls
 385   where
 386     rn_decl (ConDecl name tys src_loc)
 387       = pushSrcLocRn src_loc $
 388         lookupConstr name       `thenRn` \ new_name ->
 389         mapRn rn_bang_ty tys    `thenRn` \ new_tys  ->
 390         returnRn (ConDecl new_name new_tys src_loc)
 391
 392     rn_decl (ConOpDecl ty1 op ty2 src_loc)
 393       = pushSrcLocRn src_loc $
 394         lookupConstr op         `thenRn` \ new_op  ->
 395         rn_bang_ty ty1          `thenRn` \ new_ty1 ->
 396         rn_bang_ty ty2          `thenRn` \ new_ty2 ->
 397         returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
 398
 399     rn_decl (NewConDecl name ty src_loc)
 400       = pushSrcLocRn src_loc $
 401         lookupConstr name       `thenRn` \ new_name ->
 402         rn_mono_ty ty           `thenRn` \ new_ty  ->
 403         returnRn (NewConDecl new_name new_ty src_loc)
 404
 405     rn_decl (RecConDecl name fields src_loc)
 406       = pushSrcLocRn src_loc $
 407         lookupConstr name       `thenRn` \ new_name ->
 408         mapRn rn_field fields   `thenRn` \ new_fields ->
 409         returnRn (RecConDecl new_name new_fields src_loc)
 410
 411     rn_field (names, ty)
 412       = mapRn lookupField names `thenRn` \ new_names ->
 413         rn_bang_ty ty           `thenRn` \ new_ty ->
 414         returnRn (new_names, new_ty)
 415
 416     rn_mono_ty = rnMonoType tv_env
 417     rn_poly_ty = rnPolyType tv_env
 418
 419     rn_bang_ty (Banged ty)
 420       = rn_poly_ty ty `thenRn` \ new_ty ->
 421         returnRn (Banged new_ty)
 422     rn_bang_ty (Unbanged ty)
 423       = rn_poly_ty ty `thenRn` \ new_ty ->
 424         returnRn (Unbanged new_ty)
 425 \end{code}
 426
 427 %*********************************************************
 428 %*                                                       *
 429 \subsection{SPECIALIZE data pragmas}
 430 %*                                                       *
 431 %*********************************************************
 432
 433 \begin{code}
 434 rnSpecDataSig :: RdrNameSpecDataSig
 435               -> RnM_Fixes s RenamedSpecDataSig
 436
 437 rnSpecDataSig (SpecDataSig tycon ty src_loc)
 438   = pushSrcLocRn src_loc $
 439     let
 440         tyvars = extractMonoTyNames is_tyvar_name ty
 441     in
 442     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 443     lookupTyCon tycon                   `thenRn` \ tycon' ->
 444     rnMonoType tv_env ty                `thenRn` \ ty' ->
 445     returnRn (SpecDataSig tycon' ty' src_loc)
 446
 447 is_tyvar_name n = isLexVarId (getLocalName n)
 448 \end{code}
 449
 450 %*********************************************************
 451 %*                                                      *
 452 \subsection{Class declarations}
 453 %*                                                      *
 454 %*********************************************************
 455
 456 @rnClassDecl@ uses the `global name function' to create a new
 457 class declaration in which local names have been replaced by their
 458 original names, reporting any unknown names.
 459
 460 \begin{code}
 461 rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
 462
 463 rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
 464   = pushSrcLocRn src_loc $
 465     mkTyVarNamesEnv src_loc [tyvar]         `thenRn` \ (tv_env, [tyvar']) ->
 466     rnContext tv_env src_loc context        `thenRn` \ context' ->
 467     lookupClass cname                       `thenRn` \ cname' ->
 468     mapRn (rn_op cname' tyvar' tv_env) sigs `thenRn` \ sigs' ->
 469     rnMethodBinds cname' mbinds             `thenRn` \ mbinds' ->
 470     ASSERT(isNoClassPragmas pragmas)
 471     returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
 472   where
 473     rn_op clas clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn)
 474       = pushSrcLocRn locn $
 475         lookupClassOp clas op           `thenRn` \ op_name ->
 476         rnPolyType tv_env ty            `thenRn` \ new_ty  ->
 477         let
 478             (HsForAllTy tvs ctxt op_ty) = new_ty
 479             ctxt_tvs = extractCtxtTyNames ctxt
 480             op_tvs   = extractMonoTyNames is_tyvar_name op_ty
 481         in
 482         -- check that class tyvar appears in op_ty
 483         ( if isIn "rn_op" clas_tyvar op_tvs
 484           then returnRn ()
 485           else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn)
 486         ) `thenRn_`
 487
 488         -- check that class tyvar *doesn't* appear in the sig's context
 489         ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs
 490           then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn)
 491           else returnRn ()
 492         ) `thenRn_`
 493
 494         ASSERT(isNoClassOpPragmas pragmas)
 495         returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
 496 \end{code}
 497
 498
 499 %*********************************************************
 500 %*                                                      *
 501 \subsection{Instance declarations}
 502 %*                                                      *
 503 %*********************************************************
 504
 505
 506 @rnInstDecl@ uses the `global name function' to create a new of
 507 instance declaration in which local names have been replaced by their
 508 original names, reporting any unknown names.
 509
 510 \begin{code}
 511 rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
 512
 513 rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
 514   = pushSrcLocRn src_loc $
 515     lookupClass cname                   `thenRn` \ cname' ->
 516
 517     rnPolyType [] ty                    `thenRn` \ ty' ->
 518         -- [] tv_env ensures that tyvars will be foralled
 519
 520     rnMethodBinds cname' mbinds         `thenRn` \ mbinds' ->
 521     mapRn (rn_uprag cname') uprags      `thenRn` \ new_uprags ->
 522
 523     ASSERT(isNoInstancePragmas pragmas)
 524     returnRn (InstDecl cname' ty' mbinds'
 525                        from_here modname new_uprags noInstancePragmas src_loc)
 526   where
 527     rn_uprag class_name (SpecSig op ty using locn)
 528       = pushSrcLocRn src_loc $
 529         lookupClassOp class_name op     `thenRn` \ op_name ->
 530         rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
 531         rn_using using                  `thenRn` \ new_using ->
 532         returnRn (SpecSig op_name new_ty new_using locn)
 533
 534     rn_uprag class_name (InlineSig op locn)
 535       = pushSrcLocRn locn $
 536         lookupClassOp class_name op     `thenRn` \ op_name ->
 537         returnRn (InlineSig op_name locn)
 538
 539     rn_uprag class_name (DeforestSig op locn)
 540       = pushSrcLocRn locn $
 541         lookupClassOp class_name op     `thenRn` \ op_name ->
 542         returnRn (DeforestSig op_name locn)
 543
 544     rn_uprag class_name (MagicUnfoldingSig op str locn)
 545       = pushSrcLocRn locn $
 546         lookupClassOp class_name op     `thenRn` \ op_name ->
 547         returnRn (MagicUnfoldingSig op_name str locn)
 548
 549     rn_using Nothing
 550       = returnRn Nothing
 551     rn_using (Just v)
 552       = lookupValue v   `thenRn` \ new_v ->
 553         returnRn (Just new_v)
 554 \end{code}
 555
 556 %*********************************************************
 557 %*                                                      *
 558 \subsection{@SPECIALIZE instance@ user-pragmas}
 559 %*                                                      *
 560 %*********************************************************
 561
 562 \begin{code}
 563 rnSpecInstSig :: RdrNameSpecInstSig
 564               -> RnM_Fixes s RenamedSpecInstSig
 565
 566 rnSpecInstSig (SpecInstSig clas ty src_loc)
 567   = pushSrcLocRn src_loc $
 568     let
 569         tyvars = extractMonoTyNames is_tyvar_name ty
 570     in
 571     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env,_) ->
 572     lookupClass clas                    `thenRn` \ new_clas ->
 573     rnMonoType tv_env ty                `thenRn` \ new_ty ->
 574     returnRn (SpecInstSig new_clas new_ty src_loc)
 575 \end{code}
 576
 577 %*********************************************************
 578 %*                                                      *
 579 \subsection{Default declarations}
 580 %*                                                      *
 581 %*********************************************************
 582
 583 @rnDefaultDecl@ uses the `global name function' to create a new set
 584 of default declarations in which local names have been replaced by
 585 their original names, reporting any unknown names.
 586
 587 \begin{code}
 588 rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
 589
 590 rnDefaultDecl [] = returnRn []
 591 rnDefaultDecl [DefaultDecl tys src_loc]
 592   = pushSrcLocRn src_loc $
 593     mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
 594     returnRn [DefaultDecl tys' src_loc]
 595 rnDefaultDecl defs@(d:ds)
 596   = addErrRn (dupDefaultDeclErr defs) `thenRn_`
 597     rnDefaultDecl [d]
 598 \end{code}
 599
 600 %*************************************************************************
 601 %*                                                                      *
 602 \subsection{Fixity declarations}
 603 %*                                                                      *
 604 %*************************************************************************
 605
 606 \begin{code}
 607 rnFixes :: [RdrNameFixityDecl]  -> RnM s [RenamedFixityDecl]
 608
 609 rnFixes fixities
 610   = getSrcLocRn `thenRn` \ src_loc ->
 611     let
 612         (_, dup_fixes) = removeDups cmp_fix fixities
 613         cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2
 614
 615         rn_fixity fix@(InfixL name i)
 616           = rn_fixity_pieces InfixL name i fix
 617         rn_fixity fix@(InfixR name i)
 618           = rn_fixity_pieces InfixR name i fix
 619         rn_fixity fix@(InfixN name i)
 620           = rn_fixity_pieces InfixN name i fix
 621
 622         rn_fixity_pieces mk_fixity name i fix
 623           = getRnEnv `thenRn` \ env ->
 624               case lookupGlobalRnEnv env name of
 625                 Just res | isLocallyDefined res || opt_CompilingGhcInternals
 626                   -- the opt_CompilingGhcInternals thing is a *HACK* to get (:)'s
 627                   -- fixity decl to go through.  It has a builtin name, which
 628                   -- doesn't respond to isLocallyDefined...  sigh.
 629                   -> returnRn (Just (mk_fixity res i))
 630                 _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
 631     in
 632     mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
 633     mapRn rn_fixity fixities                              `thenRn` \ fixes_maybe ->
 634     returnRn (catMaybes fixes_maybe)
 635 \end{code}
 636
 637 %*********************************************************
 638 %*                                                      *
 639 \subsection{Support code to rename types}
 640 %*                                                      *
 641 %*********************************************************
 642
 643 \begin{code}
 644 rnPolyType :: TyVarNamesEnv
 645            -> RdrNamePolyType
 646            -> RnM_Fixes s RenamedPolyType
 647
 648 rnPolyType tv_env (HsForAllTy tvs ctxt ty)
 649   = rn_poly_help tv_env tvs ctxt ty
 650
 651 rnPolyType tv_env (HsPreForAllTy ctxt ty)
 652   = rn_poly_help tv_env forall_tyvars ctxt ty
 653   where
 654     mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
 655     forall_tyvars    = {-
 656                        pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
 657                        pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
 658                        -}
 659                        mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
 660
 661 ------------
 662 rn_poly_help :: TyVarNamesEnv
 663              -> [RdrName]
 664              -> RdrNameContext
 665              -> RdrNameMonoType
 666              -> RnM_Fixes s RenamedPolyType
 667
 668 rn_poly_help tv_env tyvars ctxt ty
 669   = {-
 670     pprTrace "rnPolyType:"
 671         (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
 672                 ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
 673                 ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
 674                 ppStr ";ty=", ppr PprShowAll ty]) $
 675     -}
 676     getSrcLocRn                         `thenRn` \ src_loc ->
 677     mkTyVarNamesEnv src_loc tyvars      `thenRn` \ (tv_env1, new_tyvars) ->
 678     let
 679         tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
 680     in
 681     rnContext tv_env2 src_loc ctxt      `thenRn` \ new_ctxt ->
 682     rnMonoType tv_env2 ty               `thenRn` \ new_ty ->
 683     returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
 684 \end{code}
 685
 686 \begin{code}
 687 rnMonoType :: TyVarNamesEnv
 688            -> RdrNameMonoType
 689            -> RnM_Fixes s RenamedMonoType
 690
 691 rnMonoType tv_env (MonoTyVar tyvar)
 692   = lookupTyVarName tv_env tyvar        `thenRn` \ tyvar' ->
 693     returnRn (MonoTyVar tyvar')
 694
 695 rnMonoType tv_env (MonoListTy ty)
 696   = rnMonoType tv_env ty        `thenRn` \ ty' ->
 697     returnRn (MonoListTy ty')
 698
 699 rnMonoType tv_env (MonoFunTy ty1 ty2)
 700   = andRn MonoFunTy (rnMonoType tv_env ty1)
 701                     (rnMonoType tv_env ty2)
 702
 703 rnMonoType  tv_env (MonoTupleTy tys)
 704   = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
 705     returnRn (MonoTupleTy tys')
 706
 707 rnMonoType tv_env (MonoTyApp name tys)
 708   = let
 709         lookup_fn = if isLexVarId (getLocalName name)
 710                     then lookupTyVarName tv_env
 711                     else lookupTyCon
 712     in
 713     lookup_fn name                      `thenRn` \ name' ->
 714     mapRn (rnMonoType tv_env) tys       `thenRn` \ tys' ->
 715     returnRn (MonoTyApp name' tys')
 716 \end{code}
 717
 718 \begin{code}
 719 rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext
 720
 721 rnContext tv_env locn ctxt
 722   = mapRn rn_ctxt ctxt  `thenRn` \ result ->
 723     let
 724         (_, dup_asserts) = removeDups cmp_assert result
 725     in
 726     -- If this isn't an error, then it ought to be:
 727     mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_`
 728     returnRn result
 729   where
 730     rn_ctxt (clas, tyvar)
 731       = lookupClass clas             `thenRn` \ clas_name ->
 732         lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
 733         returnRn (clas_name, tyvar_name)
 734
 735     cmp_assert (c1,tv1) (c2,tv2)
 736       = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2)
 737 \end{code}
 738
 739
 740 \begin{code}
 741 dupNameExportWarn locn names@((n,_):_)
 742   = addShortWarnLocLine locn $ \ sty ->
 743     ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]
 744
 745 dupLocalsExportErr locn locals@((str,_):_)
 746   = addErrLoc locn "exported names have same local name" $ \ sty ->
 747     ppInterleave ppSP (map (pprNonSym sty . snd) locals)
 748
 749 classOpExportErr op locn
 750   = addShortErrLocLine locn $ \ sty ->
 751     ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with its class"]
 752
 753 fieldExportErr op locn
 754   = addShortErrLocLine locn $ \ sty ->
 755     ppBesides [ppStr "field name `", ppr sty op, ppStr "' can only be exported with its data type"]
 756
 757 synAllExportErr is_error syn locn
 758   = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn $ \ sty ->
 759     ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]
 760
 761 withExportErr str rn has rns locn
 762   = addErrLoc locn "" $ \ sty ->
 763     ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"],
 764                ppCat [ppStr "    expected:", ppInterleave ppComma (map (ppr sty) has)],
 765                ppCat [ppStr "    found:   ", ppInterleave ppComma (map (ppr sty) rns)] ]
 766
 767 importAllErr rn locn
 768   = addShortErrLocLine locn $ \ sty ->
 769     ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]
 770
 771 badModExportErr mod locn
 772   = addShortErrLocLine locn $ \ sty ->
 773     ppCat [ ppStr "unknown module in export list: module", ppPStr mod]
 774
 775 emptyModExportWarn locn mod
 776   = addShortWarnLocLine locn $ \ sty ->
 777     ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]
 778
 779 dupModExportWarn locn mods@(mod:_)
 780   = addShortWarnLocLine locn $ \ sty ->
 781     ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]
 782
 783 derivingNonStdClassErr clas locn
 784   = addShortErrLocLine locn $ \ sty ->
 785     ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
 786
 787 dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
 788   = ppAboves (item1 : map dup_item dup_things)
 789   where
 790     item1
 791       = addShortErrLocLine locn1 (\ sty ->
 792         ppStr "multiple default declarations") sty
 793
 794     dup_item (DefaultDecl _ locn)
 795       = addShortErrLocLine locn (\ sty ->
 796         ppStr "here was another default declaration") sty
 797
 798 undefinedFixityDeclErr locn decl
 799   = addErrLoc locn "fixity declaration for unknown operator" $ \ sty ->
 800     ppr sty decl
 801
 802 dupFixityDeclErr locn dups
 803   = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty ->
 804     ppAboves (map (ppr sty) dups)
 805
 806 classTyVarNotInOpTyErr clas_tyvar sig locn
 807   = addShortErrLocLine locn $ \ sty ->
 808     ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
 809          4 (ppr sty sig)
 810
 811 classTyVarInOpCtxtErr clas_tyvar sig locn
 812   = addShortErrLocLine locn $ \ sty ->
 813     ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"])
 814          4 (ppr sty sig)
 815
 816 dupClassAssertWarn ctxt locn dups
 817   = addShortWarnLocLine locn $ \ sty ->
 818     ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
 819          4 (ppr sty ctxt)
 820 \end{code}