Implemented MultiWayIf extension.

17 files changed, 149 insertions, 44 deletions

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 28d83c9dc5..ff3cfc5189 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -423,6 +423,7 @@ isGoodBreakExpr (HsApp {})     = True
 isGoodBreakExpr (OpApp {})     = True
 isGoodBreakExpr (NegApp {})    = True
 isGoodBreakExpr (HsIf {})      = True
+isGoodBreakExpr (HsMultiIf {}) = True
 isGoodBreakExpr (HsCase {})    = True
 isGoodBreakExpr (RecordCon {}) = True
 isGoodBreakExpr (RecordUpd {}) = True
@@ -496,6 +497,10 @@ addTickHsExpr (HsIf cnd e1 e2 e3) =
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
                 (addTickLHsExprOptAlt True e2)
                 (addTickLHsExprOptAlt True e3)
+addTickHsExpr (HsMultiIf ty alts)
+  = do { let isOneOfMany = case alts of [_] -> False; _ -> True
+       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
+       ; return $ HsMultiIf ty alts' }
 addTickHsExpr (HsLet binds e) =
         bindLocals (collectLocalBinders binds) $
         liftM2 HsLet
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 4795b5f68c..f8bd213c3f 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -337,6 +337,19 @@ dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
            Just fun -> do { core_fun <- dsExpr fun
                           ; return (mkCoreApps core_fun [pred,b1,b2]) }
            Nothing  -> return $ mkIfThenElse pred b1 b2 }
+
+dsExpr (HsMultiIf res_ty alts)
+  | null alts
+  = mkErrorExpr
+
+  | otherwise
+  = do { match_result <- liftM (foldr1 combineMatchResults)
+                               (mapM (dsGRHS IfAlt res_ty) alts)
+       ; error_expr   <- mkErrorExpr
+       ; extractMatchResult match_result error_expr }
+  where
+    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
+                               (ptext (sLit "multi-way if"))
 \end{code}
 
 
diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs
index ed87d186af..9e84e46e9f 100644
--- a/compiler/deSugar/DsGRHSs.lhs
+++ b/compiler/deSugar/DsGRHSs.lhs
@@ -6,7 +6,7 @@
 Matching guarded right-hand-sides (GRHSs)
 
 \begin{code}
-module DsGRHSs ( dsGuarded, dsGRHSs ) where
+module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where
 
 #include "HsVersions.h"
 
@@ -55,8 +55,8 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id]      -- These are to build a MatchCon
         -> GRHSs Id                             -- Guarded RHSs
         -> Type                                 -- Type of RHS
         -> DsM MatchResult
-dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = do
-    match_results <- mapM (dsGRHS hs_ctx pats rhs_ty) grhss
+dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do
+    match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
     let
         match_result1 = foldr1 combineMatchResults match_results
         match_result2 = adjustMatchResultDs
@@ -66,8 +66,8 @@ dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = do
     --
     return match_result2
 
-dsGRHS :: HsMatchContext Name -> [Pat Id] -> Type -> LGRHS Id -> DsM MatchResult
-dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs))
+dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id -> DsM MatchResult
+dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
   = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
 \end{code}
 
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7a60ae4ae1..4d07c8c34e 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -890,6 +890,10 @@ repE (HsIf _ x y z)         = do
 			      b <- repLE y
 			      c <- repLE z
 			      repCond a b c
+repE (HsMultiIf _ alts)
+  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
+       ; expr' <- repMultiIf (nonEmptyCoreList alts')
+       ; wrapGenSyms (concat binds) expr' }
 repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
 			       ; e2 <- addBinds ss (repLE e)
 			       ; z <- repLetE ds e2
@@ -980,22 +984,22 @@ repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
 
 repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
 repGuards [L _ (GRHS [] e)]
