diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH.hs @@ -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 + diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Lib.hs @@ -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) [] + diff --git a/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Ppr.hs @@ -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 + diff --git a/Language/Haskell/TH/PprLib.hs b/Language/Haskell/TH/PprLib.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/PprLib.hs @@ -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 + diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Syntax.hs @@ -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 . -> + | 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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/template-haskell.cabal b/template-haskell.cabal new file mode 100644 --- /dev/null +++ b/template-haskell.cabal @@ -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 +