[Git][ghc/ghc][wip/T24359] Fix PostProcess/Parser/Exact print annotations
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Wed Oct 30 20:27:48 UTC 2024
Alan Zimmerman pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
71a23964 by Alan Zimmerman at 2024-10-30T20:26:51+00:00
Fix PostProcess/Parser/Exact print annotations
It compiles, is now stuck on something related to the main work.
- - - - -
4 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -745,7 +745,7 @@ data AnnSpecSig
= AnnSpecSig {
ass_open :: EpaLocation,
ass_close :: EpToken "#-}",
- ass_dcolon :: TokDcolon,
+ ass_dcolon :: Maybe TokDcolon,
ass_act :: ActivationAnn
} deriving Data
@@ -1021,10 +1021,10 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
data HsRuleBndrsAnn
= HsRuleBndrsAnn
- { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn)
+ { rb_tyanns :: Maybe (TokForall, EpToken ".")
-- ^ The locations of 'forall' and '.' for forall'd type vars
-- Using AddEpAnn to capture possible unicode variants
- , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn)
+ , rb_tmanns :: Maybe (TokForall, EpToken ".")
-- ^ The locations of 'forall' and '.' for forall'd term vars
-- Using AddEpAnn to capture possible unicode variants
} deriving (Data, Eq)
@@ -1033,10 +1033,10 @@ instance NoAnn HsRuleBndrsAnn where
noAnn = HsRuleBndrsAnn Nothing Nothing
-type instance XCRuleBndr (GhcPass _) = [AddEpAnn]
+type instance XCRuleBndr (GhcPass _) = AnnTyVarBndr
type instance XCRuleBndrs (GhcPass _) = HsRuleBndrsAnn
type instance XXRuleBndrs (GhcPass _) = DataConCantHappen
-type instance XRuleBndrSig (GhcPass _) = [AddEpAnn]
+type instance XRuleBndrSig (GhcPass _) = AnnTyVarBndr
type instance XXRuleBndr (GhcPass _) = DataConCantHappen
instance (OutputableBndrId p) => Outputable (RuleBndrs (GhcPass p)) where
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -67,6 +67,7 @@ module GHC.Hs.Decls (
XViaStrategyPs(..),
-- ** @RULE@ declarations
LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),
+ HsRuleAnn(..),
RuleBndr(..),LRuleBndr,
collectRuleBndrSigTys,
flattenRuleDecls, pprFullRuleName,
@@ -1314,13 +1315,24 @@ type instance XCRuleDecls GhcTc = SourceText
type instance XXRuleDecls (GhcPass _) = DataConCantHappen
-type instance XHsRule GhcPs = ([AddEpAnn], SourceText)
+type instance XHsRule GhcPs = ((ActivationAnn, EpToken "="), SourceText)
type instance XHsRule GhcRn = (HsRuleRn, SourceText)
type instance XHsRule GhcTc = (HsRuleRn, SourceText)
data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS
deriving Data
+data HsRuleAnn
+ = HsRuleAnn
+ { ra_tyanns :: Maybe (TokForall, EpToken ".")
+ , ra_tmanns :: Maybe (TokForall, EpToken ".")
+ , ra_equal :: EpToken "="
+ , ra_rest :: ActivationAnn
+ } deriving (Data, Eq)
+
+instance NoAnn HsRuleAnn where
+ noAnn = HsRuleAnn Nothing Nothing noAnn noAnn
+
type instance XXRuleDecl (GhcPass _) = DataConCantHappen
flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)]
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1926,7 +1926,7 @@ rule :: { LRuleDecl GhcPs }
{%runPV (unECP $4) >>= \ $4 ->
runPV (unECP $6) >>= \ $6 ->
amsA' (sLL $1 $> $ HsRule
- { rd_ext =(((fst $3) (epTok $5) (fst $2)), getSTRINGs $1)
+ { rd_ext =((fst $2, epTok $5), getSTRINGs $1)
, rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1)
, rd_act = snd $2 `orElse` AlwaysActive
, rd_bndrs = ruleBndrsOrDef $3
@@ -1970,12 +1970,12 @@ rule_foralls :: { Maybe (RuleBndrs GhcPs) }
{% hintExplicitForall $1
>> checkRuleTyVarBndrNames $2
>> let ann = HsRuleBndrsAnn
- (Just (mu AnnForall $1,mj AnnDot $3))
- (Just (mu AnnForall $4,mj AnnDot $6))
+ (Just (epUniTok $1,epTok $3))
+ (Just (epUniTok $4,epTok $6))
in return (Just (mkRuleBndrs ann (Just $2) $5)) }
| 'forall' rule_vars '.'
- { Just (mkRuleBndrs (HsRuleBndrsAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)))
+ { Just (mkRuleBndrs (HsRuleBndrsAnn Nothing (Just (epUniTok $1,epTok $3)))
Nothing $2) }
-- See Note [%shift: rule_foralls -> {- empty -}]
@@ -2770,11 +2770,11 @@ sigdecl :: { LHsDecl GhcPs }
let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
(NoUserInlinePrag, FunLike)
(snd $2)
- spec <- mkSpecSig $1 inl_prag (fst $2) $3 $4 $5 $6
+ spec <- mkSpecSig inl_prag (AnnSpecSig (glR $1) (epTok $6) Nothing (fst $2)) $3 $4 $5
amsA' $ sLL $1 $> $ SigD noExtField spec }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
- {% amsA' (sLL $1 $> $ SigD noExtField (SpecSig (AnnSpecSig (glR $1) (epTok $6) (epUniTok $4) (fst $2)) $3 (fromOL $5)
+ {% amsA' (sLL $1 $> $ SigD noExtField (SpecSig (AnnSpecSig (glR $1) (epTok $6) (Just $ epUniTok $4) (fst $2)) $3 (fromOL $5)
(mkInlinePragma (getSPEC_INLINE_PRAGs $1)
(getSPEC_INLINE $1) (snd $2)))) }
@@ -2785,8 +2785,8 @@ sigdecl :: { LHsDecl GhcPs }
| '{-# MINIMAL' name_boolformula_opt '#-}'
{% amsA' (sLL $1 $> $ SigD noExtField (MinimalSig ((glR $1,epTok $3), (getMINIMAL_PRAGs $1)) $2)) }
-sigtypes_maybe :: { Maybe (Located Token, OrdList (LHsSigType GhcPs)) }
- : '::' sigtypes1 { Just ($1, $2) }
+sigtypes_maybe :: { Maybe (TokDcolon, OrdList (LHsSigType GhcPs)) }
+ : '::' sigtypes1 { Just (epUniTok $1, $2) }
| {- empty -} { Nothing }
activation :: { (ActivationAnn,Maybe Activation) }
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1015,7 +1015,7 @@ ruleBndrsOrDef Nothing = mkRuleBndrs noAnn Nothing []
mkRuleBndrs :: HsRuleBndrsAnn -> Maybe [LRuleTyTmVar] -> [LRuleTyTmVar] -> RuleBndrs GhcPs
mkRuleBndrs ann tvbs tmbs
= RuleBndrs { rb_ext = ann
- , rb_tyvs = fmap (setLHsTyVarBndrNameSpace tvName . cvt_tv) tvbs
+ , rb_tyvs = fmap (fmap (setLHsTyVarBndrNameSpace tvName . cvt_tv)) tvbs
, rb_tmvs = fmap (fmap cvt_tm) tmbs }
where
-- cvt_tm turns RuleTyTmVars into RuleBnrs - this is straightforward
@@ -1039,32 +1039,30 @@ checkRuleTyVarBndrNames bndrs
PsErrParseErrorOnInput occ
check _ = panic "checkRuleTyVarBndrNames"
-mkSpecSig :: Located Token
- -> InlinePragma
- -> [AddEpAnn]
+mkSpecSig :: InlinePragma
+ -> AnnSpecSig
-> Maybe (RuleBndrs GhcPs)
-> LHsExpr GhcPs
- -> Maybe (Located Token, OrdList (LHsSigType GhcPs))
- -> Located Token
+ -> Maybe (TokDcolon, OrdList (LHsSigType GhcPs))
-> P (Sig GhcPs)
-mkSpecSig prag_start inl_prag activation_anns m_rule_binds expr m_sigtypes_ascr prag_end
+mkSpecSig inl_prag activation_anns m_rule_binds expr m_sigtypes_ascr
= case m_sigtypes_ascr of
Nothing
-- New form, no trailing type signature, e.g {-# SPECIALISE f @Int #-}
-> pure $
- SpecSigE (start_ann:end_ann:activation_anns)
+ SpecSigE activation_anns
(ruleBndrsOrDef m_rule_binds) expr inl_prag
- Just (dcolon, sigtype_ol)
+ Just (colon_ann, sigtype_ol)
-- Singleton, e.g. {-# SPECIALISE f :: ty #-}
-- Use the SpecSigE route
| [sigtype] <- sigtype_list
-> pure $
- SpecSigE (start_ann:end_ann:activation_anns)
+ SpecSigE activation_anns
(ruleBndrsOrDef m_rule_binds)
(L (getLoc expr) -- ToDo: not really the right location for (e::ty)
- (ExprWithTySig [colon_ann] expr (mkHsWildCardBndrs sigtype)))
+ (ExprWithTySig colon_ann expr (mkHsWildCardBndrs sigtype)))
inl_prag
-- So we must have the old form {# SPECIALISE f :: ty1, ty2, ty3 #-}
@@ -1072,26 +1070,18 @@ mkSpecSig prag_start inl_prag activation_anns m_rule_binds expr m_sigtypes_ascr
| Nothing <- m_rule_binds
, L _ (HsVar _ var) <- expr
-> pure $
- SpecSig (start_ann:colon_ann:end_ann:activation_anns)
+ SpecSig activation_anns
var sigtype_list inl_prag
| otherwise -> ps_err PsErrSpecExprMultipleTypeAscription
where
sigtype_list = fromOL sigtype_ol
- colon_ann = AddEpAnn (toUnicodeAnn AnnDcolon dcolon) (gl dcolon)
where
- 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)
+ (getHasLoc (ass_open activation_anns) `combineSrcSpans` getHasLoc (ass_close activation_anns))
checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)
checkRecordSyntax lr@(L loc r)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/71a2396406fcc6fb4bdf198847eded9a94a55c72
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/71a2396406fcc6fb4bdf198847eded9a94a55c72
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/20241030/e4fddaed/attachment-0001.html>
More information about the ghc-commits
mailing list