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