summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2022-05-04 11:33:33 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-05-04 16:15:34 -0400
commit934a90dd6a34d2d1100506795d5f76cd20e2c599 (patch)
tree561c17ba9967acec60db33c2f050c87a3c183848 /compiler
parentd61f742876bdf2cd32e76f7bca389106ad99a316 (diff)
downloadhaskell-934a90dd6a34d2d1100506795d5f76cd20e2c599.tar.gz
Improve error reporting in generated code
Our error reporting in generated code (via desugaring before typechecking) only worked when the generated code was just a simple call. This commit makes it work in nested cases.
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Rename/Utils.hs12
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs69
-rw-r--r--compiler/GHC/Tc/Gen/App.hs44
-rw-r--r--compiler/GHC/Tc/Gen/Head.hs28
-rw-r--r--compiler/GHC/Tc/Types.hs5
-rw-r--r--compiler/GHC/Tc/Types.hs-boot3
6 files changed, 100 insertions, 61 deletions
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 597af3d778..be0b12a278 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -20,7 +20,7 @@ module GHC.Rename.Utils (
mkFieldEnv,
badQualBndrErr, typeAppErr, badFieldConErr,
wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,
- genHsIntegralLit, genHsTyLit,
+ genHsIntegralLit, genHsTyLit, genSimpleConPat,
newLocalBndrRn, newLocalBndrsRn,
@@ -676,3 +676,13 @@ genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)
genHsTyLit :: FastString -> HsType GhcRn
genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText
+
+genSimpleConPat :: Name -> [Name] -> LPat GhcRn
+-- The pattern (C x1 .. xn)
+genSimpleConPat con args
+ = wrapGenSpan $ ConPat { pat_con_ext = noExtField
+ , pat_con = wrapGenSpan con
+ , pat_args = PrefixCon [] (map genVarPat args) }
+
+genVarPat :: Name -> LPat GhcRn
+genVarPat n = wrapGenSpan $ VarPat noExtField (wrapGenSpan n)
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 86aac8d99d..e8cf8ce097 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -46,7 +46,7 @@ import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Types.Constraint
-import {-# SOURCE #-} GHC.Tc.Types (getLclEnvLoc)
+import {-# SOURCE #-} GHC.Tc.Types( getLclEnvLoc, lclEnvInGeneratedCode )
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Rank (Rank(..))
import GHC.Tc.Utils.TcType
@@ -1913,7 +1913,7 @@ pprTcSolverReportMsg _
, mismatch_item = item
, mismatch_ty1 = ty1
, mismatch_ty2 = ty2 })
- = addArising (errorItemOrigin item) msg
+ = addArising (errorItemCtLoc item) msg
where
msg
| (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) ||
@@ -1979,7 +1979,7 @@ pprTcSolverReportMsg ctxt
, teq_mismatch_expected = exp
, teq_mismatch_actual = act
, teq_mismatch_what = mb_thing })
- = addArising orig $ pprWithExplicitKindsWhen ppr_explicit_kinds msg
+ = addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg
where
msg
| isUnliftedTypeKind act, isLiftedTypeKind exp
@@ -2155,7 +2155,7 @@ pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) =
pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) =
let givens = getUserGivens ctxt
in if null givens
- then addArising (errorItemOrigin item) $
+ then addArising (errorItemCtLoc item) $
sep [ text "Unbound implicit parameter" <> plural preds
, nest 2 (pprParendTheta preds) ]
else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (item :| items) Nothing)
@@ -2171,9 +2171,9 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extr
where
main_msg
| null useful_givens
- = addArising orig (no_instance_msg <+> missing)
+ = addArising ct_loc (no_instance_msg <+> missing)
| otherwise
- = vcat (addArising orig (no_deduce_msg <+> missing)
+ = vcat (addArising ct_loc (no_deduce_msg <+> missing)
: pp_givens useful_givens)
supplementary = case mb_extra of
@@ -2181,7 +2181,8 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extr
-> Left []
Just (CND_Extra level ty1 ty2)
-> mk_supplementary_ea_msg ctxt level ty1 ty2 orig
- orig = errorItemOrigin item
+ ct_loc = errorItemCtLoc item
+ orig = ctLocOrigin ct_loc
wanteds = map errorItemPred (item:others)
no_instance_msg =
@@ -2203,7 +2204,7 @@ pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extr
pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt item ambigs) =
pprTcSolverReportInfo ctxt (Ambiguity True ambigs) <+>
- pprArising (errorItemOrigin item) $$
+ pprArising (errorItemCtLoc item) $$
text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item)
<+> text "from being solved."
pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})
@@ -2304,7 +2305,7 @@ pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics})
pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) =
vcat
- [ addArising orig $
+ [ addArising ct_loc $
(text "Overlapping instances for"
<+> pprType (mkClassPred clas tys))
, ppUnless (null matching_givens) $
@@ -2339,7 +2340,8 @@ pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item match
, text "when compiling the other instance declarations"]
])]
where
- orig = errorItemOrigin item
+ ct_loc = errorItemCtLoc item
+ orig = ctLocOrigin ct_loc
pred = errorItemPred item
(clas, tys) = getClassPredTys pred
tyCoVars = tyCoVarsOfTypesList tys
@@ -2363,7 +2365,7 @@ pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item match
&& isJust (tcMatchTys tys tys')
Nothing -> False
pprTcSolverReportMsg _ (UnsafeOverlap item matches unsafe_overlapped) =
- vcat [ addArising orig (text "Unsafe overlapping instances for"
+ vcat [ addArising ct_loc (text "Unsafe overlapping instances for"
<+> pprType (mkClassPred clas tys))
, sep [text "The matching instance is:",
nest 2 (pprInstance $ head matches)]
@@ -2375,7 +2377,7 @@ pprTcSolverReportMsg _ (UnsafeOverlap item matches unsafe_overlapped) =
]
]
where
- orig = errorItemOrigin item
+ ct_loc = errorItemCtLoc item
pred = errorItemPred item
(clas, tys) = getClassPredTys pred
@@ -2906,20 +2908,28 @@ levelString :: TypeOrKind -> String
levelString TypeLevel = "type"
levelString KindLevel = "kind"
-pprArising :: CtOrigin -> SDoc
+pprArising :: CtLoc -> SDoc
-- Used for the main, top-level error message
-- We've done special processing for TypeEq, KindEq, givens
-pprArising (TypeEqOrigin {}) = empty
-pprArising (KindEqOrigin {}) = empty
-pprArising (AmbiguityCheckOrigin {}) = empty -- the "In the ambiguity check" context
- -- is sufficient; this would just be
- -- repetitive
-pprArising orig | isGivenOrigin orig = empty
- | otherwise = pprCtOrigin orig
+pprArising ct_loc
+ | in_generated_code = empty -- See Note ["Arising from" messages in generated code]
+ | suppress_origin = empty
+ | otherwise = pprCtOrigin orig
+ where
+ orig = ctLocOrigin ct_loc
+ in_generated_code = lclEnvInGeneratedCode (ctLocEnv ct_loc)
+ suppress_origin
+ | isGivenOrigin orig = True
+ | otherwise = case orig of
+ TypeEqOrigin {} -> True -- We've done special processing
+ KindEqOrigin {} -> True -- for TypeEq, KindEq, givens
+ AmbiguityCheckOrigin {} -> True -- The "In the ambiguity check" context
+ -- is sufficient; more would be repetitive
+ _ -> False
-- Add the "arising from..." part to a message
-addArising :: CtOrigin -> SDoc -> SDoc
-addArising orig msg = hang msg 2 (pprArising orig)
+addArising :: CtLoc -> SDoc -> SDoc
+addArising ct_loc msg = hang msg 2 (pprArising ct_loc)
pprWithArising :: [Ct] -> SDoc
-- Print something like
@@ -2931,7 +2941,7 @@ pprWithArising []
= panic "pprWithArising"
pprWithArising (ct:cts)
| null cts
- = addArising (ctLocOrigin loc) (pprTheta [ctPred ct])
+ = addArising loc (pprTheta [ctPred ct])
| otherwise
= vcat (map ppr_one (ct:cts))
where
@@ -2939,6 +2949,19 @@ pprWithArising (ct:cts)
ppr_one ct' = hang (parens (pprType (ctPred ct')))
2 (pprCtLoc (ctLoc ct'))
+{- Note ["Arising from" messages in generated code]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider code generated when we desugar code before typechecking;
+see Note [Rebindable syntax and HsExpansion].
+
+In this code, constraints may be generated, but we don't want to
+say "arising from a call of foo" if 'foo' doesn't appear in the
+users code. We leave the actual CtOrigin untouched (partly because
+it is generated in many, many places), but suppress the "Arising from"
+message for constraints that originate in generated code.
+-}
+
+
{- *********************************************************************
* *
SkolemInfo
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index e72e3ed194..8f59daf24a 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -733,18 +733,9 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
, text "do_ql" <+> ppr do_ql ])
; go emptyVarSet [] [] fun_sigma rn_args }
where
- fun_loc = appCtxtLoc fun_ctxt
fun_orig = exprCtOrigin (case fun_ctxt of
VAExpansion e _ -> e
VACall e _ _ -> e)
- set_fun_ctxt thing_inside
- | not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
- = thing_inside -- => context is already set
- | otherwise
- = setSrcSpan fun_loc $
- case fun_ctxt of
- VAExpansion orig _ -> addExprCtxt orig thing_inside
- VACall {} -> thing_inside
-- Count value args only when complaining about a function
-- applied to too many value args
@@ -803,9 +794,9 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
| (tvs, body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty
, (theta, body2) <- tcSplitPhiTy body1
, not (null tvs && null theta)
- = do { (inst_tvs, wrap, fun_rho) <- set_fun_ctxt $
+ = do { (inst_tvs, wrap, fun_rho) <- addHeadCtxt fun_ctxt $
instantiateSigma fun_orig tvs theta body2
- -- set_fun_ctxt: important for the class constraints
+ -- addHeadCtxt: important for the class constraints
-- that may be emitted from instantiating fun_sigma
; go (delta `extendVarSetList` inst_tvs)
(addArgWrap wrap acc) so_far fun_rho args }
@@ -894,19 +885,26 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
addArgCtxt :: AppCtxt -> LHsExpr GhcRn
-> TcM a -> TcM a
--- Adds a "In the third argument of f, namely blah"
--- context, unless we are in generated code, in which case
--- use "In the expression: arg"
+-- There are two cases:
+-- * In the normal case, we add an informative context
+-- "In the third argument of f, namely blah"
+-- * If we are deep inside generated code (isGeneratedCode)
+-- or if all or part of this particular application is an expansion
+-- (VAExpansion), just use the less-informative context
+-- "In the expression: arg"
+-- Unless the arg is also a generated thing, in which case do nothing.
---See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
-addArgCtxt (VACall fun arg_no _) (L arg_loc arg) thing_inside
- = setSrcSpanA arg_loc $
- addErrCtxt (funAppCtxt fun arg arg_no) $
- thing_inside
-
-addArgCtxt (VAExpansion {}) (L arg_loc arg) thing_inside
- = setSrcSpanA arg_loc $
- addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
- thing_inside
+addArgCtxt ctxt (L arg_loc arg) thing_inside
+ = do { in_generated_code <- inGeneratedCode
+ ; case ctxt of
+ VACall fun arg_no _ | not in_generated_code
+ -> setSrcSpanA arg_loc $
+ addErrCtxt (funAppCtxt fun arg arg_no) $
+ thing_inside
+
+ _ -> setSrcSpanA arg_loc $
+ addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated
+ thing_inside }
{- *********************************************************************
* *
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 296b223c8a..16d9cd05b8 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -31,7 +31,7 @@ module GHC.Tc.Gen.Head
, tyConOf, tyConOfET, lookupParents, fieldNotInType
, notSelector, nonBidirectionalErr
- , addExprCtxt, addFunResCtxt ) where
+ , addHeadCtxt, addExprCtxt, addFunResCtxt ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )
@@ -431,12 +431,11 @@ tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
--
-- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App
tcInferAppHead (fun,ctxt) args
- = setSrcSpan (appCtxtLoc ctxt) $
+ = addHeadCtxt ctxt $
do { mb_tc_fun <- tcInferAppHead_maybe fun args
; case mb_tc_fun of
Just (fun', fun_sigma) -> return (fun', fun_sigma)
- Nothing -> add_head_ctxt fun args $
- tcInfer (tcExpr fun) }
+ Nothing -> tcInfer (tcExpr fun) }
tcInferAppHead_maybe :: HsExpr GhcRn
-> [HsExprArg 'TcpRn]
@@ -447,20 +446,23 @@ tcInferAppHead_maybe fun args
= case fun of
HsVar _ (L _ nm) -> Just <$> tcInferId nm
HsRecSel _ f -> Just <$> tcInferRecSelId f
- ExprWithTySig _ e hs_ty -> add_head_ctxt fun args $
- Just <$> tcExprWithSig e hs_ty
+ ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty
HsOverLit _ lit -> Just <$> tcInferOverLit lit
HsSpliceE _ (HsSpliced _ _ (HsSplicedExpr e))
-> tcInferAppHead_maybe e args
_ -> return Nothing
-add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
--- Don't push an expression context if the arguments are empty,
--- because it has already been pushed by tcExpr
-add_head_ctxt fun args thing_inside
- | null args = thing_inside
- | otherwise = addExprCtxt fun thing_inside
-
+addHeadCtxt :: AppCtxt -> TcM a -> TcM a
+addHeadCtxt fun_ctxt thing_inside
+ | not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments
+ = thing_inside -- => context is already set
+ | otherwise
+ = setSrcSpan fun_loc $
+ case fun_ctxt of
+ VAExpansion orig _ -> addExprCtxt orig thing_inside
+ VACall {} -> thing_inside
+ where
+ fun_loc = appCtxtLoc fun_ctxt
{- *********************************************************************
* *
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index bce78dda31..f7dd7e7a9a 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -31,7 +31,7 @@ module GHC.Tc.Types(
Env(..),
TcGblEnv(..), TcLclEnv(..),
setLclEnvTcLevel, getLclEnvTcLevel,
- setLclEnvLoc, getLclEnvLoc,
+ setLclEnvLoc, getLclEnvLoc, lclEnvInGeneratedCode,
IfGblEnv(..), IfLclEnv(..),
tcVisibleOrphanMods,
RewriteEnv(..),
@@ -861,6 +861,9 @@ setLclEnvLoc env loc = env { tcl_loc = loc }
getLclEnvLoc :: TcLclEnv -> RealSrcSpan
getLclEnvLoc = tcl_loc
+lclEnvInGeneratedCode :: TcLclEnv -> Bool
+lclEnvInGeneratedCode = tcl_in_gen_code
+
type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, SDoc))
-- Monadic so that we have a chance
-- to deal with bound type variables just before error
diff --git a/compiler/GHC/Tc/Types.hs-boot b/compiler/GHC/Tc/Types.hs-boot
index 42df1f4bc0..405374a06b 100644
--- a/compiler/GHC/Tc/Types.hs-boot
+++ b/compiler/GHC/Tc/Types.hs-boot
@@ -1,5 +1,6 @@
module GHC.Tc.Types where
+import GHC.Prelude
import GHC.Tc.Utils.TcType
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
@@ -19,3 +20,5 @@ getLclEnvTcLevel :: TcLclEnv -> TcLevel
setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv
getLclEnvLoc :: TcLclEnv -> RealSrcSpan
+
+lclEnvInGeneratedCode :: TcLclEnv -> Bool