From 259d5ea8479dbbf0220335c740efebec1bc19a7f Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 30 Oct 2008 14:39:47 +0000 Subject: [PATCH] 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. --- compiler/hsSyn/HsExpr.lhs | 8 ++-- compiler/typecheck/TcArrows.lhs | 6 +-- compiler/typecheck/TcMatches.lhs | 18 ++++----- compiler/typecheck/TcPat.lhs | 75 +++++++++++++++++++++++--------------- 4 files changed, 62 insertions(+), 45 deletions(-) diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index bcc5084..66336b6 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -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] diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 4593482..ee14eb8 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -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') diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 4748901..db9089c 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -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 diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 984b2e5..b8bbed7 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -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} -- 1.7.10.4