Commit a6eede31 authored by sof's avatar sof
Browse files

[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.)
parent 35dff9ff
......@@ -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
......
......@@ -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)]]
......
......@@ -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
......
......@@ -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}
......@@ -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
......
......@@ -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}
......
......@@ -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]
......
......@@ -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
......
......@@ -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),
......
......@@ -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