From a319af507c27c67167fca95010b1aa7399ec30dc Mon Sep 17 00:00:00 2001 From: Mikhail Vorozhtsov 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/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 4795b5f..f8bd213 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 ed87d18..9e84e46 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 7a60ae4..4d07c8c 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 c80446a..8fd3a20 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 bf0f956..376ff23 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 4db827a..a9cad67 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 02d2004..b5ad8d1 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 03e8958..ac417ac 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 67baa88..6213227 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 d3d1603..2c70698 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 372daa9..e7dbe53 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 ba2ca74..51b5eb3 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 51d6c12..922b2cd 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 2941a17..acc2064 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 544acd8..24c52f2 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -1128,6 +1128,12 @@ + + Enable multi-way if-expressions. + dynamic + + + Enable the Safe Haskell Safe mode. dynamic diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 805f53a..dde235e 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -1690,6 +1690,27 @@ Note that \case starts a layout, so you can write + +Multi-way if-expressions + +With flag GHC accepts conditional expressions +with multiple branches: + + if | guard1 -> expr1 + | ... + | guardN -> exprN + +which is roughly equivalent to + + case () of + _ | guard1 -> expr1 + ... + _ | guardN -> exprN + +except that multi-way if-expressions do not alter the layout. + + + Record field disambiguation -- 1.7.11.2