-- Type signatures in patterns
-- See Note [Pattern coercions] below
tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
- = do { (inner_ty, tv_binds) <- tcPatSig (patSigCtxt pstate) sig_ty pat_ty
+ = do { (inner_ty, tv_binds, coi) <- tcPatSig (patSigCtxt pstate) sig_ty
+ pat_ty
+ ; unless (isIdentityCoercion coi) $
+ failWithTc (badSigPat pat_ty)
; (pat', tvs, res) <- tcExtendTyVarEnv2 tv_binds $
tc_lpat pat inner_ty pstate thing_inside
; return (SigPatOut pat' inner_ty, tvs, res) }
where
uwScrut = unwrapFamInstScrutinee tycon ctxt_res_tys res_pat
- ; traceTc $ case sym_coi of
- IdCo -> text "sym_coi:IdCo"
- ACo co -> text "sym_coi: ACoI" <+> ppr co
-
-- Add the stupid theta
; addDataConStupidTheta data_con ctxt_res_tys
-- ex_tvs was non-null.
-- ; unless (null theta') $
-- FIXME: AT THE MOMENT WE CHEAT! We only perform the rigidity test
- -- if we explicit or implicit (by a GADT def) have equality
+ -- if we explicitly or implicitly (by a GADT def) have equality
-- constraints.
; let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
theta' = substTheta tenv (eq_preds ++ full_theta)
pstate' | no_equalities = pstate
| otherwise = pstate { pat_eqs = True }
- ; unless no_equalities (checkTc (isRigidTy pat_ty)
- (nonRigidMatch data_con))
+ ; unless no_equalities $
+ checkTc (isRigidTy pat_ty) (nonRigidMatch data_con)
; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
| otherwise
= pat
-
tcConArgs :: DataCon -> [TcSigmaType]
-> Checker (HsConPatDetails Name) (HsConPatDetails Id)
= hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
2 (ppr sig_ty)
+badSigPat :: TcType -> SDoc
+badSigPat pat_ty = ptext (sLit "Pattern signature must exactly match:") <+>
+ ppr pat_ty
+
badTypePat :: Pat Name -> SDoc
badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat