[project @ 2004-01-15 14:43:24 by igloo]
authorigloo <unknown>
Thu, 15 Jan 2004 14:43:24 +0000 (14:43 +0000)
committerigloo <unknown>
Thu, 15 Jan 2004 14:43:24 +0000 (14:43 +0000)
Split Template Haskell out to its own package and update docs and tests.

libraries/template-haskell/Language/Haskell/TH.hs [new file with mode: 0644]
libraries/template-haskell/Language/Haskell/TH/Lib.hs [new file with mode: 0644]
libraries/template-haskell/Language/Haskell/TH/Ppr.hs [new file with mode: 0644]
libraries/template-haskell/Language/Haskell/TH/PprLib.hs [new file with mode: 0644]
libraries/template-haskell/Language/Haskell/TH/Syntax.hs [new file with mode: 0644]
libraries/template-haskell/Makefile [new file with mode: 0644]
libraries/template-haskell/package.conf.in [new file with mode: 0644]
libraries/template-haskell/prologue.txt [new file with mode: 0644]

diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
new file mode 100644 (file)
index 0000000..7ac5117
--- /dev/null
@@ -0,0 +1,36 @@
+-- The public face of Template Haskell
+
+module Language.Haskell.TH(
+       -- The monad and its operations
+       Q, runQ, 
+       report,         -- :: Bool -> String -> Q ()
+       recover,        -- :: Q a -> Q a -> Q a
+       reify,          -- :: Name -> Q Decl
+       currentModule,  -- :: Q String
+       runIO,          -- :: IO a -> Q a
+
+       -- Names
+       Name, 
+       mkName,         -- :: String -> Name
+       newName,        -- :: String -> Q Name
+       nameBase,       -- :: Name -> String
+       
+       -- The algebraic data types
+       Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..), 
+       Clause(..), Body(..), Stmt(..), Range(..),
+       Lit(..), Pat(..), FieldExp, FieldPat, 
+       Strict(..), Foreign(..), Callconv(..), Safety(..),
+       Info(..), 
+       Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
+
+       -- Library functions
+       module Language.Haskell.TH.Lib,
+    -- Pretty-printer
+       module Language.Haskell.TH.Ppr,
+       
+   ) where
+
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Ppr
+
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
new file mode 100644 (file)
index 0000000..e64c3fc
--- /dev/null
@@ -0,0 +1,366 @@
+-- TH.Lib contains lots of useful helper functions for
+-- generating and manipulating Template Haskell terms
+
+module Language.Haskell.TH.Lib where
+    -- All of the exports from this module should
+    -- be "public" functions.  The main module TH
+    -- re-exports them all.
+
+import Language.Haskell.TH.Syntax
+import Control.Monad( liftM, liftM2 )
+
+----------------------------------------------------------
+-- Type synonyms
+----------------------------------------------------------
+
+type InfoQ          = Q Info
+type ExpQ           = Q Exp
+type DecQ           = Q Dec
+type ConQ           = Q Con
+type TypeQ          = Q Type
+type CxtQ           = Q Cxt
+type MatchQ         = Q Match
+type ClauseQ        = Q Clause
+type BodyQ          = Q Body
+type StmtQ          = Q Stmt
+type RangeQ         = Q Range
+type StrictTypeQ    = Q StrictType
+type VarStrictTypeQ = Q VarStrictType
+
+----------------------------------------------------------
+-- Lowercase pattern syntax functions
+----------------------------------------------------------
+
+intPrimL    :: Integer -> Lit
+intPrimL    = IntPrimL
+floatPrimL  :: Rational -> Lit
+floatPrimL  = FloatPrimL
+doublePrimL :: Rational -> Lit
+doublePrimL = DoublePrimL
+integerL    :: Integer -> Lit
+integerL    = IntegerL
+charL       :: Char -> Lit
+charL       = CharL
+stringL     :: String -> Lit
+stringL     = StringL
+rationalL   :: Rational -> Lit
+rationalL   = RationalL
+
+litP :: Lit -> Pat
+litP = LitP
+varP :: Name -> Pat
+varP = VarP
+tupP :: [Pat] -> Pat
+tupP = TupP
+conP :: Name -> [Pat] -> Pat
+conP = ConP
+tildeP :: Pat -> Pat
+tildeP = TildeP
+asP :: Name -> Pat -> Pat
+asP = AsP
+wildP :: Pat
+wildP = WildP
+recP :: Name -> [FieldPat] -> Pat
+recP = RecP
+listP :: [Pat] -> Pat
+listP = ListP
+
+fieldPat :: Name -> Pat -> (Name, Pat)
+fieldPat = (,)
+
+
+-------------------------------------------------------------------------------
+--     Stmt
+
+bindS :: Pat -> ExpQ -> StmtQ
+bindS p e = liftM (BindS p) e
+
+letS :: [DecQ] -> StmtQ
+letS ds = do { ds1 <- sequence ds; return (LetS ds1) }
+
+noBindS :: ExpQ -> StmtQ
+noBindS e = do { e1 <- e; return (NoBindS e1) }
+
+parS :: [[StmtQ]] -> StmtQ
+parS _ = fail "No parallel comprehensions yet"
+
+-------------------------------------------------------------------------------
+--     Range
+
+fromR :: ExpQ -> RangeQ
+fromR x = do { a <- x; return (FromR a) }  
+
+fromThenR :: ExpQ -> ExpQ -> RangeQ
+fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) }  
+
+fromToR :: ExpQ -> ExpQ -> RangeQ
+fromToR x y = do { a <- x; b <- y; return (FromToR a b) }  
+
+fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ
+fromThenToR x y z = do { a <- x; b <- y; c <- z;
+                         return (FromThenToR a b c) }  
+-------------------------------------------------------------------------------
+--     Body
+
+normalB :: ExpQ -> BodyQ
+normalB e = do { e1 <- e; return (NormalB e1) }
+
+guardedB :: [(ExpQ,ExpQ)] -> BodyQ
+guardedB ges = do { ges' <- mapM f ges; return (GuardedB ges') }
+    where f (g, e) = do { g' <- g; e' <- e; return (g', e') }
+
+-------------------------------------------------------------------------------
+--     Match and Clause
+
+match :: Pat -> BodyQ -> [DecQ] -> MatchQ
+match p rhs ds = do { r' <- rhs;
+                      ds' <- sequence ds;
+                      return (Match p r' ds') }
+
+clause :: [Pat] -> BodyQ -> [DecQ] -> ClauseQ
+clause ps r ds = do { r' <- r;
+                      ds' <- sequence ds;
+                      return (Clause ps r' ds') }
+
+
+---------------------------------------------------------------------------
+--     Exp
+
+global :: Name -> ExpQ
+global s = return (VarE s)
+
+varE :: Name -> ExpQ
+varE s = return (VarE s)
+
+conE :: Name -> ExpQ
+conE s =  return (ConE s)
+
+litE :: Lit -> ExpQ
+litE c = return (LitE c)
+
+appE :: ExpQ -> ExpQ -> ExpQ
+appE x y = do { a <- x; b <- y; return (AppE a b)}
+
+infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
+infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
+                                  return (InfixE (Just a) s' (Just b))}
+infixE Nothing  s (Just y) = do { s' <- s; b <- y;
+                                  return (InfixE Nothing s' (Just b))}
+infixE (Just x) s Nothing  = do { a <- x; s' <- s;
+                                  return (InfixE (Just a) s' Nothing)}
+infixE Nothing  s Nothing  = do { s' <- s; return (InfixE Nothing s' Nothing) }
+
+infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+infixApp x y z = infixE (Just x) y (Just z)
+sectionL :: ExpQ -> ExpQ -> ExpQ
+sectionL x y = infixE (Just x) y Nothing
+sectionR :: ExpQ -> ExpQ -> ExpQ
+sectionR x y = infixE Nothing x (Just y)
+
+lamE :: [Pat] -> ExpQ -> ExpQ
+lamE ps e = liftM (LamE ps) e
+
+lam1E :: Pat -> ExpQ -> ExpQ    -- Single-arg lambda
+lam1E p e = lamE [p] e
+
+tupE :: [ExpQ] -> ExpQ
+tupE es = do { es1 <- sequence es; return (TupE es1)}
+
+condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+condE x y z =  do { a <- x; b <- y; c <- z; return (CondE a b c)}
+
+letE :: [DecQ] -> ExpQ -> ExpQ
+letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }
+
+caseE :: ExpQ -> [MatchQ] -> ExpQ
+caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) } 
+
+doE :: [StmtQ] -> ExpQ
+doE ss = do { ss1 <- sequence ss; return (DoE ss1) } 
+
+compE :: [StmtQ] -> ExpQ
+compE ss = do { ss1 <- sequence ss; return (CompE ss1) } 
+
+arithSeqE :: RangeQ -> ExpQ
+arithSeqE r = do { r' <- r; return (ArithSeqE r') }  
+
+-- arithSeqE Shortcuts
+fromE :: ExpQ -> ExpQ
+fromE x = do { a <- x; return (ArithSeqE (FromR a)) }  
+
+fromThenE :: ExpQ -> ExpQ -> ExpQ
+fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }  
+
+fromToE :: ExpQ -> ExpQ -> ExpQ
+fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }  
+
+fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+fromThenToE x y z = do { a <- x; b <- y; c <- z;
+                         return (ArithSeqE (FromThenToR a b c)) }  
+-- End arithSeqE shortcuts
+
+listE :: [ExpQ] -> ExpQ
+listE es = do { es1 <- sequence es; return (ListE es1) }
+
+sigE :: ExpQ -> TypeQ -> ExpQ
+sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }
+
+recConE :: Name -> [Q (Name,Exp)] -> ExpQ
+recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }
+
+recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ
+recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) }
+
+stringE :: String -> ExpQ
+stringE = litE . stringL
+
+fieldExp :: Name -> ExpQ -> Q (Name, Exp)
+fieldExp s e = do { e' <- e; return (s,e') }
+
+-------------------------------------------------------------------------------
+--     Dec
+
+valD :: Pat -> BodyQ -> [DecQ] -> DecQ
+valD p b ds = 
+  do { ds' <- sequence ds
+     ; b' <- b
+     ; return (ValD p b' ds')
+     }
+
+funD :: Name -> [ClauseQ] -> DecQ
+funD nm cs = 
+ do { cs1 <- sequence cs
+    ; return (FunD nm cs1)
+    }
+
+tySynD :: Name -> [Name] -> TypeQ -> DecQ
+tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }
+
+dataD :: CxtQ -> Name -> [Name] -> [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 ctxt tc tvs con derivs =
+  do
+    ctxt1 <- ctxt
+    con1 <- con
+    return (NewtypeD ctxt1 tc tvs con1 derivs)
+
+classD :: CxtQ -> Name -> [Name] -> [DecQ] -> DecQ
+classD ctxt cls tvs decs =
+  do 
+    decs1 <- sequence decs
+    ctxt1 <- ctxt
+    return $ ClassD ctxt1 cls tvs decs1
+
+instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
+instanceD ctxt ty decs =
+  do 
+    ctxt1 <- ctxt
+    decs1 <- sequence decs
+    ty1   <- ty
+    return $ InstanceD ctxt1 ty1 decs1
+
+sigD :: Name -> TypeQ -> DecQ
+sigD fun ty = liftM (SigD fun) $ ty
+
+cxt :: [TypeQ] -> CxtQ
+cxt = sequence
+
+normalC :: Name -> [StrictTypeQ] -> ConQ
+normalC con strtys = liftM (NormalC con) $ sequence strtys
+
+recC :: Name -> [VarStrictTypeQ] -> ConQ
+recC con varstrtys = liftM (RecC con) $ sequence varstrtys
+
+infixC :: Q (Strict, Type) -> Name -> Q (Strict, Type) -> ConQ
+infixC st1 con st2 = do st1' <- st1
+                        st2' <- st2
+                        return $ InfixC st1' con st2'
+
+
+-------------------------------------------------------------------------------
+--     Type
+
+forallT :: [Name] -> CxtQ -> TypeQ -> TypeQ
+forallT tvars ctxt ty = do
+    ctxt1 <- ctxt
+    ty1   <- ty
+    return $ ForallT tvars ctxt1 ty1
+
+varT :: Name -> TypeQ
+varT = return . VarT
+
+conT :: Name -> TypeQ
+conT = return . ConT
+
+appT :: TypeQ -> TypeQ -> TypeQ
+appT t1 t2 = do
+           t1' <- t1
+           t2' <- t2
+           return $ AppT t1' t2'
+
+arrowT :: TypeQ
+arrowT = return ArrowT
+
+listT :: TypeQ
+listT = return ListT
+
+tupleT :: Int -> TypeQ
+tupleT i = return (TupleT i)
+
+isStrict, notStrict :: Q Strict
+isStrict = return $ IsStrict
+notStrict = return $ NotStrict
+
+strictType :: Q Strict -> TypeQ -> StrictTypeQ
+strictType = liftM2 (,)
+
+varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ
+varStrictType v st = do (s, t) <- st
+                        return (v, s, t)
+
+--------------------------------------------------------------
+-- Useful helper functions
+
+combine :: [([(Name, Name)], Pat)] -> ([(Name, Name)], [Pat])
+combine pairs = foldr f ([],[]) pairs
+  where f (env,p) (es,ps) = (env++es,p:ps)
+
+rename :: Pat -> Q ([(Name, Name)], Pat)
+rename (LitP c)  = return([],LitP c)
+rename (VarP s)  = do { s1 <- newName (nameBase s); return([(s,s1)],VarP s1) }
+rename (TupP pats) = do { pairs <- mapM rename pats; g(combine pairs) }
+   where g (es,ps) = return (es,TupP ps)
+rename (ConP nm pats) = do { pairs <- mapM rename pats; g(combine pairs) }
+   where g (es,ps) = return (es,ConP nm ps)
+rename (TildeP p) = do { (env,p2) <- rename p; return(env,TildeP p2) }   
+rename (AsP s p) = 
+   do { s1 <- newName (nameBase s); (env,p2) <- rename p; return((s,s1):env,AsP s1 p2) }
+rename WildP = return([],WildP)
+rename (RecP nm fs) = do { pairs <- mapM rename ps; g(combine pairs) }
+    where g (env,ps') = return (env,RecP nm (zip ss ps'))
+          (ss,ps) = unzip fs
+rename (ListP pats) = do { pairs <- mapM rename pats; g(combine pairs) }
+   where g (es,ps) = return (es,ListP ps)
+
+genpat :: Pat -> Q ((Name -> ExpQ), Pat)
+genpat p = do { (env,p2) <- rename p; return (alpha env,p2) }
+
+alpha :: [(Name, Name)] -> Name -> ExpQ
+alpha env s = case lookup s env of
+               Just x -> varE x
+               Nothing -> varE s
+
+appsE :: [ExpQ] -> ExpQ
+appsE [] = error "appsExp []"
+appsE [x] = x
+appsE (x:y:zs) = appsE ( (appE x y) : zs )
+
+simpleMatch :: Pat -> Exp -> Match
+simpleMatch p e = Match p (NormalB e) []
+
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
new file mode 100644 (file)
index 0000000..955ee1e
--- /dev/null
@@ -0,0 +1,303 @@
+-- TH.Ppr contains a prettyprinter for the
+-- Template Haskell datatypes
+
+module Language.Haskell.TH.Ppr where
+    -- All of the exports from this module should
+    -- be "public" functions.  The main module TH
+    -- re-exports them all.
+
+import Text.PrettyPrint.HughesPJ (render)
+import Language.Haskell.TH.PprLib
+import Language.Haskell.TH.Syntax
+import Data.Char ( toLower )
+
+nestDepth :: Int
+nestDepth = 4
+
+type Precedence = Int
+appPrec, opPrec, noPrec :: Precedence
+appPrec = 2    -- Argument of a function application
+opPrec  = 1    -- Argument of an infix operator
+noPrec  = 0    -- Others
+
+parensIf :: Bool -> Doc -> Doc
+parensIf True d = parens d
+parensIf False d = d
+
+------------------------------
+
+pprint :: Ppr a => a -> String
+pprint x = render $ to_HPJ_Doc $ ppr x
+
+class Ppr a where
+    ppr :: a -> Doc
+    ppr_list :: [a] -> Doc
+    ppr_list = vcat . map ppr
+
+instance Ppr a => Ppr [a] where
+    ppr x = ppr_list x
+
+------------------------------
+instance Ppr Name where
+    ppr v = pprName v -- text (show v)
+
+------------------------------
+instance Ppr Info where
+    ppr (ClassI d) = ppr d
+    ppr (TyConI d) = ppr d
+    ppr (ClassOpI v ty cls fix) 
+      = text "Class op from" <+> ppr cls <> colon <+>
+        vcat [ppr_sig v ty, pprFixity v fix]
+    ppr (DataConI v ty tc fix) 
+      = text "Constructor from" <+> ppr tc <> colon <+>
+        vcat [ppr_sig v ty, pprFixity v fix]
+    ppr (TyVarI v ty)
+      = text "Type variable" <+> ppr v <+> equals <+> ppr ty
+    ppr (VarI v ty mb_d fix) 
+      = vcat [ppr_sig v ty, pprFixity v fix, 
+              case mb_d of { Nothing -> empty; Just d -> ppr d }]
+
+ppr_sig v ty = ppr v <+> text "::" <+> ppr ty
+
+pprFixity :: Name -> Fixity -> Doc
+pprFixity v f | f == defaultFixity = empty
+pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v
+    where ppr_fix InfixR = text "infixr"
+          ppr_fix InfixL = text "infixl"
+          ppr_fix InfixN = text "infix"
+
+
+------------------------------
+instance Ppr Exp where
+    ppr = pprExp noPrec
+
+pprExp :: Precedence -> Exp -> Doc
+pprExp _ (VarE v)     = ppr v
+pprExp _ (ConE c)     = ppr c
+pprExp i (LitE l)     = pprLit i l
+pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1
+                                              <+> pprExp appPrec e2
+pprExp i (InfixE (Just e1) op (Just e2))
+ = parensIf (i >= opPrec) $ pprExp opPrec e1
+                        <+> ppr op
+                        <+> pprExp opPrec e2
+pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1
+                                    <+> ppr op
+                                    <+> pprMaybeExp noPrec me2
+pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map ppr ps)
+                                           <+> text "->" <+> ppr e
+pprExp _ (TupE es) = parens $ 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,
+                       nest 1 $ text "then" <+> ppr true,
+                       nest 1 $ text "else" <+> ppr false]
+pprExp i (LetE ds e) = parensIf (i > noPrec) $ text "let" <+> ppr ds
+                                            $$ text " in" <+> ppr e
+pprExp i (CaseE e ms)
+ = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"
+                        $$ nest nestDepth (ppr ms)
+pprExp i (DoE ss) = parensIf (i > noPrec) $ text "do" <+> ppr ss
+pprExp _ (CompE []) = error "Can't happen: pprExp (CompExp [])"
+-- This will probably break with fixity declarations - would need a ';'
+pprExp _ (CompE ss) = text "[" <> ppr s
+                  <+> text "|"
+                  <+> (sep $ punctuate comma $ map ppr ss')
+                   <> text "]"
+    where s = last ss
+          ss' = init ss
+pprExp _ (ArithSeqE d) = ppr d
+pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es
+pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t
+pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
+pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
+
+pprFields :: [(Name,Exp)] -> Doc
+pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)
+
+pprMaybeExp :: Precedence -> Maybe Exp -> Doc
+pprMaybeExp _ Nothing = empty
+pprMaybeExp i (Just e) = pprExp i e
+
+------------------------------
+instance Ppr Stmt where
+    ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e
+    ppr (LetS ds) = text "let" <+> ppr ds
+    ppr (NoBindS e) = ppr e
+    ppr (ParS sss) = sep $ punctuate (text "|")
+                         $ map (sep . punctuate comma . map ppr) sss
+
+------------------------------
+instance Ppr Match where
+    ppr (Match p rhs ds) = ppr p <+> pprBody False rhs
+                        $$ where_clause ds
+
+------------------------------
+pprBody :: Bool -> Body -> Doc
+pprBody eq (GuardedB xs) = nest nestDepth $ vcat $ map do_guard xs
+  where eqd = if eq then text "=" else text "->"
+        do_guard (lhs, rhs) = text "|" <+> ppr lhs <+> eqd <+> ppr rhs
+pprBody eq (NormalB e) = (if eq then text "=" else text "->") <+> ppr e
+
+------------------------------
+pprLit :: Precedence -> Lit -> Doc
+pprLit i (IntPrimL x)    = parensIf (i > noPrec && x < 0)
+                                    (integer x <> char '#')
+pprLit i (FloatPrimL x)  = parensIf (i > noPrec && x < 0)
+                                    (float (fromRational x) <> char '#')
+pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)
+                                    (double (fromRational x) <> text "##")
+pprLit i (IntegerL x)    = parensIf (i > noPrec && x < 0) (integer x)
+pprLit _ (CharL c)       = text (show c)
+pprLit _ (StringL s)     = text (show s)
+pprLit i (RationalL rat) = parensIf (i > noPrec) $ rational rat
+
+------------------------------
+instance Ppr Pat where
+    ppr = pprPat noPrec
+
+pprPat :: Precedence -> Pat -> Doc
+pprPat i (LitP l)     = pprLit i l
+pprPat _ (VarP v)     = ppr v
+pprPat _ (TupP ps)    = parens $ sep $ punctuate comma $ map ppr ps
+pprPat i (ConP s ps)  = parensIf (i > noPrec) $ ppr s
+                                            <+> sep (map (pprPat appPrec) ps)
+pprPat i (TildeP p)   = parensIf (i > noPrec) $ pprPat appPrec p
+pprPat i (AsP v p)    = parensIf (i > noPrec) $ ppr v <> text "@"
+                                                      <> pprPat appPrec p
+pprPat _ WildP        = text "_"
+pprPat _ (RecP nm fs)
+ = parens $     ppr nm
+            <+> braces (sep $ punctuate comma $
+                        map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)
+pprPat _ (ListP ps) = brackets $ sep $ punctuate comma $ map ppr ps
+
+------------------------------
+instance Ppr Dec where
+    ppr (FunD f cs)   = vcat $ map (\c -> ppr f <+> ppr c) cs
+    ppr (ValD p r ds) = ppr p <+> pprBody True r
+                     $$ where_clause ds
+    ppr (TySynD t xs rhs) = text "type" <+> ppr t <+> hsep (map ppr xs) 
+                        <+> text "=" <+> ppr rhs
+    ppr (DataD ctxt t xs cs decs)
+        = text "data"
+      <+> pprCxt ctxt
+      <+> ppr t <+> hsep (map ppr xs)
+      <+> sep (pref $ map ppr cs)
+       $$ if null decs
+          then empty
+          else nest nestDepth
+             $ text "deriving"
+           <+> parens (hsep $ punctuate comma $ map ppr decs)
+        where pref :: [Doc] -> [Doc]
+              pref [] = [char '='] -- Can't happen in H98
+              pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds
+    ppr (NewtypeD ctxt t xs c decs)
+        = text "newtype"
+      <+> pprCxt ctxt
+      <+> ppr t <+> hsep (map ppr xs)
+      <+> char '=' <+> ppr c
+       $$ if null decs
+          then empty
+          else nest nestDepth
+             $ text "deriving"
+           <+> parens (hsep $ punctuate comma $ map ppr decs)
+    ppr (ClassD ctxt c xs ds) = text "class" <+> pprCxt ctxt
+                            <+> ppr c <+> hsep (map ppr xs)
+                             $$ where_clause ds
+    ppr (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
+                             $$ where_clause ds
+    ppr (SigD f t) = ppr f <+> text "::" <+> ppr t
+    ppr (ForeignD f) = ppr f
+
+------------------------------
+instance Ppr Foreign where
+    ppr (ImportF callconv safety impent as typ)
+       = text "foreign import"
+     <+> showtextl callconv
+     <+> showtextl safety
+     <+> text (show impent)
+     <+> ppr as
+     <+> text "::" <+> ppr typ
+    ppr (ExportF callconv expent as typ)
+        = text "foreign export"
+      <+> showtextl callconv
+      <+> text (show expent)
+      <+> ppr as
+      <+> text "::" <+> ppr typ
+
+------------------------------
+instance Ppr Clause where
+    ppr (Clause ps rhs ds) = hsep (map ppr ps) <+> pprBody True rhs
+                          $$ where_clause ds
+
+------------------------------
+instance Ppr Con where
+    ppr (NormalC c sts) = ppr c <+> hsep (map pprStrictType sts)
+    ppr (RecC c vsts)
+        = ppr c <+> braces (hsep (punctuate comma $ map pprVarStrictType vsts))
+    ppr (InfixC st1 c st2) = pprStrictType st1 <+> ppr c <+> pprStrictType st2
+
+------------------------------
+pprVarStrictType :: (Name, Strict, Type) -> Doc
+pprVarStrictType (v, str, t) = ppr v <+> text "::" <+> pprStrictType (str, t)
+
+------------------------------
+pprStrictType :: (Strict, Type) -> Doc
+pprStrictType (IsStrict, t) = char '!' <> ppr t
+pprStrictType (NotStrict, t) = ppr 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 ArrowT     = parens (text "->")
+pprParendType ListT      = text "[]"
+pprParendType other      = parens (ppr other)
+
+instance Ppr Type where
+    ppr (ForallT tvars ctxt ty) = 
+        text "forall" <+> hsep (map ppr tvars) <+> text "."
+                      <+> pprCxt ctxt <+> ppr ty
+    ppr ty = pprTyApp (split ty)
+
+pprTyApp :: (Type, [Type]) -> Doc
+pprTyApp (ArrowT, [arg1,arg2]) = sep [ppr 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 (fun, args) = pprParendType fun <+> sep (map pprParendType args)
+
+split :: Type -> (Type, [Type])    -- Split into function and args
+split t = go t []
+    where go (AppT t1 t2) args = go t1 (t2:args)
+          go ty           args = (ty, args)
+
+------------------------------
+pprCxt :: Cxt -> Doc
+pprCxt [] = empty
+pprCxt [t] = ppr t <+> text "=>"
+pprCxt ts = parens (hsep $ punctuate comma $ map ppr ts) <+> text "=>"
+
+------------------------------
+instance Ppr Range where
+    ppr = brackets . pprRange
+        where pprRange :: Range -> Doc
+              pprRange (FromR e) = ppr e <> text ".."
+              pprRange (FromThenR e1 e2) = ppr e1 <> text ","
+                                        <> ppr e2 <> text ".."
+              pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2
+              pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","
+                                             <> ppr e2 <> text ".."
+                                             <> ppr e3
+
+------------------------------
+where_clause :: [Dec] -> Doc
+where_clause [] = empty
+where_clause ds = text "where" <+> vcat (map ppr ds)
+
+showtextl :: Show a => a -> Doc
+showtextl = text . map toLower . show
+
diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
new file mode 100644 (file)
index 0000000..a1e72d3
--- /dev/null
@@ -0,0 +1,210 @@
+{-# OPTIONS -fglasgow-exts #-}
+
+-- Monadic front-end to Text.PrettyPrint.HughesPJ
+
+module Language.Haskell.TH.PprLib (
+
+       -- * The document type
+        Doc,            -- Abstract, instance of Show
+
+       -- * Primitive Documents
+        empty,
+        semi, comma, colon, space, equals,
+        lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+
+       -- * Converting values into documents
+        text, char, ptext,
+        int, integer, float, double, rational,
+
+       -- * Wrapping documents in delimiters
+        parens, brackets, braces, quotes, doubleQuotes,
+
+       -- * Combining documents
+        (<>), (<+>), hcat, hsep, 
+        ($$), ($+$), vcat, 
+        sep, cat, 
+        fsep, fcat, 
+       nest,
+        hang, punctuate,
+        
+       -- * Predicates on documents
+       isEmpty,
+
+    to_HPJ_Doc, pprName
+  ) where
+
+
+import Language.Haskell.TH.Syntax (Name(..), NameFlavour(..))
+import qualified Text.PrettyPrint.HughesPJ as HPJ
+import Monad (liftM, liftM2)
+import Data.FiniteMap (FiniteMap, lookupFM, emptyFM, addToFM)
+import GHC.Base (Int(..))
+
+infixl 6 <> 
+infixl 6 <+>
+infixl 5 $$, $+$
+
+-- ---------------------------------------------------------------------------
+-- The interface
+
+-- The primitive Doc values
+
+instance Show Doc where
+   show d = HPJ.render (to_HPJ_Doc d)
+
+isEmpty :: Doc    -> PprM Bool;  -- ^ Returns 'True' if the document is empty
+
+empty   :: Doc;                        -- ^ An empty document
+semi   :: Doc;                 -- ^ A ';' character
+comma  :: Doc;                 -- ^ A ',' character
+colon  :: Doc;                 -- ^ A ':' character
+space  :: Doc;                 -- ^ A space character
+equals :: Doc;                 -- ^ A '=' character
+lparen :: Doc;                 -- ^ A '(' character
+rparen :: Doc;                 -- ^ A ')' character
+lbrack :: Doc;                 -- ^ A '[' character
+rbrack :: Doc;                 -- ^ A ']' character
+lbrace :: Doc;                 -- ^ A '{' character
+rbrace :: Doc;                 -- ^ A '}' character
+
+text    :: String   -> Doc
+ptext   :: String   -> Doc
+char    :: Char     -> Doc
+int      :: Int      -> Doc
+integer  :: Integer  -> Doc
+float    :: Float    -> Doc
+double   :: Double   -> Doc
+rational :: Rational -> Doc
+
+
+parens       :: Doc -> Doc;    -- ^ Wrap document in @(...)@
+brackets     :: Doc -> Doc;    -- ^ Wrap document in @[...]@
+braces      :: Doc -> Doc;     -- ^ Wrap document in @{...}@
+quotes      :: Doc -> Doc;     -- ^ Wrap document in @\'...\'@
+doubleQuotes :: Doc -> Doc;    -- ^ Wrap document in @\"...\"@
+
+-- Combining @Doc@ values
+
+(<>)   :: Doc -> Doc -> Doc;     -- ^Beside
+hcat   :: [Doc] -> Doc;          -- ^List version of '<>'
+(<+>)  :: Doc -> Doc -> Doc;     -- ^Beside, separated by space
+hsep   :: [Doc] -> Doc;          -- ^List version of '<+>'
+
+($$)   :: Doc -> Doc -> Doc;     -- ^Above; if there is no
+                                -- overlap it \"dovetails\" the two
+($+$)   :: Doc -> Doc -> Doc;   -- ^Above, without dovetailing.
+vcat   :: [Doc] -> Doc;          -- ^List version of '$$'
+
+cat    :: [Doc] -> Doc;          -- ^ Either hcat or vcat
+sep    :: [Doc] -> Doc;          -- ^ Either hsep or vcat
+fcat   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of cat
+fsep   :: [Doc] -> Doc;          -- ^ \"Paragraph fill\" version of sep
+
+nest   :: Int -> Doc -> Doc;     -- ^ Nested
+
+
+-- GHC-specific ones.
+
+hang :: Doc -> Int -> Doc -> Doc;      -- ^ @hang d1 n d2 = sep [d1, nest n d2]@
+punctuate :: Doc -> [Doc] -> [Doc];      -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
+
+
+-- ---------------------------------------------------------------------------
+-- The "implementation"
+
+type State = (FiniteMap Name HPJ.Doc, Int)
+data PprM a = PprM { runPprM :: State -> (a, State) }
+
+pprName :: Name -> Doc
+pprName n@(Name o (NameU _))
+ = PprM $ \s@(fm, i@(I# i'))
+        -> case lookupFM fm n of
+               Just d -> (d, s)
+               Nothing -> let d = HPJ.text $ show $ Name o (NameU i')
+                          in (d, (addToFM fm n d, i + 1))
+pprName n = text $ show n
+
+{-
+instance Show Name where
+  show (Name occ (NameU u))    = occString occ ++ "_" ++ show (I# u)
+  show (Name occ NameS)        = occString occ
+  show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ
+      
+data Name = Name OccName NameFlavour
+
+data NameFlavour
+  | NameU Int#                 -- A unique local name
+-}
+
+to_HPJ_Doc :: Doc -> HPJ.Doc
+to_HPJ_Doc d = fst $ runPprM d (emptyFM, 0)
+
+instance Monad PprM where
+    return x = PprM $ \s -> (x, s)
+    m >>= k  = PprM $ \s -> let (x, s') = runPprM m s
+                            in runPprM (k x) s'
+
+type Doc = PprM HPJ.Doc
+
+-- The primitive Doc values
+
+isEmpty = liftM HPJ.isEmpty
+
+empty = return HPJ.empty
+semi = return HPJ.semi
+comma = return HPJ.comma
+colon = return HPJ.colon
+space = return HPJ.space
+equals = return HPJ.equals
+lparen = return HPJ.lparen
+rparen = return HPJ.rparen
+lbrack = return HPJ.lbrack
+rbrack = return HPJ.rbrack
+lbrace = return HPJ.lbrace
+rbrace = return HPJ.rbrace
+
+text = return . HPJ.text
+ptext = return . HPJ.ptext
+char = return . HPJ.char
+int = return . HPJ.int
+integer = return . HPJ.integer
+float = return . HPJ.float
+double = return . HPJ.double
+rational = return . HPJ.rational
+
+
+parens = liftM HPJ.parens
+brackets = liftM HPJ.brackets
+braces = liftM HPJ.braces
+quotes = liftM HPJ.quotes
+doubleQuotes = liftM HPJ.doubleQuotes
+
+-- Combining @Doc@ values
+
+(<>) = liftM2 (HPJ.<>)
+hcat = liftM HPJ.hcat . sequence
+(<+>) = liftM2 (HPJ.<+>)
+hsep = liftM HPJ.hsep . sequence
+
+($$) = liftM2 (HPJ.$$)
+($+$) = liftM2 (HPJ.$+$)
+vcat = liftM HPJ.vcat . sequence
+
+cat  = liftM HPJ.cat . sequence
+sep  = liftM HPJ.sep . sequence
+fcat = liftM HPJ.fcat . sequence
+fsep = liftM HPJ.fsep . sequence
+
+nest n = liftM (HPJ.nest n)
+
+hang d1 n d2 = do d1' <- d1
+                  d2' <- d2
+                  return (HPJ.hang d1' n d2')
+{-
+punctuate p ds = do p' <- p
+                    ds' <- sequence ds
+                    map return (HPJ.punctuate p' ds')
+-}
+punctuate p ds = undefined
+-- punctuate :: M Doc -> [M Doc] -> [M Doc]
+
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
new file mode 100644 (file)
index 0000000..6d8a432
--- /dev/null
@@ -0,0 +1,511 @@
+{-# OPTIONS -fglasgow-exts #-}
+       -- Need GlaExts for the nested forall in defn of Q
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Language.Haskell.Syntax
+-- Copyright   :  (c) The University of Glasgow 2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- Abstract syntax definitions for Template Haskell.
+--
+-----------------------------------------------------------------------------
+
+module Language.Haskell.TH.Syntax(
+       Quasi(..), Lift(..), 
+
+       Q, runQ, 
+       report, recover, reify,
+       currentModule, runIO,
+
+       -- Names
+       Name(..), mkName, newName, nameBase,
+
+       -- The algebraic data types
+       Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..), 
+       Clause(..), Body(..), Stmt(..), Range(..),
+       Lit(..), Pat(..), FieldExp, FieldPat, 
+       Strict(..), Foreign(..), Callconv(..), Safety(..),
+       StrictType, VarStrictType, 
+       Info(..), 
+       Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
+
+       -- Internal functions
+       returnQ, bindQ, sequenceQ,
+       NameFlavour(..), NameSpace (..), 
+       mkNameG_v, mkNameG_d, mkNameG_tc, mkNameU,
+       OccName, mkOccName, occString,
+       ModName, mkModName, modString
+    ) where
+
+import Data.PackedString
+import GHC.Base                ( Int(..), Int#, (<#), (==#) )
+
+import IO              ( hPutStrLn, stderr )
+import Data.IORef
+import GHC.IOBase      ( unsafePerformIO )
+
+-----------------------------------------------------
+--
+--             The Quasi class
+--
+-----------------------------------------------------
+
+class Monad m => Quasi m where
+       -- Fresh names
+  qNewName :: String -> m Name
+
+       -- Error reporting and recovery
+  qReport  :: Bool -> String -> m ()   -- Report an error (True) or warning (False)
+                                       -- ...but carry on; use 'fail' to stop
+  qRecover :: m a -> m a -> m a                -- Recover from the monadic 'fail'
+                                       -- The first arg is the error handler
+       -- Inspect the type-checker's environment
+  qReify :: Name -> m Info
+  qCurrentModule :: m String
+
+       -- Input/output (dangerous)
+  qRunIO :: IO a -> m a
+
+
+-----------------------------------------------------
+--     The IO instance of Quasi
+-- 
+--  This instance is used only when running a Q
+--  computation in the IO monad, usually just to
+--  print the result.  There is no interesting
+--  type environment, so reification isn't going to
+--  work.
+--
+-----------------------------------------------------
+
+instance Quasi IO where
+  qNewName s = do { n <- readIORef counter
+                 ; writeIORef counter (n+1)
+                 ; return (mkNameU s n) }
+
+  qReport True  msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+  qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
+
+  qReify v       = badIO "reify"
+  qCurrentModule = badIO "currentModule"
+  qRecover a b   = badIO "recover"     -- Maybe we could fix this?
+
+  qRunIO m = m
+  
+badIO :: String -> IO a
+badIO op = do  { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
+               ; fail "Template Haskell failure" }
+
+-- Global variable to generate unique symbols
+counter :: IORef Int
+{-# NOINLINE counter #-}
+counter = unsafePerformIO (newIORef 0)
+
+
+-----------------------------------------------------
+--
+--             The Q monad
+--
+-----------------------------------------------------
+
+newtype Q a = Q { unQ :: forall m. Quasi m => m a }
+
+runQ :: Quasi m => Q a -> m a
+runQ (Q m) = m
+
+instance Monad Q where
+  return x   = Q (return x)
+  Q m >>= k  = Q (m >>= \x -> unQ (k x))
+  Q m >> Q n = Q (m >> n)
+  fail s     = Q (fail s)
+
+----------------------------------------------------
+-- Packaged versions for the programmer, hiding the Quasi-ness
+newName :: String -> Q Name
+newName s = Q (qNewName s)
+
+report  :: Bool -> String -> Q ()
+report b s = Q (qReport b s)
+
+recover :: Q a -> Q a -> Q a
+recover (Q r) (Q m) = Q (qRecover r m)
+
+reify :: Name -> Q Info
+reify v = Q (qReify v)
+
+currentModule :: Q String
+currentModule = Q qCurrentModule
+
+runIO :: IO a -> Q a
+runIO m = Q (qRunIO m)
+
+instance Quasi Q where
+  qNewName        = newName
+  qReport       = report
+  qRecover      = recover 
+  qReify        = reify
+  qCurrentModule = currentModule
+  qRunIO         = runIO
+
+
+----------------------------------------------------
+-- The following operations are used solely in DsMeta when desugaring brackets
+-- They aren't necessary for the user, who can use ordinary return and (>>=) etc
+
+returnQ :: a -> Q a
+returnQ = return
+
+bindQ :: Q a -> (a -> Q b) -> Q b
+bindQ = (>>=)
+
+sequenceQ :: [Q a] -> Q [a]
+sequenceQ = sequence
+
+
+-----------------------------------------------------
+--
+--             The Lift class
+--
+-----------------------------------------------------
+
+class Lift t where
+  lift :: t -> Q Exp
+  
+instance Lift Integer where
+  lift x = return (LitE (IntegerL x))
+
+instance Lift Int where
+  lift x= return (LitE (IntegerL (fromIntegral x)))
+
+instance Lift Char where
+  lift x = return (LitE (CharL x))
+
+instance Lift Bool where
+  lift True  = return (ConE trueName)
+  lift False = return (ConE falseName)
+
+instance Lift a => Lift [a] where
+  lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
+
+-- TH has a special form for literal strings,
+-- which we should take advantage of.
+-- NB: the lhs of the rule has no args, so that
+--     the rule will apply to a 'lift' all on its own
+--     which happens to be the way the type checker 
+--     creates it.
+{-# RULES "TH:liftString" lift = \s -> return (LitE (StringL s)) #-}
+
+
+trueName, falseName :: Name
+trueName  = mkNameG DataName "GHC.Base" "True"
+falseName = mkNameG DataName "GHC.Base" "Frue"
+
+
+-----------------------------------------------------
+--             Names and uniques 
+-----------------------------------------------------
+
+type ModName = PackedString    -- Module name
+mkModName :: String -> ModName
+mkModName s = packString s
+
+modString :: ModName -> String
+modString m = unpackPS m
+
+-----------------------------------------------------
+--             OccName
+-----------------------------------------------------
+
+-- An OccName (occurrence name) records which name space it is from
+type OccName = PackedString
+
+
+mkOccName :: String -> OccName
+mkOccName s = packString s
+
+occString :: OccName -> String
+occString occ = unpackPS occ
+
+
+
+-----------------------------------------------------
+--              Names
+-----------------------------------------------------
+
+-- For "global" names (NameG) we need a totally unique name,
+-- so we must include the name-space of the thing
+--
+-- For unique-numbered things (NameU), we've got a unique reference
+-- anyway, so no need for name space
+--
+-- For dynamically bound thing (NameS) we probably want them to 
+-- in a context-dependent way, so again we don't want the name
+-- space.  For example:
+--     let v = mkName "T" in [| data $v = $v |]
+-- Here we use the same Name for both type constructor and data constructor
+
+data Name = Name OccName NameFlavour
+
+data NameFlavour
+  = NameS                      -- Just a string; dynamically bound
+  | NameU Int#                 -- A unique local name
+  | NameG NameSpace ModName    -- An original name (occurrences only, not binders)
+                               -- Need the namespace too to be sure which 
+                               -- thing we are naming
+
+data NameSpace = VarName       -- Variables
+              | DataName       -- Data constructors 
+              | TcClsName      -- Type constructors and classes; Haskell has them
+                               -- in the same name space for now.
+              deriving( Eq, Ord )
+
+type Uniq = Int
+
+nameBase :: Name -> String
+nameBase (Name occ _) = occString occ
+
+mkName :: String -> Name
+mkName s = Name (mkOccName s) NameS
+
+mkNameU :: String -> Uniq -> Name      -- Only used internally
+mkNameU s (I# u) = Name (mkOccName s) (NameU u)
+
+mkNameG :: NameSpace -> String -> String -> Name       -- Used for 'x etc, but not available
+mkNameG ns mod occ                             -- to the programmer
+  = Name (mkOccName occ) (NameG ns (mkModName mod))
+
+mkNameG_v  = mkNameG VarName
+mkNameG_tc = mkNameG TcClsName
+mkNameG_d  = mkNameG DataName
+
+instance Eq Name where
+  v1 == v2 = cmpEq (v1 `compare` v2)
+
+instance Ord Name where
+  (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2)   `thenCmp`
+                                       (o1 `compare` o2)
+
+instance Eq NameFlavour where
+  f1 == f2 = cmpEq (f1 `compare` f2)
+
+instance Ord NameFlavour where
+  NameS `compare` NameS = EQ
+  NameS `compare` other = LT
+
+  (NameU _)  `compare` NameS = GT
+  (NameU u1) `compare` (NameU u2) | u1  <# u2 = LT
+                                 | u1 ==# u2 = EQ
+                                 | otherwise = GT
+  (NameU _)  `compare` other = LT
+
+  (NameG ns1 m1) `compare` (NameG ns2 m2)  = (ns1 `compare` ns2) `thenCmp`
+                                            (m1 `compare` m2)
+  (NameG _ _)    `compare` other          = GT
+
+instance Show Name where
+  show (Name occ (NameU u))    = occString occ ++ "_" ++ show (I# u)
+  show (Name occ NameS)        = occString occ
+  show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ
+
+
+-----------------------------------------------------
+--
+--     The Info returned by reification
+--
+-----------------------------------------------------
+
+data Info 
+  = ClassI Dec
+  | ClassOpI
+       Name    -- The class op itself
+       Type    -- Type of the class-op (fully polymoprhic)
+       Name    -- Name of the parent class
+       Fixity
+
+  | TyConI Dec
+  | DataConI 
+       Name    -- The data con itself
+       Type    -- Type of the constructor (fully polymorphic)
+       Name    -- Name of the parent TyCon
+       Fixity
+
+  | VarI 
+       Name    -- The variable itself
+       Type 
+       (Maybe Dec)     -- Nothing for lambda-bound variables, and 
+                       -- for anything else TH can't figure out
+                       -- E.g. [| let x = 1 in $(do { d <- reify 'x; .. }) |]
+       Fixity
+
+  | TyVarI     -- Scoped type variable
+       Name
+       Type    -- What it is bound to
+
+data Fixity         = Fixity Int FixityDirection deriving( Eq )
+data FixityDirection = InfixL | InfixR | InfixN   deriving( Eq )
+
+maxPrecedence = (9::Int)
+defaultFixity = Fixity maxPrecedence InfixL
+
+
+-----------------------------------------------------
+--
+--     The main syntax data types
+--
+-----------------------------------------------------
+
+data Lit = CharL Char 
+         | StringL String 
+         | IntegerL Integer     -- Used for overloaded and non-overloaded
+                                -- literals. We don't have a good way to
+                                -- represent non-overloaded literals at
+                                -- the moment. Maybe that doesn't matter?
+         | RationalL Rational   -- Ditto
+         | IntPrimL Integer
+         | FloatPrimL Rational
+         | DoublePrimL Rational
+    deriving( Show, Eq )
+
+    -- We could add Int, Float, Double etc, as we do in HsLit, 
+    -- but that could complicate the
+    -- suppposedly-simple TH.Syntax literal type
+
+data Pat 
+  = LitP Lit                      -- { 5 or 'c' }
+  | VarP Name                   -- { x }
+  | TupP [Pat]                    -- { (p1,p2) }
+  | ConP Name [Pat]             -- data T1 = C1 t1 t2; {C1 p1 p1} = e 
+  | TildeP Pat                    -- { ~p }
+  | AsP Name Pat                -- { x @ p }
+  | WildP                         -- { _ }
+  | RecP Name [FieldPat]        -- f (Pt { pointx = x }) = g x
+  | ListP [ Pat ]                 -- { [1,2,3] }
+  deriving( Show, Eq )
+
+type FieldPat = (Name,Pat)
+
+data Match = Match Pat Body [Dec]
+                                    -- case e of { pat -> body where decs } 
+    deriving( Show, Eq )
+data Clause = Clause [Pat] Body [Dec]
+                                    -- f { p1 p2 = body where decs }
+    deriving( Show, Eq )
+data Exp 
+  = VarE Name                        -- { x }
+  | ConE Name                        -- data T1 = C1 t1 t2; p = {C1} e1 e2  
+  | LitE Lit                           -- { 5 or 'c'}
+  | AppE Exp Exp                       -- { f x }
+
+  | InfixE (Maybe Exp) Exp (Maybe Exp) -- {x + y} or {(x+)} or {(+ x)} or {(+)}
+    -- It's a bit gruesome to use an Exp as the
+    -- operator, but how else can we distinguish
+    -- constructors from non-constructors?
+    -- Maybe there should be a var-or-con type?
+    -- Or maybe we should leave it to the String itself?
+
+  | LamE [Pat] Exp                     -- { \ p1 p2 -> e }
+  | TupE [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 }
+  | DoE [Stmt]                         -- { do { p <- e1; e2 }  }
+  | CompE [Stmt]                       -- { [ (x,y) | x <- xs, y <- ys ] }
+  | ArithSeqE Range                    -- { [ 1 ,2 .. 10 ] }
+  | ListE [ Exp ]                      -- { [1,2,3] }
+  | SigE Exp Type                      -- e :: t
+  | RecConE Name [FieldExp]            -- { T { x = y, z = w } }
+  | RecUpdE Exp [FieldExp]             -- { (f x) { z = w } }
+  deriving( Show, Eq )
+
+type FieldExp = (Name,Exp)
+
+-- Omitted: implicit parameters
+
+data Body
+  = GuardedB [(Exp,Exp)]     -- f p { | e1 = e2 | e3 = e4 } where ds
+  | NormalB Exp              -- f p { = e } where ds
+  deriving( Show, Eq )
+
+data Stmt
+  = BindS Pat Exp
+  | LetS [ Dec ]
+  | NoBindS Exp
+  | ParS [[Stmt]]
+  deriving( Show, Eq )
+
+data Range = FromR Exp | FromThenR Exp Exp
+           | FromToR Exp Exp | FromThenToR Exp Exp Exp
+          deriving( Show, Eq )
+  
+data Dec 
+  = FunD Name [Clause]            -- { f p1 p2 = b where decs }
+  | ValD Pat Body [Dec]           -- { p = b where decs }
+  | DataD Cxt Name [Name] 
+         [Con] [Name]             -- { data Cxt x => T x = A x | B (T x)
+                                  --       deriving (Z,W)}
+  | NewtypeD Cxt Name [Name] 
+         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] [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
+  deriving( Show, Eq )
+
+data Foreign = ImportF Callconv Safety String Name Type
+             | ExportF Callconv        String Name Type
+         deriving( Show, Eq )
+
+data Callconv = CCall | StdCall
+          deriving( Show, Eq )
+
+data Safety = Unsafe | Safe | Threadsafe
+        deriving( Show, Eq )
+
+type Cxt = [Type]    -- (Eq a, Ord b)
+
+data Strict = IsStrict | NotStrict
+         deriving( Show, Eq )
+
+data Con = NormalC Name [StrictType]
+         | RecC Name [VarStrictType]
+         | InfixC StrictType Name StrictType
+         deriving( Show, Eq )
+
+type StrictType = (Strict, Type)
+type VarStrictType = (Name, Strict, Type)
+
+data Module = Module [ Dec ] 
+             deriving( Show, Eq )
+
+-- FIXME: Why this special status for "List" (even tuples might be handled
+--      differently)? -=chak
+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
+      deriving( Show, Eq )
+
+-----------------------------------------------------
+--             Internal helper functions
+-----------------------------------------------------
+
+cmpEq :: Ordering -> Bool
+cmpEq EQ = True
+cmpEq _  = False
+
+thenCmp :: Ordering -> Ordering -> Ordering
+thenCmp EQ o2 = o2
+thenCmp o1 o2 = o1
+
diff --git a/libraries/template-haskell/Makefile b/libraries/template-haskell/Makefile
new file mode 100644 (file)
index 0000000..2a74bc4
--- /dev/null
@@ -0,0 +1,15 @@
+# -----------------------------------------------------------------------------
+# $Id: Makefile,v 1.1 2004/01/15 14:43:22 igloo Exp $
+
+TOP=..
+include $(TOP)/mk/boilerplate.mk
+
+ALL_DIRS     = Language/Haskell Language/Haskell/TH
+PACKAGE      = template-haskell
+PACKAGE_DEPS = base
+
+Language/Haskell/TH/Syntax_HC_OPTS += -fglasgow-exts
+
+SRC_HADDOCK_OPTS += -t "Haskell Hierarchical Libraries ($(PACKAGE) package)"
+
+include $(TOP)/mk/target.mk
diff --git a/libraries/template-haskell/package.conf.in b/libraries/template-haskell/package.conf.in
new file mode 100644 (file)
index 0000000..841c148
--- /dev/null
@@ -0,0 +1,25 @@
+#include "config.h"
+
+Package {
+       name            = "template-haskell",
+       auto            = True,
+#ifdef INSTALLING
+       import_dirs     = [ "$libdir/imports" ],
+#else
+       import_dirs     = [ "$libdir/libraries/template-haskell" ],
+#endif
+       source_dirs     = [],
+#ifdef INSTALLING
+       library_dirs    = [ "$libdir" ],
+#else
+       library_dirs    = [ "$libdir/libraries/template-haskell" ],
+#endif
+       hs_libraries    = [ "HStemplate-haskell" ],
+       extra_libraries = [],
+       include_dirs    = [],
+       c_includes      = [],
+       package_deps    = [ "base", "haskell98" ],
+       extra_ghc_opts  = [],
+       extra_cc_opts   = [],
+       extra_ld_opts   = []
+}
diff --git a/libraries/template-haskell/prologue.txt b/libraries/template-haskell/prologue.txt
new file mode 100644 (file)
index 0000000..a7b2f02
--- /dev/null
@@ -0,0 +1 @@
+Facilities for manipulating Haskell source code using Template Haskell.