summaryrefslogtreecommitdiff
path: root/compiler/GHC/Parser
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Parser')
-rw-r--r--compiler/GHC/Parser/Annotation.hs1
-rw-r--r--compiler/GHC/Parser/Errors/Ppr.hs25
-rw-r--r--compiler/GHC/Parser/Errors/Types.hs9
-rw-r--r--compiler/GHC/Parser/Lexer.x12
-rw-r--r--compiler/GHC/Parser/PostProcess.hs52
5 files changed, 62 insertions, 37 deletions
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index b5effa0797..d3119fb920 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -207,6 +207,7 @@ data AnnKeywordId
| AnnBackquote -- ^ '`'
| AnnBy
| AnnCase -- ^ case or lambda case
+ | AnnCases -- ^ lambda cases
| AnnClass
| AnnClose -- ^ '\#)' or '\#-}' etc
| AnnCloseB -- ^ '|)'
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 4f649d9190..e69aabc0db 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -24,7 +24,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Data.Maybe (catMaybes)
-import GHC.Hs.Expr (prependQualified,HsExpr(..))
+import GHC.Hs.Expr (prependQualified, HsExpr(..), LamCaseVariant(..), lamCaseKeyword)
import GHC.Hs.Type (pprLHsContext)
import GHC.Builtin.Names (allNameStrings)
import GHC.Builtin.Types (filterCTuple)
@@ -175,9 +175,11 @@ instance Diagnostic PsMessage where
, text "Character literals may not be empty"
]
PsErrLambdaCase
- -> mkSimpleDecorated $ text "Illegal lambda-case"
+ -- we can't get this error for \cases, since without -XLambdaCase, that's
+ -- just a regular lambda expression
+ -> mkSimpleDecorated $ text "Illegal" <+> lamCaseKeyword LamCase
PsErrEmptyLambda
- -> mkSimpleDecorated $ text "A lambda requires at least one parameter"
+ -> mkSimpleDecorated $ text "A lambda requires at least one parameter"
PsErrLinearFunction
-> mkSimpleDecorated $ text "Illegal use of linear functions"
PsErrOverloadedRecordUpdateNotEnabled
@@ -312,8 +314,8 @@ instance Diagnostic PsMessage where
-> mkSimpleDecorated $ text "do-notation in pattern"
PsErrIfThenElseInPat
-> mkSimpleDecorated $ text "(if ... then ... else ...)-syntax in pattern"
- PsErrLambdaCaseInPat
- -> mkSimpleDecorated $ text "(\\case ...)-syntax in pattern"
+ (PsErrLambdaCaseInPat lc_variant)
+ -> mkSimpleDecorated $ lamCaseKeyword lc_variant <+> text "...-syntax in pattern"
PsErrCaseInPat
-> mkSimpleDecorated $ text "(case ... of ...)-syntax in pattern"
PsErrLetInPat
@@ -341,6 +343,9 @@ instance Diagnostic PsMessage where
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda command") a
PsErrCaseCmdInFunAppCmd a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "case command") a
+ PsErrLambdaCaseCmdInFunAppCmd lc_variant a
+ -> mkSimpleDecorated $
+ pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "command") a
PsErrIfCmdInFunAppCmd a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "if command") a
PsErrLetCmdInFunAppCmd a
@@ -355,8 +360,8 @@ instance Diagnostic PsMessage where
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda expression") a
PsErrCaseInFunAppExpr a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "case expression") a
- PsErrLambdaCaseInFunAppExpr a
- -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda-case expression") a
+ PsErrLambdaCaseInFunAppExpr lc_variant a
+ -> mkSimpleDecorated $ pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "expression") a
PsErrLetInFunAppExpr a
-> mkSimpleDecorated $ pp_unexpected_fun_app (text "let expression") a
PsErrIfInFunAppExpr a
@@ -556,7 +561,7 @@ instance Diagnostic PsMessage where
PsErrIllegalUnboxedFloatingLitInPat{} -> ErrorWithoutFlag
PsErrDoNotationInPat{} -> ErrorWithoutFlag
PsErrIfThenElseInPat -> ErrorWithoutFlag
- PsErrLambdaCaseInPat -> ErrorWithoutFlag
+ PsErrLambdaCaseInPat{} -> ErrorWithoutFlag
PsErrCaseInPat -> ErrorWithoutFlag
PsErrLetInPat -> ErrorWithoutFlag
PsErrLambdaInPat -> ErrorWithoutFlag
@@ -566,6 +571,7 @@ instance Diagnostic PsMessage where
PsErrViewPatInExpr{} -> ErrorWithoutFlag
PsErrLambdaCmdInFunAppCmd{} -> ErrorWithoutFlag
PsErrCaseCmdInFunAppCmd{} -> ErrorWithoutFlag
+ PsErrLambdaCaseCmdInFunAppCmd{} -> ErrorWithoutFlag
PsErrIfCmdInFunAppCmd{} -> ErrorWithoutFlag
PsErrLetCmdInFunAppCmd{} -> ErrorWithoutFlag
PsErrDoCmdInFunAppCmd{} -> ErrorWithoutFlag
@@ -685,7 +691,7 @@ instance Diagnostic PsMessage where
PsErrIllegalUnboxedFloatingLitInPat{} -> noHints
PsErrDoNotationInPat{} -> noHints
PsErrIfThenElseInPat -> noHints
- PsErrLambdaCaseInPat -> noHints
+ PsErrLambdaCaseInPat{} -> noHints
PsErrCaseInPat -> noHints
PsErrLetInPat -> noHints
PsErrLambdaInPat -> noHints
@@ -695,6 +701,7 @@ instance Diagnostic PsMessage where
PsErrViewPatInExpr{} -> noHints
PsErrLambdaCmdInFunAppCmd{} -> suggestParensAndBlockArgs
PsErrCaseCmdInFunAppCmd{} -> suggestParensAndBlockArgs
+ PsErrLambdaCaseCmdInFunAppCmd{} -> suggestParensAndBlockArgs
PsErrIfCmdInFunAppCmd{} -> suggestParensAndBlockArgs
PsErrLetCmdInFunAppCmd{} -> suggestParensAndBlockArgs
PsErrDoCmdInFunAppCmd{} -> suggestParensAndBlockArgs
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index d99f789154..f9a1b4661d 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -245,7 +245,7 @@ data PsMessage
| PsErrIfThenElseInPat
-- | Lambda-case in pattern
- | PsErrLambdaCaseInPat
+ | PsErrLambdaCaseInPat LamCaseVariant
-- | case..of in pattern
| PsErrCaseInPat
@@ -311,6 +311,9 @@ data PsMessage
-- | Unexpected case command in function application
| PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)
+ -- | Unexpected \case(s) command in function application
+ | PsErrLambdaCaseCmdInFunAppCmd !LamCaseVariant !(LHsCmd GhcPs)
+
-- | Unexpected if command in function application
| PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs)
@@ -332,8 +335,8 @@ data PsMessage
-- | Unexpected case expression in function application
| PsErrCaseInFunAppExpr !(LHsExpr GhcPs)
- -- | Unexpected lambda-case expression in function application
- | PsErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs)
+ -- | Unexpected \case(s) expression in function application
+ | PsErrLambdaCaseInFunAppExpr !LamCaseVariant !(LHsExpr GhcPs)
-- | Unexpected let expression in function application
| PsErrLetInFunAppExpr !(LHsExpr GhcPs)
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index b1d8f43350..82a5b9bb38 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -793,6 +793,7 @@ data Token
| ITequal
| ITlam
| ITlcase
+ | ITlcases
| ITvbar
| ITlarrow IsUnicodeSyntax
| ITrarrow IsUnicodeSyntax
@@ -961,6 +962,7 @@ reservedWordsFM = listToUFM $
[( "_", ITunderscore, 0 ),
( "as", ITas, 0 ),
( "case", ITcase, 0 ),
+ ( "cases", ITlcases, xbit LambdaCaseBit ),
( "class", ITclass, 0 ),
( "data", ITdata, 0 ),
( "default", ITdefault, 0 ),
@@ -1621,6 +1623,14 @@ varid span buf len =
_ -> return ITcase
maybe_layout keyword
return $ L span keyword
+ Just (ITlcases, _) -> do
+ lastTk <- getLastTk
+ lambdaCase <- getBit LambdaCaseBit
+ token <- case lastTk of
+ Strict.Just (L _ ITlam) | lambdaCase -> return ITlcases
+ _ -> return $ ITvarid fs
+ maybe_layout token
+ return $ L span token
Just (keyword, 0) -> do
maybe_layout keyword
return $ L span keyword
@@ -1862,6 +1872,7 @@ maybe_layout t = do -- If the alternative layout rule is enabled then
f (ITmdo _) = pushLexState layout_do
f ITof = pushLexState layout
f ITlcase = pushLexState layout
+ f ITlcases = pushLexState layout
f ITlet = pushLexState layout
f ITwhere = pushLexState layout
f ITrec = pushLexState layout
@@ -3169,6 +3180,7 @@ lexTokenAlr = do mPending <- popPendingImplicitToken
ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet)
ITof -> setAlrExpectingOCurly (Just ALRLayoutOf)
ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf)
+ ITlcases -> setAlrExpectingOCurly (Just ALRLayoutOf)
ITdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo)
ITmdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo)
ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo)
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 0457618e86..faef0161be 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1026,24 +1026,25 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
where
checkExpr :: LHsExpr GhcPs -> PV ()
checkExpr expr = case unLoc expr of
- HsDo _ (DoExpr m) _ -> check (PsErrDoInFunAppExpr m) expr
- HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m) expr
- HsLam {} -> check PsErrLambdaInFunAppExpr expr
- HsCase {} -> check PsErrCaseInFunAppExpr expr
- HsLamCase {} -> check PsErrLambdaCaseInFunAppExpr expr
- HsLet {} -> check PsErrLetInFunAppExpr expr
- HsIf {} -> check PsErrIfInFunAppExpr expr
- HsProc {} -> check PsErrProcInFunAppExpr expr
- _ -> return ()
+ HsDo _ (DoExpr m) _ -> check (PsErrDoInFunAppExpr m) expr
+ HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m) expr
+ HsLam {} -> check PsErrLambdaInFunAppExpr expr
+ HsCase {} -> check PsErrCaseInFunAppExpr expr
+ HsLamCase _ lc_variant _ -> check (PsErrLambdaCaseInFunAppExpr lc_variant) expr
+ HsLet {} -> check PsErrLetInFunAppExpr expr
+ HsIf {} -> check PsErrIfInFunAppExpr expr
+ HsProc {} -> check PsErrProcInFunAppExpr expr
+ _ -> return ()
checkCmd :: LHsCmd GhcPs -> PV ()
checkCmd cmd = case unLoc cmd of
- HsCmdLam {} -> check PsErrLambdaCmdInFunAppCmd cmd
- HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd cmd
- HsCmdIf {} -> check PsErrIfCmdInFunAppCmd cmd
- HsCmdLet {} -> check PsErrLetCmdInFunAppCmd cmd
- HsCmdDo {} -> check PsErrDoCmdInFunAppCmd cmd
- _ -> return ()
+ HsCmdLam {} -> check PsErrLambdaCmdInFunAppCmd cmd
+ HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd cmd
+ HsCmdLamCase _ lc_variant _ -> check (PsErrLambdaCaseCmdInFunAppCmd lc_variant) cmd
+ HsCmdIf {} -> check PsErrIfCmdInFunAppCmd cmd
+ HsCmdLet {} -> check PsErrLetCmdInFunAppCmd cmd
+ HsCmdDo {} -> check PsErrDoCmdInFunAppCmd cmd
+ _ -> return ()
check err a = do
blockArguments <- getBit BlockArgumentsBit
@@ -1489,8 +1490,9 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
-- | Disambiguate "case ... of ..."
mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)])
-> EpAnnHsCase -> PV (LocatedA b)
- mkHsLamCasePV :: SrcSpan -> (LocatedL [LMatch GhcPs (LocatedA b)])
- -> [AddEpAnn]
+ -- | Disambiguate "\case" and "\cases"
+ mkHsLamCasePV :: SrcSpan -> LamCaseVariant
+ -> (LocatedL [LMatch GhcPs (LocatedA b)]) -> [AddEpAnn]
-> PV (LocatedA b)
-- | Function argument representation
type FunArg b
@@ -1630,10 +1632,10 @@ instance DisambECP (HsCmd GhcPs) where
cs <- getCommentsFor l
let mg = mkMatchGroup FromSource (L lm m)
return $ L (noAnnSrcSpan l) (HsCmdCase (EpAnn (spanAsAnchor l) anns cs) c mg)
- mkHsLamCasePV l (L lm m) anns = do
+ mkHsLamCasePV l lc_variant (L lm m) anns = do
cs <- getCommentsFor l
- let mg = mkMatchGroup FromSource (L lm m)
- return $ L (noAnnSrcSpan l) (HsCmdLamCase (EpAnn (spanAsAnchor l) anns cs) mg)
+ let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m)
+ return $ L (noAnnSrcSpan l) (HsCmdLamCase (EpAnn (spanAsAnchor l) anns cs) lc_variant mg)
type FunArg (HsCmd GhcPs) = HsExpr GhcPs
superFunArg m = m
mkHsAppPV l c e = do
@@ -1716,10 +1718,10 @@ instance DisambECP (HsExpr GhcPs) where
cs <- getCommentsFor l
let mg = mkMatchGroup FromSource (L lm m)
return $ L (noAnnSrcSpan l) (HsCase (EpAnn (spanAsAnchor l) anns cs) e mg)
- mkHsLamCasePV l (L lm m) anns = do
+ mkHsLamCasePV l lc_variant (L lm m) anns = do
cs <- getCommentsFor l
- let mg = mkMatchGroup FromSource (L lm m)
- return $ L (noAnnSrcSpan l) (HsLamCase (EpAnn (spanAsAnchor l) anns cs) mg)
+ let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m)
+ return $ L (noAnnSrcSpan l) (HsLamCase (EpAnn (spanAsAnchor l) anns cs) lc_variant mg)
type FunArg (HsExpr GhcPs) = HsExpr GhcPs
superFunArg m = m
mkHsAppPV l e1 e2 = do
@@ -1804,8 +1806,8 @@ instance DisambECP (PatBuilder GhcPs) where
cs <- getCommentsFor l
let anns = EpAnn (spanAsAnchor l) [] cs
return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns
- mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat
- mkHsLamCasePV l _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaCaseInPat
+ mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat
+ mkHsLamCasePV l lc_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaCaseInPat lc_variant)
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
superFunArg m = m
mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)
View Lorry Controller Status