X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=d650c01154f00c428bcd39381f7896eeff5f6f25;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=dd5be0c783d74d4fe349299be7be2f8fdcc80930;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index dd5be0c..d650c01 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -8,8 +8,9 @@ module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where -import Ubiq -import RnLoop -- *check* the RnPass/RnExpr/RnBinds loop-breaking +IMP_Ubiq() +IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking +IMPORT_1_3(List(partition)) import HsSyn import HsPragmas @@ -17,25 +18,28 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnBinds ( rnTopBinds, rnMethodBinds ) -import RnUtils ( lookupGlobalRnEnv, lubExportFlag ) +import RnUtils ( getLocalsFromRnEnv, lookupGlobalRnEnv, lubExportFlag ) import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList ) import Class ( derivableClassKeys ) -import ErrUtils ( addErrLoc, addShortErrLocLine ) +import CmdLineOpts ( opt_CompilingGhcInternals ) +import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine ) import FiniteMap ( emptyFM, lookupFM, addListToFM_C ) +import Id ( isDataCon, GenId{-instance NamedThing-} ) import ListSetOps ( unionLists, minusList ) import Maybes ( maybeToBool, catMaybes ) -import Name ( Name, isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), - nameImportFlag, RdrName, pprNonSym ) -import Outputable -- ToDo:rm -import PprStyle -- ToDo:rm -import PrelInfo ( consDataCon ) +import Name ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), + nameImportFlag, RdrName, pprNonSym, Name ) +import Outputable ( Outputable(..){-instances-} ) +--import PprStyle -- ToDo:rm import Pretty import SrcLoc ( SrcLoc ) +import TyCon ( tyConDataCons, TyCon{-instance NamedThing-} ) import Unique ( Unique ) -import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, lookupUFM, eltsUFM ) -import UniqSet ( UniqSet(..) ) -import Util ( isIn, isn'tIn, sortLt, removeDups, cmpPString, assertPanic, pprTrace{-ToDo:rm-} ) +import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM ) +import UniqSet ( SYN_IE(UniqSet) ) +import Util ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString, + panic, assertPanic{- , pprTrace ToDo:rm-} ) \end{code} rnSource `renames' the source module and export list. @@ -53,12 +57,14 @@ Checks the (..) etc constraints in the export list. \begin{code} -rnSource :: [Module] +rnSource :: [Module] -- imported modules -> Bag (Module,RnName) -- unqualified imports from module -> Bag RenamedFixityDecl -- fixity info for imported names -> RdrNameHsModule -> RnM s (RenamedHsModule, Name -> ExportFlag, -- export info + ([(Name, ExportFlag)], -- export module X stuff + [(Name, ExportFlag)]), Bag (RnName, RdrName)) -- occurrence info rnSource imp_mods unqual_imps imp_fixes @@ -69,13 +75,13 @@ rnSource imp_mods unqual_imps imp_fixes = pushSrcLocRn src_loc $ - rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn -> + rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ (exported_fn, module_dotdots) -> rnFixes fixes `thenRn` \ src_fixes -> let all_fixes = src_fixes ++ bagToList imp_fixes all_fixes_fm = listToUFM (map pair_name all_fixes) - pair_name inf = (nameFixDecl inf, inf) + pair_name inf = (fixDeclName inf, inf) in setExtraRn all_fixes_fm $ @@ -95,7 +101,7 @@ rnSource imp_mods unqual_imps imp_fixes new_ty_decls new_specdata_sigs new_class_decls new_inst_decls new_specinst_sigs new_defaults new_binds [] src_loc, - exported_fn, + exported_fn, module_dotdots, occ_info ) where @@ -114,75 +120,135 @@ rnSource imp_mods unqual_imps imp_fixes rnExports :: [Module] -> Bag (Module,RnName) -> Maybe [RdrNameIE] - -> RnM s (Name -> ExportFlag) + -> RnM s (Name -> ExportFlag, -- main export-flag fun + ([(Name,ExportFlag)], -- info about "module X" exports + [(Name,ExportFlag)]) + ) rnExports mods unqual_imps Nothing - = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported) + = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported + , ([], []) + ) rnExports mods unqual_imps (Just exps) - = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) -> + = getModuleRn `thenRn` \ this_mod -> + getRnEnv `thenRn` \ rn_env -> + mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) -> let - exp_names = bagToList (unionManyBags exp_bags) + (tc_bags, val_bags) = unzip exp_bags + tc_names = bagToList (unionManyBags tc_bags) + val_names = bagToList (unionManyBags val_bags) exp_mods = catMaybes mod_maybes -- Warn for duplicate names and modules - (uniq_exp_names, dup_names) = removeDups cmp_fst exp_names - (uniq_exp_mods, dup_mods) = removeDups cmpPString exp_mods + (_, dup_tc_names) = removeDups cmp_fst tc_names + (_, dup_val_names) = removeDups cmp_fst val_names cmp_fst (x,_) (y,_) = x `cmp` y - -- Build finite map of exported names to export flag - exp_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst uniq_exp_names) - (exp_map1, empty_mods) = foldl add_mod_names (exp_map0, []) uniq_exp_mods - - mod_fm = addListToFM_C unionBags emptyFM - [(mod, unitBag (getName rn, nameImportFlag (getName rn))) - | (mod,rn) <- bagToList unqual_imps, isRnDecl rn] + (uniq_mods, dup_mods) = removeDups cmpPString exp_mods + (expmods_this, expmods_imps) = partition (== this_mod) uniq_mods + + -- Get names for "module This_Mod" export + (this_tcs, this_vals) + = if null expmods_this + then ([], []) + else getLocalsFromRnEnv rn_env + + -- Get names for exported imported modules + (mod_tcs, mod_vals, empty_mods) + = case mapAndUnzip3 get_mod_names expmods_imps of + (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys) + + (unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps) + + get_mod_names mod + = --pprTrace "get_mod_names" (ppAboves [ppPStr mod, interpp'SP PprDebug (map fst tcs), interpp'SP PprDebug (map fst vals)]) $ + (tcs, vals, empty_mod) + where + tcs = [(getName rn, nameImportFlag (getName rn)) + | (mod',rn) <- unqual_tcs, mod == mod'] + vals = [(getName rn, nameImportFlag (getName rn)) + | (mod',rn) <- unqual_vals, mod == mod', fun_looking rn] + empty_mod = if null tcs && null vals + then Just mod + else Nothing + + -- fun_looking: must avoid class ops and data constructors + -- and record fieldnames + fun_looking (RnName _) = True + fun_looking (WiredInId i) = not (isDataCon i) + fun_looking _ = False - add_mod_names (exp_map, empty) mod - = case lookupFM mod_fm mod of - Nothing -> (exp_map, mod:empty) - Just mod_names -> (addListToUFM_C lub_expflag exp_map (map pair_fst (bagToList mod_names)), empty) - - pair_fst p@(f,_) = (f,p) + -- Build finite map of exported names to export flag + tc_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names) + tc_map1 = addListToUFM_C lub_expflag tc_map0 (map pair_fst mod_tcs) + tc_map = addListToUFM_C lub_expflag tc_map1 (map (pair_fst.exp_all) this_tcs) + + val_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst val_names) + val_map1 = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals) + val_map = addListToUFM_C lub_expflag val_map1 (map (pair_fst.exp_all) this_vals) + + pair_fst pr@(n,_) = (n,pr) + exp_all rn = (getName rn, ExportAll) lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2) -- Check for exporting of duplicate local names - exp_locals = [(getLocalName n, n) | (n,_) <- eltsUFM exp_map1] - (_, dup_locals) = removeDups cmp_local exp_locals + tc_locals = [(getLocalName n, n) | (n,_) <- eltsUFM tc_map] + val_locals = [(getLocalName n, n) | (n,_) <- eltsUFM val_map] + (_, dup_tc_locals) = removeDups cmp_local tc_locals + (_, dup_val_locals) = removeDups cmp_local val_locals cmp_local (x,_) (y,_) = x `cmpPString` y -- Build export flag function - exp_fn n = case lookupUFM exp_map1 n of - Nothing -> NotExported - Just (_,flag) -> flag + final_exp_map = plusUFM tc_map val_map + exp_fn n = case lookupUFM final_exp_map n of + Nothing -> NotExported + Just (_,flag) -> flag in - getSrcLocRn `thenRn` \ src_loc -> - mapRn (addWarnRn . dupNameExportWarn src_loc) dup_names `thenRn_` - mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_` - mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_` - mapRn (addErrRn . dupLocalsExportErr src_loc) dup_locals `thenRn_` - returnRn exp_fn - + getSrcLocRn `thenRn` \ src_loc -> + mapRn (addWarnRn . dupNameExportWarn src_loc) dup_tc_names `thenRn_` + mapRn (addWarnRn . dupNameExportWarn src_loc) dup_val_names `thenRn_` + mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_` + mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_` + mapRn (addErrRn . dupLocalsExportErr src_loc) dup_tc_locals `thenRn_` + mapRn (addErrRn . dupLocalsExportErr src_loc) dup_val_locals `thenRn_` + returnRn (exp_fn, (mod_vals, mod_tcs)) + +------------------------------------ +-- rename an "IE" in the export list + +rnIE :: [Module] -- this module and all the (directly?) imported modules + -> RdrNameIE + -> RnM s ( + Maybe Module, -- Just m => a "module X" export item + (Bag (Name, ExportFlag), -- Exported tycons/classes + Bag (Name, ExportFlag))) -- Exported values rnIE mods (IEVar name) = lookupValue name `thenRn` \ rn -> checkIEVar rn `thenRn` \ exps -> returnRn (Nothing, exps) where - checkIEVar (RnName n) = returnRn (unitBag (n,ExportAll)) + checkIEVar (RnName n) = returnRn (emptyBag, unitBag (n,ExportAll)) + checkIEVar (WiredInId i) = returnRn (emptyBag, unitBag (getName i, ExportAll)) checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn emptyBag (classOpExportErr rn src_loc) - checkIEVar rn = returnRn emptyBag + failButContinueRn (emptyBag, emptyBag) (classOpExportErr rn src_loc) + checkIEVar rn@(RnField _ _) = getSrcLocRn `thenRn` \ src_loc -> + failButContinueRn (emptyBag, emptyBag) (fieldExportErr rn src_loc) + checkIEVar rn = --pprTrace "rnIE:IEVar:panic? ToDo?:" (ppr PprDebug rn) $ + returnRn (emptyBag, emptyBag) rnIE mods (IEThingAbs name) = lookupTyConOrClass name `thenRn` \ rn -> checkIEAbs rn `thenRn` \ exps -> returnRn (Nothing, exps) where - checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs)) - checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs)) - checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs)) - checkIEAbs rn = returnRn emptyBag + checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs), emptyBag) + checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs), emptyBag) + checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs), emptyBag) + checkIEAbs (WiredInTyCon t) = returnRn (unitBag (getName t,ExportAbs), emptyBag) + checkIEAbs rn = --pprTrace "rnIE:IEAbs:panic? ToDo?:" (ppr PprDebug rn) $ + returnRn (emptyBag, emptyBag) rnIE mods (IEThingAll name) = lookupTyConOrClass name `thenRn` \ rn -> @@ -190,12 +256,24 @@ rnIE mods (IEThingAll name) checkImportAll rn `thenRn_` returnRn (Nothing, exps) where - checkIEAll (RnData n cons fields) = returnRn (exp_all n `consBag` listToBag (map exp_all cons) - `unionBags` listToBag (map exp_all fields)) - checkIEAll (RnClass n ops) = returnRn (exp_all n `consBag` listToBag (map exp_all ops)) - checkIEAll rn@(RnSyn _) = getSrcLocRn `thenRn` \ src_loc -> - warnAndContinueRn emptyBag (synAllExportErr rn src_loc) - checkIEAll rn = returnRn emptyBag + checkIEAll (RnData n cons fields) + = returnRn (unitBag (exp_all n), + listToBag (map exp_all cons) `unionBags` listToBag (map exp_all fields)) + + checkIEAll (WiredInTyCon t) + = returnRn (unitBag (exp_all (getName t)), listToBag (map exp_all cons)) + where + cons = map getName (tyConDataCons t) + + checkIEAll (RnClass n ops) + = returnRn (unitBag (exp_all n), listToBag (map exp_all ops)) + checkIEAll rn@(RnSyn n) + = getSrcLocRn `thenRn` \ src_loc -> + warnAndContinueRn (unitBag (n, ExportAbs), emptyBag) + (synAllExportErr False{-warning-} rn src_loc) + + checkIEAll rn = --pprTrace "rnIE:IEAll:panic? ToDo?:" (ppr PprDebug rn) $ + returnRn (emptyBag, emptyBag) exp_all n = (n, ExportAll) @@ -208,19 +286,23 @@ rnIE mods (IEThingWith name names) where checkIEWith rn@(RnData n cons fields) rns | same_names (cons++fields) rns - = returnRn (consBag (exp_all n) (listToBag (map exp_all cons))) + = returnRn (unitBag (exp_all n), listToBag (map exp_all cons) + `unionBags` + listToBag (map exp_all fields)) | otherwise - = rnWithErr "constructrs (and fields)" rn (cons++fields) rns + = rnWithErr "constructors (and fields)" rn (cons++fields) rns checkIEWith rn@(RnClass n ops) rns | same_names ops rns - = returnRn (consBag (exp_all n) (listToBag (map exp_all ops))) + = returnRn (unitBag (exp_all n), listToBag (map exp_all ops)) | otherwise = rnWithErr "class ops" rn ops rns checkIEWith rn@(RnSyn _) rns = getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn emptyBag (synAllExportErr rn src_loc) + failButContinueRn (emptyBag, emptyBag) (synAllExportErr True{-error-} rn src_loc) + checkIEWith (WiredInTyCon _) rns = panic "RnSource.rnIE:checkIEWith:WiredInTyCon:ToDo (boring)" checkIEWith rn rns - = returnRn emptyBag + = --pprTrace "rnIE:IEWith:panic? ToDo?:" (ppr PprDebug rn) $ + returnRn (emptyBag, emptyBag) exp_all n = (n, ExportAll) @@ -230,14 +312,14 @@ rnIE mods (IEThingWith name names) rnWithErr str rn has rns = getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn emptyBag (withExportErr str rn has rns src_loc) + failButContinueRn (emptyBag, emptyBag) (withExportErr str rn has rns src_loc) rnIE mods (IEModuleContents mod) | isIn "rnIE:IEModule" mod mods - = returnRn (Just mod, emptyBag) + = returnRn (Just mod, (emptyBag, emptyBag)) | otherwise = getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn (Nothing,emptyBag) (badModExportErr mod src_loc) + failButContinueRn (Nothing, (emptyBag, emptyBag)) (badModExportErr mod src_loc) checkImportAll rn @@ -272,7 +354,7 @@ rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc) = pushSrcLocRn src_loc $ lookupTyCon tycon `thenRn` \ tycon' -> mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') -> - rnContext tv_env context `thenRn` \ context' -> + rnContext tv_env src_loc context `thenRn` \ context' -> rnConDecls tv_env condecls `thenRn` \ condecls' -> rn_derivs tycon' src_loc derivings `thenRn` \ derivings' -> ASSERT(isNoDataPragmas pragmas) @@ -282,7 +364,7 @@ rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc) = pushSrcLocRn src_loc $ lookupTyCon tycon `thenRn` \ tycon' -> mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') -> - rnContext tv_env context `thenRn` \ context' -> + rnContext tv_env src_loc context `thenRn` \ context' -> rnConDecls tv_env condecl `thenRn` \ condecl' -> rn_derivs tycon' src_loc derivings `thenRn` \ derivings' -> ASSERT(isNoDataPragmas pragmas) @@ -305,7 +387,7 @@ rn_derivs tycon2 locn (Just ds) rn_deriv tycon2 locn clas = lookupClass clas `thenRn` \ clas_name -> addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys) - (derivingNonStdClassErr clas locn) + (derivingNonStdClassErr clas_name locn) `thenRn_` returnRn clas_name where @@ -403,27 +485,34 @@ rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc) = pushSrcLocRn src_loc $ - mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) -> - rnContext tv_env context `thenRn` \ context' -> - lookupClass cname `thenRn` \ cname' -> - mapRn (rn_op cname' tv_env) sigs `thenRn` \ sigs' -> - rnMethodBinds cname' mbinds `thenRn` \ mbinds' -> + mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) -> + rnContext tv_env src_loc context `thenRn` \ context' -> + lookupClass cname `thenRn` \ cname' -> + mapRn (rn_op cname' tyvar' tv_env) sigs `thenRn` \ sigs' -> + rnMethodBinds cname' mbinds `thenRn` \ mbinds' -> ASSERT(isNoClassPragmas pragmas) returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc) where - rn_op clas tv_env (ClassOpSig op ty pragmas locn) + rn_op clas clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn) = pushSrcLocRn locn $ lookupClassOp clas op `thenRn` \ op_name -> rnPolyType tv_env ty `thenRn` \ new_ty -> - -{- -*** Please check here that tyvar' appears in new_ty *** -*** (used to be in tcClassSig, but it's better here) -*** not_elem = isn'tIn "tcClassSigs" -*** -- Check that the class type variable is mentioned -*** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty) -*** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_` --} + let + (HsForAllTy tvs ctxt op_ty) = new_ty + ctxt_tvs = extractCtxtTyNames ctxt + op_tvs = extractMonoTyNames is_tyvar_name op_ty + in + -- check that class tyvar appears in op_ty + ( if isIn "rn_op" clas_tyvar op_tvs + then returnRn () + else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn) + ) `thenRn_` + + -- check that class tyvar *doesn't* appear in the sig's context + ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs + then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn) + else returnRn () + ) `thenRn_` ASSERT(isNoClassOpPragmas pragmas) returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn) @@ -544,7 +633,7 @@ rnFixes fixities = getSrcLocRn `thenRn` \ src_loc -> let (_, dup_fixes) = removeDups cmp_fix fixities - cmp_fix fix1 fix2 = nameFixDecl fix1 `cmp` nameFixDecl fix2 + cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2 rn_fixity fix@(InfixL name i) = rn_fixity_pieces InfixL name i fix @@ -556,17 +645,16 @@ rnFixes fixities rn_fixity_pieces mk_fixity name i fix = getRnEnv `thenRn` \ env -> case lookupGlobalRnEnv env name of - Just res | isLocallyDefined res + Just res | isLocallyDefined res -- || opt_CompilingGhcInternals + -- the opt_CompilingGhcInternals thing is a *HACK* to get (:)'s + -- fixity decl to go through. It has a builtin name, which + -- doesn't respond to isLocallyDefined... sigh. -> returnRn (Just (mk_fixity res i)) _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix) in mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_` mapRn rn_fixity fixities `thenRn` \ fixes_maybe -> returnRn (catMaybes fixes_maybe) - -nameFixDecl (InfixL name i) = name -nameFixDecl (InfixR name i) = name -nameFixDecl (InfixN name i) = name \end{code} %********************************************************* @@ -608,13 +696,13 @@ rn_poly_help tv_env tyvars ctxt ty ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt), ppStr ";ty=", ppr PprShowAll ty]) $ -} - getSrcLocRn `thenRn` \ src_loc -> - mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) -> + getSrcLocRn `thenRn` \ src_loc -> + mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) -> let tv_env2 = catTyVarNamesEnvs tv_env1 tv_env in - rnContext tv_env2 ctxt `thenRn` \ new_ctxt -> - rnMonoType tv_env2 ty `thenRn` \ new_ty -> + rnContext tv_env2 src_loc ctxt `thenRn` \ new_ctxt -> + rnMonoType tv_env2 ty `thenRn` \ new_ty -> returnRn (HsForAllTy new_tyvars new_ctxt new_ty) \end{code} @@ -651,75 +739,105 @@ rnMonoType tv_env (MonoTyApp name tys) \end{code} \begin{code} -rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext +rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext -rnContext tv_env ctxt - = mapRn rn_ctxt ctxt +rnContext tv_env locn ctxt + = mapRn rn_ctxt ctxt `thenRn` \ result -> + let + (_, dup_asserts) = removeDups cmp_assert result + in + -- If this isn't an error, then it ought to be: + mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_` + returnRn result where rn_ctxt (clas, tyvar) - = lookupClass clas `thenRn` \ clas_name -> - lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name -> - returnRn (clas_name, tyvar_name) + = lookupClass clas `thenRn` \ clas_name -> + lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name -> + returnRn (clas_name, tyvar_name) + + cmp_assert (c1,tv1) (c2,tv2) + = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2) \end{code} \begin{code} dupNameExportWarn locn names@((n,_):_) - = addShortErrLocLine locn (\ sty -> - ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]) + = addShortWarnLocLine locn $ \ sty -> + ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"] dupLocalsExportErr locn locals@((str,_):_) - = addErrLoc locn "exported names have same local name" (\ sty -> - ppInterleave ppSP (map (pprNonSym sty . snd) locals)) + = addErrLoc locn "exported names have same local name" $ \ sty -> + ppInterleave ppSP (map (pprNonSym sty . snd) locals) classOpExportErr op locn - = addShortErrLocLine locn (\ sty -> - ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"]) + = addShortErrLocLine locn $ \ sty -> + ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with its class"] -synAllExportErr syn locn - = addShortErrLocLine locn (\ sty -> - ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]) +fieldExportErr op locn + = addShortErrLocLine locn $ \ sty -> + ppBesides [ppStr "field name `", ppr sty op, ppStr "' can only be exported with its data type"] + +synAllExportErr is_error syn locn + = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn $ \ sty -> + ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"] withExportErr str rn has rns locn - = addErrLoc locn "" (\ sty -> - ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in export list for `", ppr sty rn, ppStr "'"], + = addErrLoc locn "" $ \ sty -> + ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"], ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)], - ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ]) + ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ] importAllErr rn locn - = addShortErrLocLine locn (\ sty -> - ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]) + = addShortErrLocLine locn $ \ sty -> + ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"] badModExportErr mod locn - = addShortErrLocLine locn (\ sty -> - ppCat [ ppStr "unknown module in export list:", ppPStr mod]) - -dupModExportWarn locn mods@(mod:_) - = addShortErrLocLine locn (\ sty -> - ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]) + = addShortErrLocLine locn $ \ sty -> + ppCat [ ppStr "unknown module in export list: module", ppPStr mod] emptyModExportWarn locn mod - = addShortErrLocLine locn (\ sty -> - ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]) + = addShortWarnLocLine locn $ \ sty -> + ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"] + +dupModExportWarn locn mods@(mod:_) + = addShortWarnLocLine locn $ \ sty -> + ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"] derivingNonStdClassErr clas locn - = addShortErrLocLine locn (\ sty -> - ppCat [ppStr "non-standard class in deriving:", ppr sty clas]) + = addShortErrLocLine locn $ \ sty -> + ppCat [ppStr "non-standard class in deriving:", ppr sty clas] dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty = ppAboves (item1 : map dup_item dup_things) where item1 - = addShortErrLocLine locn1 (\ sty -> ppStr "multiple default declarations") sty + = addShortErrLocLine locn1 (\ sty -> + ppStr "multiple default declarations") sty dup_item (DefaultDecl _ locn) - = addShortErrLocLine locn (\ sty -> ppStr "here was another default declaration") sty + = addShortErrLocLine locn (\ sty -> + ppStr "here was another default declaration") sty undefinedFixityDeclErr locn decl - = addErrLoc locn "fixity declaration for unknown operator" (\ sty -> - ppr sty decl) + = addErrLoc locn "fixity declaration for unknown operator" $ \ sty -> + ppr sty decl dupFixityDeclErr locn dups - = addErrLoc locn "multiple fixity declarations for same operator" (\ sty -> - ppAboves (map (ppr sty) dups)) + = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty -> + ppAboves (map (ppr sty) dups) + +classTyVarNotInOpTyErr clas_tyvar sig locn + = addShortErrLocLine locn $ \ sty -> + ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"]) + 4 (ppr sty sig) + +classTyVarInOpCtxtErr clas_tyvar sig locn + = addShortErrLocLine locn $ \ sty -> + ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"]) + 4 (ppr sty sig) + +dupClassAssertWarn ctxt locn dups + = addShortWarnLocLine locn $ \ sty -> + ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"]) + 4 (ppr sty ctxt) \end{code}