Commit 149d7912 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Ben Gamari

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 2896082e)
parent 4cfeca02
......@@ -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
......
......@@ -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
......
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)
......
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
......@@ -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, [''])
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