From 149d7912eb84a24861b021c13d2ee61b44de5856 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones <simonpj@microsoft.com> Date: Mon, 25 Jun 2018 11:42:46 +0100 Subject: [PATCH] Fix error recovery for pattern synonyms As Trac #15289 showed, we were carrying on after a type error in a pattern synonym, and then crashing. This patch improves error handling for pattern synonyms. I also moved a bit of code from TcBinds into TcPatSyn, which helpfully narrows the API. (cherry picked from commit 2896082ec79f02b6388e038a8dae6cb22fe72dfc) --- compiler/typecheck/TcBinds.hs | 11 +-- compiler/typecheck/TcPatSyn.hs | 86 ++++++++++++++++--- compiler/typecheck/TcPatSyn.hs-boot | 12 ++- .../tests/patsyn/should_fail/T15289.stderr | 21 +++-- testsuite/tests/patsyn/should_fail/all.T | 2 +- 5 files changed, 95 insertions(+), 37 deletions(-) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 7060c350efd..4bd91d88a8f 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -19,8 +19,7 @@ import GhcPrelude import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl - , tcPatSynBuilderBind ) +import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) import CoreSyn (Tickish (..)) import CostCentre (mkUserCC, CCFlavour(DeclCC)) import DynFlags @@ -526,16 +525,10 @@ tc_single :: forall thing. tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) _ thing_inside - = do { (aux_binds, tcg_env) <- tc_pat_syn_decl + = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) ; thing <- setGblEnv tcg_env thing_inside ; return (aux_binds, thing) } - where - tc_pat_syn_decl :: TcM (LHsBinds GhcTcId, TcGblEnv) - tc_pat_syn_decl = case sig_fn name of - Nothing -> tcInferPatSynDecl psb - Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi - Just _ -> panic "tc_single" tc_single top_lvl sig_fn prag_fn lbind closed thing_inside = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index a8089b7256c..71050b8a383 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -9,8 +9,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl - , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr +module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind + , tcPatSynBuilderOcc, nonBidirectionalErr ) where import GhcPrelude @@ -53,7 +53,7 @@ import FieldLabel import Bag import Util import ErrUtils -import Control.Monad ( zipWithM ) +import Control.Monad ( zipWithM, when ) import Data.List( partition ) #include "HsVersions.h" @@ -66,6 +66,58 @@ import Data.List( partition ) ************************************************************************ -} +tcPatSynDecl :: PatSynBind GhcRn GhcRn + -> Maybe TcSigInfo + -> TcM (LHsBinds GhcTc, TcGblEnv) +tcPatSynDecl psb@(PSB { psb_id = L _ name, psb_args = details }) mb_sig + = recoverM recover $ + case mb_sig of + Nothing -> tcInferPatSynDecl psb + Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi + _ -> panic "tcPatSynDecl" + + where + -- See Note [Pattern synonym error recovery] + recover = do { matcher_name <- newImplicitBinder name mkMatcherOcc + ; let placeholder = AConLike $ PatSynCon $ + mk_placeholder matcher_name + ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv + ; return (emptyBag, gbl_env) } + + (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details + mk_placeholder matcher_name + = mkPatSyn name is_infix + ([mkTyVarBinder Specified alphaTyVar], []) ([], []) + [] -- Arg tys + alphaTy + (matcher_id, True) Nothing + [] -- Field labels + where + -- The matcher_id is used only by the desugarer, so actually + -- and error-thunk would probably do just as well here. + matcher_id = mkLocalId matcher_name $ + mkSpecForAllTys [alphaTyVar] alphaTy + +tcPatSynDecl (XPatSynBind {}) _ = panic "tcPatSynDecl" + +{- Note [Pattern synonym error recovery] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If type inference for a pattern synonym fails , we can't continue with +the rest of tc_patsyn_finish, because we may get knock-on errors, or +even a crash. E.g. from + pattern What = True :: Maybe +we get a kind error; and we must stop right away (Trac #15289). +Hence the 'when insoluble failM' in tcInferPatSyn. + +But does that abort compilation entirely? No -- we can recover +and carry on, just as we do for value bindings, provided we plug in +placeholder for the pattern synonym. The goal of the placeholder +is not to cause a raft of follow-on errors. I've used the simplest +thing for now, but we might need to elaborate it a bit later. (e.g. +I've given it zero args, which may cause knock-on errors if it is +used in a pattern.) But it'll do for now. +-} + tcInferPatSynDecl :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, @@ -76,14 +128,19 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details ; (tclvl, wanted, ((lpat', args), pat_ty)) <- pushLevelAndCaptureConstraints $ - tcInferNoInst $ \ exp_ty -> - tcPat PatSyn lpat exp_ty $ + tcInferNoInst $ \ exp_ty -> + tcPat PatSyn lpat exp_ty $ mapM tcLookupId arg_names ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args - ; (qtvs, req_dicts, ev_binds, _) <- simplifyInfer tclvl NoRestrictions [] - named_taus wanted + ; (qtvs, req_dicts, ev_binds, insoluble) + <- simplifyInfer tclvl NoRestrictions [] named_taus wanted + + ; when insoluble failM + -- simplifyInfer doesn't fail if there are errors. But to avoid + -- knock-on errors, or even crashes, we want to stop here. + -- See Note [Pattern synonym error recovery] ; let (ex_tvs, prov_dicts) = tcCollectEx lpat' ex_tv_set = mkVarSet ex_tvs @@ -772,10 +829,15 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat | Right match_group <- mb_match_group -- Bidirectional = do { patsyn <- tcLookupPatSyn name - ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn - -- Bidirectional, so patSynBuilder returns Just - - match_group' | need_dummy_arg = add_dummy_arg match_group + ; case patSynBuilder patsyn of { + Nothing -> return emptyBag ; + -- This case happens if we found a type error in the + -- pattern synonym, recovered, and put a placeholder + -- with patSynBuilder=Nothing in the environment + + Just (builder_id, need_dummy_arg) -> -- Normal case + do { -- Bidirectional, so patSynBuilder returns Just + let match_group' | need_dummy_arg = add_dummy_arg match_group | otherwise = match_group bind = FunBind { fun_ext = placeHolderNamesTc @@ -790,7 +852,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id) ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds - ; return builder_binds } + ; return builder_binds } } } | otherwise = panic "tcPatSynBuilderBind" -- Both cases dealt with where diff --git a/compiler/typecheck/TcPatSyn.hs-boot b/compiler/typecheck/TcPatSyn.hs-boot index 5db79fcbbb0..3538682f695 100644 --- a/compiler/typecheck/TcPatSyn.hs-boot +++ b/compiler/typecheck/TcPatSyn.hs-boot @@ -1,17 +1,15 @@ module TcPatSyn where import HsSyn ( PatSynBind, LHsBinds ) -import TcRnTypes ( TcM, TcPatSynInfo ) +import TcRnTypes ( TcM, TcSigInfo ) import TcRnMonad ( TcGblEnv) import Outputable ( Outputable ) import HsExtension ( GhcRn, GhcTc ) +import Data.Maybe ( Maybe ) -tcInferPatSynDecl :: PatSynBind GhcRn GhcRn - -> TcM (LHsBinds GhcTc, TcGblEnv) - -tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn - -> TcPatSynInfo - -> TcM (LHsBinds GhcTc, TcGblEnv) +tcPatSynDecl :: PatSynBind GhcRn GhcRn + -> Maybe TcSigInfo + -> TcM (LHsBinds GhcTc, TcGblEnv) tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) diff --git a/testsuite/tests/patsyn/should_fail/T15289.stderr b/testsuite/tests/patsyn/should_fail/T15289.stderr index b19d7a0d6bb..952d3586927 100644 --- a/testsuite/tests/patsyn/should_fail/T15289.stderr +++ b/testsuite/tests/patsyn/should_fail/T15289.stderr @@ -1,8 +1,13 @@ - T15289.hs:5:16: error: - • Couldn't match expected type ‘Maybe’ with actual type ‘Bool’ - • In the pattern: True - In the pattern: True :: Maybe - In the declaration for pattern synonym ‘What’ - | - 5 | pattern What = True :: Maybe - | ^^^^ + +T15289.hs:5:16: error: + • Couldn't match expected type ‘Maybe’ with actual type ‘Bool’ + • In the pattern: True + In the pattern: True :: Maybe + In the declaration for pattern synonym ‘What’ + +T15289.hs:5:24: error: + • Expecting one more argument to ‘Maybe’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + • In the type ‘Maybe’ + In a pattern type signature: Maybe + In the pattern: True :: Maybe diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T index 269dc8d8447..c029f20eb95 100644 --- a/testsuite/tests/patsyn/should_fail/all.T +++ b/testsuite/tests/patsyn/should_fail/all.T @@ -42,4 +42,4 @@ test('T14380', normal, compile_fail, ['']) test('T14498', normal, compile_fail, ['']) test('T14552', normal, compile_fail, ['']) test('T14507', normal, compile_fail, ['-dsuppress-uniques']) -test('T15289', expect_broken(15289), compile_fail, ['']) +test('T15289', normal, compile_fail, ['']) -- GitLab