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.

1 files changed, 74 insertions, 12 deletions

diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index a8089b7256..71050b8a38 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