Commit c05fddde authored by elaforge's avatar elaforge Committed by Ben Gamari
Browse files

Rearrange error msgs and add section markers (Trac #11014).

This puts the "Relevant bindings" section at the end.

It uses a TcErrors.Report Monoid to divide messages by importance and
then mappends them together.  This is not the most efficient way since
there are various intermediate Reports and list appends, but it probably
doesn't matter since error messages shouldn't get that large, and are
usually prepended.  In practice, everything is `important` except
`relevantBindings`, which is `supplementary`.

ErrMsg's errMsgShortDoc and errMsgExtraInfo were extracted into ErrDoc,
which has important, context, and suppelementary fields.  Each of those
three sections is marked with a bullet character, '•' on unicode
terminals and '*' on ascii terminals.  Since this breaks tons of tests,
I also modified testlib.normalise_errmsg to strip out '•'s.

--- Additional notes:

To avoid prepending * to an empty doc, I needed to filter empty docs.
This seemed less error-prone than trying to modify everyone who produces
SDoc to instead produce Maybe SDoc.  So I added `Outputable.isEmpty`.
Unfortunately it needs a DynFlags, which is kind of bogus, but otherwise
I think I'd need another Empty case for SDoc, and then it couldn't be a
newtype any more.

ErrMsg's errMsgShortString is only used by the Show instance, which is
in turn only used by Show HscTypes.SourceError, which is in turn only
needed for the Exception instance.  So it's probably possible to get rid
of errMsgShortString, but that would a be an unrelated cleanup.

Fixes #11014.

Test Plan: see above

Reviewers: austin, simonpj, thomie, bgamari

Reviewed By: thomie, bgamari

Subscribers: simonpj, nomeata, thomie

Differential Revision: https://phabricator.haskell.org/D1427

GHC Trac Issues: #11014
parent f09f2470
......@@ -25,7 +25,7 @@ import Util
import DynFlags
import FastString
import Outputable
import Outputable hiding ( isEmpty )
import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
......
......@@ -10,14 +10,15 @@ module ErrUtils (
MsgDoc,
Validity(..), andValid, allValid, isValid, getInvalids,
ErrMsg, WarnMsg, Severity(..),
ErrMsg, ErrDoc, errDoc, WarnMsg, Severity(..),
Messages, ErrorMessages, WarningMessages,
errMsgSpan, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
errMsgSpan, errMsgContext,
mkLocMessage, pprMessageBag, pprErrMsgBagWithLoc,
pprLocErrMsg, makeIntoWarning,
errorsFound, emptyMessages, isEmptyMessages,
mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
mkPlainWarnMsg,
printBagOfErrors,
warnIsErrorMsg, mkLongWarnMsg,
......@@ -94,13 +95,28 @@ type ErrorMessages = Bag ErrMsg
data ErrMsg = ErrMsg {
errMsgSpan :: SrcSpan,
errMsgContext :: PrintUnqualified,
errMsgShortDoc :: MsgDoc, -- errMsgShort* should always
errMsgShortString :: String, -- contain the same text
errMsgExtraInfo :: MsgDoc,
errMsgDoc :: ErrDoc,
-- | This has the same text as errDocImportant . errMsgDoc.
errMsgShortString :: String,
errMsgSeverity :: Severity
}
-- The SrcSpan is used for sorting errors into line-number order
-- | Categorise error msgs by their importance. This is so each section can
-- be rendered visually distinct. See Note [Error report] for where these come
-- from.
data ErrDoc = ErrDoc {
-- | Primary error msg.
errDocImportant :: [MsgDoc],
-- | Context e.g. \"In the second argument of ...\".
_errDocContext :: [MsgDoc],
-- | Supplementary information, e.g. \"Relevant bindings include ...\".
_errDocSupplementary :: [MsgDoc]
}
errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc
errDoc = ErrDoc
type WarnMsg = ErrMsg
data Severity
......@@ -156,13 +172,17 @@ makeIntoWarning err = err { errMsgSeverity = SevWarning }
-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.
mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
mk_err_msg dflags sev locn print_unqual msg extra
= ErrMsg { errMsgSpan = locn, errMsgContext = print_unqual
, errMsgShortDoc = msg , errMsgShortString = showSDoc dflags msg
, errMsgExtraInfo = extra
mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg dflags sev locn print_unqual doc
= ErrMsg { errMsgSpan = locn
, errMsgContext = print_unqual
, errMsgDoc = doc
, errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
, errMsgSeverity = sev }
mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mkErrDoc dflags = mk_err_msg dflags SevError
mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
-- A long (multi-line) error message
mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
......@@ -170,12 +190,12 @@ mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgD
mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
-- Variant that doesn't care about qualified/unqualified names
mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual msg extra
mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual msg empty
mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify msg empty
mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual msg extra
mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual msg empty
mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify msg empty
mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra])
mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [])
mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] [])
mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra])
mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [])
mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
----------------
emptyMessages :: Messages
......@@ -194,34 +214,42 @@ errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
= sequence_ [ let style = mkErrStyle dflags unqual
in log_action dflags dflags sev s style (d $$ e)
in log_action dflags dflags sev s style (formatErrDoc dflags doc)
| ErrMsg { errMsgSpan = s,
errMsgShortDoc = d,
errMsgDoc = doc,
errMsgSeverity = sev,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sortMsgBag (Just dflags)
bag_of_errors
]
bag_of_errors ]
formatErrDoc :: DynFlags -> ErrDoc -> SDoc
formatErrDoc dflags (ErrDoc important context supplementary)
= case msgs of
[msg] -> vcat msg
_ -> vcat $ map starred msgs
where
msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
[important, context, supplementary]
starred = (bullet<+>) . vcat
bullet = text $ if DynFlags.useUnicode dflags then "•" else "*"
pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]
pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]
pprLocErrMsg :: ErrMsg -> SDoc
pprLocErrMsg (ErrMsg { errMsgSpan = s
, errMsgShortDoc = d
, errMsgExtraInfo = e
, errMsgDoc = doc
, errMsgSeverity = sev
, errMsgContext = unqual })
= sdocWithDynFlags $ \dflags ->
withPprStyle (mkErrStyle dflags unqual) $
mkLocMessage sev s (d $$ e)
mkLocMessage sev s (formatErrDoc dflags doc)
sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
sortMsgBag dflags = sortBy (maybeFlip $ comparing errMsgSpan) . bagToList
where maybeFlip :: (a -> a -> b) -> (a -> a -> b)
maybeFlip
| fromMaybe False (fmap reverseErrors dflags) = flip
| otherwise = id
| otherwise = id
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
......
......@@ -35,7 +35,7 @@ import VarSet
import VarEnv
import NameSet
import Bag
import ErrUtils ( ErrMsg, pprLocErrMsg )
import ErrUtils ( ErrMsg, errDoc, pprLocErrMsg )
import BasicTypes
import Util
import FastString
......@@ -49,6 +49,11 @@ import Control.Monad ( when )
import Data.Maybe
import Data.List ( partition, mapAccumL, nub, sortBy )
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid ( Monoid, mempty, mappend, mconcat )
#endif
{-
************************************************************************
* *
......@@ -179,6 +184,38 @@ report_unsolved mb_binds_var err_as_warn type_errors expr_holes type_holes wante
-- Internal functions
--------------------------------------------
-- | An error Report collects messages categorised by their importance.
-- See Note [Error report] for details.
data Report
= Report { report_important :: [SDoc]
, report_relevant_bindings :: [SDoc]
}
{- Note [Error report]
The idea is that error msgs are divided into three parts: the main msg, the
context block (\"In the second argument of ...\"), and the relevant bindings
block, which are displayed in that order, with a mark to divide them. The
idea is that the main msg ('report_important') varies depending on the error
in question, but context and relevant bindings are always the same, which
should simplify visual parsing.
The context is added when the the Report is passed off to 'mkErrorReport'.
Unfortunately, unlike the context, the relevant bindings are added in
multiple places so they have to be in the Report.
-}
instance Monoid Report where
mempty = Report [] []
mappend (Report a1 b1) (Report a2 b2) = Report (a1 ++ a2) (b1 ++ b2)
-- | Put a doc into the important msgs block.
important :: SDoc -> Report
important doc = mempty { report_important = [doc] }
-- | Put a doc into the relevant bindings block.
relevant_bindings :: SDoc -> Report
relevant_bindings doc = mempty { report_relevant_bindings = [doc] }
data TypeErrorChoice -- What to do for type errors found by the type checker
= TypeError -- A type error aborts compilation with an error message
| TypeWarn -- A type error is deferred to runtime, plus a compile-time warning
......@@ -278,13 +315,13 @@ warnRedundantConstraints ctxt env info ev_vars
-- to the error context, which is a bit tiresome
addErrCtxt (ptext (sLit "In") <+> ppr info) $
do { env <- getLclEnv
; msg <- mkErrorMsg ctxt env doc
; msg <- mkErrorReport ctxt env (important doc)
; reportWarning msg }
| otherwise -- But for InstSkol there already *is* a surrounding
-- "In the instance declaration for Eq [a]" context
-- and we don't want to say it twice. Seems a bit ad-hoc
= do { msg <- mkErrorMsg ctxt env doc
= do { msg <- mkErrorReport ctxt env (important doc)
; reportWarning msg }
where
doc = ptext (sLit "Redundant constraint") <> plural redundant_evs <> colon
......@@ -445,6 +482,7 @@ mkUserTypeErrorReporter ctxt
mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
$ important
$ pprUserTypeErrorTy
$ case getUserTypeErrorMsg ct of
Just (_,msg) -> msg
......@@ -612,14 +650,16 @@ pprWithArising (ct:cts)
ppr_one ct' = hang (parens (pprType (ctPred ct')))
2 (pprCtLoc (ctLoc ct'))
mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
mkErrorMsgFromCt ctxt ct msg
= mkErrorMsg ctxt (ctLocEnv (ctLoc ct)) msg
mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
mkErrorMsgFromCt ctxt ct report
= mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report
mkErrorMsg :: ReportErrCtxt -> TcLclEnv -> SDoc -> TcM ErrMsg
mkErrorMsg ctxt tcl_env msg
= do { err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
; mkLongErrAt (RealSrcSpan (tcl_loc tcl_env)) msg err_info }
mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
mkErrorReport ctxt tcl_env (Report important relevant_bindings)
= do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env))
(errDoc important [context] relevant_bindings)
}
type UserGiven = ([EvVar], SkolemInfo, Bool, RealSrcSpan)
......@@ -713,7 +753,8 @@ mkIrredErr ctxt cts
= do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
; let orig = ctOrigin ct1
msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)
; mkErrorMsgFromCt ctxt ct1 (msg $$ binds_msg) }
; mkErrorMsgFromCt ctxt ct1 $
important msg `mappend` relevant_bindings binds_msg }
where
(ct1:_) = cts
......@@ -725,14 +766,16 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort })
= do { dflags <- getDynFlags
; rdr_env <- getGlobalRdrEnv
; impInfo <- getImports
; mkLongErrAt (RealSrcSpan (tcl_loc lcl_env)) out_of_scope_msg
(unknownNameSuggestions dflags rdr_env
(tcl_rdr lcl_env) impInfo (mkRdrUnqual occ)) }
; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env)) $
errDoc [out_of_scope_msg] []
[unknownNameSuggestions dflags rdr_env
(tcl_rdr lcl_env) impInfo (mkRdrUnqual occ)] }
| otherwise -- Explicit holes, like "_" or "_f"
= do { (ctxt, binds_doc, ct) <- relevantBindings False ctxt ct
= do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct
-- The 'False' means "don't filter the bindings"; see Trac #8191
; mkErrorMsgFromCt ctxt ct (hole_msg $$ binds_doc) }
; mkErrorMsgFromCt ctxt ct $
important hole_msg `mappend` relevant_bindings binds_msg }
where
ct_loc = ctLoc ct
......@@ -786,7 +829,7 @@ mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
----------------
mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
mkIPErr ctxt cts
= do { (ctxt, bind_msg, ct1) <- relevantBindings True ctxt ct1
= do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
; let orig = ctOrigin ct1
preds = map ctPred cts
givens = getUserGivens ctxt
......@@ -797,7 +840,8 @@ mkIPErr ctxt cts
| otherwise
= couldNotDeduce givens (preds, orig)
; mkErrorMsgFromCt ctxt ct1 (msg $$ bind_msg) }
; mkErrorMsgFromCt ctxt ct1 $
important msg `mappend` relevant_bindings binds_msg }
where
(ct1:_) = cts
......@@ -840,7 +884,8 @@ mkEqErr1 ctxt ct
= do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
; let (given_loc, given_msg) = mk_given (ctLoc ct) (cec_encl ctxt)
; dflags <- getDynFlags
; mkEqErr_help dflags ctxt (given_msg $$ binds_msg)
; let report = important given_msg `mappend` relevant_bindings binds_msg
; mkEqErr_help dflags ctxt report
(setCtLoc ct given_loc) -- Note [Inaccessible code]
Nothing ty1 ty2 }
......@@ -855,8 +900,9 @@ mkEqErr1 ctxt ct
ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
; dflags <- getDynFlags
; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct))
; mkEqErr_help dflags ctxt (wanted_msg $$ coercible_msg $$ binds_msg)
ct is_oriented ty1 ty2 }
; let report = mconcat [important wanted_msg, important coercible_msg,
relevant_bindings binds_msg]
; mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2 }
where
(ty1, ty2) = getEqPredTys (ctPred ct)
......@@ -961,61 +1007,67 @@ mkRoleSigs ty1 ty2
roles = tyConRoles tc
-}
mkEqErr_help :: DynFlags -> ReportErrCtxt -> SDoc
mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report
-> Ct
-> Maybe SwapFlag -- Nothing <=> not sure
-> TcType -> TcType -> TcM ErrMsg
mkEqErr_help dflags ctxt extra ct oriented ty1 ty2
| Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
| Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt extra ct swapped tv2 ty1
| otherwise = reportEqErr ctxt extra ct oriented ty1 ty2
mkEqErr_help dflags ctxt report ct oriented ty1 ty2
| Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2
| Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr dflags ctxt report ct swapped tv2 ty1
| otherwise = reportEqErr ctxt report ct oriented ty1 ty2
where
swapped = fmap flipSwap oriented
reportEqErr :: ReportErrCtxt -> SDoc
reportEqErr :: ReportErrCtxt -> Report
-> Ct
-> Maybe SwapFlag -- Nothing <=> not sure
-> TcType -> TcType -> TcM ErrMsg
reportEqErr ctxt extra1 ct oriented ty1 ty2
= do { let extra2 = mkEqInfoMsg ct ty1 ty2
; mkErrorMsgFromCt ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
, extra2, extra1]) }
reportEqErr ctxt report ct oriented ty1 ty2
= mkErrorMsgFromCt ctxt ct (mconcat [misMatch, eqInfo, report])
where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2
eqInfo = important $ mkEqInfoMsg ct ty1 ty2
mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct
mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> Report -> Ct
-> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
-- tv1 and ty2 are already tidied
mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
mkTyVarEqErr dflags ctxt report ct oriented tv1 ty2
| isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar, or else the thing would
-- be oriented the other way round;
-- see TcCanonical.canEqTyVarTyVar
|| isSigTyVar tv1 && not (isTyVarTy ty2)
|| ctEqRel ct == ReprEq && not (isTyVarUnderDatatype tv1 ty2)
-- the cases below don't really apply to ReprEq (except occurs check)
= mkErrorMsgFromCt ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
, extraTyVarInfo ctxt tv1 ty2
, extra ])
= mkErrorMsgFromCt ctxt ct $ mconcat
[ important $ misMatchOrCND ctxt ct oriented ty1 ty2
, important $ extraTyVarInfo ctxt tv1 ty2
, report
]
-- So tv is a meta tyvar (or started that way before we
-- generalised it). So presumably it is an *untouchable*
-- meta tyvar or a SigTv, else it'd have been unified
| not (k2 `tcIsSubKind` k1) -- Kind error
= mkErrorMsgFromCt ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
= mkErrorMsgFromCt ctxt ct $
(important $ kindErrorMsg (mkTyVarTy tv1) ty2) `mappend` report
| OC_Occurs <- occ_check_expand
, ctEqRel ct == NomEq || isTyVarUnderDatatype tv1 ty2
-- See Note [Occurs check error] in TcCanonical
= do { let occCheckMsg = addArising (ctOrigin ct) $
= do { let occCheckMsg = important $ addArising (ctOrigin ct) $
hang (text "Occurs check: cannot construct the infinite type:")
2 (sep [ppr ty1, char '~', ppr ty2])
extra2 = mkEqInfoMsg ct ty1 ty2
; mkErrorMsgFromCt ctxt ct (occCheckMsg $$ extra2 $$ extra) }
extra2 = important $ mkEqInfoMsg ct ty1 ty2
; mkErrorMsgFromCt ctxt ct $ mconcat [occCheckMsg, extra2, report] }
| OC_Forall <- occ_check_expand
= do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable")
<+> quotes (ppr tv1)
, hang (ptext (sLit "with a type involving foralls:")) 2 (ppr ty2)
, nest 2 (ptext (sLit "GHC doesn't yet support impredicative polymorphism")) ]
; mkErrorMsgFromCt ctxt ct msg }
-- Unlike the other reports, this discards the old 'report_important'
-- instead of augmenting it. This is because the details are not likely
-- to be helpful since this is just an unimplemented feature.
; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } }
-- If the immediately-enclosing implication has 'tv' a skolem, and
-- we know by now its an InferSkol kind of skolem, then presumably
......@@ -1024,46 +1076,50 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
| (implic:_) <- cec_encl ctxt
, Implic { ic_skols = skols } <- implic
, tv1 `elem` skols
= mkErrorMsgFromCt ctxt ct (vcat [ misMatchMsg ct oriented ty1 ty2
, extraTyVarInfo ctxt tv1 ty2
, extra ])
= mkErrorMsgFromCt ctxt ct $ mconcat
[ important $ misMatchMsg ct oriented ty1 ty2
, important $ extraTyVarInfo ctxt tv1 ty2
, report
]
-- Check for skolem escape
| (implic:_) <- cec_encl ctxt -- Get the innermost context
, Implic { ic_env = env, ic_skols = skols, ic_info = skol_info } <- implic
, let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) skols
, not (null esc_skols)
= do { let msg = misMatchMsg ct oriented ty1 ty2
= do { let msg = important $ misMatchMsg ct oriented ty1 ty2
esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols
<+> pprQuotedList esc_skols
, ptext (sLit "would escape") <+>
if isSingleton esc_skols then ptext (sLit "its scope")
else ptext (sLit "their scope") ]
tv_extra = vcat [ nest 2 $ esc_doc
tv_extra = important $
vcat [ nest 2 $ esc_doc
, sep [ (if isSingleton esc_skols
then ptext (sLit "This (rigid, skolem) type variable is")
else ptext (sLit "These (rigid, skolem) type variables are"))
<+> ptext (sLit "bound by")
, nest 2 $ ppr skol_info
, nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ]
; mkErrorMsgFromCt ctxt ct (msg $$ tv_extra $$ extra) }
; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }
-- Nastiest case: attempt to unify an untouchable variable
| (implic:_) <- cec_encl ctxt -- Get the innermost context
, Implic { ic_env = env, ic_given = given, ic_info = skol_info } <- implic
= do { let msg = misMatchMsg ct oriented ty1 ty2
tclvl_extra
= nest 2 $
= do { let msg = important $ misMatchMsg ct oriented ty1 ty2
tclvl_extra = important $
nest 2 $
sep [ quotes (ppr tv1) <+> ptext (sLit "is untouchable")
, nest 2 $ ptext (sLit "inside the constraints:") <+> pprEvVarTheta given
, nest 2 $ ptext (sLit "bound by") <+> ppr skol_info
, nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ]
tv_extra = extraTyVarInfo ctxt tv1 ty2
add_sig = suggestAddSig ctxt ty1 ty2
; mkErrorMsgFromCt ctxt ct (vcat [msg, tclvl_extra, tv_extra, add_sig, extra]) }
tv_extra = important $ extraTyVarInfo ctxt tv1 ty2
add_sig = important $ suggestAddSig ctxt ty1 ty2
; mkErrorMsgFromCt ctxt ct $ mconcat
[msg, tclvl_extra, tv_extra, add_sig, report] }
| otherwise
= reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2
= reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2
-- This *can* happen (Trac #6123, and test T2627b)
-- Consider an ambiguous top-level constraint (a ~ F a)
-- Not an occurs check, because F is a type function.
......@@ -1497,7 +1553,7 @@ mkDictErr ctxt cts
-- have the same source-location origin, to try avoid a cascade
-- of error from one location
; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
; mkErrorMsgFromCt ctxt ct1 err }
; mkErrorMsgFromCt ctxt ct1 (important err) }
where
no_givens = null (getUserGivens ctxt)
......
......@@ -753,6 +753,12 @@ mkLongErrAt loc msg extra
printer <- getPrintUnqualified dflags ;
return $ mkLongErrMsg dflags loc printer msg extra }
mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
mkErrDocAt loc errDoc
= do { dflags <- getDynFlags ;
printer <- getPrintUnqualified dflags ;
return $ mkErrDoc dflags loc printer errDoc }
addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
......@@ -769,7 +775,7 @@ reportError err
reportWarning :: ErrMsg -> TcRn ()
reportWarning err
= do { let warn = makeIntoWarning err
-- 'err' was build by mkLongErrMsg or something like that,
-- 'err' was built by mkLongErrMsg or something like that,
-- so it's of error severity. For a warning we downgrade
-- its severity to SevWarning
......@@ -1099,7 +1105,7 @@ mkErrInfo env ctxts
= go 0 env ctxts
where
go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
go _ _ [] = return Outputable.empty
go _ _ [] = return empty
go n env ((is_landmark, ctxt) : ctxts)
| is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
= do { (env', msg) <- ctxt env
......
......@@ -19,7 +19,7 @@ module Outputable (
docToSDoc,
interppSP, interpp'SP,
pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,
empty, nest,
empty, isEmpty, nest,
char,
text, ftext, ptext, ztext,
int, intWithCommas, integer, float, double, rational,
......@@ -301,8 +301,8 @@ pprDeeper d = SDoc $ \ctx -> case ctx of
runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))}
_ -> runSDoc d ctx
-- | Truncate a list that is longer than the current depth.
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
-- Truncate a list that list that is longer than the current depth
pprDeeperList f ds
| null ds = f []
| otherwise = SDoc work
......@@ -462,6 +462,10 @@ irrelevantNCols :: Int
-- Used for OneLineMode and LeftMode when number of cols isn't used
irrelevantNCols = 1
isEmpty :: DynFlags -> SDoc -> Bool
isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext
where dummySDocContext = initSDocContext dflags PprDebug
docToSDoc :: Doc -> SDoc
docToSDoc d = SDoc (\_ -> d)
......
# coding=utf8
#
# (c) Simon Marlow 2002
#
......@@ -1547,7 +1548,8 @@ def check_stderr_ok(name, way):
return compare_outputs(way, 'stderr',
join_normalisers(norm, getTestOpts().extra_errmsg_normaliser), \
expected_stderr_file, actual_stderr_file)
expected_stderr_file, actual_stderr_file,
whitespace_normaliser=normalise_whitespace)
def dump_stderr( name ):
print("Stderr:")
......@@ -1692,8 +1694,7 @@ def compare_outputs(way, kind, normaliser, expected_file, actual_file,
def normalise_whitespace( str ):
# Merge contiguous whitespace characters into a single space.
str = re.sub('[ \t\n]+', ' ', str)
return str.strip()
return ' '.join(w for w in str.split())
def normalise_callstacks(str):
def repl(matches):
......@@ -1722,6 +1723,11 @@ def normalise_errmsg( str ):
str = re.sub('ghc-stage[123]', 'ghc', str)
# Error messages simetimes contain integer implementation package
str = re.sub('integer-(gmp|simple)-[0-9.]+', 'integer-<IMPL>-<VERSION>', str)
# Also filter out bullet characters. This is because bullets are used to
# separate error sections, and tests shouldn't be sensitive to how the
# the division happens.
bullet = u'•'.encode('utf8')
str = str.replace(bullet, '')
return str
# normalise a .prof file, so that we can reasonably compare it against
......