Repository : ssh://darcs.haskell.org//srv/darcs/packages/template-haskell On branch : master
http://hackage.haskell.org/trac/ghc/changeset/1bee53217f68194f0c5273f90e34a45a840a7e9c >--------------------------------------------------------------- commit 1bee53217f68194f0c5273f90e34a45a840a7e9c Author: Mikhail Vorozhtsov <[email protected]> Date: Sun Jul 15 00:56:17 2012 +0700 Added multi-way if-expressions support. >--------------------------------------------------------------- Language/Haskell/TH.hs | 2 +- Language/Haskell/TH/Lib.hs | 3 +++ Language/Haskell/TH/Ppr.hs | 24 ++++++++++++++++++------ Language/Haskell/TH/PprLib.hs | 4 +++- Language/Haskell/TH/Syntax.hs | 1 + 5 files changed, 26 insertions(+), 8 deletions(-) diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs index fc4722f..8e36af7 100644 --- a/Language/Haskell/TH.hs +++ b/Language/Haskell/TH.hs @@ -56,7 +56,7 @@ module Language.Haskell.TH( -- *** Expressions dyn, global, varE, conE, litE, appE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR, - lamE, lam1E, lamCaseE, tupE, condE, letE, caseE, appsE, + lamE, lam1E, lamCaseE, tupE, condE, multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp, -- **** Ranges fromE, fromThenE, fromToE, fromThenToE, diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs index 1edeb0b..52865ad 100644 --- a/Language/Haskell/TH/Lib.hs +++ b/Language/Haskell/TH/Lib.hs @@ -254,6 +254,9 @@ unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)} condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)} +multiIfE :: [Q (Guard, Exp)] -> ExpQ +multiIfE alts = sequence alts >>= return . MultiIfE + letE :: [DecQ] -> ExpQ -> ExpQ letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) } diff --git a/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs index a53fffe..a1d08e2 100644 --- a/Language/Haskell/TH/Ppr.hs +++ b/Language/Haskell/TH/Ppr.hs @@ -115,6 +115,12 @@ 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 (MultiIfE alts) + = parensIf (i > noPrec) $ vcat $ + case alts of + [] -> [text "if {}"] + (alt : alts') -> text "if" <+> pprGuarded arrow alt + : map (nest 3 . pprGuarded arrow) alts' pprExp i (LetE ds e) = parensIf (i > noPrec) $ text "let" <+> ppr ds $$ text " in" <+> ppr e pprExp i (CaseE e ms) @@ -156,13 +162,19 @@ instance Ppr Match where $$ where_clause ds ------------------------------ +pprGuarded :: Doc -> (Guard, Exp) -> Doc +pprGuarded eqDoc (guard, expr) = case guard of + NormalG guardExpr -> char '|' <+> ppr guardExpr <+> eqDoc <+> ppr expr + PatG stmts -> char '|' <+> vcat (punctuate comma $ map ppr stmts) $$ + nest nestDepth (eqDoc <+> ppr expr) + +------------------------------ 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 +pprBody eq body = case body of + GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs + NormalB e -> eqDoc <+> ppr e + where eqDoc | eq = equals + | otherwise = arrow ------------------------------ pprLit :: Precedence -> Lit -> Doc diff --git a/Language/Haskell/TH/PprLib.hs b/Language/Haskell/TH/PprLib.hs index e42c986..42856bb 100644 --- a/Language/Haskell/TH/PprLib.hs +++ b/Language/Haskell/TH/PprLib.hs @@ -10,7 +10,7 @@ module Language.Haskell.TH.PprLib ( -- * Primitive Documents empty, - semi, comma, colon, space, equals, + semi, comma, colon, space, equals, arrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, -- * Converting values into documents @@ -63,6 +63,7 @@ comma :: Doc; -- ^ A ',' character colon :: Doc; -- ^ A ':' character space :: Doc; -- ^ A space character equals :: Doc; -- ^ A '=' character +arrow :: Doc; -- ^ A "->" string lparen :: Doc; -- ^ A '(' character rparen :: Doc; -- ^ A ')' character lbrack :: Doc; -- ^ A '[' character @@ -163,6 +164,7 @@ comma = return HPJ.comma colon = return HPJ.colon space = return HPJ.space equals = return HPJ.equals +arrow = return $ HPJ.text "->" lparen = return HPJ.lparen rparen = return HPJ.rparen lbrack = return HPJ.lbrack diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs index 65aff77..d9c1dcc 100644 --- a/Language/Haskell/TH/Syntax.hs +++ b/Language/Haskell/TH/Syntax.hs @@ -866,6 +866,7 @@ data Exp | TupE [Exp] -- ^ @{ (e1,e2) } @ | UnboxedTupE [Exp] -- ^ @{ (# e1,e2 #) } @ | CondE Exp Exp Exp -- ^ @{ if e1 then e2 else e3 }@ + | MultiIfE [(Guard, Exp)] -- ^ @{ if | g1 -> e1 | g2 -> e2 }@ | LetE [Dec] Exp -- ^ @{ let x=e1; y=e2 in e3 }@ | CaseE Exp [Match] -- ^ @{ case e of m1; m2 }@ | DoE [Stmt] -- ^ @{ do { p <- e1; e2 } }@ _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
