From: sof Date: Mon, 18 Jan 1999 19:05:07 +0000 (+0000) Subject: [project @ 1999-01-18 19:04:55 by sof] X-Git-Tag: Approx_2487_patches~61 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=a6eede3173cee960884e732f40b0998cf84ae015;p=ghc-hetmet.git [project @ 1999-01-18 19:04:55 by sof] Print out warnings/errors in the order they occur in the source code. (Well...almost, warnings are sorted and printed out on a per-pass basis.) --- diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 0b2439b..6962b92 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -49,6 +49,19 @@ data SrcLoc FAST_INT | UnhelpfulSrcLoc FAST_STRING -- Just a general indication + +instance Ord SrcLoc where + compare NoSrcLoc NoSrcLoc = EQ + compare NoSrcLoc _ = GT + compare (UnhelpfulSrcLoc _) (UnhelpfulSrcLoc _) = EQ + compare (UnhelpfulSrcLoc _) _ = GT + compare _ NoSrcLoc = LT + compare _ (UnhelpfulSrcLoc _) = LT + compare (SrcLoc _ y1) (SrcLoc _ y2) = compare IBOX(y1) IBOX(y2) + +instance Eq SrcLoc where + (==) x y = compare x y == EQ + \end{code} Note that an entity might be imported via more than one route, and diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 9c1503a..5f28650 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -26,9 +26,10 @@ import VarSet import VarEnv ( mkVarEnv ) import Name ( isLocallyDefined, getSrcLoc ) import PprCore -import ErrUtils ( doIfSet, dumpIfSet, ghcExit ) +import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message, + ErrMsg, addErrLocHdrLine, pprBagOfErrors ) import PrimRep ( PrimRep(..) ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc ) import Type ( Type, Kind, tyVarsOfType, splitFunTy_maybe, mkPiType, mkTyVarTy, splitForAllTy_maybe, splitTyConApp_maybe, @@ -38,7 +39,6 @@ import Type ( Type, Kind, tyVarsOfType, hasMoreBoxityInfo ) import TyCon ( TyCon, isPrimTyCon, tyConDataCons ) -import ErrUtils ( ErrMsg ) import Outputable infixr 9 `thenL`, `seqL`, `thenMaybeL` @@ -484,13 +484,13 @@ data LintLocInfo \end{code} \begin{code} -initL :: LintM a -> Maybe ErrMsg +initL :: LintM a -> Maybe Message initL m = case (m [] emptyVarSet emptyBag) of { (_, errs) -> if isEmptyBag errs then Nothing else - Just (vcat (bagToList errs)) + Just (pprBagOfErrors errs) } returnL :: a -> LintM a @@ -519,18 +519,24 @@ mapL f (x:xs) \end{code} \begin{code} -checkL :: Bool -> ErrMsg -> LintM () +checkL :: Bool -> Message -> LintM () checkL True msg loc scope errs = (Nothing, errs) checkL False msg loc scope errs = (Nothing, addErr errs msg loc) -addErrL :: ErrMsg -> LintM a +addErrL :: Message -> LintM a addErrL msg loc scope errs = (Nothing, addErr errs msg loc) -addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg +addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg addErr errs_so_far msg locs = ASSERT (not (null locs)) - errs_so_far `snocBag` (hang (pprLoc (head locs)) 4 msg) + errs_so_far `snocBag` mk_msg msg + where + (loc, pref) = dumpLoc (head locs) + + mk_msg msg + | isNoSrcLoc loc = (loc, hang pref 4 msg) + | otherwise = addErrLocHdrLine loc pref msg addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m loc scope errs @@ -564,7 +570,7 @@ checkInScope loc_msg id loc scope errs | otherwise = (Nothing,errs) -checkTys :: Type -> Type -> ErrMsg -> LintM () +checkTys :: Type -> Type -> Message -> LintM () checkTys ty1 ty2 msg loc scope errs | ty1 == ty2 = (Nothing, errs) | otherwise = (Nothing, addErr errs msg loc) @@ -578,27 +584,23 @@ checkTys ty1 ty2 msg loc scope errs %************************************************************************ \begin{code} -pprLoc (RhsOf v) - = ppr (getSrcLoc v) <> colon <+> - brackets (ptext SLIT("RHS of") <+> pp_binders [v]) +dumpLoc (RhsOf v) + = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v])) -pprLoc (LambdaBodyOf b) - = ppr (getSrcLoc b) <> colon <+> - brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b) +dumpLoc (LambdaBodyOf b) + = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)) -pprLoc (BodyOfLetRec bs) - = ppr (getSrcLoc (head bs)) <> colon <+> - brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs) +dumpLoc (BodyOfLetRec bs) + = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)) -pprLoc (AnExpr e) - = text "In the expression:" <+> ppr e +dumpLoc (AnExpr e) + = (noSrcLoc, text "In the expression:" <+> ppr e) -pprLoc (CaseAlt (con, args, rhs)) - = text "In a case pattern:" <+> parens (ppr con <+> ppr args) +dumpLoc (CaseAlt (con, args, rhs)) + = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args)) -pprLoc (ImportedUnfolding locn) - = ppr locn <> colon <+> - brackets (ptext SLIT("in an imported unfolding")) +dumpLoc (ImportedUnfolding locn) + = (locn, brackets (ptext SLIT("in an imported unfolding"))) pp_binders :: [Id] -> SDoc pp_binders bs = sep (punctuate comma (map pp_binder bs)) @@ -611,47 +613,47 @@ pp_binder b = hsep [ppr b, dcolon, ppr (idType b)] ------------------------------------------------------ -- Messages for case expressions -mkConAppMsg :: CoreExpr -> ErrMsg +mkConAppMsg :: CoreExpr -> Message mkConAppMsg e = hang (text "Application of newtype constructor:") 4 (ppr e) -mkConAltMsg :: Con -> ErrMsg +mkConAltMsg :: Con -> Message mkConAltMsg con = text "PrimOp in case pattern:" <+> ppr con -mkNullAltsMsg :: CoreExpr -> ErrMsg +mkNullAltsMsg :: CoreExpr -> Message mkNullAltsMsg e = hang (text "Case expression with no alternatives:") 4 (ppr e) -mkDefaultArgsMsg :: [IdOrTyVar] -> ErrMsg +mkDefaultArgsMsg :: [IdOrTyVar] -> Message mkDefaultArgsMsg args = hang (text "DEFAULT case with binders") 4 (ppr args) -mkCaseAltMsg :: CoreExpr -> ErrMsg +mkCaseAltMsg :: CoreExpr -> Message mkCaseAltMsg e = hang (text "Type of case alternatives not the same:") 4 (ppr e) -mkScrutMsg :: Id -> Type -> ErrMsg +mkScrutMsg :: Id -> Type -> Message mkScrutMsg var scrut_ty = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, text "Result binder type:" <+> ppr (idType var), text "Scrutinee type:" <+> ppr scrut_ty] -badAltsMsg :: CoreExpr -> ErrMsg +badAltsMsg :: CoreExpr -> Message badAltsMsg e = hang (text "Case statement scrutinee is not a data type:") 4 (ppr e) -nonExhaustiveAltsMsg :: CoreExpr -> ErrMsg +nonExhaustiveAltsMsg :: CoreExpr -> Message nonExhaustiveAltsMsg e = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) -mkBadPatMsg :: Type -> Type -> ErrMsg +mkBadPatMsg :: Type -> Type -> Message mkBadPatMsg con_result_ty scrut_ty = vcat [ text "In a case alternative, pattern result type doesn't match scrutinee type:", @@ -662,13 +664,13 @@ mkBadPatMsg con_result_ty scrut_ty ------------------------------------------------------ -- Other error messages -mkAppMsg :: Type -> Type -> ErrMsg +mkAppMsg :: Type -> Type -> Message mkAppMsg fun arg = vcat [ptext SLIT("Argument value doesn't match argument type:"), hang (ptext SLIT("Fun type:")) 4 (ppr fun), hang (ptext SLIT("Arg type:")) 4 (ppr arg)] -mkKindErrMsg :: TyVar -> Type -> ErrMsg +mkKindErrMsg :: TyVar -> Type -> Message mkKindErrMsg tyvar arg_ty = vcat [ptext SLIT("Kinds don't match in type application:"), hang (ptext SLIT("Type variable:")) @@ -676,7 +678,7 @@ mkKindErrMsg tyvar arg_ty hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkTyAppMsg :: Type -> Type -> ErrMsg +mkTyAppMsg :: Type -> Type -> Message mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", hang (ptext SLIT("Exp type:")) @@ -684,7 +686,7 @@ mkTyAppMsg ty arg_ty hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkRhsMsg :: Id -> Type -> ErrMsg +mkRhsMsg :: Id -> Type -> Message mkRhsMsg binder ty = vcat [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"), @@ -692,14 +694,14 @@ mkRhsMsg binder ty hsep [ptext SLIT("Binder's type:"), ppr (idType binder)], hsep [ptext SLIT("Rhs type:"), ppr ty]] -mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg +mkRhsPrimMsg :: Id -> CoreExpr -> Message mkRhsPrimMsg binder rhs = vcat [hsep [ptext SLIT("The type of this binder is primitive:"), ppr binder], hsep [ptext SLIT("Binder's type:"), ppr (idType binder)] ] -mkUnboxedTupleMsg :: Id -> ErrMsg +mkUnboxedTupleMsg :: Id -> Message mkUnboxedTupleMsg binder = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder], hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]] diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index a538c76..5b02056 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -19,7 +19,7 @@ import DsUtils import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. import Name ( Module, moduleString ) -import Bag ( isEmptyBag ) +import Bag ( isEmptyBag, unionBags ) import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn ) import CoreLint ( beginPass, endPass ) import ErrUtils ( doIfSet ) @@ -51,7 +51,7 @@ deSugar us global_val_env mod_name all_binds fo_decls = do ds_binds = fi_binds ++ ds_binds' ++ fe_binds -- Display any warnings - doIfSet (not (isEmptyBag ds_warns)) + doIfSet (not (isEmptyBag (ds_warns `unionBags` ds_warns2))) (printErrs (pprDsWarnings ds_warns)) -- Lint result if necessary diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index c531e0e..930b851 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -26,7 +26,7 @@ module DsMonad ( #include "HsVersions.h" import Bag ( emptyBag, snocBag, bagToList, Bag ) -import ErrUtils ( WarnMsg ) +import ErrUtils ( WarnMsg, pprBagOfErrors ) import HsSyn ( OutPat ) import Id ( mkUserLocal, mkSysLocal, setIdUnique, Id ) import Name ( Module, Name, maybeWiredInIdName ) @@ -236,5 +236,5 @@ data DsMatchKind deriving () pprDsWarnings :: DsWarnings -> SDoc -pprDsWarnings warns = vcat (bagToList warns) +pprDsWarnings warns = pprBagOfErrors warns \end{code} diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 17153e1..9ac0d39 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -41,6 +41,7 @@ import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, mkUnboxedTupleTy, unboxedTupleCon ) import UniqSet +import ErrUtils ( addErrLocHdrLine, dontAddErrLoc ) import Outputable \end{code} @@ -93,32 +94,31 @@ dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn where warn | length qs > maximum_output - = hang (pp_context ctx (ptext SLIT("are overlapped"))) - 12 ((vcat $ map (ppr_eqn kind) (take maximum_output qs)) - $$ ptext SLIT("...")) + = pp_context ctx (ptext SLIT("are overlapped")) + 8 (vcat (map (ppr_eqn kind) (take maximum_output qs)) $$ + ptext SLIT("...")) | otherwise - = hang (pp_context ctx (ptext SLIT("are overlapped"))) - 12 (vcat $ map (ppr_eqn kind) qs) + = pp_context ctx (ptext SLIT("are overlapped")) + 8 (vcat $ map (ppr_eqn kind) qs) + dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn where warn | length pats > maximum_output - = hang (pp_context ctx (ptext SLIT("are non-exhaustive"))) - 12 (hang (ptext SLIT("Patterns not recognized:")) - 4 ((vcat $ map (ppr_incomplete_pats kind) (take maximum_output pats)) + = pp_context ctx (ptext SLIT("are non-exhaustive")) + 8 (hang (ptext SLIT("Patterns not recognized:")) + 4 ((vcat $ map (ppr_incomplete_pats kind) (take maximum_output pats)) $$ ptext SLIT("..."))) | otherwise - = hang (pp_context ctx (ptext SLIT("are non-exhaustive"))) - 12 (hang (ptext SLIT("Patterns not recognized:")) + = pp_context ctx (ptext SLIT("are non-exhaustive")) + 8 (hang (ptext SLIT("Patterns not recognized:")) 4 (vcat $ map (ppr_incomplete_pats kind) pats)) -pp_context NoMatchContext msg = ptext SLIT("Some match(es)") <+> msg +pp_context NoMatchContext msg ind rest_of_msg = dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg ind rest_of_msg) -pp_context (DsMatchContext kind pats loc) msg - = hang (hcat [ppr loc, ptext SLIT(": ")]) - 4 (hang message - 4 (pp_match kind pats)) +pp_context (DsMatchContext kind pats loc) msg ind rest_of_msg + = addErrLocHdrLine loc message (hang (pp_match kind pats) ind rest_of_msg) where message = ptext SLIT("Pattern match(es)") <+> msg diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index dcf2934..9281fa2 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -7,6 +7,7 @@ module ErrUtils ( ErrMsg, WarnMsg, Message, addShortErrLocLine, addShortWarnLocLine, + addErrLocHdrLine, dontAddErrLoc, pprBagOfErrors, pprBagOfWarnings, ghcExit, @@ -16,35 +17,57 @@ module ErrUtils ( #include "HsVersions.h" import Bag ( Bag, bagToList ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) +import Util ( sortLt ) import Outputable \end{code} \begin{code} -type ErrMsg = SDoc -type WarnMsg = SDoc +type MsgWithLoc = (SrcLoc, SDoc) + +type ErrMsg = MsgWithLoc +type WarnMsg = MsgWithLoc type Message = SDoc -addShortErrLocLine, addShortWarnLocLine :: SrcLoc -> ErrMsg -> ErrMsg +addShortErrLocLine :: SrcLoc -> Message -> ErrMsg +addErrLocHdrLine :: SrcLoc -> Message -> Message -> ErrMsg +addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg addShortErrLocLine locn rest_of_err_msg - = hang (ppr locn <> colon) - 4 rest_of_err_msg + = ( locn + , hang (ppr locn <> colon) + 4 rest_of_err_msg + ) + +addErrLocHdrLine locn hdr rest_of_err_msg + = ( locn + , hang (ppr locn <> colon<+> hdr) + 4 rest_of_err_msg + ) addShortWarnLocLine locn rest_of_err_msg - = hang (ppr locn <> ptext SLIT(": Warning:")) - 4 rest_of_err_msg + = ( locn + , hang (ppr locn <> ptext SLIT(": Warning:")) + 4 rest_of_err_msg + ) -dontAddErrLoc :: String -> ErrMsg -> ErrMsg +dontAddErrLoc :: String -> Message -> ErrMsg dontAddErrLoc title rest_of_err_msg - = hang (hcat [text title, char ':']) - 4 rest_of_err_msg + | null title = (noSrcLoc, rest_of_err_msg) + | otherwise = + ( noSrcLoc, hang (hcat [text title, char ':']) + 4 rest_of_err_msg ) pprBagOfErrors :: Bag ErrMsg -> SDoc pprBagOfErrors bag_of_errors - = vcat [space $$ p | p <- bagToList bag_of_errors] + = vcat [space $$ p | (_,p) <- sorted_errs ] + where + bag_ls = bagToList bag_of_errors + sorted_errs = sortLt occ'ed_before bag_ls + + occ'ed_before (a,_) (b,_) = LT == compare a b -pprBagOfWarnings :: Bag ErrMsg -> SDoc +pprBagOfWarnings :: Bag WarnMsg -> SDoc pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns \end{code} diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index 70d6b6b..11d5774 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -47,7 +47,7 @@ import BasicTypes ( NewOrData(..), IfaceFlavour(..) ) import SrcLoc ( SrcLoc, incSrcLine, srcLocFile ) import Maybes ( MaybeErr(..) ) -import ErrUtils ( ErrMsg ) +import ErrUtils ( Message ) import Outputable import FastString @@ -758,7 +758,7 @@ doDiscard inStr buf = \begin{code} type IfM a = StringBuffer -- Input string -> SrcLoc - -> MaybeErr a ErrMsg + -> MaybeErr a {-error-}Message returnIf :: a -> IfM a returnIf a s l = Succeeded a @@ -801,7 +801,7 @@ checkVersion mb@Nothing s l ----------------------------------------------------------------- -ifaceParseErr :: StringBuffer -> SrcLoc -> ErrMsg +ifaceParseErr :: StringBuffer -> SrcLoc -> Message ifaceParseErr s l = hsep [ppr l, ptext SLIT("Interface-file parse error;"), ptext SLIT("current input ="), text first_bit] diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 176b3f7..07f2f5b 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -30,7 +30,7 @@ import RnHsSyn ( RenamedFixitySig ) import BasicTypes ( Version, IfaceFlavour(..) ) import SrcLoc ( noSrcLoc ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, - pprBagOfErrors, ErrMsg, WarnMsg + pprBagOfErrors, ErrMsg, WarnMsg, Message ) import Name ( Module, Name, OccName, PrintUnqualified, isLocallyDefinedName, pprModule, @@ -586,7 +586,7 @@ mapMaybeRn f def (Just v) = f v ================ Errors and warnings ===================== \begin{code} -failWithRn :: a -> ErrMsg -> RnM s d a +failWithRn :: a -> Message -> RnM s d a failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down = readMutVarSST errs_var `thenSST` \ (warns,errs) -> writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_` @@ -594,7 +594,7 @@ failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down where err = addShortErrLocLine loc msg -warnWithRn :: a -> WarnMsg -> RnM s d a +warnWithRn :: a -> Message -> RnM s d a warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down = readMutVarSST errs_var `thenSST` \ (warns,errs) -> writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_` @@ -602,18 +602,18 @@ warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down where warn = addShortWarnLocLine loc msg -addErrRn :: ErrMsg -> RnM s d () +addErrRn :: Message -> RnM s d () addErrRn err = failWithRn () err -checkRn :: Bool -> ErrMsg -> RnM s d () -- Check that a condition is true +checkRn :: Bool -> Message -> RnM s d () -- Check that a condition is true checkRn False err = addErrRn err checkRn True err = returnRn () -warnCheckRn :: Bool -> ErrMsg -> RnM s d () -- Check that a condition is true +warnCheckRn :: Bool -> Message -> RnM s d () -- Check that a condition is true warnCheckRn False err = addWarnRn err warnCheckRn True err = returnRn () -addWarnRn :: WarnMsg -> RnM s d () +addWarnRn :: Message -> RnM s d () addWarnRn warn = warnWithRn () warn checkErrsRn :: RnM s d Bool -- True <=> no errors so far diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index b733593..2b91305 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -41,7 +41,7 @@ import SrcLoc ( SrcLoc ) import NameSet ( elemNameSet, emptyNameSet ) import Outputable import Unique ( getUnique ) -import Util ( removeDups, equivClassesByUniq ) +import Util ( removeDups, equivClassesByUniq, sortLt ) import List ( nubBy ) \end{code} @@ -660,9 +660,13 @@ exportClashErr occ_name ie1 ie2 dupDeclErr (n:ns) = vcat [ptext SLIT("Multiple declarations of") <+> quotes (ppr n), - nest 4 (vcat (map pp (n:ns)))] + nest 4 (vcat (map pp sorted_ns))] where - pp n = pprProvenance (getNameProvenance n) + sorted_ns = sortLt occ'ed_before (n:ns) + + occ'ed_before a b = LT == compare (getSrcLoc a) (getSrcLoc b) + + pp n = pprProvenance (getNameProvenance n) dupExportWarn occ_name ie1 ie2 = hsep [quotes (ppr occ_name), diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index b09252d..9a70947 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -17,7 +17,7 @@ import DataCon ( DataCon, dataConArgTys, dataConType ) import Const ( literalType, conType, Literal ) import Maybes ( catMaybes ) import Name ( isLocallyDefined, getSrcLoc ) -import ErrUtils ( ErrMsg ) +import ErrUtils ( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc ) import Type ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe, isUnLiftedType, isTyVarTy, Type ) @@ -260,16 +260,14 @@ data LintLocInfo | LambdaBodyOf [Id] -- The lambda-binder | BodyOfLetRec [Id] -- One of the binders -instance Outputable LintLocInfo where - ppr (RhsOf v) - = hcat [ppr (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders [v], char ']'] +dumpLoc (RhsOf v) = + (getSrcLoc v, ptext SLIT(" [RHS of ") <> pp_binders [v] <> char ']' ) +dumpLoc (LambdaBodyOf bs) = + (getSrcLoc (head bs), ptext SLIT(" [in body of lambda with binders ") <> pp_binders bs <> char ']' ) - ppr (LambdaBodyOf bs) - = hcat [ptext SLIT(": [in body of lambda with binders "), pp_binders bs, char ']'] +dumpLoc (BodyOfLetRec bs) = + (getSrcLoc (head bs), ptext SLIT(" [in body of letrec with binders ") <> pp_binders bs <> char ']' ) - ppr (BodyOfLetRec bs) - = hcat [ppr (getSrcLoc (head bs)), - ptext SLIT(": [in body of letrec with binders "), pp_binders bs, char ']'] pp_binders :: [Id] -> SDoc pp_binders bs @@ -280,13 +278,13 @@ pp_binders bs \end{code} \begin{code} -initL :: LintM a -> Maybe ErrMsg +initL :: LintM a -> Maybe Message initL m = case (m [] emptyVarSet emptyBag) of { (_, errs) -> if isEmptyBag errs then Nothing else - Just (foldBag ($$) (\ msg -> msg) empty errs) + Just (pprBagOfErrors errs) } returnL :: a -> LintM a @@ -331,20 +329,20 @@ mapMaybeL f (x:xs) \end{code} \begin{code} -checkL :: Bool -> ErrMsg -> LintM () +checkL :: Bool -> Message -> LintM () checkL True msg loc scope errs = ((), errs) checkL False msg loc scope errs = ((), addErr errs msg loc) -addErrL :: ErrMsg -> LintM () +addErrL :: Message -> LintM () addErrL msg loc scope errs = ((), addErr errs msg loc) -addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg +addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg addErr errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where - mk_msg (loc:_) = hang (ppr loc) 4 msg - mk_msg [] = msg + mk_msg (loc:_) = let (l,hdr) = dumpLoc loc in addErrLocHdrLine l hdr msg + mk_msg [] = dontAddErrLoc "" msg addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m loc scope errs @@ -370,10 +368,10 @@ addInScopeVars ids m loc scope errs \end{code} \begin{code} -checkFunApp :: Type -- The function type - -> [Type] -- The arg type(s) - -> ErrMsg -- Error messgae - -> LintM (Maybe Type) -- The result type +checkFunApp :: Type -- The function type + -> [Type] -- The arg type(s) + -> Message -- Error messgae + -> LintM (Maybe Type) -- The result type checkFunApp fun_ty arg_tys msg loc scope errs = cfa res_ty expected_arg_tys arg_tys @@ -408,7 +406,7 @@ checkInScope id loc scope errs else ((), errs) -checkTys :: Type -> Type -> ErrMsg -> LintM () +checkTys :: Type -> Type -> Message -> LintM () checkTys ty1 ty2 msg loc scope errs = if (ty1 == ty2) then ((), errs) @@ -416,52 +414,52 @@ checkTys ty1 ty2 msg loc scope errs \end{code} \begin{code} -mkCaseAltMsg :: StgCaseAlts -> ErrMsg +mkCaseAltMsg :: StgCaseAlts -> Message mkCaseAltMsg alts = ($$) (text "In some case alternatives, type of alternatives not all same:") -- LATER: (ppr alts) (panic "mkCaseAltMsg") -mkCaseDataConMsg :: StgExpr -> ErrMsg +mkCaseDataConMsg :: StgExpr -> Message mkCaseDataConMsg expr = ($$) (ptext SLIT("A case scrutinee not a type-constructor type:")) (ppr expr) -mkCaseAbstractMsg :: TyCon -> ErrMsg +mkCaseAbstractMsg :: TyCon -> Message mkCaseAbstractMsg tycon = ($$) (ptext SLIT("An algebraic case on an abstract type:")) (ppr tycon) -mkDefltMsg :: Id -> ErrMsg +mkDefltMsg :: Id -> Message mkDefltMsg bndr = ($$) (ptext SLIT("Binder of a case expression doesn't match type of scrutinee:")) (panic "mkDefltMsg") -mkFunAppMsg :: Type -> [Type] -> StgExpr -> ErrMsg +mkFunAppMsg :: Type -> [Type] -> StgExpr -> Message mkFunAppMsg fun_ty arg_tys expr = vcat [text "In a function application, function type doesn't match arg types:", hang (ptext SLIT("Function type:")) 4 (ppr fun_ty), hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys)), hang (ptext SLIT("Expression:")) 4 (ppr expr)] -mkRhsConMsg :: Type -> [Type] -> ErrMsg +mkRhsConMsg :: Type -> [Type] -> Message mkRhsConMsg fun_ty arg_tys = vcat [text "In a RHS constructor application, con type doesn't match arg types:", hang (ptext SLIT("Constructor type:")) 4 (ppr fun_ty), hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys))] -mkUnappTyMsg :: Id -> Type -> ErrMsg +mkUnappTyMsg :: Id -> Type -> Message mkUnappTyMsg var ty = vcat [text "Variable has a for-all type, but isn't applied to any types.", (<>) (ptext SLIT("Var: ")) (ppr var), (<>) (ptext SLIT("Its type: ")) (ppr ty)] -mkAlgAltMsg1 :: Type -> ErrMsg +mkAlgAltMsg1 :: Type -> Message mkAlgAltMsg1 ty = ($$) (text "In some case statement, type of scrutinee is not a data type:") (ppr ty) -mkAlgAltMsg2 :: Type -> DataCon -> ErrMsg +mkAlgAltMsg2 :: Type -> DataCon -> Message mkAlgAltMsg2 ty con = vcat [ text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", @@ -469,7 +467,7 @@ mkAlgAltMsg2 ty con ppr con ] -mkAlgAltMsg3 :: DataCon -> [Id] -> ErrMsg +mkAlgAltMsg3 :: DataCon -> [Id] -> Message mkAlgAltMsg3 con alts = vcat [ text "In some algebraic case alternative, number of arguments doesn't match constructor:", @@ -477,7 +475,7 @@ mkAlgAltMsg3 con alts ppr alts ] -mkAlgAltMsg4 :: Type -> Id -> ErrMsg +mkAlgAltMsg4 :: Type -> Id -> Message mkAlgAltMsg4 ty arg = vcat [ text "In some algebraic case alternative, type of argument doesn't match data constructor:", @@ -485,12 +483,12 @@ mkAlgAltMsg4 ty arg ppr arg ] -mkPrimAltMsg :: (Literal, StgExpr) -> ErrMsg +mkPrimAltMsg :: (Literal, StgExpr) -> Message mkPrimAltMsg alt = text "In a primitive case alternative, type of literal doesn't match type of scrutinee:" $$ ppr alt -mkRhsMsg :: Id -> Type -> ErrMsg +mkRhsMsg :: Id -> Type -> Message mkRhsMsg binder ty = vcat [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"), ppr binder], diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index 758258b..6fe697b 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -54,8 +54,9 @@ tc_defaults [DefaultDecl mono_tys locn] returnTc tau_tys -tc_defaults decls - = failWithTc (dupDefaultDeclErr decls) +tc_defaults decls@(DefaultDecl _ loc : _) = + tcAddSrcLoc loc $ + failWithTc (dupDefaultDeclErr decls) defaultDeclCtxt = ptext SLIT("when checking that each type in a default declaration") @@ -63,11 +64,8 @@ defaultDeclCtxt = ptext SLIT("when checking that each type in a default declara dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) - = vcat (item1 : map dup_item dup_things) + = hang (ptext SLIT("Multiple default declarations")) + 4 (vcat (map pp dup_things)) where - item1 - = addShortErrLocLine locn1 (ptext SLIT("multiple default declarations")) - - dup_item (DefaultDecl _ locn) - = addShortErrLocLine locn (ptext SLIT("here was another default declaration")) + pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn \end{code} diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 09904ea..9bb8089 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -29,7 +29,7 @@ import RnMonad ( RnNameSupply, import Bag ( Bag, emptyBag, unionBags, listToBag ) import Class ( classKey, Class ) -import ErrUtils ( ErrMsg, dumpIfSet ) +import ErrUtils ( dumpIfSet, Message ) import MkId ( mkDictFunId ) import Id ( mkVanillaId ) import DataCon ( dataConArgTys, isNullaryDataCon ) @@ -681,7 +681,7 @@ gen_taggery_Names inst_infos \end{code} \begin{code} -derivingThingErr :: FAST_STRING -> FAST_STRING -> TyCon -> ErrMsg +derivingThingErr :: FAST_STRING -> FAST_STRING -> TyCon -> Message derivingThingErr thing why tycon = hang (hsep [ptext SLIT("Can't make a derived instance of"), ptext thing]) diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 10a07f3..3f2eedb 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -44,7 +44,7 @@ import TcType ( TcType, typeToTcType, import RnMonad ( RnNameSupply ) import Bag ( isEmptyBag ) -import ErrUtils ( ErrMsg, +import ErrUtils ( Message, pprBagOfErrors, dumpIfSet ) import Id ( Id, idType ) @@ -312,7 +312,7 @@ noMainErr = hsep [ptext SLIT("Module"), quotes (pprModule mAIN), ptext SLIT("must include a definition for"), quotes (ppr main_NAME)] -mainTyMisMatch :: TcType -> TcType -> ErrMsg +mainTyMisMatch :: TcType -> TcType -> Message mainTyMisMatch expected actual = hang (hsep [ppr main_NAME, ptext SLIT("has the wrong type")]) 4 (vcat [ diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 2a27a16..00104db 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -40,7 +40,7 @@ import Maybes ( mapMaybe ) import UniqSet ( UniqSet, emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) -import ErrUtils ( ErrMsg ) +import ErrUtils ( Message ) import SrcLoc ( SrcLoc ) import TyCon ( TyCon ) import Unique ( Unique, Uniquable(..) ) @@ -336,7 +336,7 @@ set_to_bag set = listToBag (uniqSetToList set) \begin{code} -typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> ErrMsg +typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message typeCycleErr syn_cycles = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)