[project @ 2004-06-01 23:22:30 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).

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index dbd8fce..42e8604 100644 (file)
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -566,13 +566,21 @@ repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
 repGuards [L _ (GRHS [L _ (ResultStmt e)])]
   = do {a <- repLE e; repNormal a }
 repGuards other 
-  = do { zs <- mapM process other; 
-        repGuarded (nonEmptyCoreList (map corePair zs)) }
+  = do { zs <- mapM process other;
+     let {(xs, ys) = unzip zs};
+        gd <- repGuarded (nonEmptyCoreList ys);
+     wrapGenSyns (concat xs) gd }
   where 
+    process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
+    process (L _ (GRHS [])) = panic "No guards in guarded body"
     process (L _ (GRHS [L _ (ExprStmt e1 ty),
                        L _ (ResultStmt e2)]))
-           = do { x <- repLE e1; y <- repLE e2; return (x, y) }
-    process other = panic "Non Haskell 98 guarded body"
+           = do { x <- repLNormalGE e1 e2;
+                  return ([], x) }
+    process (L _ (GRHS ss))
+           = do (gs, ss') <- repLSts ss
+                g <- repPatGE (nonEmptyCoreList ss')
+                return (gs, g)
 
 repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.FieldExp])
 repFields flds = do
@@ -633,6 +641,7 @@ repSts (ExprStmt e ty : ss) =
       ; z <- repNoBindSt e2 
       ; (ss2,zs) <- repSts ss
       ; return (ss2, z : zs) }
+repSts [] = panic "repSts ran out of statements"      
 repSts other = panic "Exotic Stmt in meta brackets"      
 
 
@@ -754,14 +763,14 @@ repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
 -- variable should already appear in the environment.
 
 -- Process a list of patterns
-repLPs :: [LPat Name] -> DsM (Core [TH.Pat])
+repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
 repLPs ps = do { ps' <- mapM repLP ps ;
-                coreList patTyConName ps' }
+                coreList patQTyConName ps' }
 
-repLP :: LPat Name -> DsM (Core TH.Pat)
+repLP :: LPat Name -> DsM (Core TH.PatQ)
 repLP (L _ p) = repP p
 
-repP :: Pat Name -> DsM (Core TH.Pat)
+repP :: Pat Name -> DsM (Core TH.PatQ)
 repP (WildPat _)     = repPwild 
 repP (LitPat l)      = do { l2 <- repLiteral l; repPlit l2 }
 repP (VarPat x)      = do { x' <- lookupBinder x; repPvar x' }
@@ -777,12 +786,15 @@ repP (ConPatIn dc details)
          RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
                             ; ps <- sequence $ map repLP (map snd pairs)
                             ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
-                            ; fps' <- coreList fieldPatTyConName fps
+                            ; fps' <- coreList fieldPatQTyConName fps
                             ; repPrec con_str fps' }
-         InfixCon p1 p2 -> do { qs <- repLPs [p1,p2]; repPcon con_str qs }
+         InfixCon p1 p2 -> do { p1' <- repLP p1;
+                                p2' <- repLP p2;
+                                repPinfix p1' con_str p2' }
    }
 repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
 repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
+repP (SigPatIn p t)  = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
 repP other = panic "Exotic pattern inside meta brackets"
 
 ----------------------------------------------------------
@@ -955,33 +967,39 @@ rep2 n xs = do { id <- dsLookupGlobalId n
 -- %*********************************************************************
 
 --------------- Patterns -----------------
-repPlit   :: Core TH.Lit -> DsM (Core TH.Pat) 
+repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ) 
 repPlit (MkC l) = rep2 litPName [l]
 
-repPvar :: Core TH.Name -> DsM (Core TH.Pat)
+repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
 repPvar (MkC s) = rep2 varPName [s]
 
-repPtup :: Core [TH.Pat] -> DsM (Core TH.Pat)
+repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
 repPtup (MkC ps) = rep2 tupPName [ps]
 
-repPcon   :: Core TH.Name -> Core [TH.Pat] -> DsM (Core TH.Pat)
+repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
 
-repPrec   :: Core TH.Name -> Core [(TH.Name,TH.Pat)] -> DsM (Core TH.Pat)
+repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
 
-repPtilde :: Core TH.Pat -> DsM (Core TH.Pat)
+repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
+
+repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
 repPtilde (MkC p) = rep2 tildePName [p]
 
-repPaspat :: Core TH.Name -> Core TH.Pat -> DsM (Core TH.Pat)
+repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
 
-repPwild  :: DsM (Core TH.Pat)
+repPwild  :: DsM (Core TH.PatQ)
 repPwild = rep2 wildPName []
 
-repPlist :: Core [TH.Pat] -> DsM (Core TH.Pat)
+repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
 repPlist (MkC ps) = rep2 listPName [ps]
 
+repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
+
 --------------- Expressions -----------------
 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
@@ -999,7 +1017,7 @@ repLit (MkC c) = rep2 litEName [c]
 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repApp (MkC x) (MkC y) = rep2 appEName [x,y] 
 
-repLam :: Core [TH.Pat] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
 
 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
@@ -1042,14 +1060,26 @@ repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
 
 ------------ Right hand sides (guarded expressions) ----
-repGuarded :: Core [(TH.ExpQ, TH.ExpQ)] -> DsM (Core TH.BodyQ)
+repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
 
 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
 repNormal (MkC e) = rep2 normalBName [e]
 
+------------ Guards ----
+repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repLNormalGE g e = do g' <- repLE g
+                      e' <- repLE e
+                      repNormalGE g' e'
+
+repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
+
+repPatGE :: Core [TH.StmtQ] -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repPatGE (MkC ss) = rep2 patGEName [ss]
+
 ------------- Stmts -------------------
-repBindSt :: Core TH.Pat -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
 
 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
@@ -1072,14 +1102,14 @@ repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.Ex
 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
 
 ------------ Match and Clause Tuples -----------
-repMatch :: Core TH.Pat -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
+repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
 
-repClause :: Core [TH.Pat] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
+repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
 
 -------------- Dec -----------------------------
-repVal :: Core TH.Pat -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
 
 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)  
