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

Implemented \case expressions.

parent c1f01e35
......@@ -458,6 +458,8 @@ addTickHsExpr e@(HsOverLit _) = return e
addTickHsExpr e@(HsLit _) = return e
addTickHsExpr (HsLam matchgroup) =
liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase ty mgs) =
liftM (HsLamCase ty) (addTickMatchGroup True mgs)
addTickHsExpr (HsApp e1 e2) =
liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
addTickHsExpr (OpApp e1 e2 fix e3) =
......
......@@ -205,6 +205,15 @@ dsExpr (NegApp expr neg_expr)
dsExpr (HsLam a_Match)
= uncurry mkLams <$> matchWrapper LambdaExpr a_Match
dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty))
| isEmptyMatchGroup matches -- A Core 'case' is always non-empty
= -- So desugar empty HsLamCase to error call
mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "\\case"))
| otherwise
= do { arg_var <- newSysLocalDs arg
; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
dsExpr (HsApp fun arg)
= mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg
\end{code}
......
......@@ -864,6 +864,9 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l) = do { a <- repLiteral l; repLit a }
repE (HsLam (MatchGroup [m] _)) = repLambda m
repE (HsLamCase _ (MatchGroup ms _))
= do { ms' <- mapM repMatchTup ms
; repLamCase (nonEmptyCoreList ms') }
repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
repE (OpApp e1 op _ e2) =
......@@ -878,9 +881,10 @@ repE (NegApp x _) = do
repE (HsPar x) = repLE x
repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; repCaseE arg (nonEmptyCoreList ms2) }
repE (HsCase e (MatchGroup ms _))
= do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; repCaseE arg (nonEmptyCoreList ms2) }
repE (HsIf _ x y z) = do
a <- repLE x
b <- repLE y
......@@ -1455,6 +1459,9 @@ repApp (MkC x) (MkC y) = rep2 appEName [x,y]
repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
repLamCase (MkC ms) = rep2 lamCaseEName [ms]
repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
repTup (MkC es) = rep2 tupEName [es]
......@@ -1893,7 +1900,7 @@ templateHaskellNames = [
clauseName,
-- Exp
varEName, conEName, litEName, appEName, infixEName,
infixAppName, sectionLName, sectionRName, lamEName,
infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
tupEName, unboxedTupEName,
condEName, letEName, caseEName, doEName, compEName,
fromEName, fromThenEName, fromToEName, fromThenToEName,
......@@ -2058,8 +2065,9 @@ clauseName = libFun (fsLit "clause") clauseIdKey
-- data Exp = ...
varEName, conEName, litEName, appEName, infixEName, infixAppName,
sectionLName, sectionRName, lamEName, tupEName, unboxedTupEName, condEName,
letEName, caseEName, doEName, compEName :: Name
sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
unboxedTupEName, condEName, letEName, caseEName, doEName,
compEName :: Name
varEName = libFun (fsLit "varE") varEIdKey
conEName = libFun (fsLit "conE") conEIdKey
litEName = libFun (fsLit "litE") litEIdKey
......@@ -2069,6 +2077,7 @@ infixAppName = libFun (fsLit "infixApp") infixAppIdKey
sectionLName = libFun (fsLit "sectionL") sectionLIdKey
sectionRName = libFun (fsLit "sectionR") sectionRIdKey
lamEName = libFun (fsLit "lamE") lamEIdKey
lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey
tupEName = libFun (fsLit "tupE") tupEIdKey
unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
condEName = libFun (fsLit "condE") condEIdKey
......@@ -2370,8 +2379,8 @@ clauseIdKey = mkPreludeMiscIdUnique 262
-- data Exp = ...
varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, unboxedTupEIdKey,
condEIdKey,
sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,
unboxedTupEIdKey, condEIdKey,
letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
......@@ -2384,21 +2393,22 @@ infixAppIdKey = mkPreludeMiscIdUnique 275
sectionLIdKey = mkPreludeMiscIdUnique 276
sectionRIdKey = mkPreludeMiscIdUnique 277
lamEIdKey = mkPreludeMiscIdUnique 278
tupEIdKey = mkPreludeMiscIdUnique 279
unboxedTupEIdKey = mkPreludeMiscIdUnique 280
condEIdKey = mkPreludeMiscIdUnique 281
letEIdKey = mkPreludeMiscIdUnique 282
caseEIdKey = mkPreludeMiscIdUnique 283
doEIdKey = mkPreludeMiscIdUnique 284
compEIdKey = mkPreludeMiscIdUnique 285
fromEIdKey = mkPreludeMiscIdUnique 286
fromThenEIdKey = mkPreludeMiscIdUnique 287
fromToEIdKey = mkPreludeMiscIdUnique 288
fromThenToEIdKey = mkPreludeMiscIdUnique 289
listEIdKey = mkPreludeMiscIdUnique 290
sigEIdKey = mkPreludeMiscIdUnique 291
recConEIdKey = mkPreludeMiscIdUnique 292
recUpdEIdKey = mkPreludeMiscIdUnique 293
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
-- type FieldExp = ...
fieldExpIdKey :: Unique
......
......@@ -482,6 +482,12 @@ cvtl e = wrapL (cvt e)
cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
cvt (LamCaseE ms)
| null ms = failWith (ptext (sLit "Lambda-case expression with no alternatives"))
| otherwise = do { ms' <- mapM cvtMatch ms
; return $ HsLamCase placeHolderType
(mkMatchGroup ms')
}
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
-- Note [Dropping constructors]
-- Singleton tuples treated like nothing (just parens)
......
......@@ -113,6 +113,8 @@ data HsExpr id
| HsLam (MatchGroup id) -- Currently always a single match
| HsLamCase PostTcType (MatchGroup id) -- Lambda-case
| HsApp (LHsExpr id) (LHsExpr id) -- Application
-- Operator applications:
......@@ -448,6 +450,10 @@ ppr_expr (ExplicitTuple exprs boxity)
ppr_expr (HsLam matches)
= pprMatches (LambdaExpr :: HsMatchContext id) matches
ppr_expr (HsLamCase _ matches)
= sep [ sep [ptext (sLit "\\case {")],
nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
ppr_expr (HsCase expr matches)
= sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
......
......@@ -485,6 +485,7 @@ data ExtensionFlag
| Opt_NondecreasingIndentation
| Opt_RelaxedLayout
| Opt_TraditionalRecordSyntax
| Opt_LambdaCase
deriving (Eq, Enum, Show)
-- | Contains not only a collection of 'DynFlag's but also a plethora of
......@@ -2162,6 +2163,7 @@ xFlags = [
( "NondecreasingIndentation", Opt_NondecreasingIndentation, nop ),
( "RelaxedLayout", Opt_RelaxedLayout, nop ),
( "TraditionalRecordSyntax", Opt_TraditionalRecordSyntax, nop ),
( "LambdaCase", Opt_LambdaCase, nop ),
( "MonoLocalBinds", Opt_MonoLocalBinds, nop ),
( "RelaxedPolyRec", Opt_RelaxedPolyRec,
\ turn_on -> if not turn_on
......
......@@ -500,6 +500,7 @@ data Token
| ITdcolon
| ITequal
| ITlam
| ITlcase
| ITvbar
| ITlarrow
| ITrarrow
......@@ -979,23 +980,37 @@ splitQualName orig_buf len parens = split orig_buf orig_buf
varid :: Action
varid span buf len =
fs `seq`
case lookupUFM reservedWordsFM fs of
Just (keyword,0) -> do
maybe_layout keyword
return (L span keyword)
Just (keyword,exts) -> do
b <- extension (\i -> exts .&. i /= 0)
if b then do maybe_layout keyword
return (L span keyword)
else return (L span (ITvarid fs))
_other -> return (L span (ITvarid fs))
Just (ITcase, _) -> do
lambdaCase <- extension lambdaCaseEnabled
keyword <- if lambdaCase
then do
lastTk <- getLastTk
return $ case lastTk of
Just ITlam -> ITlcase
_ -> ITcase
else
return ITcase
maybe_layout keyword
return $ L span keyword
Just (keyword, 0) -> do
maybe_layout keyword
return $ L span keyword
Just (keyword, exts) -> do
extsEnabled <- extension $ \i -> exts .&. i /= 0
if extsEnabled
then do
maybe_layout keyword
return $ L span keyword
else
return $ L span $ ITvarid fs
Nothing ->
return $ L span $ ITvarid fs
where
fs = lexemeToFastString buf len
!fs = lexemeToFastString buf len
conid :: StringBuffer -> Int -> Token
conid buf len = ITconid fs
where fs = lexemeToFastString buf len
conid buf len = ITconid $! lexemeToFastString buf len
qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token
qvarsym buf len = ITqvarsym $! splitQualName buf len False
......@@ -1007,17 +1022,18 @@ varsym, consym :: Action
varsym = sym ITvarsym
consym = sym ITconsym
sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int
-> P (RealLocated Token)
sym :: (FastString -> Token) -> Action
sym con span buf len =
case lookupUFM reservedSymsFM fs of
Just (keyword,exts) -> do
b <- extension exts
if b then return (L span keyword)
else return (L span $! con fs)
_other -> return (L span $! con fs)
Just (keyword, exts) -> do
extsEnabled <- extension exts
let !tk | extsEnabled = keyword
| otherwise = con fs
return $ L span tk
Nothing ->
return $ L span $! con fs
where
fs = lexemeToFastString buf len
!fs = lexemeToFastString buf len
-- Variations on the integral numeric literal.
tok_integral :: (Integer -> Token)
......@@ -1094,6 +1110,7 @@ maybe_layout t = do -- If the alternative layout rule is enabled then
where f ITdo = pushLexState layout_do
f ITmdo = pushLexState layout_do
f ITof = pushLexState layout
f ITlcase = pushLexState layout
f ITlet = pushLexState layout
f ITwhere = pushLexState layout
f ITrec = pushLexState layout
......@@ -1522,6 +1539,7 @@ data PState = PState {
buffer :: StringBuffer,
dflags :: DynFlags,
messages :: Messages,
last_tk :: Maybe Token,
last_loc :: RealSrcSpan, -- pos of previous token
last_len :: !Int, -- len of previous token
loc :: RealSrcLoc, -- current loc (end of prev token + 1)
......@@ -1626,6 +1644,12 @@ setLastToken loc len = P $ \s -> POk s {
last_len=len
} ()
setLastTk :: Token -> P ()
setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()
getLastTk :: P (Maybe Token)
getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
data AlexInput = AI RealSrcLoc StringBuffer
alexInputPrevChar :: AlexInput -> Char
......@@ -1841,6 +1865,8 @@ typeLiteralsBit :: Int
typeLiteralsBit = 28
explicitNamespacesBit :: Int
explicitNamespacesBit = 29
lambdaCaseBit :: Int
lambdaCaseBit = 30
always :: Int -> Bool
......@@ -1890,6 +1916,8 @@ typeLiteralsEnabled flags = testBit flags typeLiteralsBit
explicitNamespacesEnabled :: Int -> Bool
explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit
lambdaCaseEnabled :: Int -> Bool
lambdaCaseEnabled flags = testBit flags lambdaCaseBit
-- PState for parsing options pragmas
--
......@@ -1906,6 +1934,7 @@ mkPState flags buf loc =
buffer = buf,
dflags = flags,
messages = emptyMessages,
last_tk = Nothing,
last_loc = mkRealSrcSpan loc loc,
last_len = 0,
loc = loc,
......@@ -1949,6 +1978,7 @@ mkPState flags buf loc =
.|. traditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags
.|. typeLiteralsBit `setBitIf` xopt Opt_DataKinds flags
.|. explicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags
.|. lambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
......@@ -2276,7 +2306,13 @@ lexToken = do
let span = mkRealSrcSpan loc1 end
let bytes = byteDiff buf buf2
span `seq` setLastToken span bytes
t span buf bytes
lt <- t span buf bytes
case unLoc lt of
ITlineComment _ -> return lt
ITblockComment _ -> return lt
lt' -> do
setLastTk lt'
return lt
reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
reportLexError loc1 loc2 buf str
......
......@@ -275,6 +275,7 @@ incorrect.
'::' { L _ ITdcolon }
'=' { L _ ITequal }
'\\' { L _ ITlam }
'lcase' { L _ ITlcase }
'|' { L _ ITvbar }
'<-' { L _ ITlarrow }
'->' { L _ ITrarrow }
......@@ -1388,6 +1389,8 @@ exp10 :: { LHsExpr RdrName }
(unguardedGRHSs $6)
]) }
| 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 }
| '\\' 'lcase' altslist
{ LL $ HsLamCase placeHolderType (mkMatchGroup (unLoc $3)) }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
{% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
return (LL $ mkHsIf $2 $5 $8) }
......
......@@ -224,6 +224,10 @@ rnExpr (HsLam matches)
= rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
return (HsLam matches', fvMatch)
rnExpr (HsLamCase arg matches)
= rnMatchGroup CaseAlt matches `thenM` \ (matches', fvs_ms) ->
return (HsLamCase arg matches', fvs_ms)
rnExpr (HsCase expr matches)
= rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
......
......@@ -201,6 +201,14 @@ tcExpr (HsLam match) res_ty
= do { (co_fn, match') <- tcMatchLambda match res_ty
; return (mkHsWrap co_fn (HsLam match')) }
tcExpr e@(HsLamCase _ matches) res_ty
= do { (co_fn, [arg_ty], body_ty) <- matchExpectedFunTys msg 1 res_ty
; matches' <- tcMatchesCase match_ctxt arg_ty matches body_ty
; return $ mkHsWrapCo co_fn $ HsLamCase arg_ty matches' }
where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e)
, ptext (sLit "requires")]
match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
tcExpr (ExprWithTySig expr sig_ty) res_ty
= do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
......
......@@ -557,6 +557,11 @@ zonkExpr env (HsLam matches)
= zonkMatchGroup env matches `thenM` \ new_matches ->
returnM (HsLam new_matches)
zonkExpr env (HsLamCase arg matches)
= zonkTcTypeToType env arg `thenM` \ new_arg ->
zonkMatchGroup env matches `thenM` \ new_matches ->
returnM (HsLamCase new_arg new_matches)
zonkExpr env (HsApp e1 e2)
= zonkLExpr env e1 `thenM` \ new_e1 ->
zonkLExpr env e2 `thenM` \ new_e2 ->
......
......@@ -1121,6 +1121,12 @@
<entry>dynamic</entry>
<entry><option>-XNoPackageImports</option></entry>
</row>
<row>
<entry><option>-XLambdaCase</option></entry>
<entry>Enable <link linkend="lambda-case">lambda-case expressions</link>.</entry>
<entry>dynamic</entry>
<entry><option>-XNoLambdaCase</option></entry>
</row>
<row>
<entry><option>-XSafe</option></entry>
<entry>Enable the <link linkend="safe-haskell">Safe Haskell</link> Safe mode.</entry>
......
......@@ -1669,6 +1669,27 @@ continues to stand for the unboxed singleton tuple data constructor.
</sect2>
<sect2 id="lambda-case">
<title>Lambda-case</title>
<para>
The <option>-XLambdaCase</option> flag enables expressions of the form
<programlisting>
\case { p1 -> e1; ...; pN -> eN }
</programlisting>
which is equivalent to
<programlisting>
\freshName -> case freshName of { p1 -> e1; ...; pN -> eN }
</programlisting>
Note that <literal>\case</literal> starts a layout, so you can write
<programlisting>
\case
p1 -> e1
...
pN -> eN
</programlisting>
</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