Commit b2df702d authored by igloo's avatar igloo
Browse files

[project @ 2004-06-01 23:22:32 by igloo]

Add missing functions to TH export list (mostly spotted by Duncan Coutts).

Update TH test output.

Add TH support for patterns with type signatures, and test for same
(requested by Isaac Jones).

Add TH support for pattern guards, and tests for same
(requested by Isaac Jones).

Add infix patterns to TH datatypes.

Added Lift instances for 2- to 7-tuples (requested by Duncan Coutts).
parent 98c0e982
......@@ -17,26 +17,29 @@ module Language.Haskell.TH(
-- The algebraic data types
Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..),
Clause(..), Body(..), Stmt(..), Range(..),
Clause(..), Body(..), Guard(..), Stmt(..), Range(..),
Lit(..), Pat(..), FieldExp, FieldPat,
Strict(..), Foreign(..), Callconv(..), Safety(..),
Info(..),
Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
-- Library functions
InfoQ, ExpQ, DecQ, ConQ, TypeQ, CxtQ, MatchQ, ClauseQ, BodyQ,
StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ,
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, tildeP, asP, wildP, recP, listP, fieldPat,
litP, varP, tupP, conP, infixP, tildeP, asP, wildP, recP, listP, sigP,
fieldPat,
bindS, letS, noBindS, parS,
fromR, fromThenR, fromToR, fromThenToR,
normalB, guardedB, match, clause,
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,
fromE, fromThenE, fromThenToE, listE, sigE, recConE, recUpdE, stringE, fieldExp,
fromE, fromThenE, fromToE, fromThenToE,
listE, sigE, recConE, recUpdE, stringE, fieldExp,
valD, funD, tySynD, dataD, newtypeD, classD, instanceD, sigD, forImpD,
normalC, recC,
cxt, varT, conT, appT, arrowT, tupleT, isStrict, notStrict, strictType, varStrictType,
cxt, normalC, recC, infixC,
forallT, varT, conT, appT, arrowT, listT, tupleT,
isStrict, notStrict, strictType, varStrictType,
cCall, stdCall, unsafe, safe, threadsafe,
-- Pretty-printer
......
......@@ -14,6 +14,8 @@ import Control.Monad( liftM, liftM2 )
----------------------------------------------------------
type InfoQ = Q Info
type PatQ = Q Pat
type FieldPatQ = Q FieldPat
type ExpQ = Q Exp
type DecQ = Q Dec
type ConQ = Q Con
......@@ -22,6 +24,7 @@ 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
......@@ -46,34 +49,48 @@ stringL = StringL
rationalL :: Rational -> Lit
rationalL = RationalL
litP :: Lit -> Pat
litP = LitP
varP :: Name -> Pat
varP = VarP
tupP :: [Pat] -> Pat
tupP = TupP
conP :: Name -> [Pat] -> Pat
conP = ConP
tildeP :: Pat -> Pat
tildeP = TildeP
asP :: Name -> Pat -> Pat
asP = AsP
wildP :: Pat
wildP = WildP
recP :: Name -> [FieldPat] -> Pat
recP = RecP
listP :: [Pat] -> Pat
listP = ListP
fieldPat :: Name -> Pat -> (Name, Pat)
fieldPat = (,)
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 :: Pat -> ExpQ -> StmtQ
bindS p e = liftM (BindS p) e
bindS :: PatQ -> ExpQ -> StmtQ
bindS p e = liftM2 BindS p e
letS :: [DecQ] -> StmtQ
letS ds = do { ds1 <- sequence ds; return (LetS ds1) }
......@@ -105,22 +122,40 @@ fromThenToR x y z = do { a <- x; b <- y; c <- z;
normalB :: ExpQ -> BodyQ
normalB e = do { e1 <- e; return (NormalB e1) }
guardedB :: [(ExpQ,ExpQ)] -> BodyQ
guardedB ges = do { ges' <- mapM f ges; return (GuardedB ges') }
where f (g, e) = do { g' <- g; e' <- e; return (g', e') }
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] -> Q (Guard, Exp)
patGE ss = do { ss' <- sequence ss;
let {NoBindS e = last ss'};
return (PatG (init ss'), e) }
-------------------------------------------------------------------------------
-- Match and Clause
match :: Pat -> BodyQ -> [DecQ] -> MatchQ
match p rhs ds = do { r' <- rhs;
match :: PatQ -> BodyQ -> [DecQ] -> MatchQ
match p rhs ds = do { p' <- p;
r' <- rhs;
ds' <- sequence ds;
return (Match p r' ds') }
return (Match p' r' ds') }
clause :: [Pat] -> BodyQ -> [DecQ] -> ClauseQ
clause ps r ds = do { r' <- r;
clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause ps r ds = do { ps' <- sequence ps;
r' <- r;
ds' <- sequence ds;
return (Clause ps r' ds') }
return (Clause ps' r' ds') }
---------------------------------------------------------------------------
......@@ -160,10 +195,12 @@ sectionL x y = infixE (Just x) y Nothing
sectionR :: ExpQ -> ExpQ -> ExpQ
sectionR x y = infixE Nothing x (Just y)
lamE :: [Pat] -> ExpQ -> ExpQ
lamE ps e = liftM (LamE ps) e
lamE :: [PatQ] -> ExpQ -> ExpQ
lamE ps e = do ps' <- sequence ps
e' <- e
return (LamE ps' e')
lam1E :: Pat -> ExpQ -> ExpQ -- Single-arg lambda
lam1E :: PatQ -> ExpQ -> ExpQ -- Single-arg lambda
lam1E p e = lamE [p] e
tupE :: [ExpQ] -> ExpQ
......@@ -223,11 +260,12 @@ fieldExp s e = do { e' <- e; return (s,e') }
-------------------------------------------------------------------------------
-- Dec
valD :: Pat -> BodyQ -> [DecQ] -> DecQ
valD :: PatQ -> BodyQ -> [DecQ] -> DecQ
valD p b ds =
do { ds' <- sequence ds
do { p' <- p
; ds' <- sequence ds
; b' <- b
; return (ValD p b' ds')
; return (ValD p' b' ds')
}
funD :: Name -> [ClauseQ] -> DecQ
......@@ -361,6 +399,10 @@ 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) }
......
......@@ -136,7 +136,9 @@ instance Ppr Match where
pprBody :: Bool -> Body -> Doc
pprBody eq (GuardedB xs) = nest nestDepth $ vcat $ map do_guard xs
where eqd = if eq then text "=" else text "->"
do_guard (lhs, rhs) = text "|" <+> ppr lhs <+> eqd <+> ppr rhs
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
------------------------------
......@@ -162,6 +164,9 @@ pprPat _ (VarP v) = ppr v
pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps
pprPat i (ConP s ps) = parensIf (i > noPrec) $ ppr s
<+> sep (map (pprPat appPrec) ps)
pprPat i (InfixP p1 n p2)
= parensIf (i > noPrec)
$ pprPat opPrec p1 <+> ppr n <+> pprPat opPrec p2
pprPat i (TildeP p) = parensIf (i > noPrec) $ pprPat appPrec p
pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@"
<> pprPat appPrec p
......@@ -171,6 +176,7 @@ pprPat _ (RecP nm fs)
<+> 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
......
......@@ -26,7 +26,7 @@ module Language.Haskell.TH.Syntax(
-- The algebraic data types
Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..),
Clause(..), Body(..), Stmt(..), Range(..),
Clause(..), Body(..), Guard(..), Stmt(..), Range(..),
Lit(..), Pat(..), FieldExp, FieldPat,
Strict(..), Foreign(..), Callconv(..), Safety(..),
StrictType, VarStrictType,
......@@ -47,6 +47,7 @@ import GHC.Base ( Int(..), Int#, (<#), (==#) )
import IO ( hPutStrLn, stderr )
import Data.IORef
import GHC.IOBase ( unsafePerformIO )
import Control.Monad (liftM)
-----------------------------------------------------
--
......@@ -192,6 +193,33 @@ instance Lift Bool where
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
......@@ -380,11 +408,13 @@ data Pat
| 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 )
type FieldPat = (Name,Pat)
......@@ -428,10 +458,15 @@ type FieldExp = (Name,Exp)
-- Omitted: implicit parameters
data Body
= GuardedB [(Exp,Exp)] -- f p { | e1 = e2 | e3 = e4 } where ds
= GuardedB [(Guard,Exp)] -- f p { | e1 = e2 | e3 = e4 } where ds
| NormalB Exp -- f p { = e } where ds
deriving( Show, Eq )
data Guard
= NormalG Exp
| PatG [Stmt]
deriving( Show, Eq )
data Stmt
= BindS Pat Exp
| LetS [ Dec ]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment