From: igloo Date: Tue, 1 Jun 2004 23:22:33 +0000 (+0000) Subject: [project @ 2004-06-01 23:22:30 by igloo] X-Git-Tag: Initial_conversion_from_CVS_complete~1824 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=5ca86c67873a146c859cac04a76ee35260a4cf0a;p=ghc-hetmet.git [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 --- 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 --- 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