-  = do {a <- repLE e; repNormal a }
-repGuards other
-  = do { zs <- mapM process other;
-     let {(xs, ys) = unzip zs};
-	 gd <- repGuarded (nonEmptyCoreList ys);
-     wrapGenSyms (concat xs) gd }
-  where
-    process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
-    process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2))
-           = do { x <- repLNormalGE e1 e2;
-                  return ([], x) }
-    process (L _ (GRHS ss rhs))
-           = do (gs, ss') <- repLSts ss
-		rhs' <- addBinds gs $ repLE rhs
-                g <- repPatGE (nonEmptyCoreList ss') rhs'
-                return (gs, g)
+  = do { a <- repLE e
+       ; repNormal a }
+repGuards alts
+  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
+       ; body <- repGuarded (nonEmptyCoreList alts')
+       ; wrapGenSyms (concat binds) body }
+
+repLGRHS :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
+repLGRHS (L _ (GRHS [L _ (ExprStmt guard _ _ _)] rhs))
+  = do { guarded <- repLNormalGE guard rhs
+       ; return ([], guarded) }
+repLGRHS (L _ (GRHS stmts rhs))
+  = do { (gs, stmts') <- repLSts stmts
+       ; rhs'         <- addBinds gs $ repLE rhs
+       ; guarded      <- repPatGE (nonEmptyCoreList stmts') rhs'
+       ; return (gs, guarded) }
 
 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
 repFields (HsRecFields { rec_flds = flds })
@@ -1471,6 +1475,9 @@ repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
 
+repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
+repMultiIf (MkC alts) = rep2 multiIfEName [alts]
+
 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
 
@@ -1902,7 +1909,7 @@ templateHaskellNames = [
     varEName, conEName, litEName, appEName, infixEName,
     infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
     tupEName, unboxedTupEName,
-    condEName, letEName, caseEName, doEName, compEName,
+    condEName, multiIfEName, letEName, caseEName, doEName, compEName,
     fromEName, fromThenEName, fromToEName, fromThenToEName,
     listEName, sigEName, recConEName, recUpdEName,
     -- FieldExp
@@ -2066,8 +2073,8 @@ clauseName = libFun (fsLit "clause") clauseIdKey
 -- data Exp = ...
 varEName, conEName, litEName, appEName, infixEName, infixAppName,
     sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
-    unboxedTupEName, condEName, letEName, caseEName, doEName,
-    compEName :: Name
+    unboxedTupEName, condEName, multiIfEName, letEName, caseEName,
+    doEName, compEName :: Name
 varEName        = libFun (fsLit "varE")        varEIdKey
 conEName        = libFun (fsLit "conE")        conEIdKey
 litEName        = libFun (fsLit "litE")        litEIdKey
@@ -2081,6 +2088,7 @@ lamCaseEName    = libFun (fsLit "lamCaseE")    lamCaseEIdKey
 tupEName        = libFun (fsLit "tupE")        tupEIdKey
 unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
 condEName       = libFun (fsLit "condE")       condEIdKey
+multiIfEName    = libFun (fsLit "multiIfE")    multiIfEIdKey
 letEName        = libFun (fsLit "letE")        letEIdKey
 caseEName       = libFun (fsLit "caseE")       caseEIdKey
 doEName         = libFun (fsLit "doE")         doEIdKey
@@ -2380,7 +2388,7 @@ clauseIdKey         = mkPreludeMiscIdUnique 262
 -- data Exp = ...
 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
     sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,
-    unboxedTupEIdKey, condEIdKey,
+    unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
@@ -2397,18 +2405,19 @@ lamCaseEIdKey     = mkPreludeMiscIdUnique 279
 tupEIdKey         = mkPreludeMiscIdUnique 280
 unboxedTupEIdKey  = mkPreludeMiscIdUnique 281
 condEIdKey        = mkPreludeMiscIdUnique 282
-letEIdKey         = mkPreludeMiscIdUnique 283
-caseEIdKey        = mkPreludeMiscIdUnique 284
-doEIdKey          = mkPreludeMiscIdUnique 285
-compEIdKey        = mkPreludeMiscIdUnique 286
-fromEIdKey        = mkPreludeMiscIdUnique 287
-fromThenEIdKey    = mkPreludeMiscIdUnique 288
-fromToEIdKey      = mkPreludeMiscIdUnique 289
-fromThenToEIdKey  = mkPreludeMiscIdUnique 290
-listEIdKey        = mkPreludeMiscIdUnique 291
-sigEIdKey         = mkPreludeMiscIdUnique 292
-recConEIdKey      = mkPreludeMiscIdUnique 293
-recUpdEIdKey      = mkPreludeMiscIdUnique 294
+multiIfEIdKey     = mkPreludeMiscIdUnique 283
+letEIdKey         = mkPreludeMiscIdUnique 284
+caseEIdKey        = mkPreludeMiscIdUnique 285
+doEIdKey          = mkPreludeMiscIdUnique 286
+compEIdKey        = mkPreludeMiscIdUnique 287
+fromEIdKey        = mkPreludeMiscIdUnique 288
+fromThenEIdKey    = mkPreludeMiscIdUnique 289
+fromToEIdKey      = mkPreludeMiscIdUnique 290
+fromThenToEIdKey  = mkPreludeMiscIdUnique 291
+listEIdKey        = mkPreludeMiscIdUnique 292
+sigEIdKey         = mkPreludeMiscIdUnique 293
+recConEIdKey      = mkPreludeMiscIdUnique 294
+recUpdEIdKey      = mkPreludeMiscIdUnique 295
 
 -- type FieldExp = ...
 fieldExpIdKey :: Unique
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index c80446a751..8fd3a203f3 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -88,6 +88,7 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
     incomplete_flag :: HsMatchContext id -> Bool
     incomplete_flag (FunRhs {})   = wopt Opt_WarnIncompletePatterns dflags
     incomplete_flag CaseAlt       = wopt Opt_WarnIncompletePatterns dflags
+    incomplete_flag IfAlt         = False
 
     incomplete_flag LambdaExpr    = wopt Opt_WarnIncompleteUniPatterns dflags
     incomplete_flag PatBindRhs    = wopt Opt_WarnIncompleteUniPatterns dflags
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index bf0f956171..376ff236b7 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -495,6 +495,10 @@ cvtl e = wrapL (cvt e)
     cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed }
     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
 			    ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
+    cvt (MultiIfE alts)
+      | null alts      = failWith (ptext (sLit "Multi-way if-expression with no alternatives"))
+      | otherwise      = do { alts' <- mapM cvtpair alts
+                            ; return $ HsMultiIf placeHolderType alts' }
     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
                             ; e' <- cvtl e; return $ HsLet ds' e' }
     cvt (CaseE e ms)
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 4db827a574..a9cad67eb0 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -152,6 +152,8 @@ data HsExpr id
                 (LHsExpr id)    --  then part
                 (LHsExpr id)    --  else part
 
+  | HsMultiIf   PostTcType [LGRHS id] -- Multi-way if
+
   | HsLet       (HsLocalBinds id) -- let(rec)
                 (LHsExpr  id)
 
@@ -464,6 +466,12 @@ ppr_expr (HsIf _ e1 e2 e3)
          ptext (sLit "else"),
          nest 4 (ppr e3)]
 
+ppr_expr (HsMultiIf _ alts)
+  = sep $ ptext (sLit "if") : map ppr_alt alts
+  where ppr_alt (L _ (GRHS guards expr)) =
+          sep [ char '|' <+> interpp'SP guards
+              , ptext (sLit "->") <+> pprDeeper (ppr expr) ]
+
 -- special case: let ... in let ...
 ppr_expr (HsLet binds expr@(L _ (HsLet _ _)))
   = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]),
@@ -1263,6 +1271,7 @@ data HsMatchContext id  -- Context of a Match
   = FunRhs id Bool              -- Function binding for f; True <=> written infix
   | LambdaExpr                  -- Patterns of a lambda
   | CaseAlt                     -- Patterns and guards on a case alternative
+  | IfAlt                       -- Guards of a multi-way if alternative
   | ProcExpr                    -- Patterns of a proc
   | PatBindRhs                  -- A pattern binding  eg [y] <- e = e
 
@@ -1313,6 +1322,7 @@ isMonadCompExpr _                    = False
 matchSeparator :: HsMatchContext id -> SDoc
 matchSeparator (FunRhs {})  = ptext (sLit "=")
 matchSeparator CaseAlt      = ptext (sLit "->")
+matchSeparator IfAlt        = ptext (sLit "->")
 matchSeparator LambdaExpr   = ptext (sLit "->")
 matchSeparator ProcExpr     = ptext (sLit "->")
 matchSeparator PatBindRhs   = ptext (sLit "=")
@@ -1335,6 +1345,7 @@ pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc
 pprMatchContextNoun (FunRhs fun _)  = ptext (sLit "equation for")
                                       <+> quotes (ppr fun)
 pprMatchContextNoun CaseAlt         = ptext (sLit "case alternative")
+pprMatchContextNoun IfAlt           = ptext (sLit "multi-way if alternative")
 pprMatchContextNoun RecUpd          = ptext (sLit "record-update construct")
 pprMatchContextNoun ThPatQuote      = ptext (sLit "Template Haskell pattern quotation")
 pprMatchContextNoun PatBindRhs      = ptext (sLit "pattern binding")
@@ -1383,6 +1394,7 @@ pprStmtContext (TransStmtCtxt c)
 matchContextErrString :: Outputable id => HsMatchContext id -> SDoc
 matchContextErrString (FunRhs fun _)             = ptext (sLit "function") <+> ppr fun
 matchContextErrString CaseAlt                    = ptext (sLit "case")
+matchContextErrString IfAlt                      = ptext (sLit "multi-way if")
 matchContextErrString PatBindRhs                 = ptext (sLit "pattern binding")
 matchContextErrString RecUpd                     = ptext (sLit "record update")
 matchContextErrString LambdaExpr                 = ptext (sLit "lambda")
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 02d20044ae..b5ad8d11ce 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -486,6 +486,7 @@ data ExtensionFlag
    | Opt_RelaxedLayout
    | Opt_TraditionalRecordSyntax
    | Opt_LambdaCase
+   | Opt_MultiWayIf
    deriving (Eq, Enum, Show)
 
 -- | Contains not only a collection of 'DynFlag's but also a plethora of
@@ -2164,6 +2165,7 @@ xFlags = [
   ( "RelaxedLayout",                    Opt_RelaxedLayout, nop ),
   ( "TraditionalRecordSyntax",          Opt_TraditionalRecordSyntax, nop ),
   ( "LambdaCase",                       Opt_LambdaCase, nop ),
+  ( "MultiWayIf",                       Opt_MultiWayIf, nop ),
   ( "MonoLocalBinds",                   Opt_MonoLocalBinds, nop ),
   ( "RelaxedPolyRec",                   Opt_RelaxedPolyRec,
     \ turn_on -> if not turn_on
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 03e8958bb7..ac417acd0f 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -1867,6 +1867,8 @@ explicitNamespacesBit :: Int
 explicitNamespacesBit = 29
 lambdaCaseBit :: Int
 lambdaCaseBit = 30
+multiWayIfBit :: Int
+multiWayIfBit = 31
 
 
 always :: Int -> Bool
@@ -1918,6 +1920,8 @@ explicitNamespacesEnabled :: Int -> Bool
 explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit
 lambdaCaseEnabled :: Int -> Bool
 lambdaCaseEnabled flags = testBit flags lambdaCaseBit
+multiWayIfEnabled :: Int -> Bool
+multiWayIfEnabled flags = testBit flags multiWayIfBit
 
 -- PState for parsing options pragmas
 --
@@ -1979,6 +1983,7 @@ mkPState flags buf loc =
                .|. typeLiteralsBit             `setBitIf` xopt Opt_DataKinds flags
                .|. explicitNamespacesBit       `setBitIf` xopt Opt_ExplicitNamespaces flags
                .|. lambdaCaseBit               `setBitIf` xopt Opt_LambdaCase               flags
+               .|. multiWayIfBit               `setBitIf` xopt Opt_MultiWayIf               flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 67baa8821a..62132277d9 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -55,7 +55,7 @@ import FastString
 import Maybes           ( orElse )
 import Outputable
 
-import Control.Monad    ( unless )
+import Control.Monad    ( unless, liftM )
 import GHC.Exts
 import Data.Char
 import Control.Monad    ( mplus )
@@ -1394,6 +1394,8 @@ exp10 :: { LHsExpr RdrName }
         | 'if' exp optSemi 'then' exp optSemi 'else' exp
                                         {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
                                            return (LL $ mkHsIf $2 $5 $8) }
+        | 'if' gdpats                   {% hintMultiWayIf (getLoc $1) >>
+                                           return (LL $ HsMultiIf placeHolderType (reverse $ unLoc $2)) }
         | 'case' exp 'of' altslist              { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
         | '-' fexp                              { LL $ NegApp $2 noSyntaxExpr }
 
@@ -2141,4 +2143,11 @@ fileSrcSpan = do
   l <- getSrcLoc; 
   let loc = mkSrcLoc (srcLocFile l) 1 1;
   return (mkSrcSpan loc loc)
+
+-- Hint about the MultiWayIf extension
+hintMultiWayIf :: SrcSpan -> P ()
+hintMultiWayIf span = do
+  mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState
+  unless mwiEnabled $ parseErrorSDoc span $
+    text "Multi-way if-expressions need -XMultiWayIf turned on"
 }
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index d3d16033eb..2c70698fdd 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -25,7 +25,7 @@ module RnBinds (
 
    -- Other bindings
    rnMethodBinds, renameSigs, mkSigTvFn,
-   rnMatchGroup, rnGRHSs,
+   rnMatchGroup, rnGRHSs, rnGRHS,
    makeMiniFixityEnv, MiniFixityEnv,
    HsSigCtxt(..)
    ) where
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 372daa94eb..e7dbe53df3 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -29,7 +29,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
 
 import RnSource  ( rnSrcDecls, findSplice )
 import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
-                   rnMatchGroup, makeMiniFixityEnv) 
+                   rnMatchGroup, rnGRHS, makeMiniFixityEnv) 
 import HsSyn
 import TcRnMonad
 import TcEnv		( thRnBrack )
@@ -284,6 +284,10 @@ rnExpr (HsIf _ p b1 b2)
        ; (mb_ite, fvITE) <- lookupIfThenElse
        ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
 
+rnExpr (HsMultiIf ty alts)
+  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt) alts
+       ; return (HsMultiIf ty alts', fvs) }
+
 rnExpr (HsType a)
   = rnLHsType HsTypeCtx a	`thenM` \ (t, fvT) -> 
     return (HsType t, fvT)
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index ba2ca748aa..51b5eb3fa7 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -445,6 +445,11 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty   -- Note [Rebindable syntax for if]
        -- and it maintains uniformity with other rebindable syntax
        ; return (HsIf (Just fun') pred' b1' b2') }
 
+tcExpr (HsMultiIf _ alts) res_ty
+  = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
+       ; return $ HsMultiIf res_ty alts' }
+  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
+
 tcExpr (HsDo do_or_lc stmts _) res_ty
   = tcDoStmts do_or_lc stmts res_ty
 
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 51d6c12a2c..922b2cd404 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -621,6 +621,15 @@ zonkExpr env (HsIf e0 e1 e2 e3)
        ; new_e3 <- zonkLExpr env e3
        ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) }
 
+zonkExpr env (HsMultiIf ty alts)
+  = do { alts' <- mapM (wrapLocM zonk_alt) alts
+       ; ty'   <- zonkTcTypeToType env ty
+       ; returnM $ HsMultiIf ty' alts' }
+  where zonk_alt (GRHS guard expr)
+          = do { (env', guard') <- zonkStmts env guard
+               ; expr'          <- zonkLExpr env' expr
+               ; returnM $ GRHS guard' expr' }
+
 zonkExpr env (HsLet binds expr)
   = zonkLocalBinds env binds	`thenM` \ (new_env, new_binds) ->
     zonkLExpr new_env expr	`thenM` \ new_expr ->
diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 2941a17092..acc20649c0 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -13,10 +13,10 @@ TcMatches: Typecheck some @Matches@
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
 -- for details
 
-module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
-		   TcMatchCtxt(..), TcStmtChecker,
-		   tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
-		   tcDoStmt, tcGuardStmt
+module TcMatches ( tcMatchesFun, tcGRHSsPat, tcGRHS, tcMatchesCase,
+                   tcMatchLambda, TcMatchCtxt(..), TcStmtChecker,
+                   tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
+                   tcDoStmt, tcGuardStmt
        ) where
 
 import {-# SOURCE #-}	TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId,
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index 544acd8c2a..24c52f214a 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -1128,6 +1128,12 @@
             <entry><option>-XNoLambdaCase</option></entry>
           </row>
           <row>
+            <entry><option>-XMultiWayIf</option></entry>
+            <entry>Enable <link linkend="multi-way-if">multi-way if-expressions</link>.</entry>
+            <entry>dynamic</entry>
+            <entry><option>-XNoMultiWayIf</option></entry>
+          </row>
+          <row>
             <entry><option>-XSafe</option></entry>
             <entry>Enable the <link linkend="safe-haskell">Safe Haskell</link> Safe mode.</entry>
             <entry>dynamic</entry>
diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 805f53aa40..dde235eda4 100644
--- a/docs/users_guide/glasgow_exts.xml
+++ b/docs/users_guide/glasgow_exts.xml
@@ -1690,6 +1690,27 @@ Note that <literal>\case</literal> starts a layout, so you can write
 </para>
 </sect2>
 
+<sect2 id="multi-way-if">
+<title>Multi-way if-expressions</title>
+<para>
+With <option>-XMultiWayIf</option> flag GHC accepts conditional expressions
+with multiple branches:
+<programlisting>
+  if | guard1 -> expr1
+     | ...
+     | guardN -> exprN
+</programlisting>
+which is roughly equivalent to
+<programlisting>
+  case () of
+    _ | guard1 -> expr1
+    ...
+    _ | guardN -> exprN
+</programlisting>
+except that multi-way if-expressions do not alter the layout.
+</para>
+</sect2>
+
 <sect2 id="disambiguate-fields">
 <title>Record field disambiguation</title>
 <para>