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.

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, [''])