Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
cc456b0b
Commit
cc456b0b
authored
Jul 15, 2012
by
mikhail.vorozhtsov
Committed by
Simon Marlow
Jul 16, 2012
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Implemented MultiWayIf extension.
parent
b1e97f2f
Changes
17
Hide whitespace changes
Inline
Side-by-side
Showing
17 changed files
with
149 additions
and
44 deletions
+149
-44
compiler/deSugar/Coverage.lhs
compiler/deSugar/Coverage.lhs
+5
-0
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsExpr.lhs
+13
-0
compiler/deSugar/DsGRHSs.lhs
compiler/deSugar/DsGRHSs.lhs
+5
-5
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsMeta.hs
+41
-32
compiler/deSugar/Match.lhs
compiler/deSugar/Match.lhs
+1
-0
compiler/hsSyn/Convert.lhs
compiler/hsSyn/Convert.lhs
+4
-0
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsExpr.lhs
+12
-0
compiler/main/DynFlags.hs
compiler/main/DynFlags.hs
+2
-0
compiler/parser/Lexer.x
compiler/parser/Lexer.x
+5
-0
compiler/parser/Parser.y.pp
compiler/parser/Parser.y.pp
+10
-1
compiler/rename/RnBinds.lhs
compiler/rename/RnBinds.lhs
+1
-1
compiler/rename/RnExpr.lhs
compiler/rename/RnExpr.lhs
+5
-1
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcExpr.lhs
+5
-0
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsSyn.lhs
+9
-0
compiler/typecheck/TcMatches.lhs
compiler/typecheck/TcMatches.lhs
+4
-4
docs/users_guide/flags.xml
docs/users_guide/flags.xml
+6
-0
docs/users_guide/glasgow_exts.xml
docs/users_guide/glasgow_exts.xml
+21
-0
No files found.
compiler/deSugar/Coverage.lhs
View file @
cc456b0b
...
...
@@ -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
...
...
compiler/deSugar/DsExpr.lhs
View file @
cc456b0b
...
...
@@ -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}
...
...
compiler/deSugar/DsGRHSs.lhs
View file @
cc456b0b
...
...
@@ -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}
...
...
compiler/deSugar/DsMeta.hs
View file @
cc456b0b
...
...
@@ -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
s
tmt
s
rhs
))
=
do
{
(
gs
,
s
tmt
s'
)
<-
repLSts
s
tmt
s
;
rhs'
<-
addBinds
gs
$
repLE
rhs
;
guarded
<-
repPatGE
(
nonEmptyCoreList
s
tmt
s'
)
rhs'
;
return
(
gs
,
g
uarded
)
}
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
...
...
compiler/deSugar/Match.lhs
View file @
cc456b0b
...
...
@@ -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
...
...
compiler/hsSyn/Convert.lhs
View file @
cc456b0b
...
...
@@ -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)
...
...
compiler/hsSyn/HsExpr.lhs
View file @
cc456b0b
...
...
@@ -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")
...
...
compiler/main/DynFlags.hs
View file @
cc456b0b
...
...
@@ -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
...
...
compiler/parser/Lexer.x
View file @
cc456b0b
...
...
@@ -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
...
...
compiler/parser/Parser.y.pp
View file @
cc456b0b
...
...
@@ -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"
}
compiler/rename/RnBinds.lhs
View file @
cc456b0b
...
...
@@ -25,7 +25,7 @@ module RnBinds (
-- Other bindings
rnMethodBinds, renameSigs, mkSigTvFn,
rnMatchGroup, rnGRHSs,
rnMatchGroup, rnGRHSs,
rnGRHS,
makeMiniFixityEnv, MiniFixityEnv,
HsSigCtxt(..)
) where
...
...
compiler/rename/RnExpr.lhs
View file @
cc456b0b
...
...
@@ -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)
...
...
compiler/typecheck/TcExpr.lhs
View file @
cc456b0b
...
...
@@ -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
...
...
compiler/typecheck/TcHsSyn.lhs
View file @
cc456b0b
...
...
@@ -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 ->
...
...
compiler/typecheck/TcMatches.lhs
View file @
cc456b0b
...
...
@@ -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,
...
...
docs/users_guide/flags.xml
View file @
cc456b0b
...
...
@@ -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>
...
...
docs/users_guide/glasgow_exts.xml
View file @
cc456b0b
...
...
@@ -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>
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment