Template Haskell: support for kind annotations

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 5c3486a..865e4be 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -188,7 +188,7 @@ repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
               ; cons1    <- mapM repC cons
              ; cons2    <- coreList conQTyConName cons1
              ; derivs1  <- repDerivs mb_derivs
-             ; bndrs1   <- coreList nameTyConName bndrs
+             ; bndrs1   <- coreList tyVarBndrTyConName bndrs
              ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1 
               }
        ; return $ Just (loc, dec) 
@@ -204,7 +204,7 @@ repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
               ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
               ; con1     <- repC con
              ; derivs1  <- repDerivs mb_derivs
-             ; bndrs1   <- coreList nameTyConName bndrs
+             ; bndrs1   <- coreList tyVarBndrTyConName bndrs
              ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
               }
        ; return $ Just (loc, dec) 
@@ -217,7 +217,7 @@ repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys
            do { opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
               ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
              ; ty1      <- repLTy ty
-             ; bndrs1   <- coreList nameTyConName bndrs
+             ; bndrs1   <- coreList tyVarBndrTyConName bndrs
              ; repTySyn tc1 bndrs1 opt_tys2 ty1 
               }
        ; return (Just (loc, dec)) 
@@ -235,7 +235,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
              ; fds1   <- repLFunDeps fds
               ; ats1   <- repLAssocFamilys ats
              ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
-             ; bndrs1 <- coreList nameTyConName bndrs
+             ; bndrs1 <- coreList tyVarBndrTyConName bndrs
              ; repClass cxt1 cls1 bndrs1 fds1 decls1 
               }
        ; return $ Just (loc, dec) 
@@ -255,13 +255,17 @@ repTyFamily :: LTyClDecl Name
             -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
                               tcdLName = tc, tcdTyVars = tvs, 
-                              tcdKind = _kind }))
+                              tcdKind = opt_kind }))
             tyVarBinds
   = do { tc1 <- lookupLOcc tc          -- See note [Binders and occurrences] 
        ; dec <- tyVarBinds tvs $ \bndrs ->
            do { flav   <- repFamilyFlavour flavour
-             ; bndrs1 <- coreList nameTyConName bndrs
-              ; repFamily flav tc1 bndrs1
+             ; bndrs1 <- coreList tyVarBndrTyConName bndrs
+              ; case opt_kind of 
+                  Nothing -> repFamilyNoKind flav tc1 bndrs1
+                  Just ki -> do { ki1 <- repKind ki 
+                                ; repFamilyKind flav tc1 bndrs1 ki1
+                                }
               }
        ; return $ Just (loc, dec)
        }
@@ -370,16 +374,17 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
 
 repC :: LConDecl Name -> DsM (Core TH.ConQ)
 repC (L _ (ConDecl con _ [] (L _ []) details ResTyH98 _))
-  = do { con1 <- lookupLOcc con ;              -- See note [Binders and occurrences] 
-        repConstr con1 details }
+  = do { con1 <- lookupLOcc con        -- See note [Binders and occurrences] 
+       ; repConstr con1 details 
+       }
 repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc))
-  = do { addTyVarBinds tvs $ \bndrs -> do {
-             c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98 doc));
-             ctxt' <- repContext ctxt;
-             bndrs' <- coreList nameTyConName bndrs;
-             rep2 forallCName [unC bndrs', unC ctxt', unC c']
+  = addTyVarBinds tvs $ \bndrs -> 
+      do { c' <- repC (L loc (ConDecl con expl [] (L cloc []) details 
+                                      ResTyH98 doc))
+         ; ctxt' <- repContext ctxt
+         ; bndrs' <- coreList tyVarBndrTyConName bndrs
+         ; rep2 forallCName [unC bndrs', unC ctxt', unC c']
          }
-       }
 repC (L loc con_decl)          -- GADTs
   = putSrcSpanDs loc $
     notHandled "GADT declaration" (ppr con_decl) 
@@ -495,8 +500,8 @@ rep_InlineSpec (Inline (InlinePragma activation match) inline)
 -- families, depending on whether they are associated or not.
 --
 type ProcessTyVarBinds a = 
-         [LHsTyVarBndr Name]                    -- the binders to be added
-      -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
+         [LHsTyVarBndr Name]                          -- the binders to be added
+      -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
       -> DsM (Core (TH.Q a))
 
 -- gensym a list of type variables and enter them into the meta environment;
@@ -506,11 +511,13 @@ type ProcessTyVarBinds a =
 addTyVarBinds :: ProcessTyVarBinds a
 addTyVarBinds tvs m =
   do
-    let names = map (hsTyVarName.unLoc) tvs
+    let names       = hsLTyVarNames tvs
+        mkWithKinds = map repTyVarBndrWithKind tvs
     freshNames <- mkGenSyms names
     term       <- addBinds freshNames $ do
-                   bndrs <- mapM lookupBinder names 
-                   m bndrs
+                   bndrs       <- mapM lookupBinder names 
+                    kindedBndrs <- zipWithM ($) mkWithKinds bndrs
+                   m kindedBndrs
     wrapGenSyns freshNames term
 
 -- Look up a list of type variables; the computations passed as the second 
@@ -519,9 +526,19 @@ addTyVarBinds tvs m =
 lookupTyVarBinds :: ProcessTyVarBinds a
 lookupTyVarBinds tvs m =
   do
-    let names = map (hsTyVarName.unLoc) tvs
-    bndrs <- mapM lookupBinder names 
-    m bndrs
+    let names       = hsLTyVarNames tvs
+        mkWithKinds = map repTyVarBndrWithKind tvs
+    bndrs       <- mapM lookupBinder names 
+    kindedBndrs <- zipWithM ($) mkWithKinds bndrs
+    m kindedBndrs
+
+-- Produce kinded binder constructors from the Haskell tyvar binders
+--
+repTyVarBndrWithKind :: LHsTyVarBndr Name 
+                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
+repTyVarBndrWithKind (L _ (UserTyVar _))      = repPlainTV
+repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) = 
+  \nm -> repKind ki >>= repKindedTV nm
 
 -- represent a type context
 --
@@ -576,7 +593,7 @@ repTy (HsForAllTy _ tvs ctxt ty)  =
   addTyVarBinds tvs $ \bndrs -> do
     ctxt1  <- repLContext ctxt
     ty1    <- repLTy ty
-    bndrs1 <- coreList nameTyConName bndrs
+    bndrs1 <- coreList tyVarBndrTyConName bndrs
     repTForall bndrs1 ctxt1 ty1
 
 repTy (HsTyVar n)
@@ -611,9 +628,26 @@ repTy (HsOpTy ty1 n ty2)     = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
                                           `nlHsAppTy` ty2)
 repTy (HsParTy t)                = repLTy t
 repTy (HsPredTy pred)             = repPredTy pred
+repTy (HsKindSig t k)             = do
+                                      t1 <- repLTy t
+                                      k1 <- repKind k
+                                      repTSig t1 k1
 repTy ty@(HsNumTy _)              = notHandled "Number types (for generics)" (ppr ty)
 repTy ty                         = notHandled "Exotic form of type" (ppr ty)
 
+-- represent a kind
+--
+repKind :: Kind -> DsM (Core TH.Kind)
+repKind ki
+  = do { let (kis, ki') = splitKindFunTys ki
+       ; kis_rep <- mapM repKind kis
+       ; ki'_rep <- repNonArrowKind ki'
+       ; foldlM repArrowK ki'_rep kis_rep
+       }
+  where
+    repNonArrowKind k | isLiftedTypeKind k = repStarK
+                      | otherwise          = notHandled "Exotic form of kind" 
+                                                        (ppr k)
 
 -----------------------------------------------------------------------------
 --             Expressions
@@ -1336,7 +1370,7 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)  
 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
 
-repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] 
+repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] 
         -> Maybe (Core [TH.TypeQ])
         -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
@@ -1344,7 +1378,7 @@ repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
   = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
 
-repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] 
+repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] 
            -> Maybe (Core [TH.TypeQ])
            -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
@@ -1352,7 +1386,7 @@ repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
   = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
 
-repTySyn :: Core TH.Name -> Core [TH.Name] 
+repTySyn :: Core TH.Name -> Core [TH.TyVarBndr] 
          -> Maybe (Core [TH.TypeQ])
          -> Core TH.TypeQ -> DsM (Core TH.DecQ)
 repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs) 
@@ -1363,7 +1397,7 @@ repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
 
-repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] 
+repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] 
          -> Core [TH.FunDep] -> Core [TH.DecQ] 
          -> DsM (Core TH.DecQ)
 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) 
@@ -1380,10 +1414,16 @@ repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
 repPragSpecInl (MkC nm) (MkC ty) (MkC ispec) 
   = rep2 pragSpecInlDName [nm, ty, ispec]
 
-repFamily :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.Name] 
-          -> DsM (Core TH.DecQ)
-repFamily (MkC flav) (MkC nm) (MkC tvs)
-    = rep2 familyDName [flav, nm, tvs]
+repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] 
+                -> DsM (Core TH.DecQ)
+repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
+    = rep2 familyNoKindDName [flav, nm, tvs]
+
+repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] 
+              -> Core TH.Kind
+              -> DsM (Core TH.DecQ)
+repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
+    = rep2 familyKindDName [flav, nm, tvs, ki]
 
 repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ)
 repInlineSpecNoPhase (MkC inline) (MkC conlike) 
@@ -1429,7 +1469,8 @@ repConstr con (InfixCon st1 st2)
 
 ------------ Types -------------------
 
-repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ 
+           -> DsM (Core TH.TypeQ)
 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
     = rep2 forallTName [tvars, ctxt, ty]
 
@@ -1437,12 +1478,15 @@ repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
 repTvar (MkC s) = rep2 varTName [s]
 
 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
-repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
 
 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
 repTapps f []     = return f
 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
 
+repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
+repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
+
 --------- Type constructors --------------
 
 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
@@ -1458,6 +1502,19 @@ repArrowTyCon = rep2 arrowTName []
 repListTyCon :: DsM (Core TH.TypeQ)
 repListTyCon = rep2 listTName []
 
+------------ Kinds -------------------
+
+repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
+repPlainTV (MkC nm) = rep2 plainTVName [nm]
+
+repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
+repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
+
+repStarK :: DsM (Core TH.Kind)
+repStarK = rep2 starKName []
+
+repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
+repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2]
 
 ----------------------------------------------------------
 --             Literals
@@ -1614,7 +1671,8 @@ templateHaskellNames = [
     funDName, valDName, dataDName, newtypeDName, tySynDName,
     classDName, instanceDName, sigDName, forImpDName, 
     pragInlDName, pragSpecDName, pragSpecInlDName,
-    familyDName, dataInstDName, newtypeInstDName, tySynInstDName,
+    familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
+    tySynInstDName, 
     -- Cxt
     cxtName,
     -- Pred
@@ -1629,7 +1687,11 @@ templateHaskellNames = [
     varStrictTypeName,
     -- Type
     forallTName, varTName, conTName, appTName,
-    tupleTName, arrowTName, listTName,
+    tupleTName, arrowTName, listTName, sigTName,
+    -- TyVarBndr
+    plainTVName, kindedTVName,
+    -- Kind
+    starKName, arrowKName,
     -- Callconv
     cCallName, stdCallName,
     -- Safety
@@ -1648,8 +1710,9 @@ templateHaskellNames = [
     clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
     stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
-    typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
-    fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, predQTyConName,
+    typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
+    patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
+    predQTyConName, 
 
     -- Quasiquoting
     quoteExpName, quotePatName]
@@ -1672,7 +1735,8 @@ qqFun  = mk_known_key_name OccName.varName qqLib
 -------------------- TH.Syntax -----------------------
 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
     fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
-    matchTyConName, clauseTyConName, funDepTyConName, predTyConName :: Name
+    tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
+    predTyConName :: Name 
 qTyConName        = thTc (fsLit "Q")            qTyConKey
 nameTyConName     = thTc (fsLit "Name")         nameTyConKey
 fieldExpTyConName = thTc (fsLit "FieldExp")     fieldExpTyConKey
@@ -1681,6 +1745,7 @@ fieldPatTyConName = thTc (fsLit "FieldPat")     fieldPatTyConKey
 expTyConName      = thTc (fsLit "Exp")          expTyConKey
 decTyConName      = thTc (fsLit "Dec")          decTyConKey
 typeTyConName     = thTc (fsLit "Type")         typeTyConKey
+tyVarBndrTyConName= thTc (fsLit "TyVarBndr")    tyVarBndrTyConKey
 matchTyConName    = thTc (fsLit "Match")        matchTyConKey
 clauseTyConName   = thTc (fsLit "Clause")       clauseTyConKey
 funDepTyConName   = thTc (fsLit "FunDep")       funDepTyConKey
@@ -1797,8 +1862,8 @@ parSName    = libFun (fsLit "parS")    parSIdKey
 -- data Dec = ...
 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
     instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
-    pragSpecInlDName, familyDName, dataInstDName, newtypeInstDName, 
-    tySynInstDName :: Name
+    pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
+    newtypeInstDName, tySynInstDName :: Name
 funDName         = libFun (fsLit "funD")         funDIdKey
 valDName         = libFun (fsLit "valD")         valDIdKey
 dataDName        = libFun (fsLit "dataD")        dataDIdKey
@@ -1811,7 +1876,8 @@ forImpDName      = libFun (fsLit "forImpD")      forImpDIdKey
 pragInlDName     = libFun (fsLit "pragInlD")     pragInlDIdKey
 pragSpecDName    = libFun (fsLit "pragSpecD")    pragSpecDIdKey
 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
-familyDName      = libFun (fsLit "familyD")      familyDIdKey
+familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
+familyKindDName  = libFun (fsLit "familyKindD")  familyKindDIdKey
 dataInstDName    = libFun (fsLit "dataInstD")    dataInstDIdKey
 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
 tySynInstDName   = libFun (fsLit "tySynInstD")   tySynInstDIdKey
@@ -1847,14 +1913,25 @@ varStrictTypeName = libFun  (fsLit "varStrictType") varStrictTKey
 
 -- data Type = ...
 forallTName, varTName, conTName, tupleTName, arrowTName,
-    listTName, appTName :: Name
+    listTName, appTName, sigTName :: Name
 forallTName = libFun (fsLit "forallT") forallTIdKey
 varTName    = libFun (fsLit "varT")    varTIdKey
 conTName    = libFun (fsLit "conT")    conTIdKey
-tupleTName  = libFun (fsLit "tupleT") tupleTIdKey
-arrowTName  = libFun (fsLit "arrowT") arrowTIdKey
-listTName   = libFun (fsLit "listT")  listTIdKey
+tupleTName  = libFun (fsLit "tupleT")  tupleTIdKey
+arrowTName  = libFun (fsLit "arrowT")  arrowTIdKey
+listTName   = libFun (fsLit "listT")   listTIdKey
 appTName    = libFun (fsLit "appT")    appTIdKey
+sigTName    = libFun (fsLit "sigT")    sigTIdKey
+
+-- data TyVarBndr = ...
+plainTVName, kindedTVName :: Name
+plainTVName  = libFun (fsLit "plainTV")  plainTVIdKey
+kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
+
+-- data Kind = ...
+starKName, arrowKName :: Name
+starKName  = libFun (fsLit "starK")   starKIdKey
+arrowKName = libFun (fsLit "arrowK")  arrowKIdKey
 
 -- data Callconv = ...
 cCallName, stdCallName :: Name
@@ -1909,7 +1986,7 @@ quotePatName          = qqFun (fsLit "quotePat") quotePatKey
 
 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
     decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
-    stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
+    stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
     decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
     fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
@@ -1927,6 +2004,7 @@ stmtQTyConKey           = mkPreludeTyConUnique 109
 conQTyConKey            = mkPreludeTyConUnique 110
 typeQTyConKey           = mkPreludeTyConUnique 111
 typeTyConKey            = mkPreludeTyConUnique 112
+tyVarBndrTyConKey       = mkPreludeTyConUnique 125
 decTyConKey             = mkPreludeTyConUnique 113
 varStrictTypeQTyConKey  = mkPreludeTyConUnique 114
 strictTypeQTyConKey     = mkPreludeTyConUnique 115
@@ -2051,8 +2129,8 @@ parSIdKey        = mkPreludeMiscIdUnique 271
 -- data Dec = ...
 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
     classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
-    pragSpecDIdKey, pragSpecInlDIdKey, familyDIdKey, dataInstDIdKey,
-    newtypeInstDIdKey, tySynInstDIdKey :: Unique 
+    pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
+    dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique 
 funDIdKey         = mkPreludeMiscIdUnique 272
 valDIdKey         = mkPreludeMiscIdUnique 273
 dataDIdKey        = mkPreludeMiscIdUnique 274
@@ -2065,7 +2143,8 @@ forImpDIdKey      = mkPreludeMiscIdUnique 297
 pragInlDIdKey     = mkPreludeMiscIdUnique 348
 pragSpecDIdKey    = mkPreludeMiscIdUnique 349
 pragSpecInlDIdKey = mkPreludeMiscIdUnique 352
-familyDIdKey      = mkPreludeMiscIdUnique 340
+familyNoKindDIdKey= mkPreludeMiscIdUnique 340
+familyKindDIdKey  = mkPreludeMiscIdUnique 353
 dataInstDIdKey    = mkPreludeMiscIdUnique 341
 newtypeInstDIdKey = mkPreludeMiscIdUnique 342
 tySynInstDIdKey   = mkPreludeMiscIdUnique 343
@@ -2101,7 +2180,7 @@ varStrictTKey     = mkPreludeMiscIdUnique 287
 
 -- data Type = ...
 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey,
-    listTIdKey, appTIdKey :: Unique
+    listTIdKey, appTIdKey, sigTIdKey :: Unique
 forallTIdKey      = mkPreludeMiscIdUnique 290
 varTIdKey         = mkPreludeMiscIdUnique 291
 conTIdKey         = mkPreludeMiscIdUnique 292
@@ -2109,6 +2188,17 @@ tupleTIdKey       = mkPreludeMiscIdUnique 294
 arrowTIdKey       = mkPreludeMiscIdUnique 295
 listTIdKey        = mkPreludeMiscIdUnique 296
 appTIdKey         = mkPreludeMiscIdUnique 293
+sigTIdKey         = mkPreludeMiscIdUnique 358
+
+-- data TyVarBndr = ...
+plainTVIdKey, kindedTVIdKey :: Unique
+plainTVIdKey      = mkPreludeMiscIdUnique 354
+kindedTVIdKey     = mkPreludeMiscIdUnique 355
+
+-- data Kind = ...
+starKIdKey, arrowKIdKey :: Unique
+starKIdKey        = mkPreludeMiscIdUnique 356
+arrowKIdKey       = mkPreludeMiscIdUnique 357
 
 -- data Callconv = ...
 cCallIdKey, stdCallIdKey :: Unique

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 60080ee..1a9e190 100644 (file)
--- a/compiler/hsSyn/Convert.lhs
+++ b/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)
+
 -----------------------------------------------------------
 
 

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 491ca27..fa54a63 100644 (file)
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -35,7 +35,6 @@ import Id
 
 import TcRnMonad
 import PrelNames
-import Type
 import TcType
 import TcMType
 import TysPrim

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index e0b5f3d..650c0b4 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs
+++ b/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 

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 891e33c..6b326b0 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/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,