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