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 ...@@ -885,21 +885,24 @@ matchExpectedConTy :: PatEnv
-> TcM (HsWrapper, [TcSigmaType]) -> TcM (HsWrapper, [TcSigmaType])
-- See Note [Matching constructor patterns] -- See Note [Matching constructor patterns]
-- Returns a wrapper : pat_ty "->" T ty1 ... tyn -- 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 | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
-- Comments refer to Note [Matching constructor patterns] -- Comments refer to Note [Matching constructor patterns]
-- co_tc :: forall a. T [a] ~ T7 a -- co_tc :: forall a. T [a] ~ T7 a
= do { pat_ty <- expTypeToType pat_ty = do { pat_ty <- expTypeToType exp_pat_ty
; (wrap, pat_ty) <- topInstantiate orig pat_ty ; (wrap, pat_rho) <- topInstantiate orig pat_ty
; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc) ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc)
-- tys = [ty1,ty2] -- tys = [ty1,ty2]
; traceTc "matchExpectedConTy" (vcat [ppr data_tc, ; traceTc "matchExpectedConTy" (vcat [ppr data_tc,
ppr (tyConTyVars data_tc), ppr (tyConTyVars data_tc),
ppr fam_tc, ppr fam_args]) ppr fam_tc, ppr fam_args,
; co1 <- unifyType noThing (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty ppr exp_pat_ty,
-- co1 : T (ty1,ty2) ~N 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 -- could use tcSubType here... but it's the wrong way round
-- for actual vs. expected in error messages. -- for actual vs. expected in error messages.
...@@ -907,12 +910,13 @@ matchExpectedConTy (PE { pe_orig = orig }) data_tc pat_ty ...@@ -907,12 +910,13 @@ matchExpectedConTy (PE { pe_orig = orig }) data_tc pat_ty
co2 = mkTcUnbranchedAxInstCo co_tc tys' [] co2 = mkTcUnbranchedAxInstCo co_tc tys' []
-- co2 : T (ty1,ty2) ~R T7 ty1 ty2 -- co2 : T (ty1,ty2) ~R T7 ty1 ty2
; return ( wrap <.> (mkWpCastR $ full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2
mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2) -- full_co :: pat_rho ~R T7 ty1 ty2
, tys') }
; return ( mkWpCastR full_co <.> wrap, tys') }
| otherwise | otherwise
= do { pat_ty <- expTypeToType pat_ty = do { pat_ty <- expTypeToType exp_pat_ty
; (wrap, pat_rho) <- topInstantiate orig pat_ty ; (wrap, pat_rho) <- topInstantiate orig pat_ty
; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho
; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) } ; 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, ['']) ...@@ -276,3 +276,4 @@ test('T11581', normal, compile, [''])
test('T12175', normal, compile, ['']) test('T12175', normal, compile, [''])
test('T12522', normal, compile, ['']) test('T12522', normal, compile, [''])
test('T12522b', 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