diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs
index 0b2439b1f16cdf0e818e8e8de340f8c89ed5e87f..6962b92733d9d149414da6e4d33e79b54e4581ec 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 9c1503aa3ace6ffc432144877e6bd8c052ba59dc..5f286500c47f65e64ab1e0cb27ce39f3eff5a3f3 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 a538c76a8b990d5f2e68f853be4fd8bc7c636291..5b0205686768aca8230781c01b3b07d8d47fc95b 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 c531e0ea0bf22aa934768c62e65f5a915703d569..930b851bdc50003cd15c7721c4b9a69492505853 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 17153e1a39d1d246d0faf205e8effdd128c192db..9ac0d396f3cda046bcec541a4246fcb8d41a6443 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 dcf2934f7a9094882e0483033fc5c9700fbcad55..9281fa291e149889646d08f0f2969c4dc8dfbd9e 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 70d6b6b0a89cff4fa481f9f50295bb3c7250a38b..11d57749fcff4c29657a4aa25305b8cbe82689d4 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 176b3f7bc4744d89124fb406829d7bd7327d055f..07f2f5bb0d9f814cbc343e74f206ea43c49f9440 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 b7335939ff7e97f9d89c84ca2d91f6024693724c..2b91305d9b29abd2a4296268b9074a6e498b1540 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 b09252df9aaffd9961f84d8e08aa2fd0a2a6a0d8..9a70947814b784ea6fdaef4e97759e9bdba0983c 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 758258b2955a6efd4d6ad13a0b39ef2565d7c302..6fe697ba590b246f1c620306797232326e350e5b 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 09904ea2e69701d0bd09555801cf45b884433866..9bb8089f6aa990e7b63102fc0a32cd0800dc3ae5 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 10a07f3e592f78d15a6ee321e33df03e9f83be66..3f2eedbe026981b18fa7497f4a3558c7baf7243a 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 2a27a16aec252bba57c80514ab07aa09acb6a880..00104dbe2e901b30d279033e4df9654d26ecdd5e 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)