- ; ctxt_res_tys <- boxySplitTyConApp tycon pat_ty
- ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs
- ; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs)
- (ctxt_res_tys ++ mkTyVarTys ex_tvs')
- eq_spec' = substEqSpec tenv eq_spec
- theta' = substTheta tenv theta
- arg_tys' = substTys tenv arg_tys
-
- ; co_vars <- newCoVars eq_spec' -- Make coercion variables
- ; pstate' <- refineAlt data_con pstate ex_tvs co_vars pat_ty
-
- ; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
- tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
-
- ; dicts <- newDicts (SigOrigin skol_info) theta'
- ; dict_binds <- tcSimplifyCheck doc ex_tvs' dicts lie_req
-
- ; tcInstStupidTheta data_con ctxt_res_tys
-
- ; return (ConPatOut { pat_con = L con_span data_con,
- pat_tvs = ex_tvs' ++ co_vars,
- pat_dicts = map instToId dicts, pat_binds = dict_binds,
- pat_args = arg_pats', pat_ty = pat_ty },
- ex_tvs' ++ inner_tvs, res)
- }
+ -- This may involve doing a family-instance coercion,
+ -- and building a wrapper
+ ; (wrap, ctxt_res_tys) <- matchExpectedPatTy (matchExpectedConTy tycon) pat_ty
+
+ -- Add the stupid theta
+ ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys
+
+ ; checkExistentials ex_tvs penv
+ ; let skol_info = case pe_ctxt penv of
+ LamPat mc -> PatSkol data_con mc
+ LetPat {} -> UnkSkol -- Doesn't matter
+ ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs
+ -- Get location from monad, not from ex_tvs
+
+ ; let pat_ty' = mkTyConApp tycon ctxt_res_tys
+ -- pat_ty' is type of the actual constructor application
+ -- pat_ty' /= pat_ty iff coi /= IdCo
+
+ tenv = zipTopTvSubst (univ_tvs ++ ex_tvs)
+ (ctxt_res_tys ++ mkTyVarTys ex_tvs')
+ arg_tys' = substTys tenv arg_tys
+ full_theta = eq_theta ++ dict_theta
+
+ ; if null ex_tvs && null eq_spec && null full_theta
+ then do { -- The common case; no class bindings etc
+ -- (see Note [Arrows and patterns])
+ (arg_pats', res) <- tcConArgs data_con arg_tys'
+ arg_pats penv thing_inside
+ ; let res_pat = ConPatOut { pat_con = L con_span data_con,
+ pat_tvs = [], pat_dicts = [],
+ pat_binds = emptyTcEvBinds,
+ pat_args = arg_pats',
+ pat_ty = pat_ty' }
+
+ ; return (mkHsWrapPat wrap res_pat pat_ty, res) }
+
+ else do -- The general case, with existential,
+ -- and local equality constraints
+ { let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
+ theta' = substTheta tenv (eq_preds ++ full_theta)
+ -- order is *important* as we generate the list of
+ -- dictionary binders from theta'
+ no_equalities = not (any isEqPred theta')
+
+ ; gadts_on <- doptM Opt_GADTs
+ ; checkTc (no_equalities || gadts_on)
+ (ptext (sLit "A pattern match on a GADT requires -XGADTs"))
+ -- Trac #2905 decided that a *pattern-match* of a GADT
+ -- should require the GADT language flag
+
+ ; given <- newEvVars theta'
+ ; let free_tvs = pe_res_tvs penv
+ -- Since we have done checkExistentials,
+ -- pe_res_tvs can only be Just at this point
+ --
+ -- Nor do we need pat_ty, because we've put all the
+ -- unification variables in right at the start when
+ -- initialising the PatEnv; and the pattern itself
+ -- only adds skolems.
+
+ ; (ev_binds, (arg_pats', res))
+ <- checkConstraints skol_info free_tvs ex_tvs' given $
+ tcConArgs data_con arg_tys' arg_pats penv thing_inside
+
+ ; let res_pat = ConPatOut { pat_con = L con_span data_con,
+ pat_tvs = ex_tvs',
+ pat_dicts = given,
+ pat_binds = ev_binds,
+ pat_args = arg_pats',
+ pat_ty = pat_ty' }
+ ; return (mkHsWrapPat wrap res_pat pat_ty, res)
+ } }
+
+----------------------------
+matchExpectedPatTy :: (TcRhoType -> TcM (CoercionI, a))
+ -> TcRhoType -> TcM (HsWrapper, a)
+-- See Note [Matching polytyped patterns]
+-- Returns a wrapper : pat_ty ~ inner_ty
+matchExpectedPatTy inner_match pat_ty
+ | null tvs && null theta
+ = do { (coi, res) <- inner_match pat_ty
+ ; return (coiToHsWrapper (mkSymCoI coi), res) }
+ -- The Sym is because the inner_match returns a coercion
+ -- that is the other way round to matchExpectedPatTy
+
+ | otherwise
+ = do { (_, tys, subst) <- tcInstTyVars tvs
+ ; wrap1 <- instCall PatOrigin tys (substTheta subst theta)
+ ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (substTy subst tau)
+ ; return (wrap2 <.> wrap1 , arg_tys) }