[Git][ghc/ghc][wip/az/sync-ghc-exactprint] [EPA] Sync with the ghc-exactprint repo
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Mon Mar 3 22:36:49 UTC 2025
Alan Zimmerman pushed to branch wip/az/sync-ghc-exactprint at Glasgow Haskell Compiler / GHC
Commits:
60d75003 by Alan Zimmerman at 2025-03-03T22:36:33+00:00
[EPA] Sync with the ghc-exactprint repo
This brings it into line with the changes in
https://hackage.haskell.org/package/ghc-exactprint-1.12.0.0
But also keeps the latest changes from master.
- - - - -
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
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -7,15 +8,14 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE UndecidableInstances #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates #-}
@@ -38,6 +38,7 @@ import GHC.Base (NonEmpty(..))
import GHC.Core.Coercion.Axiom (Role(..))
import qualified GHC.Data.BooleanFormula as BF
import GHC.Data.FastString
+import qualified GHC.Data.Strict as Strict
import GHC.TypeLits
import GHC.Types.Basic hiding (EP)
import GHC.Types.Fixity
@@ -106,16 +107,19 @@ runEP epReader action = do
defaultEPState :: EPState
defaultEPState = EPState
- { epPos = (1,1)
- , dLHS = 0
- , pMarkLayout = False
- , pLHS = 0
- , dMarkLayout = False
- , dPriorEndPosition = (1,1)
- , uAnchorSpan = badRealSrcSpan
+ { uAnchorSpan = badRealSrcSpan
, uExtraDP = Nothing
, uExtraDPReturn = Nothing
, pAcceptSpan = False
+
+ , epPos = (1,1)
+ , pMarkLayout = False
+ , pLHS = LayoutStartCol 1
+
+ , dPriorEndPosition = (1,1)
+ , dMarkLayout = False
+ , dLHS = LayoutStartCol 1
+
, epComments = []
, epCommentsApplied = []
, epEof = Nothing
@@ -165,7 +169,7 @@ data EPState = EPState
-- Annotation
, uExtraDP :: !(Maybe EpaLocation) -- ^ Used to anchor a
-- list
- , uExtraDPReturn :: !(Maybe DeltaPos)
+ , uExtraDPReturn :: !(Maybe (SrcSpan, DeltaPos))
-- ^ Used to return Delta version of uExtraDP
, pAcceptSpan :: Bool -- ^ When we have processed an
-- entry of EpaDelta, accept the
@@ -452,7 +456,6 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
-- delta phase variables -----------------------------------
-- Calculate offset required to get to the start of the SrcSPan
!off <- getLayoutOffsetD
- let spanStart = ss2pos curAnchor
priorEndAfterComments <- getPriorEndD
let edp' = adjustDeltaForOffset
-- Use the propagated offset if one is set
@@ -471,7 +474,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
Just (EpaDelta _ dp _) -> (dp, Nothing)
-- Replace original with desired one. Allows all
-- list entry values to be DP (1,0)
- Just (EpaSpan (RealSrcSpan r _)) -> (dp, Just dp)
+ Just (EpaSpan ss@(RealSrcSpan r _)) -> (dp, Just (ss, dp))
where
dp = adjustDeltaForOffset
off (ss2delta priorEndAfterComments r)
@@ -480,6 +483,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
when (isJust medr) $ setExtraDPReturn medr
-- ---------------------------------------------
-- Preparation complete, perform the action
+ let spanStart = ss2pos curAnchor
when (priorEndAfterComments < spanStart) (do
debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart
modify (\s -> s { dPriorEndPosition = spanStart } ))
@@ -512,8 +516,8 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
Just (pos, prior) -> do
let dp = if pos == prior
then (DifferentLine 1 0)
- else origDelta pos prior
- debugM $ "EOF:(pos,posEnd,prior,dp) =" ++ showGhc (ss2pos pos, ss2posEnd pos, ss2pos prior, dp)
+ else adjustDeltaForOffset off (origDelta pos prior)
+ debugM $ "EOF:(pos,posend,prior,off,dp) =" ++ show (ss2pos pos, ss2posEnd pos, ss2pos prior, off, dp)
printStringAtLsDelta dp ""
setEofPos Nothing -- Only do this once
@@ -542,12 +546,13 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
return after
else return []
!trailing' <- markTrailing trailing_anns
- -- mapM_ printOneComment (concatMap tokComment $ following)
addCommentsA following
-- Update original anchor, comments based on the printing process
-- TODO:AZ: probably need to put something appropriate in instead of noSrcSpan
- let newAnchor = EpaDelta noSrcSpan edp []
+ let newAnchor = case anchor' of
+ EpaSpan s -> EpaDelta s edp []
+ _ -> EpaDelta noSrcSpan edp []
let r = case canUpdateAnchor of
CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs)
CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments
@@ -695,7 +700,7 @@ printStringAtRsC capture pa str = do
debugM $ "printStringAtRsC:p'=" ++ showAst p'
debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta noSrcSpan p' NoComments)
debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta noSrcSpan p' (map comment2LEpaComment cs'))
- return (EpaDelta noSrcSpan p' (map comment2LEpaComment cs'))
+ return (EpaDelta (RealSrcSpan pa Strict.Nothing) p' (map comment2LEpaComment cs'))
printStringAtRs' :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m ()
printStringAtRs' pa str = printStringAtRsC NoCaptureComments pa str >> return ()
@@ -1385,7 +1390,7 @@ printOneComment c@(Comment _str loc _r _mo) = do
dp' <- case mep of
Just (EpaDelta _ edp _) -> do
debugM $ "printOneComment:edp=" ++ show edp
- adjustDeltaForOffsetM edp
+ return edp
_ -> return dp
-- Start of debug printing
LayoutStartCol dOff <- getLayoutOffsetD
@@ -1398,28 +1403,10 @@ updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()
updateAndApplyComment (Comment str anc pp mo) dp = do
applyComment (Comment str anc' pp mo)
where
- (r,c) = ss2posEnd pp
- dp'' = case anc of
- EpaDelta _ dp1 _ -> dp1
- EpaSpan (RealSrcSpan la _) ->
- if r == 0
- then (ss2delta (r,c+0) la)
- else (ss2delta (r,c) la)
- EpaSpan (UnhelpfulSpan _) -> SameLine 0
- dp' = case anc of
- EpaSpan (RealSrcSpan r1 _) ->
- if pp == r1
- then dp
- else dp''
- _ -> dp''
- op' = case dp' of
- SameLine n -> if n >= 0
- then EpaDelta noSrcSpan dp' NoComments
- else EpaDelta noSrcSpan dp NoComments
- _ -> EpaDelta noSrcSpan dp' NoComments
- anc' = if str == "" && op' == EpaDelta noSrcSpan (SameLine 0) NoComments -- EOF comment
- then EpaDelta noSrcSpan dp NoComments
- else EpaDelta noSrcSpan dp NoComments
+ ss = case anc of
+ EpaSpan ss' -> ss'
+ _ -> noSrcSpan
+ anc' = EpaDelta ss dp NoComments
-- ---------------------------------------------------------------------
@@ -1459,11 +1446,6 @@ commentAllocationIn ss = do
markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast
markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a
--- ---------------------------------------------------------------------
-
-markTopLevelList :: (Monad m, Monoid w) => ExactPrint ast => [ast] -> EP w m [ast]
-markTopLevelList ls = mapM (\a -> setLayoutTopLevelP $ markAnnotated a) ls
-
-- ---------------------------------------------------------------------
-- End of utility functions
-- ---------------------------------------------------------------------
@@ -1540,11 +1522,11 @@ instance ExactPrint (HsModule GhcPs) where
an0 <- markLensTok an lam_mod
m' <- markAnnotated m
- mdeprec' <- setLayoutTopLevelP $ markAnnotated mdeprec
+ mdeprec' <- markAnnotated mdeprec
- mexports' <- setLayoutTopLevelP $ markAnnotated mexports
+ mexports' <- markAnnotated mexports
- an1 <- setLayoutTopLevelP $ markLensTok an0 lam_where
+ an1 <- markLensTok an0 lam_where
return (an1, Just m', mdeprec', mexports')
@@ -1595,8 +1577,8 @@ instance ExactPrint HsModuleImpDecls where
setAnnotationAnchor mid _anc _ cs = mid { id_cs = priorComments cs ++ getFollowingComments cs }
`debug` ("HsModuleImpDecls.setAnnotationAnchor:cs=" ++ showAst cs)
exact (HsModuleImpDecls cs imports decls) = do
- imports' <- markTopLevelList imports
- decls' <- markTopLevelList (filter notDocDecl decls)
+ imports' <- mapM markAnnotated imports
+ decls' <- mapM markAnnotated (filter notDocDecl decls)
return (HsModuleImpDecls cs imports' decls')
@@ -2535,8 +2517,7 @@ instance ExactPrint (HsLocalBinds GhcPs) where
setAnnotationAnchor a _ _ _ = a
exact (HsValBinds an valbinds) = do
- debugM $ "exact HsValBinds: an=" ++ showAst an
- an0 <- markLensFun' an lal_rest markEpToken
+ an0 <- markLensFun' an lal_rest markEpToken -- 'where'
case al_anchor $ anns an of
Just anc -> do
@@ -2548,9 +2529,9 @@ instance ExactPrint (HsLocalBinds GhcPs) where
medr <- getExtraDPReturn
an2 <- case medr of
Nothing -> return an1
- Just dp -> do
+ Just (ss,dp) -> do
setExtraDPReturn Nothing
- return $ an1 { anns = (anns an1) { al_anchor = Just (EpaDelta noSrcSpan dp []) }}
+ return $ an1 { anns = (anns an1) { al_anchor = Just (EpaDelta ss dp []) }}
return (HsValBinds an2 valbinds')
exact (HsIPBinds an bs) = do
@@ -4246,7 +4227,7 @@ printUnicode anc n = do
-- TODO: unicode support?
"forall" -> if spanLength (epaLocationRealSrcSpan anc) == 1 then "∀" else "forall"
s -> s
- loc <- printStringAtAAC NoCaptureComments (EpaDelta noSrcSpan (SameLine 0) []) str
+ loc <- printStringAtAAC NoCaptureComments (EpaDelta (getHasLoc anc) (SameLine 0) []) str
case loc of
EpaSpan _ -> return anc
EpaDelta ss dp [] -> return $ EpaDelta ss dp []
@@ -4901,18 +4882,6 @@ setLayoutBoth k = do
, pLHS = oldAnchorOffset} )
k <* reset
--- Use 'local', designed for this
-setLayoutTopLevelP :: (Monad m, Monoid w) => EP w m a -> EP w m a
-setLayoutTopLevelP k = do
- debugM $ "setLayoutTopLevelP entered"
- oldAnchorOffset <- getLayoutOffsetP
- modify (\a -> a { pMarkLayout = False
- , pLHS = 0} )
- r <- k
- debugM $ "setLayoutTopLevelP:resetting"
- setLayoutOffsetP oldAnchorOffset
- return r
-
------------------------------------------------------------------------
getPosP :: (Monad m, Monoid w) => EP w m Pos
@@ -4931,10 +4900,10 @@ setExtraDP md = do
debugM $ "setExtraDP:" ++ show md
modify (\s -> s {uExtraDP = md})
-getExtraDPReturn :: (Monad m, Monoid w) => EP w m (Maybe DeltaPos)
+getExtraDPReturn :: (Monad m, Monoid w) => EP w m (Maybe (SrcSpan, DeltaPos))
getExtraDPReturn = gets uExtraDPReturn
-setExtraDPReturn :: (Monad m, Monoid w) => Maybe DeltaPos -> EP w m ()
+setExtraDPReturn :: (Monad m, Monoid w) => Maybe (SrcSpan, DeltaPos) -> EP w m ()
setExtraDPReturn md = do
debugM $ "setExtraDPReturn:" ++ show md
modify (\s -> s {uExtraDPReturn = md})
=====================================
utils/check-exact/Main.hs
=====================================
@@ -533,7 +533,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 noSrcSpan (DifferentLine 1 5) [])) a b c dd) cs)
+ let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b c dd) cs)
let binds' = (HsValBinds van'
(ValBinds sortKey (decl':oldBinds)
(sig':os':oldSigs)))
@@ -557,8 +557,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 noSrcSpan (DifferentLine 1 3) [])
- let anc2 = (EpaDelta noSrcSpan (DifferentLine 1 5) [])
+ let anc = (EpaDelta noSrcSpan (DifferentLine 1 2) [])
+ let anc2 = (EpaDelta noSrcSpan (DifferentLine 1 4) [])
let an = EpAnn anc
(AnnList (Just anc2) ListNone
[]
@@ -937,13 +937,13 @@ addClassMethod :: Changer
addClassMethod libdir lp = do
Right sig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int")
Right decl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
- let decl' = setEntryDP decl (DifferentLine 1 3)
- let sig' = setEntryDP sig (DifferentLine 2 3)
+ let decl' = setEntryDP decl (DifferentLine 1 2)
+ let sig' = setEntryDP sig (DifferentLine 2 2)
let doAddMethod = do
let
[cd] = hsDecls lp
(f1:f2s:f2d:_) = hsDecls cd
- f2s' = setEntryDP f2s (DifferentLine 2 3)
+ f2s' = setEntryDP f2s (DifferentLine 2 2)
cd' = replaceDecls cd [f1, sig', decl', f2s', f2d]
lp' = replaceDecls lp [cd']
return lp'
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -258,12 +258,15 @@ setEntryDP (L (EpAnn (EpaSpan ss) an (EpaComments [])) a) dp
setEntryDP (L (EpAnn (EpaDelta ss d csd) an cs) a) dp
= L (EpAnn (EpaDelta ss d' csd') an cs') a
where
+ -- I suspect we should assume the comments are already in the
+ -- right place, and just set the entry DP for this case. This
+ -- avoids surprises from the caller.
(d', csd', cs') = case cs of
EpaComments (h:t) ->
let
(dp0,c') = go h
in
- (dp0, c':t++csd, EpaComments [])
+ (dp0, csd, EpaComments (c':t))
EpaComments [] ->
(dp, csd, cs)
EpaCommentsBalanced (h:t) ts ->
@@ -299,7 +302,9 @@ setEntryDP (L (EpAnn (EpaSpan ss@(RealSrcSpan r _)) an cs) a) dp
line = getDeltaLine delta
col = deltaColumn delta
edp' = if line == 0 then SameLine col
- else DifferentLine line col
+ else DifferentLine line (col - 1)
+ -- At the top level the layout offset is 1, adjust for it
+ -- TODO: what about the layout offset for nested items?
edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (ss2pos $ epaLocationRealSrcSpan $ getLoc lc), r))
@@ -330,17 +335,23 @@ setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP
-- ---------------------------------------------------------------------
--- |Take the annEntryDelta associated with the first item and associate it with the second.
--- Also transfer any comments occurring before it.
+-- |Take the annEntryDelta associated with the first item and
+-- associate it with the second. Also transfer any comments occurring
+-- before it.
transferEntryDP :: (Typeable t1, Typeable t2)
=> LocatedAn t1 a -> LocatedAn t2 b -> (LocatedAn t2 b)
-transferEntryDP (L (EpAnn anc1 an1 cs1) _) (L (EpAnn _anc2 an2 cs2) b) =
+transferEntryDP (L (EpAnn anc1 an1 cs1) _) (L (EpAnn anc2 an2 cs2) b) =
+ -- Note: the EpaDelta version of an EpaLocation contains the original
+ -- SrcSpan. We must preserve that.
+ let anc1' = case (anc1,anc2) of
+ (EpaDelta _ dp cs, EpaDelta ss2 _ _) -> EpaDelta ss2 dp cs
+ (_, _) -> anc1
-- Problem: if the original had preceding comments, blindly
-- transferring the location is not correct
- case priorComments cs1 of
- [] -> (L (EpAnn anc1 (combine an1 an2) cs2) b)
+ in case priorComments cs1 of
+ [] -> (L (EpAnn anc1' (combine an1 an2) cs2) b)
-- TODO: what happens if the receiving side already has comments?
- (L _ _:_) -> (L (EpAnn anc1 (combine an1 an2) (cs1 <> cs2)) b)
+ (L _ _:_) -> (L (EpAnn anc1' (combine an1 an2) (cs1 <> cs2)) b)
-- |If a and b are the same type return first arg, else return second
@@ -519,7 +530,7 @@ balanceCommentsA la1 la2 = (la1', la2')
anc2 = comments an2
(p1,m1,f1) = splitComments (anchorFromLocatedA la1) anc1
- cs1p = priorCommentsDeltas (anchorFromLocatedA la1) p1
+ cs1p = priorCommentsDeltas (anchorFromLocatedA la1) p1
-- Split cs1 following comments into those before any
-- TrailingAnn's on an1, and any after
@@ -1103,8 +1114,8 @@ oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = an'
newWhereAnnotation :: WithWhere -> (EpAnn (AnnList (EpToken "where")))
newWhereAnnotation ww = an
where
- anc = EpaDelta noSrcSpan (DifferentLine 1 3) []
- anc2 = EpaDelta noSrcSpan (DifferentLine 1 5) []
+ anc = EpaDelta noSrcSpan (DifferentLine 1 2) []
+ anc2 = EpaDelta noSrcSpan (DifferentLine 1 4) []
w = case ww of
WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) [])
WithoutWhere -> NoEpTok
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -141,7 +141,7 @@ undelta (l,_) (DifferentLine dl dc) (LayoutStartCol co) = (fl,fc)
-- ---------------------------------------------------------------------
adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos
-adjustDeltaForOffset _colOffset dp@(SameLine _) = dp
+adjustDeltaForOffset _colOffset dp@(SameLine _) = dp
adjustDeltaForOffset (LayoutStartCol colOffset) (DifferentLine l c)
= DifferentLine l (c - colOffset)
@@ -196,14 +196,17 @@ isPointSrcSpan ss = spanLength ss == 0
-- does not already have one.
commentOrigDelta :: LEpaComment -> LEpaComment
commentOrigDelta (L (EpaSpan ss@(RealSrcSpan la _)) (GHC.EpaComment t pp))
- = (L (EpaDelta ss dp NoComments) (GHC.EpaComment t pp))
- `debug` ("commentOrigDelta: (la, pp, r,c, dp)=" ++ showAst (la, pp, r,c, dp))
+ = (L (EpaDelta ss dp' NoComments) (GHC.EpaComment t pp))
+ `debug` ("commentOrigDelta: (la, pp, r,c, dp, dp')=" ++ showAst (la, pp, r,c, dp, dp'))
where
(r,c) = ss2posEnd pp
dp = if r == 0
then (ss2delta (r,c+1) la)
else (ss2delta (r,c) la)
+ dp' = case dp of
+ SameLine _ -> dp
+ DifferentLine l cc -> DifferentLine l (cc - 1)
commentOrigDelta c = c
origDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/60d75003576e087facee408c6884decd4afb2cba
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/60d75003576e087facee408c6884decd4afb2cba
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/20250303/e6629216/attachment-0001.html>
More information about the ghc-commits
mailing list