[Git][ghc/ghc][wip/T24359] Fix exact printing for RuleBndrs
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Fri Mar 29 16:02:09 UTC 2024
Alan Zimmerman pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
b984c233 by Alan Zimmerman at 2024-03-29T15:59:38+00:00
Fix exact printing for RuleBndrs
This puts the exact print annotations inside a TTG extension point in
RuleBndrs.
It also adds an exact print case for SpecSigE
- - - - -
12 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -26,6 +26,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind at .
module GHC.Hs.Binds
( module Language.Haskell.Syntax.Binds
, module GHC.Hs.Binds
+ , HsRuleBndrsAnn(..)
) where
import GHC.Prelude
@@ -976,7 +977,23 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
* *
********************************************************************* -}
+data HsRuleBndrsAnn
+ = HsRuleBndrsAnn
+ { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn)
+ -- ^ The locations of 'forall' and '.' for forall'd type vars
+ -- Using AddEpAnn to capture possible unicode variants
+ , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn)
+ -- ^ The locations of 'forall' and '.' for forall'd term vars
+ -- Using AddEpAnn to capture possible unicode variants
+ } deriving (Data, Eq)
+
+instance NoAnn HsRuleBndrsAnn where
+ noAnn = HsRuleBndrsAnn Nothing Nothing
+
+
type instance XCRuleBndr (GhcPass _) = [AddEpAnn]
+type instance XCRuleBndrs (GhcPass _) = HsRuleBndrsAnn
+type instance XXRuleBndrs (GhcPass _) = DataConCantHappen
type instance XRuleBndrSig (GhcPass _) = [AddEpAnn]
type instance XXRuleBndr (GhcPass _) = DataConCantHappen
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -62,7 +62,6 @@ module GHC.Hs.Decls (
XViaStrategyPs(..),
-- ** @RULE@ declarations
LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),
- HsRuleAnn(..),
RuleBndr(..),LRuleBndr,
collectRuleBndrSigTys,
flattenRuleDecls, pprFullRuleName,
@@ -1196,7 +1195,7 @@ type instance XCRuleDecls GhcTc = SourceText
type instance XXRuleDecls (GhcPass _) = DataConCantHappen
-type instance XHsRule GhcPs = (HsRuleAnn, SourceText)
+type instance XHsRule GhcPs = ([AddEpAnn], SourceText)
type instance XHsRule GhcRn = (HsRuleRn, SourceText)
type instance XHsRule GhcTc = (HsRuleRn, SourceText)
@@ -1205,20 +1204,6 @@ data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS
type instance XXRuleDecl (GhcPass _) = DataConCantHappen
-data HsRuleAnn
- = HsRuleAnn
- { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn)
- -- ^ The locations of 'forall' and '.' for forall'd type vars
- -- Using AddEpAnn to capture possible unicode variants
- , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn)
- -- ^ The locations of 'forall' and '.' for forall'd term vars
- -- Using AddEpAnn to capture possible unicode variants
- , ra_rest :: [AddEpAnn]
- } deriving (Data, Eq)
-
-instance NoAnn HsRuleAnn where
- noAnn = HsRuleAnn Nothing Nothing []
-
flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)]
flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1868,10 +1868,10 @@ rule :: { LRuleDecl GhcPs }
{%runPV (unECP $4) >>= \ $4 ->
runPV (unECP $6) >>= \ $6 ->
amsA' (sLL $1 $> $ HsRule
- { rd_ext = (((fst $3) (mj AnnEqual $5 : (fst $2))), getSTRINGs $1)
+ { rd_ext = (mj AnnEqual $5 : (fst $2), getSTRINGs $1)
, rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1)
, rd_act = snd $2 `orElse` AlwaysActive
- , rd_bndrs = ruleBndrsOrDef (snd $3)
+ , rd_bndrs = ruleBndrsOrDef $3
, rd_lhs = $4, rd_rhs = $6 }) }
-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
@@ -1907,23 +1907,22 @@ rule_explicit_activation :: { ([AddEpAnn]
{ ($2++[mos $1,mcs $3]
,NeverActive) }
-rule_foralls :: { ([AddEpAnn] -> HsRuleAnn, Maybe (RuleBndrs GhcPs)) }
+rule_foralls :: { Maybe (RuleBndrs GhcPs) }
: 'forall' rule_vars '.' 'forall' rule_vars '.'
{% hintExplicitForall $1
>> checkRuleTyVarBndrNames $2
- >> return ( \anns -> HsRuleAnn
- (Just (mu AnnForall $1,mj AnnDot $3))
- (Just (mu AnnForall $4,mj AnnDot $6))
- anns
- , Just (mkRuleBndrs (Just $2) $5) ) }
+ >> let ann = HsRuleBndrsAnn
+ (Just (mu AnnForall $1,mj AnnDot $3))
+ (Just (mu AnnForall $4,mj AnnDot $6))
+ in return (Just (mkRuleBndrs ann (Just $2) $5)) }
| 'forall' rule_vars '.'
- { ( \anns -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) anns
- , Just (mkRuleBndrs Nothing $2) ) }
+ { Just (mkRuleBndrs (HsRuleBndrsAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)))
+ Nothing $2) }
-- See Note [%shift: rule_foralls -> {- empty -}]
| {- empty -} %shift
- { (\anns -> HsRuleAnn Nothing Nothing anns, Nothing) }
+ { Nothing }
rule_vars :: { [LRuleTyTmVar] }
: rule_var rule_vars { $1 : $2 }
@@ -2686,7 +2685,7 @@ sigdecl :: { LHsDecl GhcPs }
let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
(NoUserInlinePrag, FunLike)
(snd $2)
- spec <- mkSpecSig $1 inl_prag (fst $2) (snd $3) $4 $5 $6
+ spec <- mkSpecSig $1 inl_prag (fst $2) $3 $4 $5 $6
amsA' $ sLL $1 $> $ SigD noExtField spec }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -997,11 +997,12 @@ data RuleTyTmVar = RuleTyTmVar [AddEpAnn] (LocatedN RdrName) (Maybe (LHsType Ghc
ruleBndrsOrDef :: Maybe (RuleBndrs GhcPs) -> RuleBndrs GhcPs
ruleBndrsOrDef (Just bndrs) = bndrs
-ruleBndrsOrDef Nothing = mkRuleBndrs Nothing []
+ruleBndrsOrDef Nothing = mkRuleBndrs noAnn Nothing []
-mkRuleBndrs :: Maybe [LRuleTyTmVar] -> [LRuleTyTmVar] -> RuleBndrs GhcPs
-mkRuleBndrs tvbs tmbs
- = RuleBndrs { rb_tyvs = fmap (fmap cvt_tv) tvbs
+mkRuleBndrs :: HsRuleBndrsAnn -> Maybe [LRuleTyTmVar] -> [LRuleTyTmVar] -> RuleBndrs GhcPs
+mkRuleBndrs ann tvbs tmbs
+ = RuleBndrs { rb_ext = ann
+ , rb_tyvs = fmap (fmap cvt_tv) tvbs
, rb_tmvs = fmap (fmap cvt_tm) tmbs }
where
-- cvt_tm turns RuleTyTmVars into RuleBnrs - this is straightforward
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -1290,7 +1290,8 @@ bindRuleBndrs doc (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) thing_inside
; names <- newLocalBndrsRn rdr_names_w_loc
; bindRuleTyVars doc tyvs $ \ tyvs' ->
bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
- thing_inside names (RuleBndrs { rb_tyvs = tyvs', rb_tmvs = tmvs' }) }
+ thing_inside names (RuleBndrs { rb_ext = noAnn
+ , rb_tyvs = tyvs', rb_tmvs = tmvs' }) }
where
get_var :: RuleBndr GhcPs -> LocatedN RdrName
get_var (RuleBndrSig _ v _) = v
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -1122,7 +1122,8 @@ tcRule (HsRule { rd_ext = ext
mkTcRuleBndrs :: RuleBndrs GhcRn -> [Var] -> RuleBndrs GhcTc
mkTcRuleBndrs (RuleBndrs { rb_tyvs = tyvs }) vars
- = RuleBndrs { rb_tyvs = tyvs -- preserved for ppr-ing
+ = RuleBndrs { rb_ext = noAnn
+ , rb_tyvs = tyvs -- preserved for ppr-ing
, rb_tmvs = map (noLocA . RuleBndr noAnn . noLocA) vars }
generateRuleConstraints :: SkolemInfo
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1697,7 +1697,7 @@ zonkRule rule@(HsRule { rd_bndrs = bndrs
zonkRuleBndrs :: RuleBndrs GhcTc -> (RuleBndrs GhcTc -> ZonkTcM a) -> ZonkTcM a
zonkRuleBndrs (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) thing_inside
= runZonkBndrT (traverse zonk_tm_bndr tmvs) $ \ new_tmvs ->
- thing_inside (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = new_tmvs })
+ thing_inside (RuleBndrs { rb_ext = noAnn, rb_tyvs = tyvs, rb_tmvs = new_tmvs })
where
zonk_tm_bndr :: LRuleBndr GhcTc -> ZonkBndrTcM (LRuleBndr GhcTc)
zonk_tm_bndr (L l (RuleBndr x (L loc v)))
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -919,7 +919,7 @@ cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
HsRule { rd_ext = (noAnn, quotedSourceText nm)
, rd_name = rd_name'
, rd_act = act
- , rd_bndrs = RuleBndrs { rb_tyvs = ty_bndrs', rb_tmvs = tm_bndrs' }
+ , rd_bndrs = RuleBndrs { rb_ext = noAnn, rb_tyvs = ty_bndrs', rb_tmvs = tm_bndrs' }
, rd_lhs = lhs'
, rd_rhs = rhs' }
; returnJustLA $ Hs.RuleD noExtField
=====================================
compiler/Language/Haskell/Syntax/Binds.hs
=====================================
@@ -558,12 +558,14 @@ isCompleteMatchSig _ = False
********************************************************************* -}
data RuleBndrs pass = RuleBndrs
- { rb_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]
+ { rb_ext :: (XCRuleBndrs pass)
+ , rb_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]
-- ^ Forall'd type vars
, rb_tmvs :: [LRuleBndr pass]
-- ^ Forall'd term vars, before typechecking;
-- after typechecking this includes all forall'd vars
}
+ | XRuleBndrs !(XXRuleBndrs pass)
-- | Located Rule Binder
type LRuleBndr pass = XRec pass (RuleBndr pass)
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -1635,8 +1635,8 @@ data RuleDecl pass
-- ^ After renamer, free-vars from the LHS and RHS
, rd_name :: XRec pass RuleName
-- ^ Note [Pragma source text] in "GHC.Types.SourceText"
- , rd_bndrs :: RuleBndrs pass
, rd_act :: Activation
+ , rd_bndrs :: RuleBndrs pass
, rd_lhs :: XRec pass (HsExpr pass)
, rd_rhs :: XRec pass (HsExpr pass)
}
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -367,6 +367,11 @@ type family XXRuleDecls x
type family XHsRule x
type family XXRuleDecl x
+-- -------------------------------------
+-- RuleBndsr type families
+type family XCRuleBndrs x
+type family XXRuleBndrs x
+
-- -------------------------------------
-- RuleBndr type families
type family XCRuleBndr x
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -350,7 +350,7 @@ instance HasTrailing AnnSig where
trailing _ = []
setTrailing a _ = a
-instance HasTrailing HsRuleAnn where
+instance HasTrailing HsRuleBndrsAnn where
trailing _ = []
setTrailing a _ = a
@@ -1179,8 +1179,8 @@ lhsCaseAnnsRest k parent = fmap (\new -> parent { hsCaseAnnsRest = new })
-- ---------------------------------------------------------------------
--- data HsRuleAnn
--- = HsRuleAnn
+-- data HsRuleBndrsAnn
+-- = HsRuleBndrsAnn
-- { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn)
-- -- ^ The locations of 'forall' and '.' for forall'd type vars
-- -- Using AddEpAnn to capture possible unicode variants
@@ -1190,7 +1190,7 @@ lhsCaseAnnsRest k parent = fmap (\new -> parent { hsCaseAnnsRest = new })
-- , ra_rest :: [AddEpAnn]
-- } deriving (Data, Eq)
-lra_tyanns :: Lens HsRuleAnn (Maybe (AddEpAnn, AddEpAnn))
+lra_tyanns :: Lens HsRuleBndrsAnn (Maybe (AddEpAnn, AddEpAnn))
lra_tyanns k parent = fmap (\new -> parent { ra_tyanns = new })
(k (ra_tyanns parent))
@@ -1209,26 +1209,22 @@ lff k parent = fmap (\new -> gg new)
(k (ff parent))
-- (.) :: Lens' a b -> Lens' b c -> Lens' a c
-lra_tyanns_fst :: Lens HsRuleAnn (Maybe AddEpAnn)
+lra_tyanns_fst :: Lens HsRuleBndrsAnn (Maybe AddEpAnn)
lra_tyanns_fst = lra_tyanns . lff . lfst
-lra_tyanns_snd :: Lens HsRuleAnn (Maybe AddEpAnn)
+lra_tyanns_snd :: Lens HsRuleBndrsAnn (Maybe AddEpAnn)
lra_tyanns_snd = lra_tyanns . lff . lsnd
-lra_tmanns :: Lens HsRuleAnn (Maybe (AddEpAnn, AddEpAnn))
+lra_tmanns :: Lens HsRuleBndrsAnn (Maybe (AddEpAnn, AddEpAnn))
lra_tmanns k parent = fmap (\new -> parent { ra_tmanns = new })
(k (ra_tmanns parent))
-lra_tmanns_fst :: Lens HsRuleAnn (Maybe AddEpAnn)
+lra_tmanns_fst :: Lens HsRuleBndrsAnn (Maybe AddEpAnn)
lra_tmanns_fst = lra_tmanns . lff . lfst
-lra_tmanns_snd :: Lens HsRuleAnn (Maybe AddEpAnn)
+lra_tmanns_snd :: Lens HsRuleBndrsAnn (Maybe AddEpAnn)
lra_tmanns_snd = lra_tmanns . lff . lsnd
-lra_rest :: Lens HsRuleAnn [AddEpAnn]
-lra_rest k parent = fmap (\new -> parent { ra_rest = new })
- (k (ra_rest parent))
-
-- ---------------------------------------------------------------------
-- data GrhsAnn
@@ -2133,26 +2129,14 @@ instance ExactPrint (RuleDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do
+ exact (HsRule (an,nsrc) (L ln n) act bndrs lhs rhs) = do
(L ln' _) <- markAnnotated (L ln (nsrc, n))
- an0 <- markActivation an lra_rest act
- (an1, mtybndrs') <-
- case mtybndrs of
- Nothing -> return (an0, Nothing)
- Just bndrs -> do
- an1 <- markLensMAA' an0 lra_tyanns_fst -- AnnForall
- bndrs' <- mapM markAnnotated bndrs
- an2 <- markLensMAA' an1 lra_tyanns_snd -- AnnDot
- return (an2, Just bndrs')
-
- an2 <- markLensMAA' an1 lra_tmanns_fst -- AnnForall
- termbndrs' <- mapM markAnnotated termbndrs
- an3 <- markLensMAA' an2 lra_tmanns_snd -- AnnDot
-
+ an0 <- markActivation an lidl act
+ bndrs' <- markAnnotated bndrs
lhs' <- markAnnotated lhs
- an4 <- markEpAnnL an3 lra_rest AnnEqual
+ an1 <- markEpAnnL an0 lidl AnnEqual
rhs' <- markAnnotated rhs
- return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs')
+ return (HsRule (an1,nsrc) (L ln' n) act bndrs' lhs' rhs')
markActivation :: (Monad m, Monoid w)
=> a -> Lens a [AddEpAnn] -> Activation -> EP w m a
@@ -2223,6 +2207,26 @@ instance ExactPrint Role where
-- ---------------------------------------------------------------------
+instance ExactPrint (RuleBndrs GhcPs) where
+ getAnnotationEntry = const NoEntryVal
+ setAnnotationAnchor a _ _ _ = a
+ exact (RuleBndrs an0 mtybndrs termbndrs) = do
+ (an1, mtybndrs') <-
+ case mtybndrs of
+ Nothing -> return (an0, Nothing)
+ Just bndrs -> do
+ an1 <- markLensMAA' an0 lra_tyanns_fst -- AnnForall
+ bndrs' <- mapM markAnnotated bndrs
+ an2 <- markLensMAA' an1 lra_tyanns_snd -- AnnDot
+ return (an2, Just bndrs')
+
+ an2 <- markLensMAA' an1 lra_tmanns_fst -- AnnForall
+ termbndrs' <- mapM markAnnotated termbndrs
+ an3 <- markLensMAA' an2 lra_tmanns_snd -- AnnDot
+ return (RuleBndrs an3 mtybndrs' termbndrs')
+
+-- ---------------------------------------------------------------------
+
instance ExactPrint (RuleBndr GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
@@ -2760,6 +2764,15 @@ instance ExactPrint (Sig GhcPs) where
an3 <- markEpAnnLMS'' an2 lidl AnnClose (Just "#-}")
return (SpecSig an3 ln' typs' inl)
+ exact (SpecSigE an bndrs expr inl) = do
+ an0 <- markAnnOpen an (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
+ an1 <- markActivation an0 lidl (inl_act inl)
+ bndrs' <- markAnnotated bndrs
+ an2 <- markEpAnnL an1 lidl AnnDcolon
+ expr' <- markAnnotated expr
+ an3 <- markEpAnnLMS'' an2 lidl AnnClose (Just "#-}")
+ return (SpecSigE an3 bndrs' expr' inl)
+
exact (SpecInstSig (an,src) typ) = do
an0 <- markAnnOpen an src "{-# SPECIALISE"
an1 <- markEpAnnL an0 lidl AnnInstance
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b984c23304fb6a82255e88504302cd1ea8d1273a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b984c23304fb6a82255e88504302cd1ea8d1273a
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/20240329/c9ae3540/attachment-0001.html>
More information about the ghc-commits
mailing list