[Git][ghc/ghc][wip/az/locateda-epa-improve-2023-03-27] EPA: getting rid of tweakDelta
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Wed Jul 12 19:01:51 UTC 2023
Alan Zimmerman pushed to branch wip/az/locateda-epa-improve-2023-03-27 at Glasgow Haskell Compiler / GHC
Commits:
3163f815 by Alan Zimmerman at 2023-07-12T20:00:56+01:00
EPA: getting rid of tweakDelta
WIP at present
- - - - -
4 changed files:
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -109,9 +109,9 @@ runEP epReader action = do
defaultEPState :: EPState
defaultEPState = EPState
{ epPos = (1,1)
- , dLHS = 1
+ , dLHS = 0
, pMarkLayout = False
- , pLHS = 1
+ , pLHS = 0
, dMarkLayout = False
, dPriorEndPosition = (1,1)
, uAnchorSpan = badRealSrcSpan
@@ -519,23 +519,12 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
-- -------------------------------------------------------------------
-- start of print phase processing
- let mflush = when (flush == FlushComments) $ do
- debugM $ "flushing comments in enterAnn:" ++ showAst cs
- flushComments (getFollowingComments cs)
-
advance edp
a' <- exact a
- mflush
-
- -- end of sub-Anchor processing, start of tail end processing
- -- postCs <- cua canUpdateAnchor takeAppliedCommentsPop
- -- when (flush == NoFlushComments) $ do
- -- when ((getFollowingComments cs) /= []) $ do
-
- -- debugM $ "enterAnn:in:(anchor') =" ++ show (eloc2str anchor')
- -- debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)
- -- mapM_ printOneComment (map tokComment $ getFollowingComments cs)
- -- debugM $ "ending trailing comments"
+ when (flush == FlushComments) $ do
+ debugM $ "flushing comments in enterAnn:" ++ showAst cs
+ flushComments (getFollowingComments cs)
+ debugM $ "flushing comments in enterAnn done"
eof <- getEofPos
case eof of
@@ -544,19 +533,19 @@ enterAnn (Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
let dp = if pos == prior
then (DifferentLine 1 0)
else origDelta pos prior
- debugM $ "EOF:(pos,prior,dp) =" ++ showGhc (ss2pos pos, ss2pos prior, dp)
+ debugM $ "EOF:(pos,posEnd,prior,dp) =" ++ showGhc (ss2pos pos, ss2posEnd pos, ss2pos prior, dp)
printStringAtLsDelta dp ""
setEofPos Nothing -- Only do this once
-- Deal with exit from the current anchor
- printCommentsIn curAnchor -- Make sure all comments in the span are printed
+ when (flush == NoFlushComments) $ do
+ printCommentsIn curAnchor -- Make sure all comments in the span are printed
p1 <- getPosP
pe1 <- getPriorEndD
debugM $ "enterAnn:done:(anchor',p,pe,a) =" ++ show (eloc2str anchor', p1, pe1, astId a')
case anchor' of
- -- EpaDelta _ _ -> setPriorEndD p1
EpaDelta _ _ -> return ()
EpaSpan (RealSrcSpan rss _) -> do
setAcceptSpan False
@@ -623,6 +612,7 @@ flushComments trailing_anns = do
-- AZ:TODO: is the sort still needed?
then mapM_ printOneComment (sortComments cs)
else mapM_ (printOneComment . commentOrigDelta') cs
+ putUnallocatedComments []
debugM $ "flushing comments done"
-- ---------------------------------------------------------------------
@@ -1429,15 +1419,12 @@ printOneComment c@(Comment _str loc _r _mo) = do
dp' <- case mep of
Just (EpaDelta edp _) -> do
debugM $ "printOneComment:edp=" ++ show edp
- ddd <- fmap unTweakDelta $ adjustDeltaForOffsetM edp
- debugM $ "printOneComment:ddd=" ++ show ddd
- fmap unTweakDelta $ adjustDeltaForOffsetM edp
+ adjustDeltaForOffsetM edp
_ -> return dp
-- Start of debug printing
LayoutStartCol dOff <- getLayoutOffsetD
debugM $ "printOneComment:(dp,dp',dOff,loc)=" ++ showGhc (dp,dp',dOff,loc)
-- End of debug printing
- -- setPriorEndD (ss2posEnd (anchor loc))
updateAndApplyComment c dp'
printQueuedComment c dp'
@@ -1451,18 +1438,11 @@ unTweakDelta (DifferentLine l d) = DifferentLine l (d+1)
updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()
updateAndApplyComment (Comment str anc pp mo) dp = do
- -- debugM $ "updateAndApplyComment: (dp,anc',co)=" ++ showAst (dp,anc',co)
applyComment (Comment str anc' pp mo)
where
- -- anc' = anc { anchor_op = op}
anc' = op
(r,c) = ss2posEnd pp
- -- la = anchor anc
- -- dp'' = if r == 0
- -- then (ss2delta (r,c+0) la)
- -- else (ss2delta (r,c) la)
- -- la = anchor anc
dp'' = case anc of
EpaDelta dp1 _ -> dp1
EpaSpan (RealSrcSpan la _) ->
@@ -1551,7 +1531,6 @@ instance (ExactPrint a) => ExactPrint (LocatedA a) where
exact (L la a) = do
debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la)
a' <- markAnnotated a
- -- la' <- markALocatedA la
return (L la a')
instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where
@@ -1638,8 +1617,6 @@ instance ExactPrint (HsModule GhcPs) where
Just (pos, prior) -> do
debugM $ "am_eof:" ++ showGhc (pos, prior)
setEofPos (Just (pos, prior))
- -- let dp = origDelta pos prior
- -- printStringAtLsDelta dp ""
let anf = an0 { anns = (anns an0) { am_decls = am_decls' }}
debugM $ "HsModule, anf=" ++ showAst anf
@@ -2567,13 +2544,6 @@ instance ExactPrint (HsValBindsLR GhcPs GhcPs) where
setAnnotationAnchor a _ _ _ = a
exact (ValBinds sortKey binds sigs) = do
- -- ds <- setLayoutBoth $ withSortKeyBind sortKey
- -- (prepareListAnnotationA (bagToList binds)
- -- ++ prepareListAnnotationA sigs
- -- )
- -- let
- -- binds' = listToBag $ undynamic ds
- -- sigs' = undynamic ds
setLayoutBoth $ mapM markAnnotated $ hsDeclsValBinds (ValBinds sortKey binds sigs)
let
binds' = binds
@@ -2632,28 +2602,12 @@ prepareListAnnotationA ls = map (\b -> (realSrcSpan "aa5" $ getLocA b,go b)) ls
b' <- markAnnotated b
return (toDyn b')
--- withSortKeyBind :: (Monad m, Monoid w)
--- => AnnSortKey [(DeclTag, Int)] -> [(RealSrcSpan, EP w m Dynamic)] -> EP w m [Dynamic]
--- withSortKeyBind annSortKey xs = do
--- debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey
--- let ordered = case annSortKey of
--- NoAnnSortKey -> sortBy orderByFst xs
--- -- Just keys -> error $ "withSortKey: keys" ++ show keys
--- AnnSortKey keys -> orderByKey xs keys
--- -- `debug` ("withSortKey:" ++
--- -- showPprUnsafe (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs),
--- -- map fst xs,
--- -- keys)
--- -- )
--- mapM snd ordered
-
withSortKey :: (Monad m, Monoid w)
=> AnnSortKey [RealSrcSpan] -> [(RealSrcSpan, EP w m Dynamic)] -> EP w m [Dynamic]
withSortKey annSortKey xs = do
debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey
let ordered = case annSortKey of
NoAnnSortKey -> sortBy orderByFst xs
- -- Just keys -> error $ "withSortKey: keys" ++ show keys
AnnSortKey keys -> orderByKey xs keys
-- `debug` ("withSortKey:" ++
-- showPprUnsafe (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs),
@@ -5134,7 +5088,7 @@ setLayoutTopLevelP k = do
debugM $ "setLayoutTopLevelP entered"
oldAnchorOffset <- getLayoutOffsetP
modify (\a -> a { pMarkLayout = False
- , pLHS = 1} )
+ , pLHS = 0} )
r <- k
debugM $ "setLayoutTopLevelP:resetting"
setLayoutOffsetP oldAnchorOffset
=====================================
utils/check-exact/Main.hs
=====================================
@@ -59,7 +59,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/ghc-api/exactprint/AddDecl2.hs" (Just changeAddDecl2)
-- "../../testsuite/tests/ghc-api/exactprint/AddDecl3.hs" (Just changeAddDecl3)
-- "../../testsuite/tests/ghc-api/exactprint/LocalDecls.hs" (Just changeLocalDecls)
- -- "../../testsuite/tests/ghc-api/exactprint/LocalDecls2.hs" (Just changeLocalDecls2)
+ "../../testsuite/tests/ghc-api/exactprint/LocalDecls2.hs" (Just changeLocalDecls2)
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn3a.hs" (Just changeWhereIn3a)
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn3b.hs" (Just changeWhereIn3b)
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn3b.hs" Nothing
@@ -69,7 +69,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl4.hs" (Just addLocaLDecl4)
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl5.hs" (Just addLocaLDecl5)
-- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl6.hs" (Just addLocaLDecl6)
- "../../testsuite/tests/ghc-api/exactprint/RmDecl1.hs" (Just rmDecl1)
+ -- "../../testsuite/tests/ghc-api/exactprint/RmDecl1.hs" (Just rmDecl1)
-- "../../testsuite/tests/ghc-api/exactprint/RmDecl2.hs" (Just rmDecl2)
-- "../../testsuite/tests/ghc-api/exactprint/RmDecl3.hs" (Just rmDecl3)
-- "../../testsuite/tests/ghc-api/exactprint/RmDecl4.hs" (Just rmDecl4)
@@ -100,6 +100,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/Ppr008.hs" Nothing
-- "../../testsuite/tests/printer/Ppr009.hs" Nothing
-- "../../testsuite/tests/printer/Ppr011.hs" Nothing
+ -- "../../testsuite/tests/printer/Ppr011a.hs" Nothing
-- "../../testsuite/tests/printer/Ppr012.hs" Nothing
-- "../../testsuite/tests/printer/Ppr013.hs" Nothing
-- "../../testsuite/tests/printer/Ppr014.hs" Nothing
@@ -148,6 +149,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/
-- "../../testsuite/tests/printer/PprRecordDotSyntax3.hs" Nothing
-- "../../testsuite/tests/printer/PprRecordDotSyntax4.hs" Nothing
-- "../../testsuite/tests/printer/PprRecordDotSyntaxA.hs" Nothing
+ -- "../../testsuite/tests/printer/PprUnicodeSyntax.hs" Nothing
-- "../../testsuite/tests/printer/StarBinderAnns.hs" Nothing
-- "../../testsuite/tests/printer/T13050p.hs" Nothing
-- "../../testsuite/tests/printer/T13199.hs" Nothing
@@ -534,7 +536,7 @@ changeLocalDecls libdir (L l p) = do
os' = setEntryDP os (DifferentLine 2 0)
let sortKey = captureOrderBinds decls
let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van
- let van' = (EpAnn anc (AnnList (Just (EpaDelta (DifferentLine 1 4) [])) a b c dd) cs)
+ let van' = (EpAnn anc (AnnList (Just (EpaDelta (DifferentLine 1 5) [])) a b c dd) cs)
let binds' = (HsValBinds van'
(ValBinds sortKey (listToBag $ decl':oldBinds)
(sig':os':oldSigs)))
@@ -558,8 +560,8 @@ changeLocalDecls2 libdir (L l p) = do
replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
-> Transform (LMatch GhcPs (LHsExpr GhcPs))
replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do
- let anc = (EpaDelta (DifferentLine 1 2) [])
- let anc2 = (EpaDelta (DifferentLine 1 4) [])
+ let anc = (EpaDelta (DifferentLine 1 3) [])
+ let anc2 = (EpaDelta (DifferentLine 1 5) [])
let an = EpAnn anc
(AnnList (Just anc2) Nothing Nothing
[AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] [])
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -330,7 +330,7 @@ setEntryDP (L (EpAnnS (EpaSpan (RealSrcSpan r _)) an cs) a) dp
csd = L (EpaDelta dp []) c:cs'
lc = head $ reverse $ (L ca c:cs')
delta = case getLoc lc of
- EpaSpan (RealSrcSpan rr _) -> tweakDelta $ ss2delta (ss2pos rr) r
+ EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r
_ -> DifferentLine 1 0
line = getDeltaLine delta
col = deltaColumn delta
@@ -383,9 +383,9 @@ setEntryDPI (L (SrcSpanAnn (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) l) a) dp
cs'' = setPriorComments cs (L (EpaDelta dp []) c:cs')
lc = head $ reverse $ (L ca c:cs')
delta = case getLoc lc of
- EpaSpan (RealSrcSpan rr _) -> tweakDelta $ ss2delta (ss2pos rr) r
- EpaSpan _ -> tweakDelta (SameLine 0)
- EpaDelta dp _ -> tweakDelta dp
+ EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r
+ EpaSpan _ -> (SameLine 0)
+ EpaDelta dp _ -> dp
line = getDeltaLine delta
col = deltaColumn delta
edp' = if line == 0 then SameLine col
@@ -1329,8 +1329,8 @@ oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = do
newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (EpAnn AnnList)
newWhereAnnotation ww = do
- let anc = EpaDelta (DifferentLine 1 2) []
- let anc2 = EpaDelta (DifferentLine 1 4) []
+ let anc = EpaDelta (DifferentLine 1 3) []
+ let anc2 = EpaDelta (DifferentLine 1 5) []
let w = case ww of
WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])]
WithoutWhere -> []
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -48,8 +48,8 @@ import Types
-- |Global switch to enable debug tracing in ghc-exactprint Delta / Print
debugEnabledFlag :: Bool
--- debugEnabledFlag = True
-debugEnabledFlag = False
+debugEnabledFlag = True
+-- debugEnabledFlag = False
-- |Provide a version of trace that comes at the end of the line, so it can
-- easily be commented out when debugging different things.
@@ -108,6 +108,7 @@ pos2delta (refl,refc) (l,c) = deltaPos lo co
lo = l - refl
co = if lo == 0 then c - refc
else c
+ -- else c - 1
-- | Apply the delta to the current position, taking into account the
-- current column offset if advancing to a new line
@@ -193,21 +194,7 @@ commentOrigDelta' (Comment s (EpaSpan (RealSrcSpan la _)) pp co)
commentOrigDelta' c = c
origDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos
-origDelta pos pp = op
- where
- (r,c) = ss2posEnd pp
-
- op = if r == 0
- then ( ss2delta (r,c+1) pos)
- else (tweakDelta $ ss2delta (r,c ) pos)
-
--- ---------------------------------------------------------------------
-
--- | For comment-related deltas starting on a new line we have an
--- off-by-one problem. Adjust
-tweakDelta :: DeltaPos -> DeltaPos
-tweakDelta (SameLine d) = SameLine d
-tweakDelta (DifferentLine l d) = DifferentLine l (d-1)
+origDelta pos pp = ss2delta (ss2posEnd pp) pos
-- ---------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3163f815e39de9119553de75c2e7bd09c0177f35
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3163f815e39de9119553de75c2e7bd09c0177f35
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/20230712/078a9ef2/attachment-0001.html>
More information about the ghc-commits
mailing list