Template Haskell: support for kind annotations

compiler/hsSyn/Convert.lhs

@@ -143,8 +143,8 @@ cvtTop (ClassD ctxt cl tvs fds decs)
 						        -- no docs in TH ^^
 	}
   where
-    isFamilyD (FamilyD _ _ _) = True
-    isFamilyD _               = False
+    isFamilyD (FamilyD _ _ _ _) = True
+    isFamilyD _                 = False
 
 cvtTop (InstanceD ctxt ty decs)
   = do 	{ let (ats, bind_sig_decs) = partition isFamInstD decs
@@ -173,10 +173,10 @@ cvtTop (PragmaD prag)
        ; returnL $ Hs.SigD prag'
        }
 
-cvtTop (FamilyD flav tc tvs)
+cvtTop (FamilyD flav tc tvs kind)
   = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
-       ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' Nothing)
-                                                                 -- FIXME: kinds
+       ; let kind' = fmap cvtKind kind
+       ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind')
        }
   where
     cvtFamFlavour TypeFam = TypeFamily
@@ -207,7 +207,7 @@ unTyClD :: LHsDecl a -> LTyClDecl a
 unTyClD (L l (TyClD d)) = L l d
 unTyClD _               = panic "Convert.unTyClD: internal error"
 
-cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.Name]
+cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
              -> CvtM ( LHsContext RdrName
                      , Located RdrName
                      , [LHsTyVarBndr RdrName]
@@ -235,7 +235,7 @@ cvt_tyinst_hdr cxt tc tys
   where
     collect (ForallT _ _ _) 
       = failWith $ text "Forall type not allowed as type parameter"
-    collect (VarT tv)    = return [tv]
+    collect (VarT tv)    = return [PlainTV tv]
     collect (ConT _)     = return []
     collect (TupleT _)   = return []
     collect ArrowT       = return []
@@ -245,6 +245,8 @@ cvt_tyinst_hdr cxt tc tys
            ; tvs2 <- collect t2
            ; return $ tvs1 ++ tvs2
            }
+    collect (SigT (VarT tv) ki) = return [KindedTV tv ki]
+    collect (SigT ty _)         = collect ty
 
 ---------------------------------------------------
 -- 	Data types
@@ -643,11 +645,18 @@ cvtPatFld (s,p)
 -----------------------------------------------------------
 --	Types and type variables
 
-cvtTvs :: [TH.Name] -> CvtM [LHsTyVarBndr RdrName]
+cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
 cvtTvs tvs = mapM cvt_tv tvs
 
-cvt_tv :: TH.Name -> CvtM (LHsTyVarBndr RdrName)
-cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' }
+cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
+cvt_tv (TH.PlainTV nm) 
+  = do { nm' <- tName nm
+       ; returnL $ UserTyVar nm' 
+       }
+cvt_tv (TH.KindedTV nm ki) 
+  = do { nm' <- tName nm
+       ; returnL $ KindedTyVar nm' (cvtKind ki)
+       }
 
 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
@@ -674,27 +683,42 @@ cvtPredTy ty
                        text (TH.pprint ty)) }
 
 cvtType :: TH.Type -> CvtM (LHsType RdrName)
-cvtType ty = do { (head_ty, tys') <- split_ty_app ty
-		; case head_ty of
-		    TupleT n | length tys' == n 	-- Saturated
-			     -> if n==1 then return (head tys')	-- Singleton tuples treated 
-								-- like nothing (ie just parens)
-					else returnL (HsTupleTy Boxed tys')
-		             | n == 1    -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
-		             | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
-		    ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y')
-		    	   | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
-		    ListT  | [x']    <- tys' -> returnL (HsListTy x')
-		    	   | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
-		    VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
-		    ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
-
-		    ForallT tvs cxt ty | null tys' -> do { tvs' <- cvtTvs tvs
-							 ; cxt' <- cvtContext cxt
-							 ; ty'  <- cvtType ty
-							 ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' }
-		    _       -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
-	     }
+cvtType ty 
+  = do { (head_ty, tys') <- split_ty_app ty
+       ; case head_ty of
+           TupleT n 
+             | length tys' == n 	-- Saturated
+             -> if n==1 then return (head tys')	-- Singleton tuples treated 
+                                                -- like nothing (ie just parens)
+                        else returnL (HsTupleTy Boxed tys')
+             | n == 1    
+             -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
+             | otherwise 
+             -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
+           ArrowT 
+             | [x',y'] <- tys' -> returnL (HsFunTy x' y')
+             | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
+           ListT  
+             | [x']    <- tys' -> returnL (HsListTy x')
+             | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
+           VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
+           ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
+
+           ForallT tvs cxt ty 
+             | null tys' 
+             -> do { tvs' <- cvtTvs tvs
+                   ; cxt' <- cvtContext cxt
+                   ; ty'  <- cvtType ty
+                   ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' 
+                   }
+
+           SigT ty ki
+             -> do { ty' <- cvtType ty
+                   ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
+                   }
+
+           _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
+    }
   where
     mk_apps head_ty []       = returnL head_ty
     mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
@@ -706,6 +730,10 @@ split_ty_app ty = go ty []
     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
     go f as 	      = return (f,as)
 
+cvtKind :: TH.Kind -> Type.Kind
+cvtKind StarK          = liftedTypeKind
+cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
+
 -----------------------------------------------------------
 
 

compiler/typecheck/TcHsSyn.lhs

@@ -35,7 +35,6 @@ import Id
 
 import TcRnMonad
 import PrelNames
-import Type
 import TcType
 import TcMType
 import TysPrim

compiler/typecheck/TcSplice.lhs

@@ -911,9 +911,13 @@ reifyTyCon tc
   | isOpenTyCon tc
   = let flavour = reifyFamFlavour tc
         tvs     = tyConTyVars tc
+        kind    = tyConKind tc
+        kind'
+          | isLiftedTypeKind kind = Nothing
+          | otherwise             = Just $ reifyKind kind
     in
     return (TH.TyConI $
-              TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs))
+              TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
   | isSynTyCon tc
   = do { let (tvs, rhs) = synTyConDefn tc 
        ; rhs' <- reifyType rhs
@@ -982,6 +986,18 @@ reifyType (PredTy {}) = panic "reifyType PredTy"
 reifyTypes :: [Type] -> TcM [TH.Type]
 reifyTypes = mapM reifyType
 
+reifyKind :: Kind -> TH.Kind
+reifyKind  ki
+  = let (kis, ki') = splitKindFunTys ki
+        kis_rep    = map reifyKind kis
+        ki'_rep    = reifyNonArrowKind ki'
+    in
+    foldl TH.ArrowK ki'_rep kis_rep
+  where
+    reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
+                        | otherwise          = pprPanic "Exotic form of kind" 
+                                                        (ppr k)
+
 reifyCxt :: [PredType] -> TcM [TH.Pred]
 reifyCxt   = mapM reifyPred
 
@@ -994,8 +1010,14 @@ reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
                    | otherwise         
                    = panic "TcSplice.reifyFamFlavour: not a type family"
 
-reifyTyVars :: [TyVar] -> [TH.Name]
-reifyTyVars = map reifyName
+reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
+reifyTyVars = map reifyTyVar
+  where
+    reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV  name
+                  | otherwise             = TH.KindedTV name (reifyKind kind)
+      where
+        kind = tyVarKind tv
+        name = reifyName tv
 
 reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
 reify_tc_app tc tys = do { tys' <- reifyTypes tys 

compiler/typecheck/TcType.lhs

@@ -98,7 +98,7 @@ module TcType (
   unliftedTypeKind, liftedTypeKind, argTypeKind,
   openTypeKind, mkArrowKind, mkArrowKinds, 
   isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, 
-  isSubArgTypeKind, isSubKind, defaultKind,
+  isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind,
   kindVarRef, mkKindVar,  
 
   Type, PredType(..), ThetaType,