= return () -- Short cut for case when there are no existentials
tcCheckExistentialPat pats ex_tvs pat_tys body_ty
- = addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs pat_tys body_ty) $
+ = addErrCtxtM (sigPatCtxt pats ex_tvs pat_tys body_ty) $
checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs
data PatState = PS {
-> HsConDetails Name (LPat Name) -> (PatState -> TcM a)
-> TcM (Pat TcId, [TcTyVar], a)
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
- = do { span <- getSrcSpanM -- Span for the whole pattern
- ; let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con
- skol_info = PatSkol data_con span
+ = do { let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con
+ skol_info = PatSkol data_con
origin = SigOrigin skol_info
-- Instantiate the constructor type variables [a->ty]
; ctxt_res_tys <- boxySplitTyConAppWithFamily tycon pat_ty
- ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs
+ ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs -- Get location from monad,
+ -- not from ex_tvs
; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs)
(ctxt_res_tys ++ mkTyVarTys ex_tvs')
eq_spec' = substEqSpec tenv eq_spec
; loc <- getInstLoc origin
; dicts <- newDictBndrs loc theta'
- ; dict_binds <- tcSimplifyCheck doc ex_tvs' dicts lie_req
+ ; dict_binds <- tcSimplifyCheckPat loc co_vars (pat_reft pstate')
+ ex_tvs' dicts lie_req
; addDataConStupidTheta data_con ctxt_res_tys
ex_tvs' ++ inner_tvs, res)
}
where
- doc = ptext SLIT("existential context for") <+> quotes (ppr data_con)
-
-- Split against the family tycon if the pattern constructor belongs to a
-- representation tycon.
--
text "In the binding group for"])
4 (ppr pat)
-sigPatCtxt bound_ids bound_tvs pat_tys body_ty tidy_env
+sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
= do { pat_tys' <- mapM zonkTcType pat_tys
; body_ty' <- zonkTcType body_ty
; let (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
sep [ptext SLIT("When checking an existential match that binds"),
nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
- ptext SLIT("The body has type:") <+> ppr tidy_body_ty
+ ptext SLIT("The body has type:") <+> ppr tidy_body_ty,
+ ppr pats
]) }
where
+ bound_ids = collectPatsBinders pats
show_ids = filter is_interesting bound_ids
is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs