[Git][ghc/ghc][wip/or-pats] Introduce language extension and errors
David (@knothed)
gitlab at gitlab.haskell.org
Fri Dec 2 16:30:33 UTC 2022
David pushed to branch wip/or-pats at Glasgow Haskell Compiler / GHC
Commits:
c353400f by David Knothe at 2022-12-02T17:30:25+01:00
Introduce language extension and errors
- - - - -
10 changed files:
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Types/Error/Codes.hs
- libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
Changes:
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3719,6 +3719,7 @@ xFlagsDeps = [
depFlagSpec' "NullaryTypeClasses" LangExt.NullaryTypeClasses
(deprecatedForExtension "MultiParamTypeClasses"),
flagSpec "NumDecimals" LangExt.NumDecimals,
+ flagSpec "OrPatterns" LangExt.OrPatterns,
depFlagSpecOp "OverlappingInstances" LangExt.OverlappingInstances
setOverlappingInsts
"instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS",
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3061,7 +3061,13 @@ texp :: { ECP }
$1 >>= \ $1 ->
pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 }
- | 'one' 'of' vocurly orpats close { ecpFromPat (sLLa ($1) (reLoc (last $4)) (mkorpat $4)) }
+ | 'one' 'of' vocurly orpats close
+ {% do {
+ let pat = sLLa $1 (reLoc (last $4)) (mkorpat $4)
+ ; orPatsOn <- hintOrPats pat
+ ; when (orPatsOn && length $4 < 2) $ addError $ mkPlainErrorMsgEnvelope (locA (getLoc pat)) (PsErrOrPatNeedsTwoAlternatives pat)
+ ; return $ ecpFromPat pat
+ } }
-- View patterns get parenthesized above
| exp '->' texp { ECP $
@@ -4186,6 +4192,13 @@ looksLikeMult ty1 l_op ty2
= True
| otherwise = False
+-- Hint about or-patterns
+hintOrPats :: MonadP m => LPat GhcPs -> m Bool
+hintOrPats pat = do
+ orPatsEnabled <- getBit OrPatternsBit
+ unless orPatsEnabled $ addError $ mkPlainErrorMsgEnvelope (locA (getLoc pat)) $ PsErrIllegalOrPat pat
+ return orPatsEnabled
+
-- Hint about the MultiWayIf extension
hintMultiWayIf :: SrcSpan -> P ()
hintMultiWayIf span = do
=====================================
compiler/GHC/Parser/Errors/Ppr.hs
=====================================
@@ -523,6 +523,13 @@ instance Diagnostic PsMessage where
, text "'" <> text [looks_like_char] <> text "' (" <> text looks_like_char_name <> text ")" <> comma
, text "but it is not" ]
+ PsErrOrPatNeedsTwoAlternatives pat
+ -> mkSimpleDecorated $ vcat [text "Or-pattern needs at least two alternatives:" <+> ppr (unLoc pat)]
+
+ PsErrIllegalOrPat pat
+ -> mkSimpleDecorated $ vcat [text "Illegal or-pattern:" <+> ppr (unLoc pat)]
+
+
diagnosticReason = \case
PsUnknownMessage m -> diagnosticReason m
PsHeaderMessage m -> psHeaderMessageReason m
@@ -641,6 +648,8 @@ instance Diagnostic PsMessage where
PsErrInvalidCApiImport {} -> ErrorWithoutFlag
PsErrMultipleConForNewtype {} -> ErrorWithoutFlag
PsErrUnicodeCharLooksLike{} -> ErrorWithoutFlag
+ PsErrOrPatNeedsTwoAlternatives{} -> ErrorWithoutFlag
+ PsErrIllegalOrPat{} -> ErrorWithoutFlag
diagnosticHints = \case
PsUnknownMessage m -> diagnosticHints m
@@ -812,6 +821,8 @@ instance Diagnostic PsMessage where
PsErrInvalidCApiImport {} -> noHints
PsErrMultipleConForNewtype {} -> noHints
PsErrUnicodeCharLooksLike{} -> noHints
+ PsErrIllegalOrPat{} -> [suggestExtension LangExt.OrPatterns]
+ PsErrOrPatNeedsTwoAlternatives{} -> noHints
diagnosticCode = constructorCode
=====================================
compiler/GHC/Parser/Errors/Types.hs
=====================================
@@ -471,6 +471,10 @@ data PsMessage
Char -- ^ the character it looks like
String -- ^ the name of the character that it looks like
+ | PsErrIllegalOrPat (LPat GhcPs)
+
+ | PsErrOrPatNeedsTwoAlternatives (LPat GhcPs)
+
deriving Generic
-- | Extra details about a parse error, which helps
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -2907,6 +2907,7 @@ data ExtBits
| NoLexicalNegationBit -- See Note [Why not LexicalNegationBit]
| OverloadedRecordDotBit
| OverloadedRecordUpdateBit
+ | OrPatternsBit
-- Flags that are updated once parsing starts
| InRulePragBit
@@ -2986,6 +2987,7 @@ mkParserOpts extensionFlags diag_opts supported
.|. NoLexicalNegationBit `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit]
.|. OverloadedRecordDotBit `xoptBit` LangExt.OverloadedRecordDot
.|. OverloadedRecordUpdateBit `xoptBit` LangExt.OverloadedRecordUpdate -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information).
+ .|. OrPatternsBit `xoptBit` LangExt.OrPatterns
optBits =
HaddockBit `setBitIf` isHaddock
.|. RawTokenStreamBit `setBitIf` rawTokStream
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -616,7 +616,7 @@ rnPatAndThen mk (OrPat _ pats)
checkNoVarsBound pat = do
let bnds = collectPatsBinders CollNoDictBinders [pat]
unless (null bnds) $
- liftCps $ addErrAt (locA $ getLoc pat) TcRnOrPatBindsVariables
+ liftCps $ addErrAt (locA $ getLoc pat) (TcRnOrPatBindsVariables pat)
rnPatAndThen mk (SumPat _ pat alt arity)
= do { pat <- rnLPatAndThen mk pat
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1153,9 +1153,8 @@ instance Diagnostic TcRnMessage where
False -> text (TH.pprint item))
TcRnReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg
TcRnInterfaceLookupError _ sdoc -> mkSimpleDecorated sdoc
- TcRnOrPatBindsVariables
- -> mkSimpleDecorated $
- text "Or Pattern may not bind variables"
+ TcRnOrPatBindsVariables pat
+ -> mkSimpleDecorated $ vcat [text "Or-pattern may not bind variables:" <+> ppr (unLoc pat)]
TcRnUnsatisfiedMinimalDef mindef
-> mkSimpleDecorated $
vcat [text "No explicit implementation for"
@@ -1595,7 +1594,7 @@ instance Diagnostic TcRnMessage where
-> if isError then ErrorWithoutFlag else WarningWithoutFlag
TcRnInterfaceLookupError{}
-> ErrorWithoutFlag
- TcRnOrPatBindsVariables
+ TcRnOrPatBindsVariables{}
-> ErrorWithoutFlag
TcRnUnsatisfiedMinimalDef{}
-> WarningWithFlag (Opt_WarnMissingMethods)
@@ -2003,7 +2002,7 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnInterfaceLookupError{}
-> noHints
- TcRnOrPatBindsVariables
+ TcRnOrPatBindsVariables{}
-> noHints
TcRnUnsatisfiedMinimalDef{}
-> noHints
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -2554,8 +2554,8 @@ data TcRnMessage where
Test case:
none yet (TODO)
-}
+ TcRnOrPatBindsVariables :: LPat GhcRn -> TcRnMessage
- TcRnOrPatBindsVariables :: TcRnMessage
{- | TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance
is missing methods that are required by the minimal definition.
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -268,6 +268,8 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "PsErrInvalidCApiImport" = 72744
GhcDiagnosticCode "PsErrMultipleConForNewtype" = 05380
GhcDiagnosticCode "PsErrUnicodeCharLooksLike" = 31623
+ GhcDiagnosticCode "PsErrIllegalOrPat" = 29847
+ GhcDiagnosticCode "PsErrOrPatNeedsTwoAlternatives" = 96152
-- Driver diagnostic codes
GhcDiagnosticCode "DriverMissingHomeModules" = 32850
@@ -470,7 +472,6 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = 40027
GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = 69639
GhcDiagnosticCode "TcRnOrPatBindsVariables" = 81303
-
GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods" = 93006
GhcDiagnosticCode "TcRnBadGenericMethod" = 59794
GhcDiagnosticCode "TcRnWarningMinimalDefIncomplete" = 13511
=====================================
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs
=====================================
@@ -64,6 +64,7 @@ data Extension
| RecordWildCards
| NamedFieldPuns
| ViewPatterns
+ | OrPatterns
| GADTs
| GADTSyntax
| NPlusKPatterns
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c353400f78ee9fbb8036d93557ead205181cd0fc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c353400f78ee9fbb8036d93557ead205181cd0fc
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221202/16849fe3/attachment-0001.html>
More information about the ghc-commits
mailing list