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
        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,
        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,
        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,
        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,
        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)
     }
 
     ; 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) }
 
 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)
 
 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)
 
 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
 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))
 
       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 =
 
 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'
 
                         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
 
 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
 forallT tvars ctxt ty = do
     ctxt1 <- ctxt
     ty1   <- ty
@@ -425,6 +428,12 @@ listT = return ListT
 tupleT :: Int -> TypeQ
 tupleT i = return (TupleT i)
 
 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
 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)
 
 -------------------------------------------------------------------------------
                         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
 --     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 _ (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
   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
 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
 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
                       <+> 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]
 
 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)
 -- 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
 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)
 
 ------------------------------
           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 "=>"
 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
         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,
        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' }
 
 data Pat 
   = LitP Lit                      -- { 5 or 'c' }
-  | VarP Name                   -- { x }
+  | VarP Name                     -- { x }
   | TupP [Pat]                    -- { (p1,p2) }
   | 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 }
   | InfixP Pat Name Pat           -- foo ({x :+ y}) = e 
   | TildeP Pat                    -- { ~p }
-  | AsP Name Pat                -- { x @ p }
+  | AsP Name Pat                  -- { x @ p }
   | WildP                         -- { _ }
   | WildP                         -- { _ }
-  | RecP Name [FieldPat]        -- f (Pt { pointx = x }) = g x
+  | RecP Name [FieldPat]          -- f (Pt { pointx = x }) = g x
   | ListP [ Pat ]                 -- { [1,2,3] }
   | ListP [ Pat ]                 -- { [1,2,3] }
-  | SigP Pat Type                 -- p :: t
+  | SigP Pat Type                 -- { p :: t }
   deriving( Show, Eq, Data, Typeable )
 
 type FieldPat = (Name,Pat)
   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 
     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 }
 
   | 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] }
   | 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 )
   | 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 }
 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)}
          [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)}
          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 #-} }
   | 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)
   | 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 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)
 
          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 )
 
 -----------------------------------------------------
       deriving( Show, Eq, Data, Typeable )
 
 -----------------------------------------------------