Commit cc456b0b authored by mikhail.vorozhtsov's avatar mikhail.vorozhtsov Committed by Simon Marlow

Implemented MultiWayIf extension.

parent b1e97f2f
......@@ -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
......
......@@ -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}
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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")
......
......@@ -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
......
......@@ -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
......
......@@ -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"
}
......@@ -25,7 +25,7 @@ module RnBinds (
-- Other bindings
rnMethodBinds, renameSigs, mkSigTvFn,
rnMatchGroup, rnGRHSs,
rnMatchGroup, rnGRHSs, rnGRHS,
makeMiniFixityEnv, MiniFixityEnv,
HsSigCtxt(..)
) where
......
......@@ -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)
......
......@@ -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
......
......@@ -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 ->
......
......@@ -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,
......
......@@ -1127,6 +1127,12 @@
<entry>dynamic</entry>
<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>
......
......@@ -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>
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment