template-haskell (empty) → 2.2.0.0
raw patch · 8 files changed
+1848/−0 lines, 8 filesdep +basedep +containersdep +packedstringsetup-changed
Dependencies added: base, containers, packedstring, pretty
Files
- LICENSE +33/−0
- Language/Haskell/TH.hs +55/−0
- Language/Haskell/TH/Lib.hs +441/−0
- Language/Haskell/TH/Ppr.hs +332/−0
- Language/Haskell/TH/PprLib.hs +217/−0
- Language/Haskell/TH/Syntax.hs +745/−0
- Setup.hs +6/−0
- template-haskell.cabal +19/−0
+ LICENSE view
@@ -0,0 +1,33 @@++The Glasgow Haskell Compiler License++Copyright 2002-2007, The University Court of the University of Glasgow.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.++- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.+
+ Language/Haskell/TH.hs view
@@ -0,0 +1,55 @@+-- 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 Info+ currentModule, -- :: Q String+ runIO, -- :: IO a -> Q a++ -- Names+ Name, + mkName, -- :: String -> Name+ newName, -- :: String -> Q Name+ nameBase, -- :: Name -> String+ nameModule, -- :: Name -> Maybe String+ tupleTypeName, tupleDataName, -- Int -> Name+ + -- The algebraic data types+ Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..), + Clause(..), Body(..), Guard(..), Stmt(..), Range(..),+ Lit(..), Pat(..), FieldExp, FieldPat, + Strict(..), Foreign(..), Callconv(..), Safety(..), FunDep(..),+ Info(..), + Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,++ -- Library functions+ InfoQ, ExpQ, DecQ, ConQ, TypeQ, CxtQ, MatchQ, ClauseQ, BodyQ, GuardQ,+ StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ,+ intPrimL, floatPrimL, doublePrimL, integerL, charL, stringL, rationalL, + litP, varP, tupP, conP, infixP, tildeP, asP, wildP, recP, listP, sigP,+ fieldPat,+ bindS, letS, noBindS, parS, + fromR, fromThenR, fromToR, fromThenToR, + normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, + dyn, global, varE, conE, litE, appE, infixE, infixApp, sectionL, sectionR, + lamE, lam1E, tupE, condE, letE, caseE, doE, compE, arithSeqE, appsE,+ fromE, fromThenE, fromToE, fromThenToE,+ listE, sigE, recConE, recUpdE, stringE, fieldExp,+ valD, funD, tySynD, dataD, newtypeD, classD, instanceD, sigD, forImpD,+ cxt, normalC, recC, infixC,+ forallT, varT, conT, appT, arrowT, listT, tupleT,+ isStrict, notStrict, strictType, varStrictType,+ cCall, stdCall, unsafe, safe, threadsafe,++ -- Pretty-printer+ Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType+ + ) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr+
+ Language/Haskell/TH/Lib.hs view
@@ -0,0 +1,441 @@+-- 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 PatQ = Q Pat+type FieldPatQ = Q FieldPat+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 GuardQ = Q Guard+type StmtQ = Q Stmt+type RangeQ = Q Range+type StrictTypeQ = Q StrictType+type VarStrictTypeQ = Q VarStrictType+type FieldExpQ = Q FieldExp++----------------------------------------------------------+-- 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 -> PatQ+litP l = return (LitP l)+varP :: Name -> PatQ+varP v = return (VarP v)+tupP :: [PatQ] -> PatQ+tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}+conP :: Name -> [PatQ] -> PatQ+conP n ps = do ps' <- sequence ps+ return (ConP n ps')+infixP :: PatQ -> Name -> PatQ -> PatQ+infixP p1 n p2 = do p1' <- p1+ p2' <- p2+ return (InfixP p1' n p2')+tildeP :: PatQ -> PatQ+tildeP p = do p' <- p+ return (TildeP p')+asP :: Name -> PatQ -> PatQ+asP n p = do p' <- p+ return (AsP n p')+wildP :: PatQ+wildP = return WildP+recP :: Name -> [FieldPatQ] -> PatQ+recP n fps = do fps' <- sequence fps+ return (RecP n fps')+listP :: [PatQ] -> PatQ+listP ps = do ps' <- sequence ps+ return (ListP ps')+sigP :: PatQ -> TypeQ -> PatQ+sigP p t = do p' <- p+ t' <- t+ return (SigP p' t')++fieldPat :: Name -> PatQ -> FieldPatQ+fieldPat n p = do p' <- p+ return (n, p')+++-------------------------------------------------------------------------------+-- Stmt++bindS :: PatQ -> ExpQ -> StmtQ+bindS p e = liftM2 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 :: [Q (Guard,Exp)] -> BodyQ+guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') }++-------------------------------------------------------------------------------+-- Guard++normalG :: ExpQ -> GuardQ+normalG e = do { e1 <- e; return (NormalG e1) }++normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp)+normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) }++patG :: [StmtQ] -> GuardQ+patG ss = do { ss' <- sequence ss; return (PatG ss') }++patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp)+patGE ss e = do { ss' <- sequence ss;+ e' <- e;+ return (PatG ss', e') }++-------------------------------------------------------------------------------+-- Match and Clause++match :: PatQ -> BodyQ -> [DecQ] -> MatchQ+match p rhs ds = do { p' <- p;+ r' <- rhs;+ ds' <- sequence ds;+ return (Match p' r' ds') }++clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ+clause ps r ds = do { ps' <- sequence ps;+ r' <- r;+ ds' <- sequence ds;+ return (Clause ps' r' ds') }+++---------------------------------------------------------------------------+-- Exp++dyn :: String -> Q Exp +dyn s = return (VarE (mkName s))++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 :: [PatQ] -> ExpQ -> ExpQ+lamE ps e = do ps' <- sequence ps+ e' <- e+ return (LamE ps' e')++lam1E :: PatQ -> 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 :: PatQ -> BodyQ -> [DecQ] -> DecQ+valD p b ds = + do { p' <- p+ ; 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] -> [FunDep] -> [DecQ] -> DecQ+classD ctxt cls tvs fds decs =+ do + decs1 <- sequence decs+ ctxt1 <- ctxt+ return $ ClassD ctxt1 cls tvs fds 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++forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ+forImpD cc s str n ty+ = do ty' <- ty+ return $ ForeignD (ImportF cc s str n 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'++forallC :: [Name] -> CxtQ -> ConQ -> ConQ+forallC ns ctxt con = liftM2 (ForallC ns) ctxt con+++-------------------------------------------------------------------------------+-- 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)++-------------------------------------------------------------------------------+-- Callconv++cCall, stdCall :: Callconv+cCall = CCall+stdCall = StdCall++-------------------------------------------------------------------------------+-- Safety++unsafe, safe, threadsafe :: Safety+unsafe = Unsafe+safe = Safe+threadsafe = Threadsafe++-------------------------------------------------------------------------------+-- FunDep++funDep :: [Name] -> [Name] -> FunDep+funDep = FunDep++--------------------------------------------------------------+-- 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 (InfixP p1 n p2) = do { r1 <- rename p1;+ r2 <- rename p2;+ let {(env, [p1', p2']) = combine [r1, r2]};+ return (env, InfixP p1' n p2') }+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) []+
+ Language/Haskell/TH/Ppr.hs view
@@ -0,0 +1,332 @@+-- 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++------------------------------+instance Ppr Info where+ ppr (ClassI d) = ppr d+ ppr (TyConI d) = ppr d+ ppr (PrimTyConI name arity is_unlifted) + = text "Primitive"+ <+> (if is_unlifted then text "unlifted" else empty)+ <+> text "type construtor" <+> quotes (ppr name)+ <+> parens (text "arity" <+> int arity)+ 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++pprInfixExp :: Exp -> Doc+pprInfixExp (VarE v) = pprName' Infix v+pprInfixExp (ConE v) = pprName' Infix v+pprInfixExp _ = error "Attempt to pretty-print non-variable or constructor in infix context!"++pprExp :: Precedence -> Exp -> Doc+pprExp _ (VarE v) = pprName' Applied v+pprExp _ (ConE c) = pprName' Applied 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+ <+> pprInfixExp op+ <+> pprExp opPrec e2+pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1+ <+> pprInfixExp op+ <+> pprMaybeExp noPrec me2+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+-- 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 (NormalG g, e) = text "|" <+> ppr g <+> eqd <+> ppr e+ do_guard (PatG ss, e) = text "|" <+> vcat (map ppr ss)+ $$ nest nestDepth (eqd <+> ppr e)+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) = pprName' Applied v+pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps+pprPat i (ConP s ps) = parensIf (i > noPrec) $ pprName' Applied s+ <+> sep (map (pprPat appPrec) ps)+pprPat i (InfixP p1 n p2)+ = parensIf (i > noPrec) (pprPat opPrec p1 <+>+ pprName' Infix n <+>+ pprPat opPrec p2)+pprPat i (TildeP p) = parensIf (i > noPrec) $ char '~' <> 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+pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> text "::" <+> ppr t++------------------------------+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 fds ds) = text "class" <+> pprCxt ctxt+ <+> ppr c <+> hsep (map ppr xs) <+> ppr fds+ $$ 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 FunDep where+ ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)+ ppr_list [] = empty+ ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs))++------------------------------+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 (pprPat appPrec) ps) <+> pprBody True rhs+ $$ where_clause ds++------------------------------+instance Ppr Con where+ ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts)+ ppr (RecC c vsts)+ = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts))+ ppr (InfixC st1 c st2) = pprStrictType st1+ <+> pprName' Infix c+ <+> pprStrictType st2+ ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns)+ <+> char '.' <+> pprCxt ctxt <+> ppr con++------------------------------+pprVarStrictType :: (Name, Strict, Type) -> Doc+-- Slight infelicity: with print non-atomic type with parens+pprVarStrictType (v, str, t) = ppr v <+> text "::" <+> pprStrictType (str, t)++------------------------------+pprStrictType :: (Strict, Type) -> Doc+-- Prints with parens if not already atomic+pprStrictType (IsStrict, t) = char '!' <> pprParendType t+pprStrictType (NotStrict, t) = 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 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 = nest nestDepth $ text "where" <+> vcat (map ppr ds)++showtextl :: Show a => a -> Doc+showtextl = text . map toLower . show+
+ Language/Haskell/TH/PprLib.hs view
@@ -0,0 +1,217 @@+{-# OPTIONS_GHC -fglasgow-exts #-}++-- Monadic front-end to Text.PrettyPrint.HughesPJ++module Language.Haskell.TH.PprLib (++ -- * The document type+ Doc, -- Abstract, instance of Show+ PprM,++ -- * 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, pprName'+ ) where+++import Language.Haskell.TH.Syntax+ (Name(..), showName', NameFlavour(..), NameIs(..))+import qualified Text.PrettyPrint.HughesPJ as HPJ+import Control.Monad (liftM, liftM2)+import Data.Map ( Map )+import qualified Data.Map as Map ( lookup, insert, empty )+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 = (Map Name Name, Int)+data PprM a = PprM { runPprM :: State -> (a, State) }++pprName :: Name -> Doc+pprName = pprName' Alone++pprName' :: NameIs -> Name -> Doc+pprName' ni n@(Name o (NameU _))+ = PprM $ \s@(fm, i@(I# i'))+ -> let (n', s') = case Map.lookup n fm of+ Just d -> (d, s)+ Nothing -> let n' = Name o (NameU i')+ in (n', (Map.insert n n' fm, i + 1))+ in (HPJ.text $ showName' ni n', s')+pprName' ni n = text $ showName' ni 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 (Map.empty, 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 uses the same definition as Text.PrettyPrint.HughesPJ+punctuate p [] = []+punctuate p (d:ds) = go d ds+ where+ go d [] = [d]+ go d (e:es) = (d <> p) : go e es+
+ Language/Haskell/TH/Syntax.hs view
@@ -0,0 +1,745 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+ -- Need GlaExts for the nested forall in defn of Q,+ -- and the deriving Data, Typeable+{-# OPTIONS_GHC -w #-}+-- The above warning supression flag is a temporary kludge.+-- While working on this module you are encouraged to remove it and fix+-- any warnings in the module. See+-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings+-- for details+-----------------------------------------------------------------------------+-- |+-- 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, nameModule,+ showName, showName', NameIs(..),++ -- The algebraic data types+ Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..), + Clause(..), Body(..), Guard(..), Stmt(..), Range(..),+ Lit(..), Pat(..), FieldExp, FieldPat, + Strict(..), Foreign(..), Callconv(..), Safety(..),+ StrictType, VarStrictType, FunDep(..),+ Info(..), + Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,++ -- Internal functions+ returnQ, bindQ, sequenceQ,+ NameFlavour(..), NameSpace (..), + mkNameG_v, mkNameG_d, mkNameG_tc, Uniq, mkNameL, mkNameU,+ tupleTypeName, tupleDataName,+ OccName, mkOccName, occString,+ ModName, mkModName, modString,+ PkgName, mkPkgName, pkgString+ ) where++import Data.PackedString+import GHC.Base ( Int(..), Int#, (<#), (==#) )++import Data.Generics (Data(..), Typeable, mkConstr, mkDataType)+import qualified Data.Generics as Generics+import Data.IORef+import GHC.IOBase ( unsafePerformIO )+import Control.Monad (liftM)+import System.IO ( hPutStrLn, stderr )+import Data.Char ( isAlpha )++-----------------------------------------------------+--+-- The Quasi class+--+-----------------------------------------------------++class (Monad m, Functor 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 = report True s >> Q (fail "Q monad failure")++instance Functor Q where+ fmap f (Q x) = Q (fmap f x)++----------------------------------------------------+-- 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' looks up information about the 'Name'+reify :: Name -> Q Info+reify v = Q (qReify v)++-- | 'currentModule' gives you the name of the module in which this +-- computation is spliced.+currentModule :: Q String+currentModule = Q qCurrentModule++-- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.+-- Take care: you are guaranteed the ordering of calls to 'runIO' within +-- a single 'Q' computation, but not about the order in which splices are run. +--+-- Note: for various murky reasons, stdout and stderr handles are not +-- necesarily flushed when the compiler finishes running, so you should+-- flush them yourself.+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 are not 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 (Maybe a) where+ lift Nothing = return (ConE nothingName)+ lift (Just x) = liftM (ConE justName `AppE`) (lift x)++instance (Lift a, Lift b) => Lift (Either a b) where+ lift (Left x) = liftM (ConE leftName `AppE`) (lift x)+ lift (Right y) = liftM (ConE rightName `AppE`) (lift y)++instance Lift a => Lift [a] where+ lift xs = do { xs' <- mapM lift xs; return (ListE xs') }++instance (Lift a, Lift b) => Lift (a, b) where+ lift (a, b)+ = liftM TupE $ sequence [lift a, lift b]++instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where+ lift (a, b, c)+ = liftM TupE $ sequence [lift a, lift b, lift c]++instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where+ lift (a, b, c, d)+ = liftM TupE $ sequence [lift a, lift b, lift c, lift d]++instance (Lift a, Lift b, Lift c, Lift d, Lift e)+ => Lift (a, b, c, d, e) where+ lift (a, b, c, d, e)+ = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e]++instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)+ => Lift (a, b, c, d, e, f) where+ lift (a, b, c, d, e, f)+ = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]++instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)+ => Lift (a, b, c, d, e, f, g) where+ lift (a, b, c, d, e, f, g)+ = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]++-- 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 "base" "GHC.Base" "True"+falseName = mkNameG DataName "base" "GHC.Base" "False"++nothingName, justName :: Name+nothingName = mkNameG DataName "base" "Data.Maybe" "Nothing"+justName = mkNameG DataName "base" "Data.Maybe" "Just"++leftName, rightName :: Name+leftName = mkNameG DataName "base" "Data.Either" "Left"+rightName = mkNameG DataName "base" "Data.Either" "Right"+++-----------------------------------------------------+-- Names and uniques +-----------------------------------------------------++type ModName = PackedString -- Module name++mkModName :: String -> ModName+mkModName s = packString s++modString :: ModName -> String+modString m = unpackPS m+++type PkgName = PackedString -- package name++mkPkgName :: String -> PkgName+mkPkgName s = packString s++pkgString :: PkgName -> String+pkgString m = unpackPS m+++-----------------------------------------------------+-- OccName+-----------------------------------------------------++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 deriving (Typeable, Data)++data NameFlavour+ = NameS -- An unqualified name; dynamically bound+ | NameQ ModName -- A qualified name; dynamically bound++ | NameU Int# -- A unique local name++ -- The next two are for lexically-scoped names that+ -- are bound *outside* the TH syntax tree, + -- either globally (NameG) or locally (NameL)+ -- e.g. f x = $(h [| (map, x) |]+ -- The 'map' will be a NameG, and 'x' wil be a NameL+ -- These Names should never appear in a binding position in a TH syntax tree++ | NameL Int# -- + | NameG NameSpace PkgName ModName -- An original name (occurrences only, not binders)+ -- Need the namespace too to be sure which + -- thing we are naming+ deriving ( Typeable )++instance Data NameFlavour where+ gunfold = error "gunfold"+ toConstr NameS = con_NameS+ toConstr (NameQ _) = con_NameQ+ toConstr (NameU _) = con_NameU+ toConstr (NameL _) = con_NameL+ toConstr (NameG _ _ _) = con_NameG+ dataTypeOf _ = ty_NameFlavour++con_NameS = mkConstr ty_NameFlavour "NameS" [] Generics.Prefix+con_NameQ = mkConstr ty_NameFlavour "NameQ" [] Generics.Prefix+con_NameU = mkConstr ty_NameFlavour "NameU" [] Generics.Prefix+con_NameL = mkConstr ty_NameFlavour "NameL" [] Generics.Prefix+con_NameG = mkConstr ty_NameFlavour "NameG" [] Generics.Prefix+ty_NameFlavour = mkDataType "Language.Haskell.TH.Syntax.NameFlavour"+ [con_NameS, con_NameQ, con_NameU,+ con_NameL, con_NameG]++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, Data, Typeable )++type Uniq = Int++nameBase :: Name -> String+nameBase (Name occ _) = occString occ++nameModule :: Name -> Maybe String+nameModule (Name _ (NameQ m)) = Just (modString m)+nameModule (Name _ (NameG _ _ m)) = Just (modString m)+nameModule other_name = Nothing++mkName :: String -> Name+-- The string can have a '.', thus "Foo.baz",+-- giving a dynamically-bound qualified name,+-- in which case we want to generate a NameQ+--+-- Parse the string to see if it has a "." in it+-- so we know whether to generate a qualified or unqualified name+-- It's a bit tricky because we need to parse +-- Foo.Baz.x as Qual Foo.Baz x+-- So we parse it from back to front+mkName str+ = split [] (reverse str)+ where+ split occ [] = Name (mkOccName occ) NameS+ split occ ('.':rev) | not (null occ), + not (null rev), head rev /= '.'+ = Name (mkOccName occ) (NameQ (mkModName (reverse rev)))+ -- The 'not (null occ)' guard ensures that+ -- mkName "&." = Name "&." NameS+ -- The 'rev' guards ensure that+ -- mkName ".&" = Name ".&" NameS+ -- mkName "Data.Bits..&" = Name ".&" (NameQ "Data.Bits")+ -- This rather bizarre case actually happened; (.&.) is in Data.Bits+ split occ (c:rev) = split (c:occ) rev++mkNameU :: String -> Uniq -> Name -- Only used internally+mkNameU s (I# u) = Name (mkOccName s) (NameU u)++mkNameL :: String -> Uniq -> Name -- Only used internally+mkNameL s (I# u) = Name (mkOccName s) (NameL u)++mkNameG :: NameSpace -> String -> String -> String -> Name -- Used for 'x etc, but not available+mkNameG ns pkg mod occ -- to the programmer+ = Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName mod))++mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name+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 < NameQ < NameU < NameL < NameG+ NameS `compare` NameS = EQ+ NameS `compare` other = LT++ (NameQ _) `compare` NameS = GT+ (NameQ m1) `compare` (NameQ m2) = m1 `compare` m2+ (NameQ _) `compare` other = LT++ (NameU _) `compare` NameS = GT+ (NameU _) `compare` (NameQ _) = GT+ (NameU u1) `compare` (NameU u2) | u1 <# u2 = LT+ | u1 ==# u2 = EQ+ | otherwise = GT+ (NameU _) `compare` other = LT++ (NameL _) `compare` NameS = GT+ (NameL _) `compare` (NameQ _) = GT+ (NameL _) `compare` (NameU _) = GT+ (NameL u1) `compare` (NameL u2) | u1 <# u2 = LT+ | u1 ==# u2 = EQ+ | otherwise = GT+ (NameL _) `compare` other = LT++ (NameG ns1 p1 m1) `compare` (NameG ns2 p2 m2) = (ns1 `compare` ns2) `thenCmp`+ (p1 `compare` p2) `thenCmp`+ (m1 `compare` m2) + (NameG _ _ _) `compare` other = GT++data NameIs = Alone | Applied | Infix++showName :: Name -> String+showName = showName' Alone++showName' :: NameIs -> Name -> String+showName' ni nm+ = case ni of+ Alone -> nms+ Applied+ | pnam -> nms+ | otherwise -> "(" ++ nms ++ ")"+ Infix+ | pnam -> "`" ++ nms ++ "`"+ | otherwise -> nms+ where+ -- For now, we make the NameQ and NameG print the same, even though+ -- NameQ is a qualified name (so what it means depends on what the+ -- current scope is), and NameG is an original name (so its meaning+ -- should be independent of what's in scope.+ -- We may well want to distinguish them in the end.+ -- Ditto NameU and NameL+ nms = case nm of+ Name occ NameS -> occString occ+ Name occ (NameQ m) -> modString m ++ "." ++ occString occ+ Name occ (NameG ns p m) -> modString m ++ "." ++ occString occ+ Name occ (NameU u) -> occString occ ++ "_" ++ show (I# u)+ Name occ (NameL u) -> occString occ ++ "_" ++ show (I# u)++ pnam = classify nms++ -- True if we are function style, e.g. f, [], (,)+ -- False if we are operator style, e.g. +, :++ classify "" = False -- shouldn't happen; . operator is handled below+ classify (x:xs) | isAlpha x || (x `elem` "_[]()") =+ case dropWhile (/='.') xs of+ (_:xs') -> classify xs'+ [] -> True+ | otherwise = False++instance Show Name where+ show = showName++-- Tuple data and type constructors+tupleDataName :: Int -> Name -- Data constructor+tupleTypeName :: Int -> Name -- Type constructor++tupleDataName 0 = mk_tup_name 0 DataName +tupleDataName 1 = error "tupleDataName 1"+tupleDataName n = mk_tup_name (n-1) DataName ++tupleTypeName 0 = mk_tup_name 0 TcClsName +tupleTypeName 1 = error "tupleTypeName 1"+tupleTypeName n = mk_tup_name (n-1) TcClsName ++mk_tup_name n_commas space+ = Name occ (NameG space (mkPkgName "base") tup_mod)+ where+ occ = mkOccName ('(' : replicate n_commas ',' ++ ")")+ tup_mod = mkModName "Data.Tuple"+++++-----------------------------------------------------+--+-- 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++ | PrimTyConI -- Ones that can't be expressed with a data type + -- decl, such as (->), Int#+ Name + Int -- Arity+ Bool -- False => lifted type; True => unlifted++ | 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+ deriving( Show, Data, Typeable )++data Fixity = Fixity Int FixityDirection+ deriving( Eq, Show, Data, Typeable )+data FixityDirection = InfixL | InfixR | InfixN+ deriving( Eq, Show, Data, Typeable )++maxPrecedence :: Int+maxPrecedence = (9::Int)++defaultFixity :: Fixity+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, Data, Typeable )++ -- 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 + | InfixP Pat Name Pat -- foo ({x :+ y}) = e + | TildeP Pat -- { ~p }+ | AsP Name Pat -- { x @ p }+ | WildP -- { _ }+ | RecP Name [FieldPat] -- f (Pt { pointx = x }) = g x+ | ListP [ Pat ] -- { [1,2,3] }+ | SigP Pat Type -- p :: t+ deriving( Show, Eq, Data, Typeable )++type FieldPat = (Name,Pat)++data Match = Match Pat Body [Dec]+ -- case e of { pat -> body where decs } + deriving( Show, Eq, Data, Typeable )+data Clause = Clause [Pat] Body [Dec]+ -- f { p1 p2 = body where decs }+ deriving( Show, Eq, Data, Typeable )+ +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, Data, Typeable )++type FieldExp = (Name,Exp)++-- Omitted: implicit parameters++data Body+ = GuardedB [(Guard,Exp)] -- f p { | e1 = e2 | e3 = e4 } where ds+ | NormalB Exp -- f p { = e } where ds+ deriving( Show, Eq, Data, Typeable )++data Guard+ = NormalG Exp+ | PatG [Stmt]+ deriving( Show, Eq, Data, Typeable )++data Stmt+ = BindS Pat Exp+ | LetS [ Dec ]+ | NoBindS Exp+ | ParS [[Stmt]]+ deriving( Show, Eq, Data, Typeable )++data Range = FromR Exp | FromThenR Exp Exp+ | FromToR Exp Exp | FromThenToR Exp Exp Exp+ deriving( Show, Eq, Data, Typeable )+ +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] [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+ deriving( Show, Eq, Data, Typeable )++data FunDep = FunDep [Name] [Name]+ deriving( Show, Eq, Data, Typeable )++data Foreign = ImportF Callconv Safety String Name Type+ | ExportF Callconv String Name Type+ deriving( Show, Eq, Data, Typeable )++data Callconv = CCall | StdCall+ deriving( Show, Eq, Data, Typeable )++data Safety = Unsafe | Safe | Threadsafe+ deriving( Show, Eq, Data, Typeable )++type Cxt = [Type] -- (Eq a, Ord b)++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+ deriving( Show, Eq, Data, Typeable )++type StrictType = (Strict, Type)+type VarStrictType = (Name, Strict, Type)++-- 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, Data, Typeable )++-----------------------------------------------------+-- Internal helper functions+-----------------------------------------------------++cmpEq :: Ordering -> Bool+cmpEq EQ = True+cmpEq _ = False++thenCmp :: Ordering -> Ordering -> Ordering+thenCmp EQ o2 = o2+thenCmp o1 o2 = o1+
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ template-haskell.cabal view
@@ -0,0 +1,19 @@+name: template-haskell+version: 2.2.0.0+license: BSD3+license-file: LICENSE+maintainer: libraries@haskell.org+description:+ Facilities for manipulating Haskell source code using Template Haskell.+build-type: Simple+build-depends: base, pretty, packedstring, containers+exposed-modules:+ Language.Haskell.TH.Syntax,+ Language.Haskell.TH.PprLib,+ Language.Haskell.TH.Ppr,+ Language.Haskell.TH.Lib,+ Language.Haskell.TH+-- We need to set the package name to template-haskell (without a+-- version number) as it's magic.+ghc-options: -package-name template-haskell+