[commit: ghc] wip/rae: Change treatment of CUSKs for synonyms and families (#9200). (077d880)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/rae
Link       : http://ghc.haskell.org/trac/ghc/changeset/077d880ba2a7c3a9684ac911828d943d1e920bc7/ghc

>---------------------------------------------------------------

commit 077d880ba2a7c3a9684ac911828d943d1e920bc7
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Thu Aug 7 08:28:32 2014 -0400

    Change treatment of CUSKs for synonyms and families (#9200).


>---------------------------------------------------------------

077d880ba2a7c3a9684ac911828d943d1e920bc7
 compiler/typecheck/TcHsType.lhs    | 27 +++++++++++++++++++++++----
 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 14a3c17..d075cbc 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 b74177a..ca05066 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
+