[project @ 2004-06-01 23:22:32 by igloo]
authorigloo <unknown>
Tue, 1 Jun 2004 23:22:32 +0000 (23:22 +0000)
committerigloo <unknown>
Tue, 1 Jun 2004 23:22:32 +0000 (23:22 +0000)
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).

libraries/template-haskell/Language/Haskell/TH.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs

index 6b1572d..39fe492 100644 (file)
@@ -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
index fa422d6..3d25349 100644 (file)
@@ -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) }
index 02ac80c..3c1fbac 100644 (file)
@@ -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
index b9ec9e8..4d9c449 100644 (file)
@@ -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 ]