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