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.)
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
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,
hasMoreBoxityInfo
)
import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
-import ErrUtils ( ErrMsg )
import Outputable
infixr 9 `thenL`, `seqL`, `thenMaybeL`
\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
\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
| 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)
%************************************************************************
\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))
------------------------------------------------------
-- 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:",
------------------------------------------------------
-- 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:"))
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:"))
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:"),
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)]]
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 )
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
#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 )
deriving ()
pprDsWarnings :: DsWarnings -> SDoc
-pprDsWarnings warns = vcat (bagToList warns)
+pprDsWarnings warns = pprBagOfErrors warns
\end{code}
mkUnboxedTupleTy, unboxedTupleCon
)
import UniqSet
+import ErrUtils ( addErrLocHdrLine, dontAddErrLoc )
import Outputable
\end{code}
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
module ErrUtils (
ErrMsg, WarnMsg, Message,
addShortErrLocLine, addShortWarnLocLine,
+ addErrLocHdrLine,
dontAddErrLoc,
pprBagOfErrors, pprBagOfWarnings,
ghcExit,
#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}
import SrcLoc ( SrcLoc, incSrcLine, srcLocFile )
import Maybes ( MaybeErr(..) )
-import ErrUtils ( ErrMsg )
+import ErrUtils ( Message )
import Outputable
import FastString
\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
-----------------------------------------------------------------
-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]
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,
================ 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_`
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_`
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
import NameSet ( elemNameSet, emptyNameSet )
import Outputable
import Unique ( getUnique )
-import Util ( removeDups, equivClassesByUniq )
+import Util ( removeDups, equivClassesByUniq, sortLt )
import List ( nubBy )
\end{code}
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),
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
)
| 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
\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
\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
\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
else
((), errs)
-checkTys :: Type -> Type -> ErrMsg -> LintM ()
+checkTys :: Type -> Type -> Message -> LintM ()
checkTys ty1 ty2 msg loc scope errs
= if (ty1 == ty2)
then ((), 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:",
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:",
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:",
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],
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")
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}
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 )
\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])
import RnMonad ( RnNameSupply )
import Bag ( isEmptyBag )
-import ErrUtils ( ErrMsg,
+import ErrUtils ( Message,
pprBagOfErrors, dumpIfSet
)
import Id ( Id, idType )
= 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 [
import UniqSet ( UniqSet, emptyUniqSet,
unitUniqSet, unionUniqSets,
unionManyUniqSets, uniqSetToList )
-import ErrUtils ( ErrMsg )
+import ErrUtils ( Message )
import SrcLoc ( SrcLoc )
import TyCon ( TyCon )
import Unique ( Unique, Uniquable(..) )
\begin{code}
-typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> ErrMsg
+typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
typeCycleErr syn_cycles
= vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
projects / ghc-hetmet.git / commitdiff