[Git][ghc/ghc][wip/T24359] fix exact-print for SpecPragE
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Mon Nov 4 16:57:04 UTC 2024
sheaf pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
390b6b02 by sheaf at 2024-11-04T17:56:56+01:00
fix exact-print for SpecPragE
- - - - -
1 changed file:
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1145,17 +1145,15 @@ lhsCaseAnnOf k parent = fmap (\new -> parent { hsCaseAnnOf = new })
-- ---------------------------------------------------------------------
--- data HsRuleAnn
--- = HsRuleAnn
--- { ra_tyanns :: Maybe (TokForall, EpToken ".")
--- , ra_tmanns :: Maybe (TokForall, EpToken ".")
--- , ra_equal :: EpToken "="
--- , ra_rest :: ActivationAnn
--- } deriving (Data, Eq)
-
-lra_tyanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken "."))
-lra_tyanns k parent = fmap (\new -> parent { ra_tyanns = new })
- (k (ra_tyanns parent))
+-- data HsRuleBndrsAnn
+-- = HsRuleBndrsAnn
+-- { rb_tyanns :: Maybe (TokForall, EpToken ".")
+-- , rb_tmanns :: Maybe (TokForall, EpToken ".")
+-- }
+
+lrb_tyanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken "."))
+lrb_tyanns k parent = fmap (\new -> parent { rb_tyanns = new })
+ (k (rb_tyanns parent))
ff :: Maybe (a,b) -> (Maybe a,Maybe b)
ff Nothing = (Nothing, Nothing)
@@ -1172,21 +1170,21 @@ lff k parent = fmap (\new -> gg new)
(k (ff parent))
-- (.) :: Lens' a b -> Lens' b c -> Lens' a c
-lra_tyanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall)
-lra_tyanns_fst = lra_tyanns . lff . lfst
+lrb_tyanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall)
+lrb_tyanns_fst = lrb_tyanns . lff . lfst
-lra_tyanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken "."))
-lra_tyanns_snd = lra_tyanns . lff . lsnd
+lrb_tyanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken "."))
+lrb_tyanns_snd = lrb_tyanns . lff . lsnd
-lra_tmanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken "."))
-lra_tmanns k parent = fmap (\new -> parent { ra_tmanns = new })
- (k (ra_tmanns parent))
+lrb_tmanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken "."))
+lrb_tmanns k parent = fmap (\new -> parent { rb_tmanns = new })
+ (k (rb_tmanns parent))
-lra_tmanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall)
-lra_tmanns_fst = lra_tmanns . lff . lfst
+lrb_tmanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall)
+lrb_tmanns_fst = lrb_tmanns . lff . lfst
-lra_tmanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken "."))
-lra_tmanns_snd = lra_tmanns . lff . lsnd
+lrb_tmanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken "."))
+lrb_tmanns_snd = lrb_tmanns . lff . lsnd
-- ---------------------------------------------------------------------
-- data GrhsAnn
@@ -2030,25 +2028,14 @@ instance ExactPrint (RuleDecl GhcPs) where
getAnnotationEntry _ = NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (HsRule (an,nsrc) (L ln n) act bndrs lhs rhs) = do
+ exact (HsRule ((ann_act, ann_eq),nsrc) (L ln n) act bndrs lhs rhs) = do
(L ln' _) <- markAnnotated (L ln (nsrc, n))
- (an1, bndrs') <-
- case bndrs of
- Nothing -> return (an0, Nothing)
- Just bndrs -> do
- an1 <- markLensFun an0 lra_tyanns_fst (\mt -> mapM markEpUniToken mt) -- AnnForall
- bndrs' <- mapM markAnnotated bndrs
- an2 <- markLensFun an1 lra_tyanns_snd (\mt -> mapM markEpToken mt) -- AnnDot
- return (an2, Just bndrs')
+ ann_act' <- markActivation ann_act act
+ bndrs' <- markAnnotated bndrs
lhs' <- markAnnotated lhs
- return (HsRule (an1,nsrc) (L ln' n) act bndrs' lhs' rhs')
-
-
-markActivationL :: (Monad m, Monoid w)
- => a -> Lens a ActivationAnn -> Activation -> EP w m a
-markActivationL a l act = do
- new <- markActivation (view l a) act
- return (set l new a)
+ ann_eq' <- markEpToken ann_eq
+ rhs' <- markAnnotated rhs
+ return (HsRule ((ann_act', ann_eq'),nsrc) (L ln' n) act bndrs' lhs' rhs')
markActivation :: (Monad m, Monoid w)
=> ActivationAnn -> Activation -> EP w m ActivationAnn
@@ -2123,19 +2110,19 @@ instance ExactPrint (RuleBndrs GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
exact (RuleBndrs an0 mtybndrs termbndrs) = do
- (an1, mtybndrs') <-
+ (an2, mtybndrs') <-
case mtybndrs of
Nothing -> return (an0, Nothing)
Just bndrs -> do
- an1 <- markLensMAA' an0 lra_tyanns_fst -- AnnForall
+ an1 <- markLensFun an0 lrb_tyanns_fst (traverse markEpUniToken) -- AnnForall
bndrs' <- mapM markAnnotated bndrs
- an2 <- markLensMAA' an1 lra_tyanns_snd -- AnnDot
+ an2 <- markLensFun an1 lrb_tyanns_snd (traverse markEpToken) -- AnnDot
return (an2, Just bndrs')
- an2 <- markLensMAA' an1 lra_tmanns_fst -- AnnForall
+ an3 <- markLensFun an2 lrb_tmanns_fst (traverse markEpUniToken) -- AnnForall
termbndrs' <- mapM markAnnotated termbndrs
- an3 <- markLensMAA' an2 lra_tmanns_snd -- AnnDot
- return (RuleBndrs an3 mtybndrs' termbndrs')
+ an4 <- markLensFun an3 lrb_tmanns_snd (traverse markEpToken) -- AnnDot
+ return (RuleBndrs an4 mtybndrs' termbndrs')
-- ---------------------------------------------------------------------
@@ -2704,21 +2691,21 @@ instance ExactPrint (Sig GhcPs) where
o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
act' <- markActivation act (inl_act inl)
ln' <- markAnnotated ln
- dc' <- markEpUniToken dc
+ dc' <- traverse markEpUniToken dc
typs' <- markAnnotated typs
c' <- markEpToken c
return (SpecSig (AnnSpecSig o' c' dc' act') 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)
+ exact (SpecSigE (AnnSpecSig o c dc act) bndrs expr inl) = do
+ o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE
+ act' <- markActivation act (inl_act inl)
bndrs' <- markAnnotated bndrs
- an2 <- markEpAnnL an1 lidl AnnDcolon
+ dc' <- traverse markEpUniToken dc
expr' <- markAnnotated expr
- an3 <- markEpAnnLMS'' an2 lidl AnnClose (Just "#-}")
- return (SpecSigE an3 bndrs' expr' inl)
+ c' <- markEpToken c
+ return (SpecSigE (AnnSpecSig o' c' dc' act') bndrs' expr' inl)
- exact (SpecInstSig (an,src) typ) = do
+ exact (SpecInstSig ((o,i,c),src) typ) = do
o' <- markAnnOpen'' o src "{-# SPECIALISE"
i' <- markEpToken i
typ' <- markAnnotated typ
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/390b6b02c2b0c921059ea413b40af2b6ca82c90c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/390b6b02c2b0c921059ea413b40af2b6ca82c90c
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/20241104/0e00af21/attachment-0001.html>
More information about the ghc-commits
mailing list