Ticket #4359: multi-way-if.patch

File multi-way-if.patch, 23.5 KB (added by mikhail.vorozhtsov, 10 months ago)

MultiWayIf, patch for the GHC

  • compiler/deSugar/Coverage.lhs 

    From a319af507c27c67167fca95010b1aa7399ec30dc Mon Sep 17 00:00:00 2001
From: Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com>
Date: Sun, 15 Jul 2012 00:53:52 +0700
Subject: [PATCH] Implemented MultiWayIf extension.

---
 compiler/deSugar/Coverage.lhs     |  5 +++
 compiler/deSugar/DsExpr.lhs       | 13 +++++++
 compiler/deSugar/DsGRHSs.lhs      | 10 +++---
 compiler/deSugar/DsMeta.hs        | 73 ++++++++++++++++++++++-----------------
 compiler/deSugar/Match.lhs        |  1 +
 compiler/hsSyn/Convert.lhs        |  4 +++
 compiler/hsSyn/HsExpr.lhs         | 12 +++++++
 compiler/main/DynFlags.hs         |  2 ++
 compiler/parser/Lexer.x           |  5 +++
 compiler/parser/Parser.y.pp       | 11 +++++-
 compiler/rename/RnBinds.lhs       |  2 +-
 compiler/rename/RnExpr.lhs        |  6 +++-
 compiler/typecheck/TcExpr.lhs     |  5 +++
 compiler/typecheck/TcHsSyn.lhs    |  9 +++++
 compiler/typecheck/TcMatches.lhs  |  8 ++---
 docs/users_guide/flags.xml        |  6 ++++
 docs/users_guide/glasgow_exts.xml | 21 +++++++++++
 17 files changed, 149 insertions(+), 44 deletions(-)

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 28d83c9..ff3cfc5 100644
    a b  
    423423isGoodBreakExpr (OpApp {})     = True 
    424424isGoodBreakExpr (NegApp {})    = True 
    425425isGoodBreakExpr (HsIf {})      = True 
     426isGoodBreakExpr (HsMultiIf {}) = True 
    426427isGoodBreakExpr (HsCase {})    = True 
    427428isGoodBreakExpr (RecordCon {}) = True 
    428429isGoodBreakExpr (RecordUpd {}) = True 
    … …  
    496497                (addBinTickLHsExpr (BinBox CondBinBox) e1) 
    497498                (addTickLHsExprOptAlt True e2) 
    498499                (addTickLHsExprOptAlt True e3) 
     500addTickHsExpr (HsMultiIf ty alts) 
     501  = do { let isOneOfMany = case alts of [_] -> False; _ -> True 
     502       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts 
     503       ; return $ HsMultiIf ty alts' } 
    499504addTickHsExpr (HsLet binds e) = 
    500505        bindLocals (collectLocalBinders binds) $ 
    501506        liftM2 HsLet 

  • compiler/deSugar/DsExpr.lhs 

    diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 4795b5f..f8bd213 100644
    a b  
    337337           Just fun -> do { core_fun <- dsExpr fun 
    338338                          ; return (mkCoreApps core_fun [pred,b1,b2]) } 
    339339           Nothing  -> return $ mkIfThenElse pred b1 b2 } 
     340 
     341dsExpr (HsMultiIf res_ty alts) 
     342  | null alts 
     343  = mkErrorExpr 
     344 
     345  | otherwise 
     346  = do { match_result <- liftM (foldr1 combineMatchResults) 
     347                               (mapM (dsGRHS IfAlt res_ty) alts) 
     348       ; error_expr   <- mkErrorExpr 
     349       ; extractMatchResult match_result error_expr } 
     350  where 
     351    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty 
     352                               (ptext (sLit "multi-way if")) 
    340353\end{code} 
    341354 
    342355 

  • compiler/deSugar/DsGRHSs.lhs 

    diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.lhs
