compiler/basicTypes/DataCon.lhs

@@ -1004,13 +1004,13 @@ buildAlgTyCon :: Name
 	      -> ThetaType	       -- ^ Stupid theta
 	      -> AlgTyConRhs
 	      -> RecFlag
-	      -> Bool		       -- ^ True <=> this TyCon is promotable
+              -> PromotionInfo ()
 	      -> Bool		       -- ^ True <=> was declared in GADT syntax
               -> TyConParent
 	      -> TyCon
 
 buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs 
-              is_rec is_promotable gadt_syn parent
+              is_rec prom_flavor gadt_syn parent
   = tc
   where 
     kind = mkPiKinds ktvs liftedTypeKind
@@ -1018,11 +1018,10 @@ buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
     -- tc and mb_promoted_tc are mutually recursive
     tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta 
                     rhs parent is_rec gadt_syn 
-                    mb_promoted_tc
+                    promotion_info
 
-    mb_promoted_tc
-      | is_promotable = Just (mkPromotedTyCon tc (promoteKind kind))
-      | otherwise     = Nothing
+    promotion_info =
+      fmap (\ _ -> mkPromotedTyCon tc (promoteKind kind)) prom_flavor
 \end{code}
 
 

compiler/hsSyn/Convert.lhs

@@ -166,6 +166,7 @@ cvtDec (DataD ctxt tc tvs constrs derivs)
         ; cons' <- mapM cvtConstr constrs
         ; derivs' <- cvtDerivs derivs
         ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+                                , dd_try_promote = True
                                 , dd_ctxt = ctxt'
                                 , dd_kindSig = Nothing
                                 , dd_cons = cons', dd_derivs = derivs' }
@@ -177,6 +178,7 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs)
         ; con' <- cvtConstr constr
         ; derivs' <- cvtDerivs derivs
         ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+                                , dd_try_promote = True
                                 , dd_ctxt = ctxt'
                                 , dd_kindSig = Nothing
                                 , dd_cons = [con'], dd_derivs = derivs' }
@@ -224,6 +226,7 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
        ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
+                               , dd_try_promote = True
                                , dd_ctxt = ctxt'
                                , dd_kindSig = Nothing
                                , dd_cons = cons', dd_derivs = derivs' }
@@ -237,6 +240,7 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs)
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
        ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
+                               , dd_try_promote = True
                                , dd_ctxt = ctxt'
                                , dd_kindSig = Nothing
                                , dd_cons = [con'], dd_derivs = derivs' }

compiler/hsSyn/HsDecls.lhs

@@ -16,7 +16,7 @@ module HsDecls (
   HsDecl(..), LHsDecl, HsDataDefn(..),
   -- ** Class or type declarations
   TyClDecl(..), LTyClDecl, TyClGroup,
-  isClassDecl, isDataDecl, isSynDecl, tcdName,
+  isClassDecl, isDataDecl, isKindDecl, isSynDecl, tcdName,
   isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
   isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
   tyFamInstDeclName, tyFamInstDeclLName,
@@ -50,6 +50,8 @@ module HsDecls (
   -- ** Data-constructor declarations
   ConDecl(..), LConDecl, ResType(..), 
   HsConDeclDetails, hsConDeclArgTys, 
+  TyConDecl(..), LTyConDecl,
+  HsTyConDeclDetails,
   -- ** Document comments
   DocDecl(..), LDocDecl, docDeclDoc,
   -- ** Deprecations
@@ -456,6 +458,12 @@ data TyClDecl name
              , tcdDataDefn :: HsDataDefn name
              , tcdFVs      :: NameSet }
 
+  | -- | @data kind@ declaration
+    KindDecl { tcdLName    :: Located name
+             , tcdKVars    :: [Located name]
+             , tcdTypeCons :: [LTyConDecl name]
+             , tcdFvs      :: NameSet }
+
   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
                 tcdLName   :: Located name,             -- ^ Name of the class
                 tcdTyVars  :: LHsTyVarBndrs name,       -- ^ Class type variables
@@ -497,6 +505,10 @@ isDataDecl :: TyClDecl name -> Bool
 isDataDecl (DataDecl {}) = True
 isDataDecl _other        = False
 
+isKindDecl :: TyClDecl name -> Bool
+isKindDecl (KindDecl {}) = True
+isKindDecl _             = False
+
 -- | type or type instance declaration
 isSynDecl :: TyClDecl name -> Bool
 isSynDecl (SynDecl {})   = True
@@ -566,6 +578,7 @@ tyClDeclTyVars d = tcdTyVars d
 \begin{code}
 countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int)
         -- class, synonym decls, data, newtype, family decls
+        -- we don't count `data kind` decls here
 countTyClDecls decls 
  = (count isClassDecl    decls,
     count isSynDecl      decls,  -- excluding...
@@ -596,6 +609,9 @@ instance OutputableBndr name
     ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn })
       = pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn
 
+    ppr (KindDecl { tcdLName = lkcon, tcdKVars = kvars, tcdTypeCons = cons })
+      = pp_kind_decl lkcon kvars cons
+
     ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, 
                     tcdFDs  = fds,
                     tcdSigs = sigs, tcdMeths = methods,
@@ -660,6 +676,7 @@ pprTyClDeclFlavour (FamDecl {})    = ptext (sLit "family")
 pprTyClDeclFlavour (SynDecl {})    = ptext (sLit "type")
 pprTyClDeclFlavour (DataDecl { tcdDataDefn = (HsDataDefn { dd_ND = nd }) })
   = ppr nd
+pprTyClDeclFlavour (KindDecl {})    = ptext (sLit "data kind")
 pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type")
 \end{code}
 
@@ -682,6 +699,10 @@ data HsDataDefn name   -- The payload of a data type defn
     HsDataDefn { dd_ND     :: NewOrData,
                  dd_ctxt   :: LHsContext name,           -- ^ Context
                  dd_cType  :: Maybe CType,
+                 dd_try_promote :: Bool,
+                 -- ^ This boolean determines whether we should try to promote
+                 -- the type.  Even if it's True, the type may still not be
+                 -- promotable.
                  dd_kindSig:: Maybe (LHsKind name),
                      -- ^ Optional kind signature.
                      --
@@ -769,6 +790,28 @@ data ConDecl name
         -- need to report decprecated use
     } deriving (Data, Typeable)
 
+type LTyConDecl name = Located (TyConDecl name)
+
+type HsTyConDeclDetails name = HsConDetails (LHsKind name) ()
+
+-- | The type constructor for the right hand side of a @data kind@ declaration.
+data TyConDecl name
+  = TyConDecl
+    { tycon_name    :: Located name            -- ^ name of type constructor
+    , tycon_details :: HsTyConDeclDetails name -- ^ argument kinds
+    , tycon_doc     :: Maybe LHsDocString      -- ^ optional documentation
+    } deriving (Data, Typeable)
+
+instance OutputableBndr name => Outputable (TyConDecl name) where
+  ppr TyConDecl { tycon_name = name, tycon_details = details
+                , tycon_doc = doc }
+    = sep [ppr_mbDoc doc, ppr_details]
+    where
+    ppr_details = case details of
+      InfixCon l r   -> hsep [ppr l, pprInfixOcc (unLoc name), ppr r]
+      PrefixCon args -> hsep (pprPrefixOcc (unLoc name) : map (pprParendHsType .  unLoc) args)
+      RecCon _       -> panic "Outputtable (TyConDecl name)" "unexpected record constructor"
+
 type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]
 
 hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
@@ -790,20 +833,35 @@ instance Outputable ty => Outputable (ResType ty) where
 
 
 \begin{code}
+
+pp_kind_decl :: OutputableBndr name
+             => Located name -> [Located name] -> [LTyConDecl name] -> SDoc
+pp_kind_decl kname kvars cons
+  = ptext (sLit "data kind") <+> ppr (unLoc kname)
+    <+> hsep (map (ppr . unLoc) kvars) <+> rhs
+
+  where
+  rhs | null cons = empty
+      | otherwise = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cons))
+
 pp_data_defn :: OutputableBndr name
                   => (HsContext name -> SDoc)   -- Printing the header
                   -> HsDataDefn name
                   -> SDoc 
 pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
+                                , dd_try_promote = try_promote
                                 , dd_kindSig = mb_sig 
                                 , dd_cons = condecls, dd_derivs = derivings })
   | null condecls
-  = ppr new_or_data <+> pp_hdr context <+> pp_sig
+  = ppr new_or_data <+> pp_prom <+> pp_hdr context <+> pp_sig
 
   | otherwise
-  = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig)
+  = hang (ppr new_or_data <+> pp_prom <+> pp_hdr context <+> pp_sig)
        2 (pp_condecls condecls $$ pp_derivings)
   where
+    pp_prom | try_promote = empty
+            | otherwise   = ptext (sLit "type")
+
     pp_sig = case mb_sig of
                Nothing   -> empty
                Just kind -> dcolon <+> ppr kind

compiler/hsSyn/HsUtils.lhs

@@ -655,6 +655,9 @@ hsTyClDeclBinders (ClassDecl { tcdLName = cls_name, tcdSigs = sigs
 hsTyClDeclBinders (DataDecl { tcdLName = name, tcdDataDefn = defn }) 
   = name : hsDataDefnBinders defn
 
+hsTyClDeclBinders (KindDecl { tcdLName = name, tcdTypeCons = cons })
+  = name : map (tycon_name . unLoc) cons
+
 -------------------
 hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
 hsInstDeclBinders (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })

compiler/iface/IfaceSyn.lhs

@@ -16,12 +16,14 @@ module IfaceSyn (
 
         IfaceDecl(..), IfaceSynTyConRhs(..), IfaceClassOp(..), IfaceAT(..), 
         IfaceConDecl(..), IfaceConDecls(..),
+        IfaceTyConDecl(..),
         IfaceExpr(..), IfaceAlt, IfaceLetBndr(..),
         IfaceBinding(..), IfaceConAlt(..),
         IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
         IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), 
         IfaceBang(..), IfaceAxBranch(..),
+        IfacePromotionInfo(..),
 
         -- Misc
         ifaceDeclImplicitBndrs, visibleIfConDecls,
@@ -76,6 +78,12 @@ data IfaceDecl
               ifIdDetails :: IfaceIdDetails,
               ifIdInfo    :: IfaceIdInfo }
 
+  | IfaceDataKind { ifName   :: OccName,         -- Kind constructor
+                    ifRec    :: RecFlag,         -- Recursive or not?
+                    ifKVars  :: [IfaceTvBndr],   -- Kind parameters
+                    ifTyCons :: [IfaceTyConDecl] -- Type constructors of this kind
+    }
+
   | IfaceData { ifName       :: OccName,        -- Type constructor
                 ifCType      :: Maybe CType,    -- C type for CAPI FFI
                 ifTyVars     :: [IfaceTvBndr],  -- Type variables
@@ -83,7 +91,7 @@ data IfaceDecl
                 ifCtxt       :: IfaceContext,   -- The "stupid theta"
                 ifCons       :: IfaceConDecls,  -- Includes new/data/data family info
                 ifRec        :: RecFlag,        -- Recursive or not?
-                ifPromotable :: Bool,           -- Promotable to kind level?
+                ifPromotable :: IfacePromotionInfo,-- Promotable to kind level?
                 ifGadtSyntax :: Bool,           -- True <=> declared using
                                                 -- GADT syntax
                 ifAxiom      :: Maybe IfExtName -- The axiom, for a newtype, 
@@ -173,6 +181,14 @@ instance Binary IfaceDecl where
         put_ bh a3
         put_ bh a4
 
+    put_ bh (IfaceDataKind a1 a2 a3 a4) = do
+        putByte bh 6
+        put_ bh (occNameFS a1)
+        put_ bh a2
+        put_ bh a3
+        put_ bh a4
+
+
     get bh = do
         h <- getByte bh
         case h of
@@ -212,12 +228,37 @@ instance Binary IfaceDecl where
                     a8 <- get bh
                     occ <- return $! mkOccNameFS clsName a2
                     return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8)
-            _ -> do a1 <- get bh
+            5 -> do a1 <- get bh
                     a2 <- get bh
                     a3 <- get bh
                     a4 <- get bh
                     occ <- return $! mkOccNameFS tcName a1
                     return (IfaceAxiom occ a2 a3 a4)
+            6 -> do a1 <- get bh
+                    a2 <- get bh
+                    a3 <- get bh
+                    a4 <- get bh
+                    occ <- return $! mkOccNameFS tcName a1
+                    return (IfaceDataKind occ a2 a3 a4)
+            _ -> error ("Binary.get(TyClDecl): Unknown tag " ++ show h)
+
+data IfacePromotionInfo
+  = IfaceNeverPromote
+  | IfaceNotPromotable
+  | IfacePromotable
+
+instance Binary IfacePromotionInfo where
+  put_ bh p = case p of
+    IfaceNeverPromote  -> putByte bh 0x0
+    IfaceNotPromotable -> putByte bh 0x1
+    IfacePromotable    -> putByte bh 0x2
+  get bh = do
+    tag <- getByte bh
+    case tag of
+      0x0 -> return IfaceNeverPromote
+      0x1 -> return IfaceNotPromotable
+      0x2 -> return IfacePromotable
+      _   -> error ("Binary.get(Promotable ()): Unknown tag " ++ show tag)
 
 data IfaceSynTyConRhs
   = IfaceOpenSynFamilyTyCon
@@ -398,6 +439,25 @@ instance Binary IfaceBang where
               2 -> do return IfUnpack
               _ -> do { a <- get bh; return (IfUnpackCo a) }
 
+data IfaceTyConDecl
+  = IfTyCon {
+        ifTyConOcc   :: OccName,     -- constructor name
+        ifTyConArgKs :: [IfaceKind], -- constructor argument kinds
+        ifTyConRoles :: [Role]       -- constructor argument roles
+    }
+
+instance Binary IfaceTyConDecl where
+  put_ bh (IfTyCon a1 a2 a3) = do
+    put_ bh (occNameFS a1)
+    put_ bh a2
+    put_ bh a3
+  get bh = do
+    a1 <- get bh
+    a2 <- get bh
+    a3 <- get bh
+    occ <- return $! mkOccNameFS tcName a1
+    return (IfTyCon occ a2 a3)
+
 data IfaceClsInst
   = IfaceClsInst { ifInstCls  :: IfExtName,                -- See comments with
                    ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst
@@ -951,6 +1011,9 @@ ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ,
           has_wrapper = ifConWrapper con_decl     -- This is the reason for
                                                   -- having the ifConWrapper field!
 
+ifaceDeclImplicitBndrs IfaceDataKind { ifTyCons = cons }
+  = map ifTyConOcc cons
+
 ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ,
                                ifSigs = sigs, ifATs = ats })
   = --   (possibly) newtype coercion
@@ -1020,6 +1083,15 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles,
   = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars roles)
        4 (dcolon <+> ppr kind)
 
+pprIfaceDecl IfaceDataKind {ifName = kcon, ifKVars = kvars,
+                            ifTyCons = tycons }
+  -- XXX what should the roles argument be here?
+  = hang (ptext (sLit "data kind") <+> pprIfaceDeclHead [] kcon kvars []) 4 $
+    if null tycons
+       then empty
+       else equals <+> sep (punctuate (ptext (sLit " |")) (map pprIfaceTyConDecl tycons))
+
+
 -- this case handles both abstract and instantiated closed family tycons
 pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles,
                         ifSynRhs = _closedSynFamilyTyCon, ifSynKind = kind })
@@ -1037,8 +1109,11 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
                , pp_condecls tycon condecls
                , pprAxiom mbAxiom])
   where
-    pp_prom | is_prom   = ptext (sLit "Promotable")
-            | otherwise = ptext (sLit "Not promotable")
+    pp_prom = case is_prom of
+      IfaceNeverPromote  -> ptext (sLit "Never promotable")
+      IfaceNotPromotable -> ptext (sLit "Not promotable")
+      IfacePromotable    -> ptext (sLit "Promotable")
+
     pp_nd = case condecls of
                 IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis)
                 IfDataFamTyCon     -> ptext (sLit "data family")
@@ -1086,6 +1161,10 @@ pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c
 pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
                                                             (map (pprIfaceConDecl tc) cs))
 
+pprIfaceTyConDecl :: IfaceTyConDecl -> SDoc
+pprIfaceTyConDecl IfTyCon { ifTyConOcc = name, ifTyConArgKs = kinds }
+  = hsep (parenSymOcc name (ppr name) : map pprParendIfaceType kinds)
+
 mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType
 -- IA0_NOTE: This is wrong, but only used for pretty-printing.
 mkIfaceEqPred ty1 ty2 = IfaceTyConApp (IfaceTc eqTyConName) [ty1, ty2]
@@ -1306,6 +1385,9 @@ freeNamesIfDecl d@IfaceData{} =
   maybe emptyNameSet unitNameSet (ifAxiom d) &&&
   freeNamesIfContext (ifCtxt d) &&&
   freeNamesIfConDecls (ifCons d)
+freeNamesIfDecl d@IfaceDataKind{} =
+  freeNamesIfTvBndrs (ifKVars d) &&&
+  fnList freeNamesIfTyConDecl (ifTyCons d)
 freeNamesIfDecl d@IfaceSyn{} =
   freeNamesIfTvBndrs (ifTyVars d) &&&
   freeNamesIfSynRhs (ifSynRhs d) &&&
@@ -1355,6 +1437,10 @@ freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c
 freeNamesIfConDecls (IfNewTyCon c)  = freeNamesIfConDecl c
 freeNamesIfConDecls _               = emptyNameSet
 
+freeNamesIfTyConDecl :: IfaceTyConDecl -> NameSet
+freeNamesIfTyConDecl c =
+  fnList freeNamesIfKind (ifTyConArgKs c)
+
 freeNamesIfConDecl :: IfaceConDecl -> NameSet
 freeNamesIfConDecl c =
   freeNamesIfTvBndrs (ifConUnivTvs c) &&&

compiler/iface/MkIface.lhs

@@ -1499,6 +1499,12 @@ tyConToIfaceDecl env tycon
                 ifSynRhs  = to_ifsyn_rhs syn_rhs,
                 ifSynKind = tidyToIfaceType env1 (synTyConResKind tycon) }
 
+  | DataKindTyCon cons <- algTyConRhs tycon
+  = IfaceDataKind { ifName   = getOccName tycon
+                  , ifRec    = boolToRecFlag (isRecursiveTyCon tycon)
+                  , ifKVars  = toIfaceTvBndrs tyvars
+                  , ifTyCons = map ifaceTyConDecl cons }
+
   | isAlgTyCon tycon
   = IfaceData { ifName    = getOccName tycon,
                 ifCType   = tyConCType tycon,
@@ -1508,7 +1514,8 @@ tyConToIfaceDecl env tycon
                 ifCons    = ifaceConDecls (algTyConRhs tycon),
                 ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
                 ifGadtSyntax = isGadtSyntaxTyCon tycon,
-                ifPromotable = isJust (promotableTyCon_maybe tycon),
+                ifPromotable = toIfacePromotionInfo
+                             $ fmap (\_ -> ()) (promotableTyConInfo tycon),
                 ifAxiom   = fmap coAxiomName (tyConFamilyCoercion_maybe tycon) }
 
   | isForeignTyCon tycon
@@ -1534,6 +1541,7 @@ tyConToIfaceDecl env tycon
         -- Furthermore, tyThingToIfaceDecl is also used
         -- in TcRnDriver for GHCi, when browsing a module, in which case the
         -- AbstractTyCon case is perfectly sensible.
+    ifaceConDecls DataKindTyCon{}                   = pprPanic "ifaceConDecls" (ptext (sLit "unexpected 'data kind' rhs"))
 
     ifaceConDecl data_con
         = IfCon   { ifConOcc     = getOccName (dataConName data_con),
@@ -1557,6 +1565,19 @@ tyConToIfaceDecl env tycon
           to_eq_spec spec = [ (getOccName (tidyTyVar env2 tv), tidyToIfaceType env2 ty)
                             | (tv,ty) <- spec]
 
+    ifaceTyConDecl ty_con
+        = IfTyCon { ifTyConOcc   = getOccName (tyConName ty_con),
+                    ifTyConArgKs = map (tidyToIfaceType emptyTidyEnv) args,
+                    ifTyConRoles = tyConRoles ty_con }
+        where
+          (args,_) = splitFunTys (tyConKind ty_con)
+
+toIfacePromotionInfo :: PromotionInfo () -> IfacePromotionInfo
+toIfacePromotionInfo pi = case pi of
+  NeverPromote  -> IfaceNeverPromote
+  NotPromotable -> IfaceNotPromotable
+  Promotable () -> IfacePromotable
+
 toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
 toIfaceBang _    HsNoBang            = IfNoBang
 toIfaceBang _   (HsUnpack Nothing)   = IfUnpack

compiler/iface/TcIface.lhs

@@ -434,6 +434,30 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
         ; info <- tcIdInfo ignore_prags name ty info
         ; return (AnId (mkGlobalId details name ty info)) }
 
+tc_iface_decl _ _ IfaceDataKind {ifName = occ_name,
+                                 ifRec  = is_rec,
+                                 ifKVars = kvs,
+                                 ifTyCons = cons}
+  = bindIfaceTyVars_AT kvs $ \ kvs' ->
+    do kc_name <- lookupIfaceTop occ_name
+       kcon <- fixM $ \ kcon ->
+         do let kind = mkTyConApp kcon (mkTyVarTys kvs')
+            cons <- mapM (tcIfaceTyConDecl kind kcon) cons
+            let sKind = mkFunTys (map Var.tyVarKind kvs') superKind
+            return $ mkAlgTyCon
+               kc_name
+               sKind
+               kvs'
+               []
+               Nothing
+               []
+               (DataKindTyCon cons)
+               NoParentTyCon
+               is_rec
+               False
+               NotPromotable
+       return (ATyCon kcon)
+
 tc_iface_decl parent _ (IfaceData {ifName = occ_name, 
                           ifCType = cType, 
                           ifTyVars = tv_bndrs,
@@ -449,10 +473,17 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
             ; parent' <- tc_parent tyvars mb_axiom_name
             ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
             ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta 
-                                    cons is_rec is_prom gadt_syn parent') }
+                                    cons is_rec is_prom' gadt_syn parent') }
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
     ; return (ATyCon tycon) }
   where
+
+    is_prom' :: PromotionInfo ()
+    is_prom'  = case is_prom of
+      IfaceNeverPromote  -> NeverPromote
+      IfaceNotPromotable -> NotPromotable
+      IfacePromotable    -> Promotable ()
+
     tc_parent :: [TyVar] -> Maybe Name -> IfL TyConParent
     tc_parent _ Nothing = return parent
     tc_parent tyvars (Just ax_name)
@@ -643,6 +674,17 @@ tcIfaceDataCons tycon_name tycon _ if_cons
     tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
                                       ; return (HsUnpack (Just co)) }
 
+tcIfaceTyConDecl :: Kind -> KCon -> IfaceTyConDecl -> IfL TyCon
+tcIfaceTyConDecl kind kcon IfTyCon { ifTyConOcc = occ_name, ifTyConArgKs = args,
+                                     ifTyConRoles = roles }
+  = do name  <- lookupIfaceTop occ_name
+       -- See the comment in tc_con_decl of tcIfaceDataCons for why forkM
+       kinds <- forkM pp_name (mapM tcIfaceKind args)
+       return (mkDataKindTyCon kcon name (mkFunTys kinds kind) roles)
+  where
+  pp_name = ptext (sLit "Type constructor") <+> ppr occ_name
+
+
 tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)]
 tcIfaceEqSpec spec
   = mapM do_item spec

compiler/main/HscTypes.lhs

@@ -1376,9 +1376,12 @@ implicitTyConThings tc
 
       -- for each data constructor in order,
       --   the contructor, worker, and (possibly) wrapper
-    concatMap (extras_plus . ADataCon) (tyConDataCons tc)
+    concatMap (extras_plus . ADataCon) (tyConDataCons tc) ++
       -- NB. record selectors are *not* implicit, they have fully-fledged
       -- bindings that pass through the compilation pipeline as normal.
+
+      -- type constructors, if this is a 'data kind' declaration.
+    map ATyCon (kConTypeCons tc)
   where
     class_stuff = case tyConClass_maybe tc of
         Nothing -> []
@@ -1414,9 +1417,13 @@ isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax
 -- might have a parent.
 tyThingParent_maybe :: TyThing -> Maybe TyThing
 tyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
-tyThingParent_maybe (ATyCon tc)   = case tyConAssoc_maybe tc of
-                                      Just cls -> Just (ATyCon (classTyCon cls))
-                                      Nothing  -> Nothing
+tyThingParent_maybe (ATyCon tc)
+  | Just cls <- tyConAssoc_maybe tc
+  = Just (ATyCon (classTyCon cls))
+  | Just s <- tyConDataKind_maybe tc
+  = Just (ATyCon s)
+  | otherwise
+  = Nothing
 tyThingParent_maybe (AnId id)     = case idDetails id of
                                          RecSelId { sel_tycon = tc } -> Just (ATyCon tc)
                                          ClassOpId cls               -> Just (ATyCon (classTyCon cls))

compiler/main/PprTyThing.hs

@@ -40,6 +40,7 @@ import VarEnv( emptyTidyEnv )
 import StaticFlags( opt_PprStyle_Debug )
 import Outputable
 import FastString
+import Data.Maybe (isJust)
 
 -- -----------------------------------------------------------------------------
 -- Pretty-printing entities that we get from the GHC API
@@ -116,7 +117,7 @@ pprTyConHdr pefas tyCon
   | Just cls <- tyConClass_maybe tyCon
   = pprClassHdr pefas cls
   | otherwise
-  = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> pprTvBndrs vars
+  = ptext keyword <+> opt_modifier <+> opt_stupid <+> ppr_bndr tyCon <+> pprTvBndrs vars
   where
     vars | GHC.isPrimTyCon tyCon ||
 	   GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
@@ -126,8 +127,10 @@ pprTyConHdr pefas tyCon
             | GHC.isNewTyCon tyCon = sLit "newtype"
             | otherwise            = sLit "data"
 
-    opt_family
+    opt_modifier
       | GHC.isFamilyTyCon tyCon = ptext (sLit "family")
+      | isJust (kConTypeCons_maybe tyCon) = ptext (sLit "kind")
+      | NeverPromote <- promotableTyConInfo tyCon = ptext (sLit "type")
       | otherwise             = empty
 
     opt_stupid 	-- The "stupid theta" part of the declaration
@@ -187,14 +190,33 @@ pprTyCon pefas ss tyCon
                                                  -- e.g. type T = forall a. a->a
   | Just cls <- GHC.tyConClass_maybe tyCon
   = pprClass pefas ss cls
+  | Just s <- tyConDataKind_maybe tyCon
+  = pprTyCon pefas ss s
+  | Just tys <- kConTypeCons_maybe tyCon
+  = pprDataKind pefas ss tyCon tys
   | otherwise
   = pprAlgTyCon pefas ss tyCon
-
   where
     closed_family_header
       = pprTyConHdr pefas tyCon <+> dcolon <+>
         pprTypeForUser pefas (GHC.synTyConResKind tyCon) <+> ptext (sLit "where")
 
+pprDataKind :: PrintExplicitForalls -> ShowSub -> TyCon -> [TyCon] -> SDoc
+pprDataKind pefas ss kcon tys =
+  hang (pprTyConHdr pefas kcon)
+     2 (add_bars (ppr_trim (map show_con tys)))
+  where
+  ok_con tyc = showSub ss tyc
+  show_con tyc
+    | ok_con tyc = Just (pprTyConDecl tyc)
+    | otherwise  = Nothing
+
+pprTyConDecl :: TyCon -> SDoc
+pprTyConDecl tyc = ppr_bndr tyc <+> sep (map GHC.pprParendType fs)
+  where
+  (_vars, kind) = GHC.splitForAllTys (tyConKind tyc)
+  (fs, _res)    = tcSplitFunTys kind
+
 pprAlgTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc
 pprAlgTyCon pefas ss tyCon
   | gadt      = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$

compiler/parser/HaddockUtils.hs

@@ -28,3 +28,16 @@ addConDocs (x:xs) doc = x : addConDocs xs doc
 addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a]
 addConDocFirst [] _ = []
 addConDocFirst (x:xs) doc = addConDoc x doc : xs
+
+addTyConDoc :: LTyConDecl a -> Maybe LHsDocString -> LTyConDecl a
+addTyConDoc decl    Nothing = decl
+addTyConDoc (L p c) doc     = L p ( c { tycon_doc = tycon_doc c `mplus` doc } )
+
+addTyConDocs :: [LTyConDecl a] -> Maybe LHsDocString -> [LTyConDecl a]
+addTyConDocs [] _ = []
+addTyConDocs [x] doc = [addTyConDoc x doc]
+addTyConDocs (x:xs) doc = x : addTyConDocs xs doc
+
+addTyConDocFirst :: [LTyConDecl a] -> Maybe LHsDocString -> [LTyConDecl a]
+addTyConDocFirst [] _ = []
+addTyConDocFirst (x:xs) doc = addTyConDoc x doc : xs

compiler/parser/Lexer.x

@@ -56,7 +56,7 @@ module Lexer (
    getLexState, popLexState, pushLexState,
    extension, bangPatEnabled, datatypeContextsEnabled,
    traditionalRecordSyntaxEnabled,
-   typeLiteralsEnabled,
+   dataKindsEnabled,
    explicitForallEnabled,
    inRulePrag,
    explicitNamespacesEnabled, sccProfilingOn, hpcEnabled,
@@ -478,6 +478,7 @@ data Token
   | ITgroup
   | ITby
   | ITusing
+  | ITkind
   | ITnominal
   | ITrepresentational
   | ITphantom
@@ -656,6 +657,7 @@ reservedWordsFM = listToUFM $
          ( "group",          ITgroup,         bit transformComprehensionsBit),
          ( "by",             ITby,            bit transformComprehensionsBit),
          ( "using",          ITusing,         bit transformComprehensionsBit),
+         ( "kind",           ITkind,          bit dataKindsBit),
 
          ( "foreign",        ITforeign,       bit ffiBit),
          ( "export",         ITexport,        bit ffiBit),
@@ -1894,8 +1896,8 @@ safeHaskellBit :: Int
 safeHaskellBit = 26
 traditionalRecordSyntaxBit :: Int
 traditionalRecordSyntaxBit = 27
-typeLiteralsBit :: Int
-typeLiteralsBit = 28
+dataKindsBit    :: Int
+dataKindsBit    = 28
 explicitNamespacesBit :: Int
 explicitNamespacesBit = 29
 lambdaCaseBit :: Int
@@ -1950,8 +1952,8 @@ sccProfilingOn :: Int -> Bool
 sccProfilingOn flags = testBit flags sccProfilingOnBit
 traditionalRecordSyntaxEnabled :: Int -> Bool
 traditionalRecordSyntaxEnabled flags = testBit flags traditionalRecordSyntaxBit
-typeLiteralsEnabled :: Int -> Bool
-typeLiteralsEnabled flags = testBit flags typeLiteralsBit
+dataKindsEnabled :: Int -> Bool
+dataKindsEnabled flags = testBit flags dataKindsBit
 
 explicitNamespacesEnabled :: Int -> Bool
 explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit
@@ -2019,7 +2021,7 @@ mkPState flags buf loc =
                .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
                .|. safeHaskellBit              `setBitIf` safeImportsOn                     flags
                .|. traditionalRecordSyntaxBit  `setBitIf` xopt Opt_TraditionalRecordSyntax  flags
-               .|. typeLiteralsBit             `setBitIf` xopt Opt_DataKinds flags
+               .|. dataKindsBit                `setBitIf` xopt Opt_DataKinds flags
                .|. explicitNamespacesBit       `setBitIf` xopt Opt_ExplicitNamespaces flags
                .|. lambdaCaseBit               `setBitIf` xopt Opt_LambdaCase               flags
                .|. negativeLiteralsBit         `setBitIf` xopt Opt_NegativeLiterals         flags

compiler/parser/Parser.y.pp

@@ -257,6 +257,7 @@ incorrect.
  'group'    { L _ ITgroup }     -- for list transform extension
  'by'       { L _ ITby }        -- for list transform extension
  'using'    { L _ ITusing }     -- for list transform extension
+ 'kind'         { L _ ITkind }
  'N'        { L _ ITnominal }            -- Nominal role
  'R'        { L _ ITrepresentational }   -- Representational role
  'P'        { L _ ITphantom }            -- Phantom role
@@ -637,20 +638,26 @@ ty_decl :: { LTyClDecl RdrName }
                 {% do { L loc decl <- mkFamDecl (comb4 $1 $3 $4 $5) (unLoc $5) $3 (unLoc $4)
                       ; return (L loc (FamDecl decl)) } }
 
+        | 'data' 'kind' type kconstrs
+                {% mkTyDataKind (comb3 $1 $3 $4) $3 (unLoc $4) }
+
+        | 'data' 'kind' type
+                {% mkTyDataKind (comb2 $1 $3) $3 [] }
+
           -- ordinary data type or newtype declaration
-        | data_or_newtype capi_ctype tycl_hdr constrs deriving
-                {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3
-                            Nothing (reverse (unLoc $4)) (unLoc $5) }
+        | data_or_newtype promotable capi_ctype tycl_hdr constrs deriving
+                {% mkTyData (comb4 $1 $4 $5 $6) (unLoc $1) $2 $3 $4
+                            Nothing (reverse (unLoc $5)) (unLoc $6) }
                                    -- We need the location on tycl_hdr in case
                                    -- constrs and deriving are both empty
 
           -- ordinary GADT declaration
-        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig
+        | data_or_newtype promotable capi_ctype tycl_hdr opt_kind_sig
                  gadt_constrlist
                  deriving
-                {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3
-                            (unLoc $4) (unLoc $5) (unLoc $6) }
-                                   -- We need the location on tycl_hdr in case
+                {% mkTyData (comb4 $1 $4 $6 $7) (unLoc $1) $2 $3 $4
+                            (unLoc $5) (unLoc $6) (unLoc $7) }
+                                   -- We need the location on tycl_hdr in case 
                                    -- constrs and deriving are both empty
 
           -- data/newtype family
@@ -658,6 +665,10 @@ ty_decl :: { LTyClDecl RdrName }
                 {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4)
                       ; return (L loc (FamDecl decl)) } }
 
+promotable :: { Bool }
+        : 'type'      { False  } -- not promotable
+        |             { True   } -- promotable
+
 inst_decl :: { LInstDecl RdrName }
         : 'instance' inst_type where_inst
                  { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $3) in
@@ -1289,10 +1300,10 @@ constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
 --      C t1 t2
 -- as a btype (treating C as a type constructor) and then convert C to be
 -- a data constructor.  Reason: it might continue like this:
---      C t1 t2 %: D Int
+--      C t1 t2 :% D Int
 -- in which case C really would be a type constructor.  We can't resolve this
 -- ambiguity till we come across the constructor oprerator :% (or not, more usually)
-        : btype                         {% splitCon $1 >>= return.LL }
+        : btype                         {% splitCon True $1 >>= return.LL }
         | btype conop btype             {  LL ($2, InfixCon $1 $3) }
 
 fielddecls :: { [ConDeclField RdrName] }
@@ -1322,6 +1333,34 @@ deriving :: { Located (Maybe [LHsType RdrName]) }
              -- Glasgow extension: allow partial
              -- applications in derivings
 
+kconstrs :: { Located [LTyConDecl RdrName] }
+        : maybe_docnext '=' kconstrs1
+                { L (comb2 $2 $3) (addTyConDocs (reverse (unLoc $3)) $1) }
+
+kconstrs1 :: { Located [LTyConDecl RdrName] }
+        : kconstrs1 maybe_docnext '|' maybe_docprev kconstr
+                { LL (addTyConDoc $5 $2 : addTyConDocFirst (unLoc $1) $4) }
+        | kconstr
+                { L1 [$1] }
+
+kconstr :: { LTyConDecl RdrName }
+        : maybe_docnext kconstr_stuff maybe_docprev
+                { let (con,details) = unLoc $2 in
+                  addTyConDoc (L (getLoc $2) (mkTyConDecl con details)) ($1 `mplus` $3)
+                }
+
+kconstr_stuff :: { Located (Located RdrName, HsTyConDeclDetails RdrName) }
+          -- we reuse splitCon here because types and kinds are represented in
+          -- the same way, except that we don't change the constructor
+          -- namespace.
+        : bkind                 {% splitCon False $1 >>= \ (con,details) ->
+                                  toTyConDetails (getLoc $1) details >>= \ kdetails ->
+                                  return (LL (con,kdetails))
+                                }
+        | bkind conop bkind     { LL ($2, InfixCon $1 $3) }
+
+
+
 -----------------------------------------------------------------------------
 -- Value definitions
 
@@ -2012,6 +2051,7 @@ varid :: { Located RdrName }
         | 'interruptible'       { L1 $! mkUnqual varName (fsLit "interruptible") }
         | 'forall'              { L1 $! mkUnqual varName (fsLit "forall") }
         | 'family'              { L1 $! mkUnqual varName (fsLit "family") }
+        | 'kind'                { L1 $! mkUnqual varName (fsLit "kind") }
 
 qvarsym :: { Located RdrName }
         : varsym                { $1 }

compiler/parser/RdrHsSyn.lhs

@@ -10,10 +10,11 @@ module RdrHsSyn (
         mkHsDo, mkHsSplice, mkTopSpliceDecl,
         mkClassDecl, 
         mkTyData, mkFamInstData, 
+        mkTyDataKind,
         mkTySynonym, mkTyFamInstEqn,
         mkTyFamInst, 
         mkFamDecl, 
-        splitCon, mkInlinePragma,
+        splitCon, mkInlinePragma, toTyConDetails,
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
         mkTyLit,
 
@@ -29,6 +30,7 @@ module RdrHsSyn (
         mkExtName,           -- RdrName -> CLabelString
         mkGadtDecl,          -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName
         mkSimpleConDecl,
+        mkTyConDecl,
         mkDeprecatedGadtRecordDecl,
 
         -- Bunch of functions in the parser monad for
@@ -123,20 +125,60 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
 
 mkTyData :: SrcSpan
          -> NewOrData
+         -> Bool
          -> Maybe CType
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
          -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LTyClDecl RdrName)
-mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
+mkTyData loc new_or_data promotable cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
        ; tyvars <- checkTyVars tycl_hdr tparams
-       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
+
+         -- promotion has been explicitly disabled, make sure that -XDataKinds
+         -- is present
+       ; when (not promotable) $ do
+           pstate  <- getPState
+           let enabled = xopt Opt_DataKinds (dflags pstate)
+           unless enabled (parseErrorSDoc loc (text "Illegal `data type` declaration (use -XDataKinds to enable)"))
+       ; defn <- mkDataDefn new_or_data promotable cType mcxt ksig data_cons maybe_deriv
        ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
                                    tcdDataDefn = defn,
                                    tcdFVs = placeHolderNames })) }
 
+mkTyDataKind :: SrcSpan
+         -> LHsType RdrName
+         -> [LTyConDecl RdrName]
+         -> P (LTyClDecl RdrName)
+mkTyDataKind loc k_hdr ty_cons
+  = do { (kc, kparamTys) <- checkTyClHdr k_hdr
+       ; unless (null kparamTys) $ do
+           pstate  <- getPState
+           let enabled = xopt Opt_PolyKinds (dflags pstate)
+           unless enabled (parseErrorSDoc loc (text "Illegal polymorphic `data kind` declaration (use -XPolyKinds to enable)"))
+       ; kparams  <- checkTyVars k_hdr kparamTys
+       ; kvars    <- checkKVars kparams
+       ; return $ L loc $ KindDecl
+         { tcdLName    = kc
+         , tcdKVars    = kvars
+         , tcdTypeCons = ty_cons
+         , tcdFvs      = placeHolderNames
+         }
+       }
+
+  where
+
+  -- check that there are no sort signatures
+  checkKVars tparams
+    | not (null (hsq_kvs tparams)) = panic "mkTyDataKind" "unexpected sort variables"
+    | otherwise                    = mapM checkKVar (hsq_tvs tparams)
+
+  checkKVar bndr = case unLoc bndr of
+    HsTyVarBndr n Nothing _  -> return (L (getLoc bndr) n)
+    HsTyVarBndr _ (Just _) _ -> parseErrorSDoc (getLoc bndr) (text "kind parameters may not have sort signatures")
+
+
 mkFamInstData :: SrcSpan
          -> NewOrData
          -> Maybe CType
@@ -147,21 +189,25 @@ mkFamInstData :: SrcSpan
          -> P (LDataFamInstDecl RdrName)
 mkFamInstData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
-       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
+         -- promotable is always false here, as data families aren't currently
+         -- promotable
+       ; defn <- mkDataDefn new_or_data False cType mcxt ksig data_cons maybe_deriv
        ; return (L loc (DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams
                                         , dfid_defn = defn, dfid_fvs = placeHolderNames })) }
 
 mkDataDefn :: NewOrData
+           -> Bool
            -> Maybe CType
            -> Maybe (LHsContext RdrName)
            -> Maybe (LHsKind RdrName)
            -> [LConDecl RdrName]
            -> Maybe [LHsType RdrName]
            -> P (HsDataDefn RdrName)
-mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
+mkDataDefn new_or_data promotable cType mcxt ksig data_cons maybe_deriv
   = do { checkDatatypeContext mcxt
        ; let cxt = fromMaybe (noLoc []) mcxt
        ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+                            , dd_try_promote = promotable
                             , dd_ctxt = cxt 
                             , dd_cons = data_cons
                             , dd_kindSig = ksig
@@ -217,7 +263,7 @@ mkTopSpliceDecl other_expr                          = SpliceD (SpliceDecl other_
 
 mkTyLit :: Located (HsTyLit) -> P (LHsType RdrName)
 mkTyLit l =
-  do allowed <- extension typeLiteralsEnabled
+  do allowed <- extension dataKindsEnabled
      if allowed
        then return (HsTyLit `fmap` l)
        else parseErrorSDoc (getLoc l)
@@ -345,17 +391,17 @@ has_args ((L _ (Match args _ _)) : _) = not (null args)
 -- This function splits up the type application, adds any pending
 -- arguments, and converts the type constructor back into a data constructor.
 
-splitCon :: LHsType RdrName
+splitCon :: Bool -> LHsType RdrName
       -> P (Located RdrName, HsConDeclDetails RdrName)
 -- This gets given a "type" that should look like
 --      C Int Bool
 -- or   C { x::Int, y::Bool }
 -- and returns the pieces
-splitCon ty
+splitCon changeNamespace ty
  = split ty []
  where
    split (L _ (HsAppTy t u)) ts    = split t (u : ts)
-   split (L l (HsTyVar tc))  ts    = do data_con <- tyConToDataCon l tc
+   split (L l (HsTyVar tc))  ts    = do data_con <- tyConToDataCon changeNamespace l tc
                                         return (data_con, mk_rest ts)
    split (L l (HsTupleTy _ [])) [] = return (L l (getRdrName unitDataCon), PrefixCon [])
                                          -- See Note [Unit tuples] in HsTypes
@@ -364,6 +410,12 @@ splitCon ty
    mk_rest [L _ (HsRecTy flds)] = RecCon flds
    mk_rest ts                   = PrefixCon ts
 
+toTyConDetails :: SrcSpan -> HsConDeclDetails RdrName -> P (HsTyConDeclDetails RdrName)
+toTyConDetails loc details = case details of
+  PrefixCon args -> return (PrefixCon args)
+  InfixCon l r   -> return (InfixCon l r)
+  RecCon _       -> parseErrorSDoc loc (text "record notation is not allowd in a `data kind` declaration")
+
 mkDeprecatedGadtRecordDecl :: SrcSpan
                            -> Located RdrName
                            -> [ConDeclField RdrName]
@@ -373,7 +425,7 @@ mkDeprecatedGadtRecordDecl :: SrcSpan
 --    C { x,y ::Int } :: T a b
 -- We give it a RecCon details right away
 mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
-  = do { data_con <- tyConToDataCon con_loc con
+  = do { data_con <- tyConToDataCon True con_loc con
        ; return (L loc (ConDecl { con_old_rec  = True
                                 , con_name     = data_con
                                 , con_explicit = Implicit
@@ -397,6 +449,14 @@ mkSimpleConDecl name qvars cxt details
             , con_res      = ResTyH98
             , con_doc      = Nothing }
 
+mkTyConDecl :: Located RdrName -> HsTyConDeclDetails RdrName
+            -> TyConDecl RdrName
+mkTyConDecl name details
+  = TyConDecl { tycon_name    = name
+              , tycon_details = details
+              , tycon_doc     = Nothing
+              }
+
 mkGadtDecl :: [Located RdrName]
            -> LHsType RdrName     -- Always a HsForAllTy
            -> [ConDecl RdrName]
@@ -423,10 +483,10 @@ mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau))
                  , con_doc      = Nothing }
 mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty)
 
-tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
-tyConToDataCon loc tc
+tyConToDataCon :: Bool -> SrcSpan -> RdrName -> P (Located RdrName)
+tyConToDataCon changeNamespace loc tc
   | isTcOcc (rdrNameOcc tc)
-  = return (L loc (setRdrNameSpace tc srcDataName))
+  = return (L loc newName)
   | otherwise
   = parseErrorSDoc loc (msg $$ extra)
   where
@@ -434,6 +494,12 @@ tyConToDataCon loc tc
     extra | tc == forall_tv_RDR
           = text "Perhaps you intended to use -XExistentialQuantification"
           | otherwise = empty
+
+   -- for ordinary data declarations, we change the namespace of the data
+   -- constructor, but for data kind declarations, we leave them in the type
+   -- namespace
+    newName | changeNamespace = setRdrNameSpace tc srcDataName
+            | otherwise       = tc
 \end{code}
 
 Note [Sorting out the result type]

compiler/prelude/TysWiredIn.lhs

@@ -249,7 +249,7 @@ pcTyCon is_enum is_rec is_prom name cType tyvars cons
                 []              -- No stupid theta
                 (DataTyCon cons is_enum)
                 is_rec
-                is_prom
+                (if is_prom then Promotable () else NotPromotable)
                 False           -- Not in GADT syntax
                 NoParentTyCon
 
@@ -365,9 +365,9 @@ mk_tuple sort arity = (tycon, tuple_con)
   where
         tycon   = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort prom_tc
         prom_tc = case sort of
-          BoxedTuple      -> Just (mkPromotedTyCon tycon (promoteKind tc_kind))
-          UnboxedTuple    -> Nothing
-          ConstraintTuple -> Nothing
+          BoxedTuple      -> Promotable (mkPromotedTyCon tycon (promoteKind tc_kind))
+          UnboxedTuple    -> NotPromotable
+          ConstraintTuple -> NotPromotable
 
         modu    = mkTupleModule sort arity
         tc_name = mkWiredInName modu (mkTupleOcc tcName sort arity) tc_uniq
@@ -435,7 +435,7 @@ eqTyCon = mkAlgTyCon eqTyConName
             NoParentTyCon
             NonRecursive
             False
-            Nothing   -- No parent for constraint-kinded types
+            NotPromotable   -- No parent for constraint-kinded types
   where
     kv = kKiVar
     k = mkTyVarTy kv

compiler/rename/RnSource.lhs

@@ -925,6 +925,22 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn
        ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
                           , tcdDataDefn = defn', tcdFVs = fvs }, fvs) }
 
+rnTyClDecl KindDecl { tcdLName = kcon, tcdKVars = kvars, tcdTypeCons = tycons }
+  = do kcon' <- lookupLocatedTopBndrRn kcon
+       let doc = TyDataCtx kcon -- TODO is this right?
+           fixLoc o = L (getLoc o)
+
+       ((kvars', tycons'), fvs) <- bindHsTyVars doc Nothing (map unLoc kvars) (mkHsQTvs []) $ \ vars ->
+         do (tycons', fvss) <- mapAndUnzipM (rnTyConDecl doc . unLoc) tycons
+            return ((hsq_kvs vars, tycons'), plusFVs fvss)
+
+
+       return (KindDecl { tcdLName = kcon'
+                        , tcdKVars = zipWith fixLoc kvars kvars'
+                        , tcdTypeCons = zipWith fixLoc tycons tycons'
+                        , tcdFvs = fvs }
+              , fvs)
+
 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
                               tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
                               tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
@@ -995,6 +1011,7 @@ rnTySyn doc rhs = rnLHsType doc rhs
 
 rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+                           , dd_try_promote = prom
                            , dd_ctxt = context, dd_cons = condecls 
                            , dd_kindSig = sig, dd_derivs = derivs })
   = do  { checkTc (h98_style || null (unLoc context)) 
@@ -1018,6 +1035,7 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
         ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
                         con_fvs `plusFV` sig_fvs
         ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+                              , dd_try_promote = prom
                               , dd_ctxt = context', dd_kindSig = sig'
                               , dd_cons = condecls', dd_derivs = derivs' }
                  , all_fvs )
@@ -1103,6 +1121,10 @@ depAnalTyClDecls ds_w_fvs
                  , tcdDataDefn = HsDataDefn { dd_cons = cons } } 
           -> do L _ dc <- cons
                 return (unLoc (con_name dc), data_name)
+        KindDecl { tcdLName = L _ kind_name
+                 , tcdTypeCons = cons }
+          -> do L _ tc <- cons
+                return (unLoc (tycon_name tc), kind_name)
         _ -> []
 \end{code}
 
@@ -1226,6 +1248,29 @@ rnConDeclDetails doc (RecCon fields)
                 -- since that is done by RnNames.extendGlobalRdrEnvRn
         ; return (RecCon new_fields, fvs) }
 
+
+rnTyConDecl :: HsDocContext -> TyConDecl RdrName
+            -> RnM (TyConDecl Name, FreeVars)
+rnTyConDecl doc TyConDecl { tycon_name = name, tycon_details = details
+                          , tycon_doc = mb_doc }
+  = do name'           <- lookupLocatedTopBndrRn name
+       (details', fvs) <- case details of
+
+         PrefixCon args -> do
+           (args', fvs) <- rnLHsKinds doc args
+           return (PrefixCon args', fvs)
+
+         InfixCon l r -> do
+           (l',lfvs) <- rnLHsKind doc l
+           (r',rfvs) <- rnLHsKind doc r
+           return (InfixCon l' r', lfvs `plusFV` rfvs)
+
+         RecCon{} -> panic "rnTyConDecl" "unexpected record constructor"
+
+       return (TyConDecl { tycon_name = name', tycon_details = details'
+                         , tycon_doc = mb_doc }
+              , fvs)
+
 -------------------------------------------------
 deprecRecSyntax :: ConDecl RdrName -> SDoc
 deprecRecSyntax decl

compiler/rename/RnTypes.lhs

@@ -4,10 +4,17 @@
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}
+{-# OPTIONS -fno-warn-tabs #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and
+-- detab the module (please do the detabbing in a separate patch). See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
+-- for details
+
 module RnTypes (
         -- Type related stuff
         rnHsType, rnLHsType, rnLHsTypes, rnContext,
-        rnHsKind, rnLHsKind, rnLHsMaybeKind,
+        rnHsKind, rnLHsKind, rnLHsKinds, rnLHsMaybeKind,
         rnHsSigType, rnLHsInstType, rnConDeclFields,
         newTyVarNameRn,
 
@@ -308,6 +315,11 @@ rnTyVar is_type rdr_name
 rnLHsTypes :: HsDocContext -> [LHsType RdrName]
            -> RnM ([LHsType Name], FreeVars)
 rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
+
+
+rnLHsKinds :: HsDocContext -> [LHsKind RdrName]
+           -> RnM ([LHsKind Name], FreeVars)
+rnLHsKinds doc ks = mapFvRn (rnLHsKind doc) ks
 \end{code}
 
 

compiler/typecheck/TcGenGenerics.lhs

@@ -91,7 +91,7 @@ genGenericMetaTyCons tc mod =
         mkTyCon name = ASSERT( isExternalName name )
                        buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs
                                           NonRecursive 
-                                          False          -- Not promotable
+                                          NotPromotable
                                           False          -- Not GADT syntax
                                           NoParentTyCon
 

compiler/typecheck/TcHsType.lhs

@@ -1082,6 +1082,8 @@ kcStrategy (DataDecl { tcdDataDefn = HsDataDefn { dd_kindSig = m_ksig }})
   | Just _ <- m_ksig            = FullKindSignature
   | otherwise                   = ParametricKinds
 kcStrategy (ClassDecl {})     = ParametricKinds
+-- TODO: not sure if this is the right choice for 'data kind' decls
+kcStrategy (KindDecl {})      = ParametricKinds
 
 -- if the ClosedTypeFamily has no equations, do the defaulting to *, etc.
 kcStrategyFamDecl :: FamilyDecl Name -> KindCheckingStrategy
@@ -1754,6 +1756,13 @@ tc_kind_var_app name arg_kis
   = do { thing <- tcLookup name
        ; case thing of
   	   AGlobal (ATyCon tc)
+             | let (args,res) = splitFunTys (tyConKind tc)
+             , isSuperKind res
+             -> if length args == length arg_kis
+                   then return (mkTyConApp tc arg_kis)
+                   else tycon_err tc "is not fully applied"
+
+             | otherwise
   	     -> do { data_kinds <- xoptM Opt_DataKinds
   	           ; unless data_kinds $ addErr (dataKindsErr name)
   	     	   ; case promotableTyCon_maybe tc of
@@ -1775,7 +1784,7 @@ tc_kind_var_app name arg_kis
              -> return (mkAppTys (mkTyVarTy kind_var) arg_kis)
 
   	   -- It is in scope, but not what we expected
-  	   AThing _ 
+  	   AThing _
              | isTyVarName name 
              -> failWithTc (ptext (sLit "Type variable") <+> quotes (ppr name)
                             <+> ptext (sLit "used in a kind"))

compiler/typecheck/TcInstDcls.lhs

@@ -698,8 +698,8 @@ tcDataFamInstDecl mb_clsinfo
                     parent   = FamInstTyCon axiom fam_tc pats'
                     roles    = map (const Nominal) tvs'
                     rep_tc   = buildAlgTyCon rep_tc_name tvs' roles cType stupid_theta tc_rhs 
-                                             Recursive 
-                                             False      -- No promotable to the kind level
+                                             Recursive
+                                             NotPromotable -- No promotable to the kind level
                                              h98_syntax parent
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a

compiler/typecheck/TcTyClsDecls.lhs

@@ -118,6 +118,25 @@ tcTyAndClassDecls boot_details tyclds_s
              -- remaining groups are typecheck in the extended global env
 
 tcTyClGroup :: ModDetails -> TyClGroup Name -> TcM TcGblEnv
+tcTyClGroup _boot_details decls
+  | all (isKindDecl . unLoc) decls
+  = do (kcons, _) <- fixM $ \ ~(_, conss) -> do
+         let rec_info = panic "tcTyClGroup" "rec_info"
+
+         kind_cons <- zipWithM (\ix d -> addLocM (mkKindCon rec_info (conss !! ix)) d) [0 ..] decls
+         let kind_env  = [ (kind_name, panic "tcTyClGroup" "kind")
+                         | L _ KindDecl { tcdLName = L _ kind_name } <- decls ]
+
+         final_conss <- tcExtendRecEnv (zipRecTyClss kind_env (map ATyCon kind_cons))
+             (mapM (addLocM (tcKindDecl rec_info)) decls)
+
+         return (kind_cons, final_conss)
+
+       let tycons = [ ATyCon x | x <- kcons ]
+       tcExtendGlobalEnv tycons (tcAddImplicits tycons)
+
+
+
 -- Typecheck one strongly-connected component of type and class decls
 tcTyClGroup boot_details tyclds
   = do {    -- Step 1: kind-check this group and returns the final
@@ -128,10 +147,16 @@ tcTyClGroup boot_details tyclds
        ; traceTc "tcTyAndCl generalized kinds" (ppr names_w_poly_kinds)
             -- the checkNoErrs is necessary to fix #7175.
 
+
+            -- If any of the data declarations are explicitly not promotable,
+            -- the whole group is not promotable.
+       ; let dont_promote = or [ not (dd_try_promote dd)
+                               | DataDecl { tcdDataDefn = dd } <- map unLoc tyclds ]
+
             -- Step 2: type-check all groups together, returning
             -- the final TyCons and Classes
        ; tyclss <- fixM $ \ rec_tyclss -> do
-           { let rec_flags = calcRecFlags boot_details role_annots rec_tyclss
+           { let rec_flags = calcRecFlags dont_promote boot_details role_annots rec_tyclss
 
                  -- Populate environment with knot-tied ATyCon for TyCons
                  -- NB: if the decls mention any ill-staged data cons
@@ -402,6 +427,10 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
              role_annots' = role_annots ++ replicate num_extra_tvs Nothing
        ; return ((main_pr : inner_prs), role_annots') }
 
+getInitialKind KindDecl {}
+  = failWithTc (ptext (sLit "`data kind` declarations can only be recursive")
+            <+> ptext (sLit "with other `data kind` declarations"))
+
 getInitialKind (FamDecl { tcdFam = decl }) 
   = do { pairs <- getFamDeclInitialKind decl
        ; return (pairs, []) }
@@ -493,6 +522,9 @@ kcTyClDecl (DataDecl { tcdLName = L _ name, tcdTyVars = hs_tvs, tcdDataDefn = de
 
 kcTyClDecl decl@(SynDecl {}) = pprPanic "kcTyClDecl" (ppr decl)
 
+-- do we need to do any sort checking here?
+kcTyClDecl (KindDecl {}) = return ()
+
 kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
                        , tcdCtxt = ctxt, tcdSigs = sigs })
   = kcTyClTyVars name hs_tvs $
@@ -620,6 +652,9 @@ tcTyClDecl1 _parent rec_info
     tcTyClTyVars tc_name tvs $ \ tvs' kind ->
     tcDataDefn rec_info tc_name tvs' kind defn
 
+tcTyClDecl1 _parent _rec_info KindDecl {}
+  = failWithTc (ptext (sLit "'data kind' declarations can not appear in a recursive group"))
+
 tcTyClDecl1 _parent rec_info
             (ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs
             , tcdCtxt = ctxt, tcdMeths = meths
@@ -757,7 +792,7 @@ tcFamDecl1 parent
         roles     = map (const Nominal) final_tvs
         tycon = buildAlgTyCon tc_name final_tvs roles Nothing []
                               DataFamilyTyCon Recursive
-                              False   -- Not promotable to the kind level
+                              NotPromotable
                               True    -- GADT syntax
                               parent
   ; return [ATyCon tycon] }
@@ -776,12 +811,53 @@ tcTySynRhs rec_info tc_name tvs kind hs_ty
                                 kind NoParentTyCon
        ; return [ATyCon tycon] }
 
+mkKindCon :: RecTyInfo -> [TyCon] -> TyClDecl Name -> TcM TyCon
+mkKindCon _rec_info tycons KindDecl { tcdLName  = L _ kind_name
+                                     , tcdKVars  = lknames } =
+  do let knames = map unLoc lknames
+     kvars <- mapM (\n -> newSigTyVar n superKind) knames
+     return $ mkAlgTyCon
+       kind_name
+       sKind
+       kvars
+       (replicate (length kvars) Nominal) -- no interesting kind equality
+       Nothing
+       []
+       (DataKindTyCon tycons)
+       NoParentTyCon
+       NonRecursive -- XXX is this OK?
+       False
+       NotPromotable
+  where
+  -- for now, we assume all kind variables have sort BOX.
+  sKind = mkFunTys (replicate arity superKind) superKind
+  arity = length lknames
+
+mkKindCon _ _ _ =
+  panic "mkKindCon" "non 'data kind' declaration"
+
+tcKindDecl :: RecTyInfo -> TyClDecl Name -> TcM [TyCon]
+tcKindDecl _rec_info KindDecl { tcdLName = L _ kind_name, tcdKVars = lknames
+                              , tcdTypeCons = cons }
+  = do traceTc "tcKindDecl" (ppr kind_name)
+
+       ~(ATyCon kcon) <- tcLookupGlobal kind_name
+       let kvars  = tyConTyVars kcon
+           knames = map unLoc lknames
+           kind   = mkTyConApp kcon (mkTyVarTys kvars)
+       tcExtendTyVarEnv2 (knames `zip` kvars)
+           (mapM (addLocM (tcTyConDecl kvars kind)) cons)
+
+tcKindDecl _ _
+  = panic "tcKindDecl" "unexpected non-KindDecl constructor"
+
 tcDataDefn :: RecTyInfo -> Name
            -> [TyVar] -> Kind
            -> HsDataDefn Name -> TcM [TyThing]
   -- NB: not used for newtype/data instances (whether associated or not)
 tcDataDefn rec_info tc_name tvs kind
          (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+                     , dd_try_promote = try_promote
                      , dd_ctxt = ctxt, dd_kindSig = mb_ksig
                      , dd_cons = cons })
   = do { extra_tvs <- tcDataKindSig kind
@@ -812,9 +888,13 @@ tcDataDefn rec_info tc_name tvs kind
                    DataType -> return (mkDataTyConRhs data_cons)
                    NewType  -> ASSERT( not (null data_cons) )
                                     mkNewTyConRhs tc_name tycon (head data_cons)
+             ; let prom_info
+                     | not try_promote         = NeverPromote
+                     | rti_promotable rec_info = Promotable ()
+                     | otherwise               = NotPromotable
              ; return (buildAlgTyCon tc_name final_tvs roles cType stupid_theta tc_rhs
                                      (rti_is_rec rec_info tc_name)
-                                     (rti_promotable rec_info)
+                                     prom_info
                                      (not h98_syntax) NoParentTyCon) }
        ; return [ATyCon tycon] }
 \end{code}
@@ -1303,6 +1383,21 @@ rejigConRes tmpl_tvs res_tmpl dc_tvs (ResTyGADT res_ty)
                        new_tmpl = updateTyVarKind (substTy subst) tmpl
       | otherwise = pprPanic "tcResultType" (ppr res_ty)
     ex_tvs = dc_tvs `minusList` univ_tvs
+
+
+tcTyConDecl :: [TyVar] -> Kind -> TyConDecl Name -> TcM TyCon
+tcTyConDecl kvars kind TyConDecl { tycon_name = name, tycon_details = details }
+  = do ks <- case details of
+               PrefixCon args -> mapM tcLHsKind args
+               InfixCon l r   -> mapM tcLHsKind [l,r]
+               RecCon {}      -> panic "tcTyConDecl" "unexpected record constructor"
+       let (kcon,_) = splitTyConApp kind
+           con_kind = mkPiKinds kvars (mkFunTys ks kind)
+           roles    = replicate (length kvars) Nominal
+                   ++ replicate (length ks)    Representational
+       return (mkDataKindTyCon kcon (unLoc name) con_kind roles)
+
+
 \end{code}
 
 Note [Substitution in template variables kinds]