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