Commit 259d5ea8 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Improve error reporting for non-rigid GADT matches

Following suggestions from users, this patch improves the error message
when a GADT match needs a rigid type:

 tcfail172.hs:19:10:
     GADT pattern match in non-rigid context for `Nil'
-      Solution: add a type signature
+      Probable solution: add a type signature for `is_normal'
     In the pattern: Nil
     In the definition of `is_normal': is_normal Nil = True

Now GHC tries to tell you what to give a type signature *for*.
Thanks to Daniel Gorin and others for the suggestions.
parent 9bcd95ba
......@@ -1020,10 +1020,10 @@ pp_dotdot = ptext (sLit " .. ")
\begin{code}
data HsMatchContext id -- Context of a Match
= FunRhs id Bool -- Function binding for f; True <=> written infix
| CaseAlt -- Guard on a case alternative
| LambdaExpr -- Pattern of a lambda
| ProcExpr -- Pattern of a proc
| PatBindRhs -- Pattern binding
| CaseAlt -- Patterns and guards on a case alternative
| LambdaExpr -- Patterns of a lambda
| ProcExpr -- Patterns of a proc
| PatBindRhs -- Patterns in the *guards* of a pattern binding
| RecUpd -- Record update [used only in DsExpr to
-- tell matchWrapper what sort of
-- runtime error message to generate]
......
......@@ -53,7 +53,7 @@ tcProc pat cmd exp_ty
do { ((exp_ty1, res_ty), coi) <- boxySplitAppTy exp_ty
; ((arr_ty, arg_ty), coi1) <- boxySplitAppTy exp_ty1
; let cmd_env = CmdEnv { cmd_arr = arr_ty }
; (pat', cmd') <- tcProcPat pat arg_ty res_ty $
; (pat', cmd') <- tcPat ProcExpr pat arg_ty res_ty $
tcCmdTop cmd_env cmd []
; let res_coi = mkTransCoI coi (mkAppTyCoI exp_ty1 coi1 res_ty IdCo)
; return (pat', cmd', res_coi)
......@@ -186,8 +186,8 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig
(kappaUnderflow cmd)
-- Check the patterns, and the GRHSs inside
; (pats', grhss') <- setSrcSpan mtch_loc $
tcLamPats pats cmd_stk res_ty $
; (pats', grhss') <- setSrcSpan mtch_loc $
tcPats LambdaExpr pats cmd_stk res_ty $
tc_grhss grhss
; let match' = L mtch_loc (Match pats' Nothing grhss')
......
......@@ -166,7 +166,7 @@ tcMatch ctxt pat_tys rhs_ty match
where
tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
= add_match_ctxt match $
do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $
tc_grhss ctxt maybe_rhs_sig grhss
; return (Match pats' Nothing grhss') }
......@@ -326,9 +326,9 @@ tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
; thing <- thing_inside res_ty
; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
tcGuardStmt _ (BindStmt pat rhs _ _) res_ty thing_inside
tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcGuardStmt _ stmt _ _
......@@ -342,10 +342,10 @@ tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
-> TcStmtChecker
-- A generator, pat <- rhs
tcLcStmt m_tc _ (BindStmt pat rhs _ _) res_ty thing_inside
tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
tcMonoExpr rhs (mkTyConApp m_tc [ty])
; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-- A boolean guard
......@@ -463,7 +463,7 @@ tcLcStmt _ _ stmt _ _
tcDoStmt :: TcStmtChecker
tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRhoNC rhs
-- We should use type *inference* for the RHS computations,
-- becuase of GADTs.
......@@ -489,7 +489,7 @@ tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
then return noSyntaxExpr
else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
; (pat', thing) <- tcLamPat pat pat_ty new_res_ty thing_inside
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty thing_inside
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
......@@ -522,9 +522,9 @@ tcDoStmt _ stmt _ _
tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
-> TcStmtChecker
tcMDoStmt tc_rhs _ (BindStmt pat rhs _ _) res_ty thing_inside
tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', pat_ty) <- tc_rhs rhs
; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
......
......@@ -6,7 +6,7 @@
TcPat: Typechecking patterns
\begin{code}
module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcProcPat, tcOverloadedLit,
module TcPat ( tcLetPat, tcPat, tcPats, tcOverloadedLit,
addDataConStupidTheta, badFieldCon, polyPatSig ) where
#include "HsVersions.h"
......@@ -70,11 +70,12 @@ tcLetPat sig_fn pat pat_ty thing_inside
; return (pat', res) }
-----------------
tcLamPats :: [LPat Name] -- Patterns,
-> [BoxySigmaType] -- and their types
-> BoxyRhoType -- Result type,
-> (BoxyRhoType -> TcM a) -- and the checker for the body
-> TcM ([LPat TcId], a)
tcPats :: HsMatchContext Name
-> [LPat Name] -- Patterns,
-> [BoxySigmaType] -- and their types
-> BoxyRhoType -- Result type,
-> (BoxyRhoType -> TcM a) -- and the checker for the body
-> TcM ([LPat TcId], a)
-- This is the externally-callable wrapper function
-- Typecheck the patterns, extend the environment to bind the variables,
......@@ -87,17 +88,17 @@ tcLamPats :: [LPat Name] -- Patterns,
-- 3. Check the body
-- 4. Check that no existentials escape
tcLamPats pats tys res_ty thing_inside
= tc_lam_pats LamPat (zipEqual "tcLamPats" pats tys)
tcPats ctxt pats tys res_ty thing_inside
= tc_lam_pats (APat ctxt) (zipEqual "tcLamPats" pats tys)
res_ty thing_inside
tcLamPat, tcProcPat :: LPat Name -> BoxySigmaType
-> BoxyRhoType -- Result type
-> (BoxyRhoType -> TcM a) -- Checker for body, given
-- its result type
-> TcM (LPat TcId, a)
tcLamPat = tc_lam_pat LamPat
tcProcPat = tc_lam_pat ProcPat
tcPat :: HsMatchContext Name
-> LPat Name -> BoxySigmaType
-> BoxyRhoType -- Result type
-> (BoxyRhoType -> TcM a) -- Checker for body, given
-- its result type
-> TcM (LPat TcId, a)
tcPat ctxt = tc_lam_pat (APat ctxt)
tc_lam_pat :: PatCtxt -> LPat Name -> BoxySigmaType -> BoxyRhoType
-> (BoxyRhoType -> TcM a) -> TcM (LPat TcId, a)
......@@ -117,7 +118,7 @@ tc_lam_pats ctxt pat_ty_prs res_ty thing_inside
; (pats', ex_tvs, res) <- do { traceTc (text "tc_lam_pats" <+> (ppr pat_ty_prs $$ ppr res_ty))
; tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' ->
if (pat_eqs pstate' && (not $ isRigidTy res_ty))
then nonRigidResult res_ty
then nonRigidResult ctxt res_ty
else thing_inside res_ty }
; let tys = map snd pat_ty_prs
......@@ -154,11 +155,13 @@ data PatState = PS {
}
data PatCtxt
= LamPat
| ProcPat -- The pattern in (proc pat -> ...)
-- see Note [Arrows and patterns]
= APat (HsMatchContext Name)
| LetPat (Name -> Maybe TcRhoType) -- Used for let(rec) bindings
notProcPat :: PatCtxt -> Bool
notProcPat (APat ProcExpr) = False
notProcPat _ = True
patSigCtxt :: PatState -> UserTypeCtxt
patSigCtxt (PS { pat_ctxt = LetPat _ }) = BindPatSigCtxt
patSigCtxt _ = LamPatSigCtxt
......@@ -647,8 +650,9 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
else do -- The general case, with existential, and local equality
-- constraints
{ checkTc (case pat_ctxt pstate of { ProcPat -> False; _ -> True })
{ checkTc (notProcPat (pat_ctxt pstate))
(existentialProcPat data_con)
-- See Note [Arrows and patterns]
-- Need to test for rigidity if *any* constraints in theta as class
-- constraints may have superclass equality constraints. However,
......@@ -666,8 +670,8 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
pstate' | no_equalities = pstate
| otherwise = pstate { pat_eqs = True }
; unless no_equalities $
checkTc (isRigidTy pat_ty) (nonRigidMatch data_con)
; unless no_equalities $ checkTc (isRigidTy pat_ty) $
nonRigidMatch (pat_ctxt pstate) data_con
; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
......@@ -1029,17 +1033,30 @@ lazyPatErr _ tvs
hang (ptext (sLit "A lazy (~) pattern cannot bind existential type variables"))
2 (vcat (map pprSkolTvBinding tvs))
nonRigidMatch :: DataCon -> SDoc
nonRigidMatch con
nonRigidMatch :: PatCtxt -> DataCon -> SDoc
nonRigidMatch ctxt con
= hang (ptext (sLit "GADT pattern match in non-rigid context for") <+> quotes (ppr con))
2 (ptext (sLit "Solution: add a type signature"))
nonRigidResult :: Type -> TcM a
nonRigidResult res_ty
2 (ptext (sLit "Probable solution: add a type signature for") <+> what ctxt)
where
what (APat (FunRhs f _)) = quotes (ppr f)
what (APat CaseAlt) = ptext (sLit "the scrutinee of the case expression")
what (APat LambdaExpr ) = ptext (sLit "the lambda expression")
what (APat (StmtCtxt _)) = ptext (sLit "the right hand side of a do/comprehension binding")
what _other = ptext (sLit "something")
nonRigidResult :: PatCtxt -> Type -> TcM a
nonRigidResult ctxt res_ty
= do { env0 <- tcInitTidyEnv
; let (env1, res_ty') = tidyOpenType env0 res_ty
msg = hang (ptext (sLit "GADT pattern match with non-rigid result type")
<+> quotes (ppr res_ty'))
2 (ptext (sLit "Solution: add a type signature"))
2 (ptext (sLit "Solution: add a type signature for")
<+> what ctxt )
; failWithTcM (env1, msg) }
where
what (APat (FunRhs f _)) = quotes (ppr f)
what (APat CaseAlt) = ptext (sLit "the entire case expression")
what (APat LambdaExpr) = ptext (sLit "the lambda exression")
what (APat (StmtCtxt _)) = ptext (sLit "the entire do/comprehension expression")
what _other = ptext (sLit "something")
\end{code}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment