Commit f7278a90 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix wrapping order in matchExpectedConTy

The wrappers in matchExpectedConTy were being composed back
to front, resulting in a Core Lint error.  Yikes!  This has
been here a long time.

Fixes Trac #12676.
parent a693d1cb
......@@ -885,21 +885,24 @@ matchExpectedConTy :: PatEnv
-> TcM (HsWrapper, [TcSigmaType])
-- See Note [Matching constructor patterns]
-- Returns a wrapper : pat_ty "->" T ty1 ... tyn
matchExpectedConTy (PE { pe_orig = orig }) data_tc pat_ty
matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty
| Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
-- Comments refer to Note [Matching constructor patterns]
-- co_tc :: forall a. T [a] ~ T7 a
= do { pat_ty <- expTypeToType pat_ty
; (wrap, pat_ty) <- topInstantiate orig pat_ty
= do { pat_ty <- expTypeToType exp_pat_ty
; (wrap, pat_rho) <- topInstantiate orig pat_ty
; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc)
-- tys = [ty1,ty2]
; traceTc "matchExpectedConTy" (vcat [ppr data_tc,
ppr (tyConTyVars data_tc),
ppr fam_tc, ppr fam_args])
; co1 <- unifyType noThing (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty
-- co1 : T (ty1,ty2) ~N pat_ty
ppr fam_tc, ppr fam_args,
ppr exp_pat_ty,
ppr pat_ty,
ppr pat_rho, ppr wrap])
; co1 <- unifyType noThing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho
-- co1 : T (ty1,ty2) ~N pat_rho
-- could use tcSubType here... but it's the wrong way round
-- for actual vs. expected in error messages.
......@@ -907,12 +910,13 @@ matchExpectedConTy (PE { pe_orig = orig }) data_tc pat_ty
co2 = mkTcUnbranchedAxInstCo co_tc tys' []
-- co2 : T (ty1,ty2) ~R T7 ty1 ty2
; return ( wrap <.> (mkWpCastR $
mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2)
, tys') }
full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2
-- full_co :: pat_rho ~R T7 ty1 ty2
; return ( mkWpCastR full_co <.> wrap, tys') }
| otherwise
= do { pat_ty <- expTypeToType pat_ty
= do { pat_ty <- expTypeToType exp_pat_ty
; (wrap, pat_rho) <- topInstantiate orig pat_ty
; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho
; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) }
......
{-# LANGUAGE RankNTypes, TypeFamilies #-}
module T12676 where
data family T a
data instance T () = MkT
foo :: (forall s. T ()) -> ()
foo MkT = ()
......@@ -276,3 +276,4 @@ test('T11581', normal, compile, [''])
test('T12175', normal, compile, [''])
test('T12522', normal, compile, [''])
test('T12522b', normal, compile, [''])
test('T12676', normal, compile, [''])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment