diff options
| -rw-r--r-- | compiler/typecheck/TcHsType.lhs | 27 | ||||
| -rw-r--r-- | testsuite/tests/polykinds/T9200.hs | 12 |
2 files changed, 34 insertions, 5 deletions
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 14a3c175f8..d075cbcfbf 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -1067,22 +1067,41 @@ kcStrategy :: TyClDecl Name -> KindCheckingStrategy kcStrategy d@(ForeignType {}) = pprPanic "kcStrategy" (ppr d) kcStrategy (FamDecl fam_decl) = kcStrategyFamDecl fam_decl -kcStrategy (SynDecl {}) = ParametricKinds +kcStrategy (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) + | all_tyvars_annotated tyvars + , rhs_annotated rhs + = FullKindSignature + | otherwise + = ParametricKinds + where + rhs_annotated (L _ ty) = case ty of + HsParTy lty -> rhs_annotated lty + HsKindSig {} -> True + _ -> False kcStrategy decl@(DataDecl {}) = kcStrategyAlgDecl decl kcStrategy decl@(ClassDecl {}) = kcStrategyAlgDecl decl kcStrategyAlgDecl :: TyClDecl Name -> KindCheckingStrategy kcStrategyAlgDecl decl - | all (isHsKindedTyVar . unLoc) (hsQTvBndrs $ tcdTyVars decl) + | all_tyvars_annotated $ tcdTyVars decl = FullKindSignature | otherwise = ParametricKinds --- if the ClosedTypeFamily has no equations, do the defaulting to *, etc. kcStrategyFamDecl :: FamilyDecl Name -> KindCheckingStrategy -kcStrategyFamDecl (FamilyDecl { fdInfo = ClosedTypeFamily (_:_) }) = NonParametricKinds +kcStrategyFamDecl (FamilyDecl { fdInfo = ClosedTypeFamily _ + , fdTyVars = tyvars + , fdKindSig = Just _ }) + | all (isHsKindedTyVar . unLoc) (hsQTvBndrs tyvars) + = FullKindSignature +-- if the ClosedTypeFamily has no equations, do the defaulting to *, etc. +kcStrategyFamDecl (FamilyDecl { fdInfo = ClosedTypeFamily (_:_) }) = ParametricKinds kcStrategyFamDecl _ = FullKindSignature +-- | Are all the type variables given with a kind annotation? +all_tyvars_annotated :: LHsTyVarBndrs name -> Bool +all_tyvars_annotated = all (isHsKindedTyVar . unLoc) . hsQTvBndrs + mkKindSigVar :: Name -> TcM KindVar -- Use the specified name; don't clone it mkKindSigVar n diff --git a/testsuite/tests/polykinds/T9200.hs b/testsuite/tests/polykinds/T9200.hs index b74177a54c..ca050661a2 100644 --- a/testsuite/tests/polykinds/T9200.hs +++ b/testsuite/tests/polykinds/T9200.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE PolyKinds, MultiParamTypeClasses, FlexibleContexts, DataKinds #-} +{-# LANGUAGE PolyKinds, MultiParamTypeClasses, FlexibleContexts, DataKinds, + TypeFamilies #-} module T9200 where @@ -17,3 +18,12 @@ data T1 a b c = MkT1 (S True b c) data T2 p q r = MkT2 (S p 5 r) data T3 x y q = MkT3 (S x y '()) type S (f :: k1) (g :: k2) (h :: k3) = ((T1 f g h, T2 f g h, T3 f g h) :: *) + + +---------- +-- test CUSK on closed type families +type family F (a :: k) :: k where + F True = False + F False = True + F x = x + |