[Git][ghc/ghc][wip/T22516] Use mkNakedFunTy in tcPatSynSig

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T22516 at Glasgow Haskell Compiler / GHC


Commits:
f7c2dd0e by Simon Peyton Jones at 2022-11-28T15:36:25+00:00
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 changed files:

- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Rep.hs-boot
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Tc/Gen/Sig.hs
- + testsuite/tests/patsyn/should_compile/T22521.hs
- testsuite/tests/patsyn/should_compile/all.T


Changes:

=====================================
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 }
 


=====================================
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


=====================================
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


=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -52,6 +52,7 @@ 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 )
@@ -61,6 +62,7 @@ import GHC.Types.Basic
 import GHC.Types.Name
 import GHC.Types.Name.Env
 import GHC.Types.SrcLoc
+import GHC.Types.Var( invisArgTypeLike )
 
 import GHC.Builtin.Names( mkUnboundName )
 import GHC.Unit.Module( getModule )
@@ -485,11 +487,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])


=====================================
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


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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f7c2dd0ed98f87e050d0b4a8a042f47f1dee23e3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f7c2dd0ed98f87e050d0b4a8a042f47f1dee23e3
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221128/d451fc62/attachment-0001.html>