summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2022-11-28 15:36:25 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-11-30 09:32:03 -0500
commita9d9b8c0458e838f331ead62dca272665ecbf20d (patch)
tree423877074f00e2ac8d690dd2fde71fa60cb58002
parenta3a8e9e968ff9b10c6785d53a5f1c8fcef6db72b (diff)
downloadhaskell-a9d9b8c0458e838f331ead62dca272665ecbf20d.tar.gz
Use mkNakedFunTy in tcPatSynSig
As #22521 showed, in tcPatSynSig we make a "fake type" to kind-generalise; and that type has unzonked type variables in it. So we must not use `mkFunTy` (which checks FunTy's invariants) via `mkPhiTy` when building this type. Instead we need to use `mkNakedFunTy`. Easy fix.
-rw-r--r--compiler/GHC/Core/TyCo/Rep.hs6
-rw-r--r--compiler/GHC/Core/TyCo/Rep.hs-boot2
-rw-r--r--compiler/GHC/Core/TyCon.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs15
-rw-r--r--testsuite/tests/patsyn/should_compile/T22521.hs9
-rw-r--r--testsuite/tests/patsyn/should_compile/all.T1
6 files changed, 29 insertions, 10 deletions
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index 9f1267ab56..4247e9f8dd 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -45,7 +45,7 @@ module GHC.Core.TyCo.Rep (
-- * Functions over types
mkNakedTyConTy, mkTyVarTy, mkTyVarTys,
mkTyCoVarTy, mkTyCoVarTys,
- mkFunTy, mkNakedKindFunTy,
+ mkFunTy, mkNakedFunTy,
mkVisFunTy, mkScaledFunTys,
mkInvisFunTy, mkInvisFunTys,
tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTys,
@@ -799,10 +799,10 @@ mkTyCoVarTys = map mkTyCoVarTy
infixr 3 `mkFunTy`, `mkInvisFunTy`, `mkVisFunTyMany`
-mkNakedKindFunTy :: FunTyFlag -> Kind -> Kind -> Kind
+mkNakedFunTy :: FunTyFlag -> Kind -> Kind -> Kind
-- See Note [Naked FunTy] in GHC.Builtin.Types
-- Always Many multiplicity; kinds have no linearity
-mkNakedKindFunTy af arg res
+mkNakedFunTy af arg res
= FunTy { ft_af = af, ft_mult = manyDataConTy
, ft_arg = arg, ft_res = res }
diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot
index c2dd2a63fe..a560e0d608 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs-boot
+++ b/compiler/GHC/Core/TyCo/Rep.hs-boot
@@ -27,7 +27,7 @@ type MCoercionN = MCoercion
mkForAllTy :: VarBndr Var ForAllTyFlag -> Type -> Type
mkNakedTyConTy :: TyCon -> Type
-mkNakedKindFunTy :: FunTyFlag -> Type -> Type -> Type
+mkNakedFunTy :: FunTyFlag -> Type -> Type -> Type
-- To support Data instances in GHC.Core.Coercion.Axiom
diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index 0cbb9ece43..49f33fdc21 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -137,7 +137,7 @@ import GHC.Prelude
import GHC.Platform
import {-# SOURCE #-} GHC.Core.TyCo.Rep
- ( Kind, Type, PredType, mkForAllTy, mkNakedKindFunTy, mkNakedTyConTy )
+ ( Kind, Type, PredType, mkForAllTy, mkNakedFunTy, mkNakedTyConTy )
import {-# SOURCE #-} GHC.Core.TyCo.Ppr
( pprType )
import {-# SOURCE #-} GHC.Builtin.Types
@@ -525,8 +525,8 @@ mkTyConKind bndrs res_kind = foldr mk res_kind bndrs
where
mk :: TyConBinder -> Kind -> Kind
mk (Bndr tv (NamedTCB vis)) k = mkForAllTy (Bndr tv vis) k
- mk (Bndr tv (AnonTCB af)) k = mkNakedKindFunTy af (varType tv) k
- -- mkNakedKindFunTy: see Note [Naked FunTy] in GHC.Builtin.Types
+ mk (Bndr tv (AnonTCB af)) k = mkNakedFunTy af (varType tv) k
+ -- mkNakedFunTy: see Note [Naked FunTy] in GHC.Builtin.Types
-- | (mkTyConTy tc) returns (TyConApp tc [])
-- but arranges to share that TyConApp among all calls
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index b1e59a78b3..0c74bd54f6 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -52,9 +52,10 @@ import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )
import GHC.Core( hasSomeUnfolding )
import GHC.Core.Type ( mkTyVarBinders )
import GHC.Core.Multiplicity
+import GHC.Core.TyCo.Rep( mkNakedFunTy )
import GHC.Types.Error
-import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars )
+import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars, invisArgTypeLike )
import GHC.Types.Id ( Id, idName, idType, setInlinePragma
, mkLocalId, realIdUnfolding )
import GHC.Types.Basic
@@ -485,11 +486,19 @@ tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty
build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body
= mkInvisForAllTys implicit_bndrs $
mkInvisForAllTys univ_bndrs $
- mkPhiTy req $
+ mk_naked_phi_ty req $
mkInvisForAllTys ex_bndrs $
- mkPhiTy prov $
+ mk_naked_phi_ty prov $
body
+ -- Use mk_naked_phi_ty because we call build_patsyn_type /before zonking/
+ -- just before kindGeneraliseAll, and the invariants that mkPhiTy checks
+ -- don't hold of the un-zonked types. #22521 was a case in point.
+ -- (We also called build_patsyn_type on the fully zonked type, so mkPhiTy
+ -- would work; but it doesn't seem worth duplicating the code.)
+ mk_naked_phi_ty :: [TcPredType] -> TcType -> TcType
+ mk_naked_phi_ty theta body = foldr (mkNakedFunTy invisArgTypeLike) body theta
+
ppr_tvs :: [TyVar] -> SDoc
ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
| tv <- tvs])
diff --git a/testsuite/tests/patsyn/should_compile/T22521.hs b/testsuite/tests/patsyn/should_compile/T22521.hs
new file mode 100644
index 0000000000..0fbac4f49e
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T22521.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+module Bug (pattern P) where
+
+pattern P :: C a => a
+pattern P <- (m -> True)
+
+class C a where
+ m :: a -> Bool
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index e8da69d553..93a0bdb123 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -82,3 +82,4 @@ test('T16682', [extra_files(['T16682.hs', 'T16682a.hs'])],
test('T17775-singleton', normal, compile, [''])
test('T14630', normal, compile, ['-Wname-shadowing'])
test('T21531', [ grep_errmsg(r'INLINE') ], compile, ['-ddump-ds'])
+test('T22521', normal, compile, [''])