X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=64f64c5f48a901457248d21790c5b9bc9e1dc2d7;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=2d608011fae6960cb124e3b33ea5839cb10d7647;hpb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 2d60801..64f64c5 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -8,8 +8,8 @@ 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 HsSyn import HsPragmas @@ -21,20 +21,21 @@ import RnUtils ( lookupGlobalRnEnv, lubExportFlag ) import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList ) import Class ( derivableClassKeys ) -import ErrUtils ( addErrLoc, addShortErrLocLine ) +import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine ) import FiniteMap ( emptyFM, lookupFM, addListToFM_C ) 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 Outputable -- ToDo:rm +import PprStyle -- ToDo:rm import Pretty import SrcLoc ( SrcLoc ) import Unique ( Unique ) -import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, lookupUFM, eltsUFM ) +import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM ) import UniqSet ( UniqSet(..) ) -import Util ( isIn, isn'tIn, sortLt, removeDups, cmpPString, assertPanic, pprTrace{-ToDo:rm-} ) +import Util ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString, + assertPanic, pprTrace{-ToDo:rm-} ) \end{code} rnSource `renames' the source module and export list. @@ -52,7 +53,7 @@ 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 @@ -71,10 +72,10 @@ rnSource imp_mods unqual_imps imp_fixes rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn -> rnFixes fixes `thenRn` \ src_fixes -> let - pair_name inf = (nameFixDecl inf, inf) + all_fixes = src_fixes ++ bagToList imp_fixes + all_fixes_fm = listToUFM (map pair_name all_fixes) - all_fixes = src_fixes ++ bagToList imp_fixes - all_fixes_fm = listToUFM (map pair_name all_fixes) + pair_name inf = (fixDeclName inf, inf) in setExtraRn all_fixes_fm $ @@ -121,45 +122,67 @@ rnExports mods unqual_imps Nothing rnExports mods unqual_imps (Just exps) = 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 + (uniq_mods, dup_mods) = removeDups cmpPString exp_mods + + -- Get names for exported modules + + (mod_tcs, mod_vals, empty_mods) + = case mapAndUnzip3 get_mod_names uniq_mods of + (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys) + + (unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps) + + get_mod_names mod + = (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'] + empty_mod = if null tcs && null vals + then Just mod + else Nothing + -- 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] - - 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) + tc_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names) + tc_map = addListToUFM_C lub_expflag tc_map0 (map pair_fst mod_tcs) + + val_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst val_names) + val_map = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals) pair_fst p@(f,_) = (f,p) 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 + 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_` + 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 @@ -168,20 +191,20 @@ rnIE mods (IEVar name) checkIEVar rn `thenRn` \ exps -> returnRn (Nothing, exps) where - checkIEVar (RnName n) = returnRn (unitBag (n,ExportAll)) + checkIEVar (RnName n) = returnRn (emptyBag, unitBag (n,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 = 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 rn = returnRn (emptyBag, emptyBag) rnIE mods (IEThingAll name) = lookupTyConOrClass name `thenRn` \ rn -> @@ -189,12 +212,14 @@ 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 (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 = returnRn (emptyBag, emptyBag) exp_all n = (n, ExportAll) @@ -207,19 +232,21 @@ 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 rn rns - = returnRn emptyBag + = returnRn (emptyBag, emptyBag) exp_all n = (n, ExportAll) @@ -229,14 +256,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 @@ -271,7 +298,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) @@ -281,7 +308,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) @@ -304,7 +331,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 @@ -402,27 +429,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) @@ -543,7 +577,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 @@ -562,10 +596,6 @@ rnFixes fixities 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} %********************************************************* @@ -586,8 +616,10 @@ rnPolyType tv_env (HsPreForAllTy ctxt ty) = rn_poly_help tv_env forall_tyvars ctxt ty where mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty - forall_tyvars = --pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $ - --pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $ + forall_tyvars = {- + pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $ + pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $ + -} mentioned_tyvars `minusList` domTyVarNamesEnv tv_env ------------ @@ -598,18 +630,20 @@ rn_poly_help :: TyVarNamesEnv -> RnM_Fixes s RenamedPolyType rn_poly_help tv_env tyvars ctxt ty - = --pprTrace "rnPolyType:" (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env), - -- ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars), - -- 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) -> + = {- + pprTrace "rnPolyType:" + (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env), + ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars), + 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) -> 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} @@ -646,75 +680,101 @@ 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 class"] -synAllExportErr syn locn - = addShortErrLocLine locn (\ sty -> - ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]) +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}