Add unboxed tuple support to Template Haskell
authorIan Lynagh <igloo@earth.li>
Thu, 10 Feb 2011 13:47:25 +0000 (13:47 +0000)
committerIan Lynagh <igloo@earth.li>
Thu, 10 Feb 2011 13:47:25 +0000 (13:47 +0000)
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 a65c53f..fc8ab76 100644 (file)
@@ -64,6 +64,8 @@ varP :: Name -> PatQ
 varP v = return (VarP v)
 tupP :: [PatQ] -> PatQ
 tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
+unboxedTupP :: [PatQ] -> PatQ
+unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)}
 conP :: Name -> [PatQ] -> PatQ
 conP n ps = do ps' <- sequence ps
                return (ConP n ps')
@@ -226,6 +228,9 @@ lam1E p e = lamE [p] e
 tupE :: [ExpQ] -> ExpQ
 tupE es = do { es1 <- sequence es; return (TupE es1)}
 
+unboxedTupE :: [ExpQ] -> ExpQ
+unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}
+
 condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
 condE x y z =  do { a <- x; b <- y; c <- z; return (CondE a b c)}
 
@@ -443,6 +448,9 @@ listT = return ListT
 tupleT :: Int -> TypeQ
 tupleT i = return (TupleT i)
 
+unboxedTupleT :: Int -> TypeQ
+unboxedTupleT i = return (UnboxedTupleT i)
+
 sigT :: TypeQ -> Kind -> TypeQ
 sigT t k
   = do
index d48d027..6c324f0 100644 (file)
@@ -108,6 +108,7 @@ pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1
 pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)
                                            <+> text "->" <+> ppr e
 pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es
+pprExp _ (UnboxedTupE es) = hashParens $ sep $ punctuate comma $ map ppr es
 -- Nesting in Cond is to avoid potential problems in do statments
 pprExp i (CondE guard true false)
  = parensIf (i > noPrec) $ sep [text "if"   <+> ppr guard,
@@ -190,6 +191,7 @@ pprPat :: Precedence -> Pat -> Doc
 pprPat i (LitP l)     = pprLit i l
 pprPat _ (VarP v)     = pprName' Applied v
 pprPat _ (TupP ps)    = parens $ sep $ punctuate comma $ map ppr ps
+pprPat _ (UnboxedTupP ps) = hashParens $ sep $ punctuate comma $ map ppr ps
 pprPat i (ConP s ps)  = parensIf (i >= appPrec) $ pprName' Applied s
                                               <+> sep (map (pprPat appPrec) ps)
 pprPat i (InfixP p1 n p2)
@@ -379,6 +381,7 @@ 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 other      = parens (ppr other)
@@ -453,3 +456,6 @@ where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds
 showtextl :: Show a => a -> Doc
 showtextl = text . map toLower . show
 
+hashParens :: Doc -> Doc
+hashParens d = text "(# " <> d <> text " #)"
+
index 27e5707..b763aba 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE UnboxedTuples #-}
 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 -- The -fno-warn-warnings-deprecations flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
@@ -45,6 +46,7 @@ module Language.Haskell.TH.Syntax(
        NameFlavour(..), NameSpace (..), 
        mkNameG_v, mkNameG_d, mkNameG_tc, Uniq, mkNameL, mkNameU,
        tupleTypeName, tupleDataName,
+       unboxedTupleTypeName, unboxedTupleDataName,
        OccName, mkOccName, occString,
        ModName, mkModName, modString,
        PkgName, mkPkgName, pkgString
@@ -557,17 +559,17 @@ showName' ni nm
 instance Show Name where
   show = showName
 
---     Tuple data and type constructors
+-- Tuple data and type constructors
 tupleDataName :: Int -> Name    -- ^ Data constructor
 tupleTypeName :: Int -> Name    -- ^ Type constructor
 
-tupleDataName 0 = mk_tup_name 0 DataName 
+tupleDataName 0 = mk_tup_name 0 DataName
 tupleDataName 1 = error "tupleDataName 1"
-tupleDataName n = mk_tup_name (n-1) DataName 
+tupleDataName n = mk_tup_name (n-1) DataName
 
-tupleTypeName 0 = mk_tup_name 0 TcClsName 
+tupleTypeName 0 = mk_tup_name 0 TcClsName
 tupleTypeName 1 = error "tupleTypeName 1"
-tupleTypeName n = mk_tup_name (n-1) TcClsName 
+tupleTypeName n = mk_tup_name (n-1) TcClsName
 
 mk_tup_name :: Int -> NameSpace -> Name
 mk_tup_name n_commas space
@@ -577,6 +579,25 @@ mk_tup_name n_commas space
     -- XXX Should it be GHC.Unit for 0 commas?
     tup_mod = mkModName "GHC.Tuple"
 
+-- Unboxed tuple data and type constructors
+unboxedTupleDataName :: Int -> Name    -- ^ Data constructor
+unboxedTupleTypeName :: Int -> Name    -- ^ Type constructor
+
+unboxedTupleDataName 0 = error "unboxedTupleDataName 0"
+unboxedTupleDataName 1 = error "unboxedTupleDataName 1"
+unboxedTupleDataName n = mk_unboxed_tup_name (n-1) DataName
+
+unboxedTupleTypeName 0 = error "unboxedTupleTypeName 0"
+unboxedTupleTypeName 1 = error "unboxedTupleTypeName 1"
+unboxedTupleTypeName n = mk_unboxed_tup_name (n-1) TcClsName
+
+mk_unboxed_tup_name :: Int -> NameSpace -> Name
+mk_unboxed_tup_name n_commas space
+  = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod)
+  where
+    occ = mkOccName ("(#" ++ replicate n_commas ',' ++ "#)")
+    tup_mod = mkModName "GHC.Tuple"
+
 
 
 -----------------------------------------------------
@@ -691,6 +712,7 @@ data Pat
   = LitP Lit                      -- ^ @{ 5 or 'c' }@
   | VarP Name                     -- ^ @{ x }@
   | TupP [Pat]                    -- ^ @{ (p1,p2) }@
+  | UnboxedTupP [Pat]             -- ^ @{ (# p1,p2 #) }@
   | ConP Name [Pat]               -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@
   | InfixP Pat Name Pat           -- ^ @foo ({x :+ y}) = e@
   | TildeP Pat                    -- ^ @{ ~p }@
@@ -736,6 +758,7 @@ data Exp
 
   | LamE [Pat] Exp                     -- ^ @{ \ p1 p2 -> e }@
   | TupE [Exp]                         -- ^ @{ (e1,e2) }  @
+  | UnboxedTupE [Exp]                  -- ^ @{ (# e1,e2 #) }  @
   | CondE Exp Exp Exp                  -- ^ @{ if e1 then e2 else e3 }@
   | LetE [Dec] Exp                     -- ^ @{ let x=e1;   y=e2 in e3 }@
   | CaseE Exp [Match]                  -- ^ @{ case e of m1; m2 }@
@@ -855,6 +878,7 @@ data Type = ForallT [TyVarBndr] Cxt Type  -- ^ @forall <vars>. <ctxt> -> <type>@
           | VarT Name                     -- ^ @a@
           | ConT Name                     -- ^ @T@
           | TupleT Int                    -- ^ @(,), (,,), etc.@
+          | UnboxedTupleT Int             -- ^ @(#,#), (#,,#), etc.@
           | ArrowT                        -- ^ @->@
           | ListT                         -- ^ @[]@
           | AppT Type Type                -- ^ @T a b@