index ed87d18..9e84e46 100644
    a b  
    66Matching guarded right-hand-sides (GRHSs) 
    77 
    88\begin{code} 
    9 module DsGRHSs ( dsGuarded, dsGRHSs ) where 
     9module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where 
    1010 
    1111#include "HsVersions.h" 
    1212 
    … …  
    5555        -> GRHSs Id                             -- Guarded RHSs 
    5656        -> Type                                 -- Type of RHS 
    5757        -> DsM MatchResult 
    58 dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = do 
    59     match_results <- mapM (dsGRHS hs_ctx pats rhs_ty) grhss 
     58dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do 
     59    match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss 
    6060    let 
    6161        match_result1 = foldr1 combineMatchResults match_results 
    6262        match_result2 = adjustMatchResultDs 
    … …  
    6666    -- 
    6767    return match_result2 
    6868 
    69 dsGRHS :: HsMatchContext Name -> [Pat Id] -> Type -> LGRHS Id -> DsM MatchResult 
    70 dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs)) 
     69dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id -> DsM MatchResult 
     70dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) 
    7171  = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty 
    7272\end{code} 
    7373 

  • compiler/deSugar/DsMeta.hs 

    diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7a60ae4..4d07c8c 100644
    a b  
    890890                              b <- repLE y 
    891891                              c <- repLE z 
    892892                              repCond a b c 
     893repE (HsMultiIf _ alts) 
     894  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts 
     895       ; expr' <- repMultiIf (nonEmptyCoreList alts') 
     896       ; wrapGenSyms (concat binds) expr' } 
    893897repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs 
    894898                               ; e2 <- addBinds ss (repLE e) 
    895899                               ; z <- repLetE ds e2 
    … …  
    980984 
    981985repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ) 
    982986repGuards [L _ (GRHS [] e)] 
    983   = do {a <- repLE e; repNormal a } 
    984 repGuards other 
    985   = do { zs <- mapM process other; 
    986      let {(xs, ys) = unzip zs}; 
    987          gd <- repGuarded (nonEmptyCoreList ys); 
    988      wrapGenSyms (concat xs) gd } 
    989   where 
    990     process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) 
    991     process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2)) 
    992            = do { x <- repLNormalGE e1 e2; 
    993                   return ([], x) } 
    994     process (L _ (GRHS ss rhs)) 
    995            = do (gs, ss') <- repLSts ss 
    996                 rhs' <- addBinds gs $ repLE rhs 
    997                 g <- repPatGE (nonEmptyCoreList ss') rhs' 
    998                 return (gs, g) 
     987  = do { a <- repLE e 
     988       ; repNormal a } 
     989repGuards alts 
     990  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts 
     991       ; body <- repGuarded (nonEmptyCoreList alts') 
     992       ; wrapGenSyms (concat binds) body } 
     993 
     994repLGRHS :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) 
     995repLGRHS (L _ (GRHS [L _ (ExprStmt guard _ _ _)] rhs)) 
     996  = do { guarded <- repLNormalGE guard rhs 
     997       ; return ([], guarded) } 
     998repLGRHS (L _ (GRHS stmts rhs)) 
     999  = do { (gs, stmts') <- repLSts stmts 
     1000       ; rhs'        <- addBinds gs $ repLE rhs 
     1001       ; guarded      <- repPatGE (nonEmptyCoreList stmts') rhs' 
     1002       ; return (gs, guarded) } 
    9991003 
    10001004repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp]) 
    10011005repFields (HsRecFields { rec_flds = flds }) 
    … …  
    14711475repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) 
    14721476repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] 
    14731477 
     1478repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ) 
     1479repMultiIf (MkC alts) = rep2 multiIfEName [alts] 
     1480 
    14741481repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) 
    14751482repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] 
    14761483 
    … …  
    19021909    varEName, conEName, litEName, appEName, infixEName, 
    19031910    infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, 
    19041911    tupEName, unboxedTupEName, 
    1905     condEName, letEName, caseEName, doEName, compEName, 
     1912    condEName, multiIfEName, letEName, caseEName, doEName, compEName, 
    19061913    fromEName, fromThenEName, fromToEName, fromThenToEName, 
    19071914    listEName, sigEName, recConEName, recUpdEName, 
    19081915    -- FieldExp 
    … …  
    20662073-- data Exp = ... 
    20672074varEName, conEName, litEName, appEName, infixEName, infixAppName, 
    20682075    sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, 
    2069     unboxedTupEName, condEName, letEName, caseEName, doEName, 
    2070     compEName :: Name 
     2076    unboxedTupEName, condEName, multiIfEName, letEName, caseEName, 
     2077    doEName, compEName :: Name 
    20712078varEName        = libFun (fsLit "varE")        varEIdKey 
    20722079conEName        = libFun (fsLit "conE")        conEIdKey 
    20732080litEName        = libFun (fsLit "litE")        litEIdKey 
    … …  
    20812088tupEName        = libFun (fsLit "tupE")        tupEIdKey 
    20822089unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey 
    20832090condEName       = libFun (fsLit "condE")       condEIdKey 
     2091multiIfEName    = libFun (fsLit "multiIfE")    multiIfEIdKey 
    20842092letEName        = libFun (fsLit "letE")        letEIdKey 
    20852093caseEName       = libFun (fsLit "caseE")       caseEIdKey 
    20862094doEName         = libFun (fsLit "doE")         doEIdKey 
    … …  
    23802388-- data Exp = ... 
    23812389varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, 
    23822390    sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey, 
    2383     unboxedTupEIdKey, condEIdKey, 
     2391    unboxedTupEIdKey, condEIdKey, multiIfEIdKey, 
    23842392    letEIdKey, caseEIdKey, doEIdKey, compEIdKey, 
    23852393    fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, 
    23862394    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique 
    … …  
    23972405tupEIdKey         = mkPreludeMiscIdUnique 280 
    23982406unboxedTupEIdKey  = mkPreludeMiscIdUnique 281 
    23992407condEIdKey        = mkPreludeMiscIdUnique 282 
    2400 letEIdKey         = mkPreludeMiscIdUnique 283 
    2401 caseEIdKey        = mkPreludeMiscIdUnique 284 
    2402 doEIdKey          = mkPreludeMiscIdUnique 285 
    2403 compEIdKey        = mkPreludeMiscIdUnique 286 
    2404 fromEIdKey        = mkPreludeMiscIdUnique 287 
    2405 fromThenEIdKey    = mkPreludeMiscIdUnique 288 
    2406 fromToEIdKey      = mkPreludeMiscIdUnique 289 
    2407 fromThenToEIdKey  = mkPreludeMiscIdUnique 290 
    2408 listEIdKey        = mkPreludeMiscIdUnique 291 
    2409 sigEIdKey         = mkPreludeMiscIdUnique 292 
    2410 recConEIdKey      = mkPreludeMiscIdUnique 293 
    2411 recUpdEIdKey      = mkPreludeMiscIdUnique 294 
     2408multiIfEIdKey     = mkPreludeMiscIdUnique 283 
     2409letEIdKey         = mkPreludeMiscIdUnique 284 
     2410caseEIdKey        = mkPreludeMiscIdUnique 285 
     2411doEIdKey          = mkPreludeMiscIdUnique 286 
     2412compEIdKey        = mkPreludeMiscIdUnique 287 
     2413fromEIdKey        = mkPreludeMiscIdUnique 288 
     2414fromThenEIdKey    = mkPreludeMiscIdUnique 289 
     2415fromToEIdKey      = mkPreludeMiscIdUnique 290 
     2416fromThenToEIdKey  = mkPreludeMiscIdUnique 291 
     2417listEIdKey        = mkPreludeMiscIdUnique 292 
     2418sigEIdKey         = mkPreludeMiscIdUnique 293 
     2419recConEIdKey      = mkPreludeMiscIdUnique 294 
     2420recUpdEIdKey      = mkPreludeMiscIdUnique 295 
    24122421 
    24132422-- type FieldExp = ... 
    24142423fieldExpIdKey :: Unique 

  • compiler/deSugar/Match.lhs 

    diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index c80446a..8fd3a20 100644
    a b  
    8888    incomplete_flag :: HsMatchContext id -> Bool 
    8989    incomplete_flag (FunRhs {})   = wopt Opt_WarnIncompletePatterns dflags 
    9090    incomplete_flag CaseAlt       = wopt Opt_WarnIncompletePatterns dflags 
     91    incomplete_flag IfAlt         = False 
    9192 
    9293    incomplete_flag LambdaExpr    = wopt Opt_WarnIncompleteUniPatterns dflags 
    9394    incomplete_flag PatBindRhs    = wopt Opt_WarnIncompleteUniPatterns dflags 

  • compiler/hsSyn/Convert.lhs 

    diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index bf0f956..376ff23 100644
    a b  
    495495    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed } 
    496496    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; 
    497497                            ; return $ HsIf (Just noSyntaxExpr) x' y' z' } 
     498    cvt (MultiIfE alts) 
     499      | null alts      = failWith (ptext (sLit "Multi-way if-expression with no alternatives")) 
     500      | otherwise      = do { alts' <- mapM cvtpair alts 
     501                            ; return $ HsMultiIf placeHolderType alts' } 
    498502    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds 
    499503                            ; e' <- cvtl e; return $ HsLet ds' e' } 
    500504    cvt (CaseE e ms) 

  • compiler/hsSyn/HsExpr.lhs 

    diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 4db827a..a9cad67 100644
    a b  
    152152                (LHsExpr id)    --  then part 
    153153                (LHsExpr id)    --  else part 
    154154 
     155  | HsMultiIf   PostTcType [LGRHS id] -- Multi-way if 
     156 
    155157  | HsLet       (HsLocalBinds id) -- let(rec) 
    156158                (LHsExpr  id) 
    157159 
    … …  
    464466         ptext (sLit "else"), 
    465467         nest 4 (ppr e3)] 
    466468 
     469ppr_expr (HsMultiIf _ alts) 
     470  = sep $ ptext (sLit "if") : map ppr_alt alts 
     471  where ppr_alt (L _ (GRHS guards expr)) = 
     472          sep [ char '|' <+> interpp'SP guards 
     473              , ptext (sLit "->") <+> pprDeeper (ppr expr) ] 
     474 
    467475-- special case: let ... in let ... 
    468476ppr_expr (HsLet binds expr@(L _ (HsLet _ _))) 
    469477  = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]), 
    … …  
    12631271  = FunRhs id Bool              -- Function binding for f; True <=> written infix 
    12641272  | LambdaExpr                  -- Patterns of a lambda 
    12651273  | CaseAlt                     -- Patterns and guards on a case alternative 
     1274  | IfAlt                       -- Guards of a multi-way if alternative 
    12661275  | ProcExpr                    -- Patterns of a proc 
    12671276  | PatBindRhs                  -- A pattern binding  eg [y] <- e = e 
    12681277 
    … …  
    13131322matchSeparator :: HsMatchContext id -> SDoc 
    13141323matchSeparator (FunRhs {})  = ptext (sLit "=") 
    13151324matchSeparator CaseAlt      = ptext (sLit "->") 
     1325matchSeparator IfAlt        = ptext (sLit "->") 
    13161326matchSeparator LambdaExpr   = ptext (sLit "->") 
    13171327matchSeparator ProcExpr     = ptext (sLit "->") 
    13181328matchSeparator PatBindRhs   = ptext (sLit "=") 
    … …  
    13351345pprMatchContextNoun (FunRhs fun _)  = ptext (sLit "equation for") 
    13361346                                      <+> quotes (ppr fun) 
    13371347pprMatchContextNoun CaseAlt         = ptext (sLit "case alternative") 
     1348pprMatchContextNoun IfAlt           = ptext (sLit "multi-way if alternative") 
    13381349pprMatchContextNoun RecUpd          = ptext (sLit "record-update construct") 
    13391350pprMatchContextNoun ThPatQuote      = ptext (sLit "Template Haskell pattern quotation") 
    13401351pprMatchContextNoun PatBindRhs      = ptext (sLit "pattern binding") 
    … …  
    13831394matchContextErrString :: Outputable id => HsMatchContext id -> SDoc 
    13841395matchContextErrString (FunRhs fun _)             = ptext (sLit "function") <+> ppr fun 
    13851396matchContextErrString CaseAlt                    = ptext (sLit "case") 
     1397matchContextErrString IfAlt                      = ptext (sLit "multi-way if") 
    13861398matchContextErrString PatBindRhs                 = ptext (sLit "pattern binding") 
    13871399matchContextErrString RecUpd                     = ptext (sLit "record update") 
    13881400matchContextErrString LambdaExpr                 = ptext (sLit "lambda") 

  • compiler/main/DynFlags.hs 

    diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 02d2004..b5ad8d1 100644
    a b  
    486486   | Opt_RelaxedLayout 
    487487   | Opt_TraditionalRecordSyntax 
    488488   | Opt_LambdaCase 
     489   | Opt_MultiWayIf 
    489490   deriving (Eq, Enum, Show) 
    490491 
    491492-- | Contains not only a collection of 'DynFlag's but also a plethora of 
    … …  
    21642165  ( "RelaxedLayout",                    Opt_RelaxedLayout, nop ), 
    21652166  ( "TraditionalRecordSyntax",          Opt_TraditionalRecordSyntax, nop ), 
    21662167  ( "LambdaCase",                       Opt_LambdaCase, nop ), 
     2168  ( "MultiWayIf",                       Opt_MultiWayIf, nop ), 
    21672169  ( "MonoLocalBinds",                   Opt_MonoLocalBinds, nop ), 
    21682170  ( "RelaxedPolyRec",                   Opt_RelaxedPolyRec, 
    21692171    \ turn_on -> if not turn_on 

  • compiler/parser/Lexer.x 

    diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 03e8958..ac417ac 100644
    a b  
    18671867explicitNamespacesBit = 29 
    18681868lambdaCaseBit :: Int 
    18691869lambdaCaseBit = 30 
     1870multiWayIfBit :: Int 
     1871multiWayIfBit = 31 
    18701872 
    18711873 
    18721874always :: Int -> Bool 
    … …  
    19181920explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit 
    19191921lambdaCaseEnabled :: Int -> Bool 
    19201922lambdaCaseEnabled flags = testBit flags lambdaCaseBit 
     1923multiWayIfEnabled :: Int -> Bool 
     1924multiWayIfEnabled flags = testBit flags multiWayIfBit 
    19211925 
    19221926-- PState for parsing options pragmas 
    19231927-- 
    … …  
    19791983               .|. typeLiteralsBit             `setBitIf` xopt Opt_DataKinds flags 
    19801984               .|. explicitNamespacesBit       `setBitIf` xopt Opt_ExplicitNamespaces flags 
    19811985               .|. lambdaCaseBit               `setBitIf` xopt Opt_LambdaCase               flags 
     1986               .|. multiWayIfBit               `setBitIf` xopt Opt_MultiWayIf               flags 
    19821987      -- 
    19831988      setBitIf :: Int -> Bool -> Int 
    19841989      b `setBitIf` cond | cond      = bit b 

  • compiler/parser/Parser.y.pp 

    diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 67baa88..6213227 100644
    a b  
    5555import Maybes           ( orElse ) 
    5656import Outputable 
    5757 
    58 import Control.Monad    ( unless ) 
     58import Control.Monad    ( unless, liftM ) 
    5959import GHC.Exts 
    6060import Data.Char 
    6161import Control.Monad    ( mplus ) 
    … …  
    13941394        | 'if' exp optSemi 'then' exp optSemi 'else' exp 
    13951395                                        {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >> 
    13961396                                           return (LL $ mkHsIf $2 $5 $8) } 
     1397        | 'if' gdpats                   {% hintMultiWayIf (getLoc $1) >> 
     1398                                           return (LL $ HsMultiIf placeHolderType (reverse $ unLoc $2)) } 
    13971399        | 'case' exp 'of' altslist              { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } 
    13981400        | '-' fexp                              { LL $ NegApp $2 noSyntaxExpr } 
    13991401 
    … …  
    21412143  l <- getSrcLoc;  
    21422144  let loc = mkSrcLoc (srcLocFile l) 1 1; 
    21432145  return (mkSrcSpan loc loc) 
     2146 
     2147-- Hint about the MultiWayIf extension 
     2148hintMultiWayIf :: SrcSpan -> P () 
     2149hintMultiWayIf span = do 
     2150  mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState 
     2151  unless mwiEnabled $ parseErrorSDoc span $ 
     2152    text "Multi-way if-expressions need -XMultiWayIf turned on" 
    21442153} 

  • compiler/rename/RnBinds.lhs 

    diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index d3d1603..2c70698 100644
    a b  
    2525 
    2626   -- Other bindings 
    2727   rnMethodBinds, renameSigs, mkSigTvFn, 
    28    rnMatchGroup, rnGRHSs, 
     28   rnMatchGroup, rnGRHSs, rnGRHS, 
    2929   makeMiniFixityEnv, MiniFixityEnv, 
    3030   HsSigCtxt(..) 
    3131   ) where 

  • compiler/rename/RnExpr.lhs 

    diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 372daa9..e7dbe53 100644
    a b  
    2929 
    3030import RnSource  ( rnSrcDecls, findSplice ) 
    3131import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, 
    32                    rnMatchGroup, makeMiniFixityEnv)  
     32                   rnMatchGroup, rnGRHS, makeMiniFixityEnv)  
    3333import HsSyn 
    3434import TcRnMonad 
    3535import TcEnv            ( thRnBrack ) 
    … …  
    284284       ; (mb_ite, fvITE) <- lookupIfThenElse 
    285285       ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } 
    286286 
     287rnExpr (HsMultiIf ty alts) 
     288  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt) alts 
     289       ; return (HsMultiIf ty alts', fvs) } 
     290 
    287291rnExpr (HsType a) 
    288292  = rnLHsType HsTypeCtx a       `thenM` \ (t, fvT) ->  
    289293    return (HsType t, fvT) 

  • compiler/typecheck/TcExpr.lhs 

    diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index ba2ca74..51b5eb3 100644
    a b  
    445445       -- and it maintains uniformity with other rebindable syntax 
    446446       ; return (HsIf (Just fun') pred' b1' b2') } 
    447447 
     448tcExpr (HsMultiIf _ alts) res_ty 
     449  = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts 
     450       ; return $ HsMultiIf res_ty alts' } 
     451  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } 
     452 
    448453tcExpr (HsDo do_or_lc stmts _) res_ty 
    449454  = tcDoStmts do_or_lc stmts res_ty 
    450455 

  • compiler/typecheck/TcHsSyn.lhs 

    diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 51d6c12..922b2cd 100644
    a b  
    621621       ; new_e3 <- zonkLExpr env e3 
    622622       ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) } 
    623623 
     624zonkExpr env (HsMultiIf ty alts) 
     625  = do { alts' <- mapM (wrapLocM zonk_alt) alts 
     626       ; ty'   <- zonkTcTypeToType env ty 
     627       ; returnM $ HsMultiIf ty' alts' } 
     628  where zonk_alt (GRHS guard expr) 
     629          = do { (env', guard') <- zonkStmts env guard 
     630               ; expr'          <- zonkLExpr env' expr 
     631               ; returnM $ GRHS guard' expr' } 
     632 
    624633zonkExpr env (HsLet binds expr) 
    625634  = zonkLocalBinds env binds    `thenM` \ (new_env, new_binds) -> 
    626635    zonkLExpr new_env expr      `thenM` \ new_expr -> 

  • compiler/typecheck/TcMatches.lhs 

    diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 2941a17..acc2064 100644
    a b  
    1313--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces 
    1414-- for details 
    1515 
    16 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, 
    17                   TcMatchCtxt(..), TcStmtChecker, 
    18                    tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, 
    19                    tcDoStmt, tcGuardStmt 
     16module TcMatches ( tcMatchesFun, tcGRHSsPat, tcGRHS, tcMatchesCase, 
     17                   tcMatchLambda, TcMatchCtxt(..), TcStmtChecker, 
     18                   tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, 
     19                   tcDoStmt, tcGuardStmt 
    2020       ) where 
    2121 
    2222import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId, 

  • docs/users_guide/flags.xml 

    diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index 544acd8..24c52f2 100644
    a b  
    11281128            <entry><option>-XNoLambdaCase</option></entry> 
    11291129          </row> 
    11301130          <row> 
     1131            <entry><option>-XMultiWayIf</option></entry> 
     1132            <entry>Enable <link linkend="multi-way-if">multi-way if-expressions</link>.</entry> 
     1133            <entry>dynamic</entry> 
     1134            <entry><option>-XNoMultiWayIf</option></entry> 
     1135          </row> 
     1136          <row> 
    11311137            <entry><option>-XSafe</option></entry> 
    11321138            <entry>Enable the <link linkend="safe-haskell">Safe Haskell</link> Safe mode.</entry> 
    11331139            <entry>dynamic</entry> 

  • docs/users_guide/glasgow_exts.xml 

    diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml
index 805f53a..dde235e 100644
    a b  
    16901690</para> 
    16911691</sect2> 
    16921692 
     1693<sect2 id="multi-way-if"> 
     1694<title>Multi-way if-expressions</title> 
     1695<para> 
     1696With <option>-XMultiWayIf</option> flag GHC accepts conditional expressions 
     1697with multiple branches: 
     1698<programlisting> 
     1699  if | guard1 -> expr1 
     1700     | ... 
     1701     | guardN -> exprN 
     1702</programlisting> 
     1703which is roughly equivalent to 
     1704<programlisting> 
     1705  case () of 
     1706    _ | guard1 -> expr1 
     1707    ... 
     1708    _ | guardN -> exprN 
     1709</programlisting> 
     1710except that multi-way if-expressions do not alter the layout. 
     1711</para> 
     1712</sect2> 
     1713 
    16931714<sect2 id="disambiguate-fields"> 
    16941715<title>Record field disambiguation</title> 
    16951716<para>