[Git][ghc/ghc][wip/cusk-ext] Guard CUSKs behind a language pragma
Vladislav Zavialov
gitlab at gitlab.haskell.org
Fri May 10 17:31:24 UTC 2019
Vladislav Zavialov pushed to branch wip/cusk-ext at Glasgow Haskell Compiler / GHC
Commits:
d0d3d38a by Vladislav Zavialov at 2019-05-10T17:30:50Z
Guard CUSKs behind a language pragma
GHC Proposal #36 describes a transition plan away from CUSKs and to
top-level kind signatures:
1. Introduce a new extension, -XCUSKs, on by default, that detects CUSKs
as they currently exist.
2. We turn off the -XCUSKs extension in a few releases and remove it
sometime thereafter.
This patch implements phase 1 of this plan, introducing a new language
extension to control whether CUSKs are enabled. When top-level kind
signatures are implemented, we can transition to phase 2.
- - - - -
10 changed files:
- compiler/hsSyn/HsDecls.hs
- compiler/main/DynFlags.hs
- compiler/rename/RnSource.hs
- compiler/typecheck/TcTyClsDecls.hs
- docs/users_guide/glasgow_exts.rst
- libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
- testsuite/tests/driver/T4437.hs
- testsuite/tests/typecheck/should_fail/all.T
- + testsuite/tests/typecheck/should_fail/tcfail225.hs
- + testsuite/tests/typecheck/should_fail/tcfail225.stderr
Changes:
=====================================
compiler/hsSyn/HsDecls.hs
=====================================
@@ -679,11 +679,15 @@ countTyClDecls decls
-- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures]
-hsDeclHasCusk :: TyClDecl GhcRn -> Bool
-hsDeclHasCusk (FamDecl { tcdFam = fam_decl })
- = famDeclHasCusk False fam_decl
+hsDeclHasCusk
+ :: Bool -- True <=> the -XCUSKs extension is enabled
+ -> TyClDecl GhcRn
+ -> Bool
+hsDeclHasCusk _cusks_enabled at False _ = False
+hsDeclHasCusk cusks_enabled (FamDecl { tcdFam = fam_decl })
+ = famDeclHasCusk cusks_enabled False fam_decl
-- False: this is not: an associated type of a class with no cusk
-hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
+hsDeclHasCusk _cusks_enabled at True (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
-- NB: Keep this synchronized with 'getInitialKind'
= hsTvbAllKinded tyvars && rhs_annotated rhs
where
@@ -691,9 +695,9 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
HsParTy _ lty -> rhs_annotated lty
HsKindSig {} -> True
_ -> False
-hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
-hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
-hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk"
+hsDeclHasCusk _cusks_enabled at True (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
+hsDeclHasCusk _cusks_enabled at True (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
+hsDeclHasCusk _ (XTyClDecl _) = panic "hsDeclHasCusk"
-- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -787,6 +791,10 @@ declaration before checking all of the others, supporting polymorphic recursion.
See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/kind-inference#proposed-new-strategy
and #9200 for lots of discussion of how we got here.
+The detection of CUSKs is enabled by the -XCUSKs extension, switched on by default.
+Under -XNoCUSKs, all declarations are treated as if they have no CUSK.
+See https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst
+
PRINCIPLE:
a type declaration has a CUSK iff we could produce a separate kind signature
for it, just like a type signature for a function,
@@ -1080,11 +1088,13 @@ data FamilyInfo pass
-- | Does this family declaration have a complete, user-supplied kind signature?
-- See Note [CUSKs: complete user-supplied kind signatures]
-famDeclHasCusk :: Bool -- ^ True <=> this is an associated type family,
+famDeclHasCusk :: Bool -- ^ True <=> the -XCUSKs extension is enabled
+ -> Bool -- ^ True <=> this is an associated type family,
-- and the parent class has /no/ CUSK
-> FamilyDecl pass
-> Bool
-famDeclHasCusk assoc_with_no_cusk
+famDeclHasCusk _cusks_enabled at False _ _ = False
+famDeclHasCusk _cusks_enabled at True assoc_with_no_cusk
(FamilyDecl { fdInfo = fam_info
, fdTyVars = tyvars
, fdResultSig = L _ resultSig })
@@ -1095,7 +1105,7 @@ famDeclHasCusk assoc_with_no_cusk
-- Un-associated open type/data families have CUSKs
-- Associated type families have CUSKs iff the parent class does
-famDeclHasCusk _ (XFamilyDecl {}) = panic "famDeclHasCusk"
+famDeclHasCusk _ _ (XFamilyDecl {}) = panic "famDeclHasCusk"
-- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool
=====================================
compiler/main/DynFlags.hs
=====================================
@@ -2260,6 +2260,7 @@ languageExtensions (Just Haskell98)
= [LangExt.ImplicitPrelude,
-- See Note [When is StarIsType enabled]
LangExt.StarIsType,
+ LangExt.CUSKs,
LangExt.MonomorphismRestriction,
LangExt.NPlusKPatterns,
LangExt.DatatypeContexts,
@@ -2276,6 +2277,7 @@ languageExtensions (Just Haskell2010)
= [LangExt.ImplicitPrelude,
-- See Note [When is StarIsType enabled]
LangExt.StarIsType,
+ LangExt.CUSKs,
LangExt.MonomorphismRestriction,
LangExt.DatatypeContexts,
LangExt.TraditionalRecordSyntax,
@@ -4358,6 +4360,7 @@ xFlagsDeps = [
flagSpec "BinaryLiterals" LangExt.BinaryLiterals,
flagSpec "CApiFFI" LangExt.CApiFFI,
flagSpec "CPP" LangExt.Cpp,
+ flagSpec "CUSKs" LangExt.CUSKs,
flagSpec "ConstrainedClassMethods" LangExt.ConstrainedClassMethods,
flagSpec "ConstraintKinds" LangExt.ConstraintKinds,
flagSpec "DataKinds" LangExt.DataKinds,
=====================================
compiler/rename/RnSource.hs
=====================================
@@ -1552,7 +1552,8 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
do { (defn', fvs) <- rnDataDefn doc defn
-- See Note [Complete user-supplied kind signatures] in HsDecls
- ; let cusk = hsTvbAllKinded tyvars' && no_rhs_kvs
+ ; cusks_enabled <- xoptM LangExt.CUSKs
+ ; let cusk = cusks_enabled && hsTvbAllKinded tyvars' && no_rhs_kvs
rn_info = DataDeclRn { tcdDataCusk = cusk
, tcdFVs = fvs }
; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
=====================================
compiler/typecheck/TcTyClsDecls.hs
=====================================
@@ -510,8 +510,9 @@ kcTyClGroup decls
-- 3. Generalise the inferred kinds
-- See Note [Kind checking for type and class decls]
+ ; cusks_enabled <- xoptM LangExt.CUSKs
; let (cusk_decls, no_cusk_decls)
- = partition (hsDeclHasCusk . unLoc) decls
+ = partition (hsDeclHasCusk cusks_enabled . unLoc) decls
; poly_cusk_tcs <- getInitialKinds True cusk_decls
@@ -1040,17 +1041,25 @@ getInitialKind cusk (FamDecl { tcdFam = decl })
getInitialKind cusk (SynDecl { tcdLName = dL->L _ name
, tcdTyVars = ktvs
, tcdRhs = rhs })
- = do { tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $
- case kind_annotation rhs of
+ = do { cusks_enabled <- xoptM LangExt.CUSKs
+ ; tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $
+ case kind_annotation cusks_enabled rhs of
Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig
- Nothing -> newMetaKindVar
+ Nothing -> newMetaKindVar
; return [tycon] }
where
-- Keep this synchronized with 'hsDeclHasCusk'.
- kind_annotation (dL->L _ ty) = case ty of
- HsParTy _ lty -> kind_annotation lty
- HsKindSig _ _ k -> Just k
- _ -> Nothing
+ kind_annotation
+ :: Bool -- cusks_enabled?
+ -> LHsType GhcRn -- rhs
+ -> Maybe (LHsKind GhcRn)
+ kind_annotation False = const Nothing
+ kind_annotation True = go
+ where
+ go (dL->L _ ty) = case ty of
+ HsParTy _ lty -> go lty
+ HsKindSig _ _ k -> Just k
+ _ -> Nothing
getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind"
getInitialKind _ (XTyClDecl _) = panic "getInitialKind"
@@ -1074,18 +1083,20 @@ getFamDeclInitialKind parent_cusk mb_parent_tycon
, fdTyVars = ktvs
, fdResultSig = (dL->L _ resultSig)
, fdInfo = info })
- = kcLHsQTyVars name flav fam_cusk ktvs $
- case resultSig of
- KindSig _ ki -> tcLHsKindSig ctxt ki
- TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki
- _ -- open type families have * return kind by default
- | tcFlavourIsOpen flav -> return liftedTypeKind
- -- closed type families have their return kind inferred
- -- by default
- | otherwise -> newMetaKindVar
+ = do { cusks_enabled <- xoptM LangExt.CUSKs
+ ; kcLHsQTyVars name flav (fam_cusk cusks_enabled) ktvs $
+ case resultSig of
+ KindSig _ ki -> tcLHsKindSig ctxt ki
+ TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki
+ _ -- open type families have * return kind by default
+ | tcFlavourIsOpen flav -> return liftedTypeKind
+ -- closed type families have their return kind inferred
+ -- by default
+ | otherwise -> newMetaKindVar
+ }
where
assoc_with_no_cusk = isJust mb_parent_tycon && not parent_cusk
- fam_cusk = famDeclHasCusk assoc_with_no_cusk decl
+ fam_cusk cusks_enabled = famDeclHasCusk cusks_enabled assoc_with_no_cusk decl
flav = case info of
DataFamily -> DataFamilyFlavour mb_parent_tycon
OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon
=====================================
docs/users_guide/glasgow_exts.rst
=====================================
@@ -9012,6 +9012,11 @@ do so.
Complete user-supplied kind signatures and polymorphic recursion
----------------------------------------------------------------
+.. extension:: CUSKs
+ :shortdesc: Enable detection of complete user-supplied kind signatures.
+
+ :since: 8.10.1
+
Just as in type inference, kind inference for recursive types can only
use *monomorphic* recursion. Consider this (contrived) example: ::
@@ -9110,6 +9115,13 @@ example, consider ::
According to the rules above ``X`` has a CUSK. Yet, the kind of ``k`` is undetermined.
It is thus quantified over, giving ``X`` the kind ``forall k1 (k :: k1). Proxy k -> Type``.
+The detection of CUSKs is enabled by the :extension:`CUSKs` flag, which is
+switched on by default. When :extension:`CUSKs` is switched off, there is
+currently no way to enable polymorphic recursion in types. In the future, the
+notion of a CUSK will be replaced by top-level kind signatures
+(`GHC Proposal #36 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst>`__),
+then, after a transition period, this extension will be turned off by default, and eventually removed.
+
Kind inference in closed type families
--------------------------------------
=====================================
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
=====================================
@@ -140,4 +140,5 @@ data Extension
| QuantifiedConstraints
| StarIsType
| ImportQualifiedPost
+ | CUSKs
deriving (Eq, Enum, Show, Generic, Bounded)
=====================================
testsuite/tests/driver/T4437.hs
=====================================
@@ -41,6 +41,7 @@ expectedGhcOnlyExtensions = ["RelaxedLayout",
"AlternativeLayoutRuleTransitional",
"EmptyDataDeriving",
"GeneralisedNewtypeDeriving",
+ "CUSKs",
"ImportQualifiedPost"]
expectedCabalOnlyExtensions :: [String]
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -241,6 +241,7 @@ test('tcfail217', normal, compile_fail, [''])
test('tcfail218', normal, compile_fail, [''])
test('tcfail223', normal, compile_fail, [''])
test('tcfail224', normal, compile_fail, [''])
+test('tcfail225', normal, compile_fail, [''])
test('SilentParametersOverlapping', normal, compile, [''])
test('FailDueToGivenOverlapping', normal, compile_fail, [''])
=====================================
testsuite/tests/typecheck/should_fail/tcfail225.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE PolyKinds, GADTs #-}
+{-# LANGUAGE NoCUSKs #-}
+
+module TcFail225 where
+
+import Data.Kind (Type)
+
+data T (m :: k -> Type) :: k -> Type where
+ MkT :: m a -> T Maybe (m a) -> T m a
=====================================
testsuite/tests/typecheck/should_fail/tcfail225.stderr
=====================================
@@ -0,0 +1,6 @@
+
+tcfail225.hs:9:19: error:
+ • Expected kind ‘k -> *’, but ‘Maybe’ has kind ‘* -> *’
+ • In the first argument of ‘T’, namely ‘Maybe’
+ In the type ‘T Maybe (m a)’
+ In the definition of data constructor ‘MkT’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/d0d3d38a260695953e0244a75a67ef78ea23d119
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/d0d3d38a260695953e0244a75a67ef78ea23d119
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/20190510/8962b0be/attachment-0001.html>
More information about the ghc-commits
mailing list