diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index dd889929e7c780b9889c04e4b1bc164cad4c9805..2f115c694cb11c647fe25a441e88c1312688045a 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -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) } diff --git a/testsuite/tests/indexed-types/should_compile/T12676.hs b/testsuite/tests/indexed-types/should_compile/T12676.hs new file mode 100644 index 0000000000000000000000000000000000000000..feb1403950f7cc9b74165a20ef7f51b6bc00e871 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T12676.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE RankNTypes, TypeFamilies #-} + +module T12676 where + +data family T a +data instance T () = MkT + +foo :: (forall s. T ()) -> () +foo MkT = () diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T index eab93ac720847eba3434e6f8cdc779385d166150..05c9ad3d41610f8d71a6e23c58ed14b6581d7856 100644 --- a/testsuite/tests/indexed-types/should_compile/all.T +++ b/testsuite/tests/indexed-types/should_compile/all.T @@ -276,3 +276,4 @@ test('T11581', normal, compile, ['']) test('T12175', normal, compile, ['']) test('T12522', normal, compile, ['']) test('T12522b', normal, compile, ['']) +test('T12676', normal, compile, [''])