From d0d3d38a260695953e0244a75a67ef78ea23d119 Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Thu, 9 May 2019 01:53:26 +0300 Subject: 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. --- compiler/hsSyn/HsDecls.hs | 30 +++++++++----- compiler/main/DynFlags.hs | 3 ++ compiler/rename/RnSource.hs | 3 +- compiler/typecheck/TcTyClsDecls.hs | 47 +++++++++++++--------- docs/users_guide/glasgow_exts.rst | 12 ++++++ .../ghc-boot-th/GHC/LanguageExtensions/Type.hs | 1 + testsuite/tests/driver/T4437.hs | 1 + testsuite/tests/typecheck/should_fail/all.T | 1 + testsuite/tests/typecheck/should_fail/tcfail225.hs | 9 +++++ .../tests/typecheck/should_fail/tcfail225.stderr | 6 +++ 10 files changed, 84 insertions(+), 29 deletions(-) create mode 100644 testsuite/tests/typecheck/should_fail/tcfail225.hs create mode 100644 testsuite/tests/typecheck/should_fail/tcfail225.stderr diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index c194c2e21a..e328bf43c7 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/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@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@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@True (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk +hsDeclHasCusk _cusks_enabled@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@False _ _ = False +famDeclHasCusk _cusks_enabled@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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index ece0c2208e..e407937ad7 100644 --- a/compiler/main/DynFlags.hs +++ b/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, diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index e7ff909c02..537f283183 100644 --- a/compiler/rename/RnSource.hs +++ b/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) diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 8b5142158d..a825573dba 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/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 diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 5fef204831..bce2bf8370 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/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 `__), +then, after a transition period, this extension will be turned off by default, and eventually removed. + Kind inference in closed type families -------------------------------------- diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs index 565187be59..ac47e165ff 100644 --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -140,4 +140,5 @@ data Extension | QuantifiedConstraints | StarIsType | ImportQualifiedPost + | CUSKs deriving (Eq, Enum, Show, Generic, Bounded) diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index 2f28c05ec2..b8ef646a9b 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -41,6 +41,7 @@ expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRuleTransitional", "EmptyDataDeriving", "GeneralisedNewtypeDeriving", + "CUSKs", "ImportQualifiedPost"] expectedCabalOnlyExtensions :: [String] diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index c51398f00b..c4c5040b9b 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/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, ['']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail225.hs b/testsuite/tests/typecheck/should_fail/tcfail225.hs new file mode 100644 index 0000000000..c01f49fdd1 --- /dev/null +++ b/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 diff --git a/testsuite/tests/typecheck/should_fail/tcfail225.stderr b/testsuite/tests/typecheck/should_fail/tcfail225.stderr new file mode 100644 index 0000000000..5a3ba3681f --- /dev/null +++ b/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’ -- cgit v1.2.1