[Git][ghc/ghc][wip/T24359] Fix derivations conflict in parser, disambiguate them in post-process
Andrei Borzenkov (@sand-witch)
gitlab at gitlab.haskell.org
Thu Mar 28 17:13:32 UTC 2024
Andrei Borzenkov pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
2d39571f by Andrei Borzenkov at 2024-03-28T21:13:19+04:00
Fix derivations conflict in parser, disambiguate them in post-process
- - - - -
5 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Types/Error/Codes.hs
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1871,7 +1871,7 @@ rule :: { LRuleDecl GhcPs }
{ rd_ext = (((fst $3) (mj AnnEqual $5 : (fst $2))), getSTRINGs $1)
, rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1)
, rd_act = snd $2 `orElse` AlwaysActive
- , rd_bndrs = snd $3
+ , rd_bndrs = ruleBndrsOrDef (snd $3)
, rd_lhs = $4, rd_rhs = $6 }) }
-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
@@ -1907,7 +1907,7 @@ rule_explicit_activation :: { ([AddEpAnn]
{ ($2++[mos $1,mcs $3]
,NeverActive) }
-rule_foralls :: { ([AddEpAnn] -> HsRuleAnn, RuleBndrs GhcPs) }
+rule_foralls :: { ([AddEpAnn] -> HsRuleAnn, Maybe (RuleBndrs GhcPs)) }
: 'forall' rule_vars '.' 'forall' rule_vars '.'
{% hintExplicitForall $1
>> checkRuleTyVarBndrNames $2
@@ -1915,15 +1915,15 @@ rule_foralls :: { ([AddEpAnn] -> HsRuleAnn, RuleBndrs GhcPs) }
(Just (mu AnnForall $1,mj AnnDot $3))
(Just (mu AnnForall $4,mj AnnDot $6))
anns
- , mkRuleBndrs (Just $2) $5 ) }
+ , Just (mkRuleBndrs (Just $2) $5) ) }
| 'forall' rule_vars '.'
{ ( \anns -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) anns
- , mkRuleBndrs Nothing $2 ) }
+ , Just (mkRuleBndrs Nothing $2) ) }
-- See Note [%shift: rule_foralls -> {- empty -}]
| {- empty -} %shift
- { (\anns -> HsRuleAnn Nothing Nothing anns, mkRuleBndrs Nothing []) }
+ { (\anns -> HsRuleAnn Nothing Nothing anns, Nothing) }
rule_vars :: { [LRuleTyTmVar] }
: rule_var rule_vars { $1 : $2 }
@@ -2681,25 +2681,13 @@ sigdecl :: { LHsDecl GhcPs }
; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing
; amsA' (sLL $1 $> (SigD noExtField (SCCFunSig ([mo $1, mc $4], (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }}
- | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
- {% amsA' (
- let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
- (NoUserInlinePrag, FunLike) (snd $2)
- in sLL $1 $> $ SigD noExtField $
- SpecSig (mo $1:mu AnnDcolon $4:mc $6:fst $2)
- $3 (fromOL $5)
- inl_prag) }
-
- | '{-# SPECIALISE' activation rule_foralls exp '#-}'
- {% runPV (unECP $4) >>= \ $4 ->
- amsA' (
+ | '{-# SPECIALISE' activation rule_foralls infixexp sigtypes_maybe '#-}'
+ {% runPV (unECP $4) >>= \ $4 -> do
let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
(NoUserInlinePrag, FunLike)
(snd $2)
- in sLL $1 $> $ SigD noExtField $
- SpecSigE (mo $1:mc $5:fst $2)
- (snd $3) $4
- inl_prag) }
+ spec <- mkSpecSig $1 inl_prag (fst $2) (snd $3) $4 $5 $6
+ amsA' $ sLL $1 $> $ SigD noExtField spec }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
{% amsA' (sLL $1 $> $ SigD noExtField (SpecSig (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) $3 (fromOL $5)
@@ -2713,6 +2701,10 @@ sigdecl :: { LHsDecl GhcPs }
| '{-# MINIMAL' name_boolformula_opt '#-}'
{% amsA' (sLL $1 $> $ SigD noExtField (MinimalSig ([mo $1,mc $3], (getMINIMAL_PRAGs $1)) $2)) }
+sigtypes_maybe :: { Maybe (Located Token, OrdList (LHsSigType GhcPs)) }
+ : '::' sigtypes1 { Just ($1, $2) }
+ | {- empty -} { Nothing }
+
activation :: { ([AddEpAnn],Maybe Activation) }
-- See Note [%shift: activation -> {- empty -}]
: {- empty -} %shift { ([],Nothing) }
=====================================
compiler/GHC/Parser/Errors/Ppr.hs
=====================================
@@ -531,6 +531,10 @@ instance Diagnostic PsMessage where
, text "Use" <+> quotes (text "Sum<n># a b c ...") <+> text "to refer to the type constructor."
]
+ PsErrSpecEpxrMultipleTypeAscription
+ -> mkSimpleDecorated $
+ text "SPECIALIZE expression doesn't support multiple specialize type ascriptions"
+
diagnosticReason = \case
PsUnknownMessage m -> diagnosticReason m
PsHeaderMessage m -> psHeaderMessageReason m
@@ -646,6 +650,7 @@ instance Diagnostic PsMessage where
PsErrMultipleConForNewtype {} -> ErrorWithoutFlag
PsErrUnicodeCharLooksLike{} -> ErrorWithoutFlag
PsErrInvalidPun {} -> ErrorWithoutFlag
+ PsErrSpecEpxrMultipleTypeAscription{} -> ErrorWithoutFlag
diagnosticHints = \case
PsUnknownMessage m -> diagnosticHints m
@@ -816,6 +821,7 @@ instance Diagnostic PsMessage where
PsErrMultipleConForNewtype {} -> noHints
PsErrUnicodeCharLooksLike{} -> noHints
PsErrInvalidPun {} -> [suggestExtension LangExt.ListTuplePuns]
+ PsErrSpecEpxrMultipleTypeAscription {} -> noHints
diagnosticCode = constructorCode
=====================================
compiler/GHC/Parser/Errors/Types.hs
=====================================
@@ -461,6 +461,8 @@ data PsMessage
| PsErrInvalidPun !PsErrPunDetails
+ | PsErrSpecEpxrMultipleTypeAscription
+
deriving Generic
-- | Extra details about a parse error, which helps
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -63,7 +63,9 @@ module GHC.Parser.PostProcess (
checkValSigLhs,
LRuleTyTmVar, RuleTyTmVar(..),
mkRuleBndrs,
+ ruleBndrsOrDef,
checkRuleTyVarBndrNames,
+ mkSpecSig,
checkRecordSyntax,
checkEmptyGADTs,
addFatalError, hintBangPat,
@@ -993,6 +995,10 @@ type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar
data RuleTyTmVar = RuleTyTmVar [AddEpAnn] (LocatedN RdrName) (Maybe (LHsType GhcPs))
-- ^ Essentially a wrapper for a @RuleBndr GhcPs@
+ruleBndrsOrDef :: Maybe (RuleBndrs GhcPs) -> RuleBndrs GhcPs
+ruleBndrsOrDef (Just bndrs) = bndrs
+ruleBndrsOrDef Nothing = mkRuleBndrs Nothing []
+
mkRuleBndrs :: Maybe [LRuleTyTmVar] -> [LRuleTyTmVar] -> RuleBndrs GhcPs
mkRuleBndrs tvbs tmbs
= RuleBndrs { rb_tyvs = fmap (fmap cvt_tv) tvbs
@@ -1023,6 +1029,43 @@ checkRuleTyVarBndrNames bndrs
PsErrParseErrorOnInput occ
check _ = panic "checkRuleTyVarBndrNames"
+mkSpecSig :: Located Token
+ -> InlinePragma
+ -> [AddEpAnn]
+ -> Maybe (RuleBndrs GhcPs)
+ -> LHsExpr GhcPs
+ -> Maybe (Located Token, OrdList (LHsSigType GhcPs))
+ -> Located Token
+ -> P (Sig GhcPs)
+mkSpecSig prag_start inl_prag activation_anns m_rule_binds expr m_sigtypes_ascr prag_end =
+ match_on_pragma_structure m_rule_binds expr m_sigtypes_ascr
+ where
+ match_on_pragma_structure _ _ Nothing = pure $
+ SpecSigE (start_ann:end_ann:activation_anns)
+ (ruleBndrsOrDef m_rule_binds) expr
+ inl_prag
+
+ match_on_pragma_structure Nothing (L _ (HsVar _ var)) (Just (dcolon, sigtypes)) = pure $
+ SpecSig (start_ann:colon_ann:end_ann:activation_anns)
+ var (fromOL sigtypes)
+ inl_prag
+ where colon_ann = AddEpAnn (toUnicodeAnn AnnDcolon dcolon) (gl dcolon)
+
+ match_on_pragma_structure _ _ _ =
+ ps_err PsErrSpecEpxrMultipleTypeAscription
+
+
+ gl = srcSpan2e . getLoc
+ start_ann = AddEpAnn AnnOpen (gl prag_start)
+ end_ann = AddEpAnn AnnClose (gl prag_end)
+
+ toUnicodeAnn !a (L _ (ITdcolon UnicodeSyntax)) = unicodeAnn a
+ toUnicodeAnn a _ = a
+
+ ps_err = addFatalError
+ . mkPlainErrorMsgEnvelope
+ (getLoc prag_start `combineSrcSpans` getLoc prag_end)
+
checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)
checkRecordSyntax lr@(L loc r)
= do allowed <- getBit TraditionalRecordSyntaxBit
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -287,6 +287,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "PsErrMultipleConForNewtype" = 05380
GhcDiagnosticCode "PsErrUnicodeCharLooksLike" = 31623
GhcDiagnosticCode "PsErrInvalidPun" = 52943
+ GhcDiagnosticCode "PsErrSpecEpxrMultipleTypeAscription" = 62037
-- Driver diagnostic codes
GhcDiagnosticCode "DriverMissingHomeModules" = 32850
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2d39571f017252663e89a233247c76f89ba1629b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2d39571f017252663e89a233247c76f89ba1629b
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/20240328/335c084b/attachment-0001.html>
More information about the ghc-commits
mailing list