Template Haskell: kind annotations
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>
Thu, 26 Mar 2009 09:32:36 +0000 (09:32 +0000)
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>
Thu, 26 Mar 2009 09:32:36 +0000 (09:32 +0000)
- Kind annotations at variables in type declarations
- Kind signatures in types

  *** This patch changes the API!  Existing client code will break! ***

libraries/template-haskell/Language/Haskell/TH.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs

index 64cee37..625e403 100644 (file)
@@ -18,9 +18,9 @@ module Language.Haskell.TH(
        tupleTypeName, tupleDataName,   -- Int -> Name
        
        -- The algebraic data types
-       Dec(..), Exp(..), Con(..), Type(..), Cxt, Pred(..), Match(..), 
-       Clause(..), Body(..), Guard(..), Stmt(..), Range(..),
-       Lit(..), Pat(..), FieldExp, FieldPat, 
+       Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..), Cxt,
+       Pred(..), Match(..), Clause(..), Body(..), Guard(..), Stmt(..),
+       Range(..), Lit(..), Pat(..), FieldExp, FieldPat, 
        Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
        InlineSpec(..), FunDep(..), FamFlavour(..), Info(..), Loc(..),
        Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
@@ -41,9 +41,10 @@ module Language.Haskell.TH(
        fromE, fromThenE, fromToE, fromThenToE,
        listE, sigE, recConE, recUpdE, stringE, fieldExp,
        valD, funD, tySynD, dataD, newtypeD, classD, instanceD, sigD, forImpD,
-        pragInlD, pragSpecD, familyD, dataInstD, newtypeInstD, tySynInstD,
+        pragInlD, pragSpecD, familyNoKindD, familyKindD, dataInstD,
+        newtypeInstD, tySynInstD, 
        cxt, classP, equalP, normalC, recC, infixC,
-       forallT, varT, conT, appT, arrowT, listT, tupleT,
+       forallT, varT, conT, appT, arrowT, listT, tupleT, sigT,
        isStrict, notStrict, strictType, varStrictType,
        cCall, stdCall, unsafe, safe, threadsafe, 
         inlineSpecNoPhase, inlineSpecPhase, typeFam, dataFam,
index 7bc7ccb..a45090b 100644 (file)
@@ -279,24 +279,24 @@ funD nm cs =
     ; return (FunD nm cs1)
     }
 
-tySynD :: Name -> [Name] -> TypeQ -> DecQ
+tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ
 tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }
 
-dataD :: CxtQ -> Name -> [Name] -> [ConQ] -> [Name] -> DecQ
+dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> [Name] -> DecQ
 dataD ctxt tc tvs cons derivs =
   do
     ctxt1 <- ctxt
     cons1 <- sequence cons
     return (DataD ctxt1 tc tvs cons1 derivs)
 
-newtypeD :: CxtQ -> Name -> [Name] -> ConQ -> [Name] -> DecQ
+newtypeD :: CxtQ -> Name -> [TyVarBndr] -> ConQ -> [Name] -> DecQ
 newtypeD ctxt tc tvs con derivs =
   do
     ctxt1 <- ctxt
     con1 <- con
     return (NewtypeD ctxt1 tc tvs con1 derivs)
 
-classD :: CxtQ -> Name -> [Name] -> [FunDep] -> [DecQ] -> DecQ
+classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ
 classD ctxt cls tvs fds decs =
   do 
     decs1 <- sequence decs
@@ -338,8 +338,11 @@ pragSpecInlD n ty ispec
       ispec1 <- ispec
       return $ PragmaD (SpecialiseP n ty1 (Just ispec1))
 
-familyD :: FamFlavour -> Name -> [Name] -> DecQ
-familyD flav tc tvs = return $ FamilyD flav tc tvs
+familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ
+familyNoKindD flav tc tvs = return $ FamilyD flav tc tvs Nothing
+
+familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ
+familyKindD flav tc tvs k = return $ FamilyD flav tc tvs (Just k)
 
 dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> [Name] -> DecQ
 dataInstD ctxt tc tys cons derivs =
@@ -391,14 +394,14 @@ infixC st1 con st2 = do st1' <- st1
                         st2' <- st2
                         return $ InfixC st1' con st2'
 
-forallC :: [Name] -> CxtQ -> ConQ -> ConQ
+forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
 forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
 
 
 -------------------------------------------------------------------------------
 --     Type
 
-forallT :: [Name] -> CxtQ -> TypeQ -> TypeQ
+forallT :: [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
 forallT tvars ctxt ty = do
     ctxt1 <- ctxt
     ty1   <- ty
@@ -425,6 +428,12 @@ listT = return ListT
 tupleT :: Int -> TypeQ
 tupleT i = return (TupleT i)
 
+sigT :: TypeQ -> Kind -> TypeQ
+sigT t k
+  = do
+      t' <- t
+      return $ SigT t' k
+
 isStrict, notStrict :: Q Strict
 isStrict = return $ IsStrict
 notStrict = return $ NotStrict
@@ -437,6 +446,21 @@ varStrictType v st = do (s, t) <- st
                         return (v, s, t)
 
 -------------------------------------------------------------------------------
+--     Kind
+
+plainTV :: Name -> TyVarBndr
+plainTV = PlainTV
+
+kindedTV :: Name -> Kind -> TyVarBndr
+kindedTV = KindedTV
+
+starK :: Kind
+starK = StarK
+
+arrowK :: Kind -> Kind -> Kind
+arrowK = ArrowK
+
+-------------------------------------------------------------------------------
 --     Callconv
 
 cCall, stdCall :: Callconv
index fe5c5ed..a534fb7 100644 (file)
@@ -215,11 +215,14 @@ ppr_dec _ (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
 ppr_dec _ (SigD f t) = ppr f <+> text "::" <+> ppr t
 ppr_dec _ (ForeignD f) = ppr f
 ppr_dec _ (PragmaD p) = ppr p
-ppr_dec isTop (FamilyD flav tc tvs) 
-  = ppr flav <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs)
+ppr_dec isTop (FamilyD flav tc tvs k
+  = ppr flav <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind
   where
     maybeFamily | isTop     = text "family"
                 | otherwise = empty
+
+    maybeKind | (Just k') <- k = text "::" <+> ppr k'
+              | otherwise      = empty
 ppr_dec isTop (DataInstD ctxt tc tys cs decs) 
   = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) cs decs
   where
@@ -363,10 +366,11 @@ pprParendType ListT      = text "[]"
 pprParendType other      = parens (ppr other)
 
 instance Ppr Type where
-    ppr (ForallT tvars ctxt ty) = 
-        text "forall" <+> hsep (map ppr tvars) <+> text "."
+    ppr (ForallT tvars ctxt ty)
+      = text "forall" <+> hsep (map ppr tvars) <+> text "."
                       <+> pprCxt ctxt <+> ppr ty
-    ppr ty = pprTyApp (split ty)
+    ppr (SigT ty k) = ppr ty <+> text "::" <+> ppr k
+    ppr ty          = pprTyApp (split ty)
 
 pprTyApp :: (Type, [Type]) -> Doc
 pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
@@ -379,6 +383,7 @@ pprFunArgType :: Type -> Doc        -- Should really use a precedence argument
 -- Everything except forall and (->) binds more tightly than (->)
 pprFunArgType ty@(ForallT {})                 = parens (ppr ty)
 pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)
+pprFunArgType ty@(SigT _ _)                   = parens (ppr ty)
 pprFunArgType ty                              = ppr ty
 
 split :: Type -> (Type, [Type])    -- Split into function and args
@@ -387,6 +392,19 @@ split t = go t []
           go ty           args = (ty, args)
 
 ------------------------------
+instance Ppr TyVarBndr where
+    ppr (PlainTV nm)    = ppr nm
+    ppr (KindedTV nm k) = parens (ppr nm <+> text "::" <+> ppr k)
+
+instance Ppr Kind where
+    ppr StarK          = char '*'
+    ppr (ArrowK k1 k2) = pprArrowArgKind k1 <+> text "->" <+> ppr k2
+
+pprArrowArgKind :: Kind -> Doc
+pprArrowArgKind k@(ArrowK _ _) = parens (ppr k)
+pprArrowArgKind k              = ppr k
+
+------------------------------
 pprCxt :: Cxt -> Doc
 pprCxt [] = empty
 pprCxt [t] = ppr t <+> text "=>"
index 7554b62..0b38572 100644 (file)
@@ -30,9 +30,9 @@ module Language.Haskell.TH.Syntax(
         showName, showName', NameIs(..),
 
        -- The algebraic data types
-       Dec(..), Exp(..), Con(..), Type(..), Cxt, Pred(..), Match(..), 
-       Clause(..), Body(..), Guard(..), Stmt(..), Range(..),
-       Lit(..), Pat(..), FieldExp, FieldPat, 
+       Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..),Cxt,
+       Pred(..), Match(..),  Clause(..), Body(..), Guard(..), Stmt(..),
+       Range(..), Lit(..), Pat(..), FieldExp, FieldPat, 
        Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
        InlineSpec(..), StrictType, VarStrictType, FunDep(..), FamFlavour(..),
        Info(..), Loc(..), CharPos,
@@ -639,16 +639,16 @@ data Lit = CharL Char
 
 data Pat 
   = LitP Lit                      -- { 5 or 'c' }
-  | VarP Name                   -- { x }
+  | VarP Name                     -- { x }
   | TupP [Pat]                    -- { (p1,p2) }
-  | ConP Name [Pat]             -- data T1 = C1 t1 t2; {C1 p1 p1} = e 
+  | ConP Name [Pat]               -- data T1 = C1 t1 t2; {C1 p1 p1} = e 
   | InfixP Pat Name Pat           -- foo ({x :+ y}) = e 
   | TildeP Pat                    -- { ~p }
-  | AsP Name Pat                -- { x @ p }
+  | AsP Name Pat                  -- { x @ p }
   | WildP                         -- { _ }
-  | RecP Name [FieldPat]        -- f (Pt { pointx = x }) = g x
+  | RecP Name [FieldPat]          -- f (Pt { pointx = x }) = g x
   | ListP [ Pat ]                 -- { [1,2,3] }
-  | SigP Pat Type                 -- p :: t
+  | SigP Pat Type                 -- { p :: t }
   deriving( Show, Eq, Data, Typeable )
 
 type FieldPat = (Name,Pat)
@@ -661,8 +661,8 @@ data Clause = Clause [Pat] Body [Dec]
     deriving( Show, Eq, Data, Typeable )
  
 data Exp 
-  = VarE Name                        -- { x }
-  | ConE Name                        -- data T1 = C1 t1 t2; p = {C1} e1 e2  
+  = VarE Name                          -- { x }
+  | ConE Name                          -- data T1 = C1 t1 t2; p = {C1} e1 e2  
   | LitE Lit                           -- { 5 or 'c'}
   | AppE Exp Exp                       -- { f x }
 
@@ -682,7 +682,7 @@ data Exp
   | CompE [Stmt]                       -- { [ (x,y) | x <- xs, y <- ys ] }
   | ArithSeqE Range                    -- { [ 1 ,2 .. 10 ] }
   | ListE [ Exp ]                      -- { [1,2,3] }
-  | SigE Exp Type                      -- e :: t
+  | SigE Exp Type                      -- { e :: t }
   | RecConE Name [FieldExp]            -- { T { x = y, z = w } }
   | RecUpdE Exp [FieldExp]             -- { (f x) { z = w } }
   deriving( Show, Eq, Data, Typeable )
@@ -715,24 +715,25 @@ data Range = FromR Exp | FromThenR Exp Exp
 data Dec 
   = FunD Name [Clause]            -- { f p1 p2 = b where decs }
   | ValD Pat Body [Dec]           -- { p = b where decs }
-  | DataD Cxt Name [Name
+  | DataD Cxt Name [TyVarBndr
          [Con] [Name]             -- { data Cxt x => T x = A x | B (T x)
                                   --       deriving (Z,W)}
-  | NewtypeD Cxt Name [Name
+  | NewtypeD Cxt Name [TyVarBndr
          Con [Name]               -- { newtype Cxt x => T x = A (B x)
                                   --       deriving (Z,W)}
-  | TySynD Name [Name] Type       -- { type T x = (x,x) }
-  | ClassD Cxt Name [Name] [FunDep] [Dec]
-                                  -- { class Eq a => Ord a where ds }
+  | TySynD Name [TyVarBndr] Type  -- { type T x = (x,x) }
+  | ClassD Cxt Name [TyVarBndr] 
+         [FunDep] [Dec]           -- { class Eq a => Ord a where ds }
   | InstanceD Cxt Type [Dec]      -- { instance Show w => Show [w]
                                   --       where ds }
   | SigD Name Type                -- { length :: [a] -> Int }
   | ForeignD Foreign
   -- pragmas
   | PragmaD Pragma                -- { {-# INLINE [1] foo #-} }
-  -- type families (may appear in [Dec] of 'ClassD' and 'InstanceD')
-  | FamilyD FamFlavour Name [Name] {- (Maybe Kind) -}
-                                  -- { type family T a b c }
+  -- type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
+  | FamilyD FamFlavour Name 
+         [TyVarBndr] (Maybe Kind) -- { type family T a b c :: * }
+                                 
   | DataInstD Cxt Name [Type]
          [Con] [Name]             -- { data instance Cxt x => T [x] = A x 
                                   --                                | B (T x)
@@ -778,22 +779,31 @@ data Pred = ClassP Name [Type]    -- Eq (Int, a)
 data Strict = IsStrict | NotStrict
          deriving( Show, Eq, Data, Typeable )
 
-data Con = NormalC Name [StrictType]
-         | RecC Name [VarStrictType]
-         | InfixC StrictType Name StrictType
-         | ForallC [Name] Cxt Con
+data Con = NormalC Name [StrictType]          -- C Int a
+         | RecC Name [VarStrictType]          -- C { v :: Int, w :: a }
+         | InfixC StrictType Name StrictType  -- Int :+ a
+         | ForallC [TyVarBndr] Cxt Con        -- forall a. Eq a => C [a]
          deriving( Show, Eq, Data, Typeable )
 
 type StrictType = (Strict, Type)
 type VarStrictType = (Name, Strict, Type)
 
-data Type = ForallT [Name] Cxt Type   -- forall <vars>. <ctxt> -> <type>
-          | VarT Name                 -- a
-          | ConT Name                 -- T
-          | TupleT Int                -- (,), (,,), etc.
-          | ArrowT                    -- ->
-          | ListT                     -- []
-          | AppT Type Type            -- T a b
+data Type = ForallT [TyVarBndr] Cxt Type  -- forall <vars>. <ctxt> -> <type>
+          | VarT Name                     -- a
+          | ConT Name                     -- T
+          | TupleT Int                    -- (,), (,,), etc.
+          | ArrowT                        -- ->
+          | ListT                         -- []
+          | AppT Type Type                -- T a b
+          | SigT Type Kind                -- t :: k
+      deriving( Show, Eq, Data, Typeable )
+
+data TyVarBndr = PlainTV  Name            -- a
+               | KindedTV Name Kind       -- (a :: k)
+      deriving( Show, Eq, Data, Typeable )
+
+data Kind = StarK                         -- '*'
+          | ArrowK Kind Kind              -- k1 -> k2
       deriving( Show, Eq, Data, Typeable )
 
 -----------------------------------------------------