Change TH syntax to allow promoted kinds and kind polymorphism
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 18 May 2012 09:06:17 +0000 (10:06 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 18 May 2012 09:06:17 +0000 (10:06 +0100)
The big change here is that Kind is no longer a distinct type,
it's just a type synonym for Type.  This reflects exactly what
happens in the HsSyn world, and avoids a great deal of duplication
between types and kinds.   But it is a breaking for (the few)
TH users who were using the constructors for Kind.

Thanks to lunaris and Richard Eisenberg for doing the work.

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 d6c8994..a04967c 100644 (file)
@@ -6,7 +6,7 @@ For other documentation, refer to:
 -}
 module Language.Haskell.TH(
        -- * The monad and its operations
-       Q, runQ, 
+       Q, runQ,
        report,           -- :: Bool -> String -> Q ()
        recover,          -- :: Q a -> Q a -> Q a
        reify,            -- :: Name -> Q Info
@@ -51,11 +51,11 @@ module Language.Haskell.TH(
        fieldPat,
 
     -- *** Pattern Guards
-       normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, 
+       normalB, guardedB, normalG, normalGE, patG, patGE, match, clause,
 
     -- *** Expressions
        dyn, global, varE, conE, litE, appE, uInfixE, parensE,
-       infixE, infixApp, sectionL, sectionR, 
+       infixE, infixApp, sectionL, sectionR,
        lamE, lam1E, tupE, condE, letE, caseE, appsE,
        listE, sigE, recConE, recUpdE, stringE, fieldExp,
     -- **** Ranges
@@ -63,18 +63,24 @@ module Language.Haskell.TH(
 
     -- ***** Ranges with more indirection
     arithSeqE,
-    fromR, fromThenR, fromToR, fromThenToR, 
+    fromR, fromThenR, fromToR, fromThenToR,
     -- **** Statements
     doE, compE,
     bindS, letS, noBindS, parS,
 
     -- *** Types
-       forallT, varT, conT, appT, arrowT, listT, tupleT, sigT,
+       forallT, varT, conT, appT, arrowT, listT, tupleT, sigT, litT,
+    promotedT, promotedTupleT, promotedNilT, promotedConsT,
+    -- **** Type literals
+    numTyLit, strTyLit,
     -- **** Strictness
        isStrict, notStrict, strictType, varStrictType,
     -- **** Class Contexts
     cxt, classP, equalP, normalC, recC, infixC,
 
+    -- *** Kinds
+  varK, conK, tupleK, arrowK, listK, appK, starK, constraintK,
+
     -- *** Top Level Declarations
     -- **** Data
        valD, funD, tySynD, dataD, newtypeD,
@@ -82,7 +88,7 @@ module Language.Haskell.TH(
     classD, instanceD, sigD,
     -- **** Type Family / Data Family
     familyNoKindD, familyKindD, dataInstD,
-    newtypeInstD, tySynInstD, 
+    newtypeInstD, tySynInstD,
     typeFam, dataFam,
     -- **** Foreign Function Interface (FFI)
     cCall, stdCall, unsafe, safe, forImpD,
@@ -93,7 +99,7 @@ module Language.Haskell.TH(
 
        -- * Pretty-printer
     Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType
-       
+
    ) where
 
 import Language.Haskell.TH.Syntax
index 909573c..abb070f 100644 (file)
@@ -470,8 +470,8 @@ arrowT = return ArrowT
 listT :: TypeQ
 listT = return ListT
 
-litT :: TyLit -> TypeQ
-litT l = return (LitT l)
+litT :: TyLitQ -> TypeQ
+litT l = fmap LitT l
 
 tupleT :: Int -> TypeQ
 tupleT i = return (TupleT i)
@@ -485,6 +485,18 @@ sigT t k
       t' <- t
       return $ SigT t' k
 
+promotedT :: Name -> TypeQ
+promotedT = return . PromotedT
+
+promotedTupleT :: Int -> TypeQ
+promotedTupleT i = return (PromotedTupleT i)
+
+promotedNilT :: TypeQ
+promotedNilT = return PromotedNilT
+
+promotedConsT :: TypeQ
+promotedConsT = return PromotedConsT
+
 isStrict, notStrict, unpacked :: Q Strict
 isStrict = return $ IsStrict
 notStrict = return $ NotStrict
@@ -517,11 +529,29 @@ plainTV = PlainTV
 kindedTV :: Name -> Kind -> TyVarBndr
 kindedTV = KindedTV
 
+varK :: Name -> Kind
+varK = VarT
+
+conK :: Name -> Kind
+conK = ConT
+
+tupleK :: Int -> Kind
+tupleK = TupleT
+
+arrowK :: Kind
+arrowK = ArrowT
+
+listK :: Kind
+listK = ListT
+
+appK :: Kind -> Kind -> Kind
+appK = AppT
+
 starK :: Kind
-starK = StarK
+starK = StarT
 
-arrowK :: Kind -> Kind -> Kind
-arrowK = ArrowK
+constraintK :: Kind
+constraintK = ConstraintT
 
 -------------------------------------------------------------------------------
 -- *   Callconv
index b17e4c0..89fd3df 100644 (file)
@@ -388,15 +388,22 @@ pprStrictType (Unpacked, t) = text "{-# UNPACK #-} !" <> pprParendType t
 
 ------------------------------
 pprParendType :: Type -> Doc
-pprParendType (VarT v)   = ppr v
-pprParendType (ConT c)   = ppr c
-pprParendType (TupleT 0) = text "()"
-pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))
-pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma
-pprParendType ArrowT     = parens (text "->")
-pprParendType ListT      = text "[]"
-pprParendType (LitT l)   = pprTyLit l
-pprParendType other      = parens (ppr other)
+pprParendType (VarT v)            = ppr v
+pprParendType (ConT c)            = ppr c
+pprParendType (TupleT 0)          = text "()"
+pprParendType (TupleT n)          = parens (hcat (replicate (n-1) comma))
+pprParendType (UnboxedTupleT n)   = hashParens $ hcat $ replicate (n-1) comma
+pprParendType ArrowT              = parens (text "->")
+pprParendType ListT               = text "[]"
+pprParendType (LitT l)            = pprTyLit l
+pprParendType (PromotedT c)       = text "'" <> ppr c
+pprParendType (PromotedTupleT 0)  = text "'()"
+pprParendType (PromotedTupleT n)  = quoteParens (hcat (replicate (n-1) comma))
+pprParendType PromotedNilT        = text "'[]"
+pprParendType PromotedConsT       = text "(':)"
+pprParendType StarT               = char '*'
+pprParendType ConstraintT         = text "Constraint"
+pprParendType other               = parens (ppr other)
 
 instance Ppr Type where
     ppr (ForallT tvars ctxt ty)
@@ -410,6 +417,8 @@ pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2
 pprTyApp (ListT, [arg]) = brackets (ppr arg)
 pprTyApp (TupleT n, args)
  | length args == n = parens (sep (punctuate comma (map ppr args)))
+pprTyApp (PromotedTupleT n, args)
+ | length args == n = quoteParens (sep (punctuate comma (map ppr args)))
 pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)
 
 pprFunArgType :: Type -> Doc   -- Should really use a precedence argument
@@ -436,14 +445,6 @@ 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
@@ -478,3 +479,6 @@ showtextl = text . map toLower . show
 hashParens :: Doc -> Doc
 hashParens d = text "(# " <> d <> text " #)"
 
+quoteParens :: Doc -> Doc
+quoteParens d = text "'(" <> d <> text ")"
+
index cb1a20f..c18d801 100644 (file)
@@ -986,14 +986,22 @@ type StrictType = (Strict, Type)
 type VarStrictType = (Name, Strict, Type)
 
 data Type = ForallT [TyVarBndr] Cxt Type  -- ^ @forall <vars>. <ctxt> -> <type>@
+          | AppT Type Type                -- ^ @T a b@
+          | SigT Type Kind                -- ^ @t :: k@
           | VarT Name                     -- ^ @a@
           | ConT Name                     -- ^ @T@
+          | PromotedT Name                -- ^ @'T@
+
+          -- See Note [Representing concrete syntax in types]
           | TupleT Int                    -- ^ @(,), (,,), etc.@
           | UnboxedTupleT Int             -- ^ @(#,#), (#,,#), etc.@
           | ArrowT                        -- ^ @->@
           | ListT                         -- ^ @[]@
-          | AppT Type Type                -- ^ @T a b@
-          | SigT Type Kind                -- ^ @t :: k@
+          | PromotedTupleT Int            -- ^ @'(), '(,), '(,,), etc.@
+          | PromotedNilT                  -- ^ @'[]@
+          | PromotedConsT                 -- ^ @(':)@
+          | StarT                         -- ^ @*@
+          | ConstraintT                   -- ^ @Constraint@
           | LitT TyLit                    -- ^ @0,1,2, etc.@
       deriving( Show, Eq, Data, Typeable )
 
@@ -1001,13 +1009,49 @@ data TyVarBndr = PlainTV  Name            -- ^ @a@
                | KindedTV Name Kind       -- ^ @(a :: k)@
       deriving( Show, Eq, Data, Typeable )
 
-data TyLit = NumTyLit Integer
-           | StrTyLit String
+data TyLit = NumTyLit Integer             -- ^ @2@
+           | StrTyLit String              -- ^ @"Hello"@
   deriving ( Show, Eq, Data, Typeable )
 
-data Kind = StarK                         -- ^ @'*'@
-          | ArrowK Kind Kind              -- ^ @k1 -> k2@
-      deriving( Show, Eq, Data, Typeable )
+-- | To avoid duplication between kinds and types, they
+-- are defined to be the same. Naturally, you would never
+-- have a type be 'StarT' and you would never have a kind
+-- be 'SigT', but many of the other constructors are shared.
+-- Note that the kind @Bool@ is denoted with 'ConT', not
+-- 'PromotedT'. Similarly, tuple kinds are made with 'TupleT',
+-- not 'PromotedTupleT'.
+
+type Kind = Type     
+
+{- Note [Representing concrete syntax in types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Haskell has a rich concrete syntax for types, including
+  t1 -> t2, (t1,t2), [t], and so on
+In TH we represent all of this using AppT, with a distinguished
+type construtor at the head.  So,
+  Type              TH representation
+  -----------------------------------------------
+  t1 -> t2          ArrowT `AppT` t2 `AppT` t2
+  [t]               ListT `AppT` t
+  (t1,t2)          TupleT 2 `AppT` t1 `AppT` t2
+  '(t1,t2)          PromotedTupleT 2 `AppT` t1 `AppT` t2
+
+But if the original HsSyn used prefix application, we won't use
+these special TH constructors.  For example
+  [] t              ConT "[]" `AppT` t
+  (->) t            ConT "->" `AppT` t
+In this way we can faithfully represent in TH whether the original
+HsType used concrete syntax or not.
+
+The one case that doesn't fit this pattern is that of promoted lists
+  '[ Maybe, IO ]    PromotedListT 2 `AppT` t1 `AppT` t2
+but it's very smelly because there really is no type constructor
+corresponding to PromotedListT. So we encode HsExplicitListTy with
+PromotedConsT and PromotedNilT (which *do* have underlying type
+constructors):
+  '[ Maybe, IO ]    PromotedConsT `AppT` Maybe `AppT` 
+                    (PromotedConsT  `AppT` IO `AppT` PromotedNilT)
+-}
 
 -----------------------------------------------------
 --             Internal helper functions