[Git][ghc/ghc][master] Fix missing escaping-kind check in tcPatSynSig
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Apr 26 22:04:55 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
4d6394dd by Simon Peyton Jones at 2024-04-26T18:03:49-04:00
Fix missing escaping-kind check in tcPatSynSig
Note [Escaping kind in type signatures] explains how we deal
with escaping kinds in type signatures, e.g.
f :: forall r (a :: TYPE r). a
where the kind of the body is (TYPE r), but `r` is not in
scope outside the forall-type.
I had missed this subtlety in tcPatSynSig, leading to #24686.
This MR fixes it; and a similar bug in tc_top_lhs_type. (The
latter is tested by T24686a.)
- - - - -
8 changed files:
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Sig.hs
- + testsuite/tests/polykinds/T24686.hs
- + testsuite/tests/polykinds/T24686.stderr
- + testsuite/tests/polykinds/T24686a.hs
- + testsuite/tests/polykinds/T24686a.stderr
- testsuite/tests/polykinds/all.T
- testsuite/tests/rep-poly/RepPolyPatSynRes.stderr
Changes:
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -56,7 +56,7 @@ module GHC.Tc.Gen.HsType (
tcHsLiftedType, tcHsOpenType,
tcHsLiftedTypeNC, tcHsOpenTypeNC,
tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated,
- tcCheckLHsTypeInContext,
+ tcCheckLHsTypeInContext, tcCheckLHsType,
tcHsContext, tcLHsPredType,
kindGeneralizeAll,
@@ -496,7 +496,7 @@ tc_lhs_sig_type skol_info full_hs_ty@(L loc (HsSig { sig_bndrs = hs_outer_bndrs
{- Note [Escaping kind in type signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider kind-checking the signature for `foo` (#19495):
+Consider kind-checking the signature for `foo` (#19495, #24686):
type family T (r :: RuntimeRep) :: TYPE r
foo :: forall (r :: RuntimeRep). T r
@@ -508,7 +508,8 @@ because we allow signatures like `foo :: Int#`.)
Suppose we are at level L currently. We do this
* pushLevelAndSolveEqualitiesX: moves to level L+1
- * newExpectedKind: allocates delta{L+1}
+ * newExpectedKind: allocates delta{L+1}. Note carefully that
+ this call is /outside/ the tcOuterTKBndrs call.
* tcOuterTKBndrs: pushes the level again to L+2, binds skolem r{L+2}
* kind-check the body (T r) :: TYPE delta{L+1}
@@ -607,9 +608,9 @@ tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs
; skol_info <- mkSkolemInfo skol_info_anon
; (tclvl, wanted, (outer_bndrs, ty))
<- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $
- tcOuterTKBndrs skol_info hs_outer_bndrs $
do { kind <- newExpectedKind (expectedKindInCtxt ctxt)
- ; tc_check_lhs_type (mkMode tyki) body kind }
+ ; tcOuterTKBndrs skol_info hs_outer_bndrs $
+ tc_check_lhs_type (mkMode tyki) body kind }
; outer_bndrs <- scopedSortOuter outer_bndrs
; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -36,7 +36,7 @@ import GHC.Tc.Gen.HsType
import GHC.Tc.Types
import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep )
+import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep, newOpenTypeKind )
import GHC.Tc.Zonk.Type
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
@@ -386,14 +386,16 @@ tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty
; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty))))
<- pushLevelAndSolveEqualitiesX "tcPatSynSig" $
-- See Note [Report unsolved equalities in tcPatSynSig]
- tcOuterTKBndrs skol_info hs_outer_bndrs $
- tcExplicitTKBndrs skol_info ex_hs_tvbndrs $
- do { req <- tcHsContext hs_req
- ; prov <- tcHsContext hs_prov
- ; body_ty <- tcHsOpenType hs_body_ty
- -- A (literal) pattern can be unlifted;
- -- e.g. pattern Zero <- 0# (#12094)
- ; return (req, prov, body_ty) }
+ do { res_kind <- newOpenTypeKind
+ -- "open" because a (literal) pattern can be unlifted;
+ -- e.g. pattern Zero <- 0# (#12094)
+ -- See Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType
+ ; tcOuterTKBndrs skol_info hs_outer_bndrs $
+ tcExplicitTKBndrs skol_info ex_hs_tvbndrs $
+ do { req <- tcHsContext hs_req
+ ; prov <- tcHsContext hs_prov
+ ; body_ty <- tcCheckLHsType hs_body_ty res_kind
+ ; return (req, prov, body_ty) } }
; let implicit_tvs :: [TcTyVar]
univ_bndrs :: [TcInvisTVBinder]
=====================================
testsuite/tests/polykinds/T24686.hs
=====================================
@@ -0,0 +1,28 @@
+{-# LANGUAGE ViewPatterns, PatternSynonyms #-}
+module T24686 where
+
+import GHC.Exts
+import GHC.Stack
+
+{-
+ on GHC 9.4 / 9.6 / 9.8 this panics with
+ <no location info>: error:
+ panic! (the 'impossible' happened)
+ GHC version 9.4.8:
+ typeKind
+ forall {r :: RuntimeRep} (a :: TYPE r). a
+ [r_aNu, a_aNy]
+ a_aNy :: TYPE r_aNu
+ Call stack:
+ CallStack (from HasCallStack):
+ callStackDoc, called at compiler/GHC/Utils/Panic.hs:182:37 in ghc:GHC.Utils.Panic
+ pprPanic, called at compiler/GHC/Core/Type.hs:3059:18 in ghc:GHC.Core.Type
+
+ This regression test exists to make sure the fix introduced between 9.8 and 9.11 does not get removed
+ again.
+-}
+
+pattern Bug :: forall. HasCallStack => forall {r :: RuntimeRep} (a :: TYPE r). a
+pattern Bug <- (undefined -> _unused)
+ where
+ Bug = undefined
=====================================
testsuite/tests/polykinds/T24686.stderr
=====================================
@@ -0,0 +1,7 @@
+
+T24686.hs:25:80: error: [GHC-25897]
+ Couldn't match kind ‘r’ with ‘LiftedRep’
+ Expected kind ‘*’, but ‘a’ has kind ‘TYPE r’
+ ‘r’ is a rigid type variable bound by
+ the type signature for ‘Bug’
+ at T24686.hs:25:48
=====================================
testsuite/tests/polykinds/T24686a.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE StandaloneKindSignatures #-}
+module T24686a where
+
+import GHC.Exts
+
+-- This one crashed GHC too: see #24686
+
+type T :: forall a (b:: TYPE a). b
+data T
=====================================
testsuite/tests/polykinds/T24686a.stderr
=====================================
@@ -0,0 +1,8 @@
+
+T24686a.hs:8:34: error: [GHC-25897]
+ • Couldn't match kind ‘a’ with ‘LiftedRep’
+ Expected kind ‘*’, but ‘b’ has kind ‘TYPE a’
+ ‘a’ is a rigid type variable bound by
+ a standalone kind signature for ‘T’
+ at T24686a.hs:8:18
+ • In a standalone kind signature for ‘T’: forall a (b :: TYPE a). b
=====================================
testsuite/tests/polykinds/all.T
=====================================
@@ -245,3 +245,5 @@ test('T22742', normal, compile_fail, [''])
test('T22793', normal, compile_fail, [''])
test('T24083', normal, compile_fail, [''])
test('T24083a', normal, compile, [''])
+test('T24686', normal, compile_fail, [''])
+test('T24686a', normal, compile_fail, [''])
=====================================
testsuite/tests/rep-poly/RepPolyPatSynRes.stderr
=====================================
@@ -1,4 +1,7 @@
-RepPolyPatSynRes.hs:13:1: error: [GHC-18478]
- The pattern synonym scrutinee does not have a fixed runtime representation:
- • a :: TYPE rep
+RepPolyPatSynRes.hs:13:59: error: [GHC-25897]
+ Couldn't match kind ‘rep’ with ‘LiftedRep’
+ Expected kind ‘*’, but ‘a’ has kind ‘TYPE rep’
+ ‘rep’ is a rigid type variable bound by
+ the type signature for ‘Pat’
+ at RepPolyPatSynRes.hs:13:23-25
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d6394dde448341fc222bf7b2aecac04c751d48d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4d6394dde448341fc222bf7b2aecac04c751d48d
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/20240426/e7baf22b/attachment-0001.html>
More information about the ghc-commits
mailing list