@@ -1267,8 +1297,8 @@ templateHaskellNames = [
     charLName, stringLName, integerLName, intPrimLName,
     floatPrimLName, doublePrimLName, rationalLName,
     -- Pat
-    litPName, varPName, tupPName, conPName, tildePName,
-    asPName, wildPName, recPName, listPName,
+    litPName, varPName, tupPName, conPName, tildePName, infixPName,
+    asPName, wildPName, recPName, listPName, sigPName,
     -- FieldPat
     fieldPatName,
     -- Match
@@ -1285,6 +1315,8 @@ templateHaskellNames = [
     fieldExpName,
     -- Body
     guardedBName, normalBName,
+    -- Guard
+    normalGEName, patGEName,
     -- Stmt
     bindSName, letSName, noBindSName, parSName,
     -- Dec
@@ -1315,7 +1347,8 @@ templateHaskellNames = [
     clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
     decQTyConName, conQTyConName, strictTypeQTyConName,
     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
-    typeTyConName, matchTyConName, clauseTyConName]
+    typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
+    fieldPatQTyConName]
 
 tH_SYN_Name = mkModuleName "Language.Haskell.TH.Syntax"
 tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib"
@@ -1373,11 +1406,13 @@ litPName   = libFun FSLIT("litP")   litPIdKey
 varPName   = libFun FSLIT("varP")   varPIdKey
 tupPName   = libFun FSLIT("tupP")   tupPIdKey
 conPName   = libFun FSLIT("conP")   conPIdKey
+infixPName = libFun FSLIT("infixP") infixPIdKey
 tildePName = libFun FSLIT("tildeP") tildePIdKey
 asPName    = libFun FSLIT("asP")    asPIdKey
 wildPName  = libFun FSLIT("wildP")  wildPIdKey
 recPName   = libFun FSLIT("recP")   recPIdKey
 listPName  = libFun FSLIT("listP")  listPIdKey
+sigPName   = libFun FSLIT("sigP")   sigPIdKey
 
 -- type FieldPat = ...
 fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
@@ -1422,6 +1457,10 @@ fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey
 guardedBName = libFun FSLIT("guardedB") guardedBIdKey
 normalBName  = libFun FSLIT("normalB")  normalBIdKey
 
+-- data Guard = ...
+normalGEName = libFun FSLIT("normalGE") normalGEIdKey
+patGEName    = libFun FSLIT("patGE")    patGEIdKey
+
 -- data Stmt = ...
 bindSName   = libFun FSLIT("bindS")   bindSIdKey
 letSName    = libFun FSLIT("letS")    letSIdKey
@@ -1484,6 +1523,8 @@ conQTyConName           = libTc FSLIT("ConQ")          conQTyConKey
 strictTypeQTyConName    = libTc FSLIT("StrictTypeQ")    strictTypeQTyConKey
 varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
 typeQTyConName          = libTc FSLIT("TypeQ")          typeQTyConKey
+patQTyConName           = libTc FSLIT("PatQ")           patQTyConKey
+fieldPatQTyConName      = libTc FSLIT("FieldPatQ")      fieldPatQTyConKey
 
 --     TyConUniques available: 100-119
 --     Check in PrelNames if you want to change this
@@ -1506,7 +1547,9 @@ varStrictTypeQTyConKey  = mkPreludeTyConUnique 114
 strictTypeQTyConKey     = mkPreludeTyConUnique 115
 fieldExpTyConKey        = mkPreludeTyConUnique 116
 fieldPatTyConKey        = mkPreludeTyConUnique 117
-nameTyConKey             = mkPreludeTyConUnique 118
+nameTyConKey            = mkPreludeTyConUnique 118
+patQTyConKey            = mkPreludeTyConUnique 119
+fieldPatQTyConKey       = mkPreludeTyConUnique 120
 
 --     IdUniques available: 200-399
 --     If you want to change this, make sure you check in PrelNames
@@ -1537,11 +1580,13 @@ litPIdKey         = mkPreludeMiscIdUnique 220
 varPIdKey         = mkPreludeMiscIdUnique 221
 tupPIdKey         = mkPreludeMiscIdUnique 222
 conPIdKey         = mkPreludeMiscIdUnique 223
+infixPIdKey       = mkPreludeMiscIdUnique 312
 tildePIdKey       = mkPreludeMiscIdUnique 224
 asPIdKey          = mkPreludeMiscIdUnique 225
 wildPIdKey        = mkPreludeMiscIdUnique 226
 recPIdKey         = mkPreludeMiscIdUnique 227
 listPIdKey        = mkPreludeMiscIdUnique 228
+sigPIdKey         = mkPreludeMiscIdUnique 229
 
 -- type FieldPat = ...
 fieldPatIdKey       = mkPreludeMiscIdUnique 230
@@ -1584,6 +1629,10 @@ fieldExpIdKey       = mkPreludeMiscIdUnique 265
 guardedBIdKey     = mkPreludeMiscIdUnique 266
 normalBIdKey      = mkPreludeMiscIdUnique 267
 
+-- data Guard = ...
+normalGEIdKey     = mkPreludeMiscIdUnique 310
+patGEIdKey        = mkPreludeMiscIdUnique 311
+
 -- data Stmt = ...
 bindSIdKey       = mkPreludeMiscIdUnique 268
 letSIdKey        = mkPreludeMiscIdUnique 269

diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index 8c30abb..2d7c85a 100644 (file)
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -10,7 +10,7 @@ module Convert( convertToHsExpr, convertToHsDecls, convertToHsType ) where
 
 #include "HsVersions.h"
 
-import Language.Haskell.TH as TH
+import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
 
 import HsSyn as Hs
@@ -262,9 +262,10 @@ cvtguard :: TH.Body -> [LGRHS RdrName]
 cvtguard (GuardedB pairs) = map cvtpair pairs
 cvtguard (NormalB e)    = [noLoc (GRHS [  nlResultStmt (cvtl e) ])]
 
-cvtpair :: (TH.Exp,TH.Exp) -> LGRHS RdrName
-cvtpair (x,y) = noLoc (GRHS [nlBindStmt truePat (cvtl x),
-                       nlResultStmt (cvtl y)])
+cvtpair :: (TH.Guard,TH.Exp) -> LGRHS RdrName
+cvtpair (NormalG x,y) = noLoc (GRHS [nlBindStmt truePat (cvtl x),
+                               nlResultStmt (cvtl y)])
+cvtpair (PatG x,y) = noLoc (GRHS (cvtstmts x ++ [nlResultStmt (cvtl y)]))
 
 cvtOverLit :: Lit -> HsOverLit
 cvtOverLit (IntegerL i)  = mkHsIntegral i
@@ -292,11 +293,14 @@ cvtp (TH.VarP s)     = Hs.VarPat(vName s)
 cvtp (TupP [p])   = cvtp p
 cvtp (TupP ps)    = TuplePat (map cvtlp ps) Boxed
 cvtp (ConP s ps)  = ConPatIn (noLoc (cName s)) (PrefixCon (map cvtlp ps))
+cvtp (InfixP p1 s p2)
+                  = ConPatIn (noLoc (cName s)) (InfixCon (cvtlp p1) (cvtlp p2))
 cvtp (TildeP p)   = LazyPat (cvtlp p)
 cvtp (TH.AsP s p) = AsPat (noLoc (vName s)) (cvtlp p)
 cvtp TH.WildP   = WildPat void
 cvtp (RecP c fs)  = ConPatIn (noLoc (cName c)) $ Hs.RecCon (map (\(s,p) -> (noLoc (vName s),cvtlp p)) fs)
 cvtp (ListP ps)   = ListPat (map cvtlp ps) void
+cvtp (SigP p t)   = SigPatIn (cvtlp p) (cvtType t)
 
 -----------------------------------------------------------
 --     Types and type variables