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 2896082)

Author: Simon Peyton Jones

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

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

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)
 

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

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, [''])