[commit: template-haskell] master: Added multi-way if-expressions support. (1bee532)

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 }  }@