diff options
Diffstat (limited to 'compiler/typecheck/TcPatSyn.hs')
-rw-r--r-- | compiler/typecheck/TcPatSyn.hs | 86 |
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 |