[Git][ghc/ghc][wip/az/exactprint-epalocation-for-anchor] 2 commits: EPA: remove anchor and anchor_op
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Thu Dec 8 23:23:24 UTC 2022
Alan Zimmerman pushed to branch wip/az/exactprint-epalocation-for-anchor at Glasgow Haskell Compiler / GHC
Commits:
19bb5840 by Alan Zimmerman at 2022-12-08T21:15:55+00:00
EPA: remove anchor and anchor_op
- - - - -
414268f5 by Alan Zimmerman at 2022-12-08T23:22:38+00:00
Remove Anchor = EpaLocation type synonym
- - - - -
11 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Types.hs
- utils/check-exact/Utils.hs
- utils/check-ppr/Main.hs
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -4249,7 +4249,7 @@ glA = getLocA
glN :: LocatedN a -> SrcSpan
glN = getLocA
-glR :: Located a -> Anchor
+glR :: Located a -> EpaLocation
glR la = spanAsAnchor$ getLoc la
glAA :: Located a -> EpaLocation
@@ -4258,16 +4258,16 @@ glAA = srcSpan2e . getLoc
glRR :: Located a -> RealSrcSpan
glRR = realSrcSpan . getLoc
-glAR :: LocatedAn t a -> Anchor
+glAR :: LocatedAn t a -> EpaLocation
glAR la = spanAsAnchor $ getLocA la
-glNR :: LocatedN a -> Anchor
+glNR :: LocatedN a -> EpaLocation
glNR ln = spanAsAnchor $ getLocA ln
glNRR :: LocatedN a -> EpaLocation
glNRR = srcSpan2e . getLocA
-anc :: RealSrcSpan -> Anchor
+anc :: RealSrcSpan -> EpaLocation
anc r = EpaSpan r Strict.Nothing -- AZ:DANGER
acs :: MonadP m => (EpAnnComments -> Located a) -> m (Located a)
@@ -4397,7 +4397,7 @@ hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList
hsDoAnn (L l _) (L ll _) kw
= AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] []
-listAsAnchor :: [LocatedAn t a] -> Anchor
+listAsAnchor :: [LocatedAn t a] -> EpaLocation
listAsAnchor [] = spanAsAnchor noSrcSpan
listAsAnchor (L l _:_) = spanAsAnchor (locA l)
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -17,8 +17,7 @@ module GHC.Parser.Annotation (
TokenLocation(..),
DeltaPos(..), deltaPos, getDeltaLine,
- EpAnn(..), Anchor, AnchorOperation(..),
- anchor, anchor_op,
+ EpAnn(..),
spanAsAnchor, realSpanAsAnchor,
noAnn,
@@ -453,7 +452,7 @@ epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan"
epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation
epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) Strict.Nothing
-epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) Strict.Nothing
+epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = anc
instance Outputable EpaLocation where
ppr (EpaSpan r _) = text "EpaSpan" <+> ppr r
@@ -498,7 +497,7 @@ instance Outputable AddEpAnn where
-- new AST fragments out of old ones, and have them still printed out
-- in a precise way.
data EpAnn ann
- = EpAnn { entry :: !Anchor
+ = EpAnn { entry :: !EpaLocation
-- ^ Base location for the start of the syntactic element
-- holding the annotations.
, anns :: !ann -- ^ Annotations added by the Parser
@@ -525,37 +524,16 @@ data EpAnn ann
-- , anchor_op :: AnchorOperation }
-- deriving (Data, Eq, Show)
-type Anchor = EpaLocation -- Transitional
+-- type Anchor = EpaLocation -- Transitional
-anchor :: Anchor -> RealSrcSpan
-anchor (EpaSpan r _) = r
-anchor (EpaDelta _ _) = panic "anchor"
--- anchor (EpaDelta _ _) = placeholderRealSpan
-
--- AZ:TODO: remove AnchorOperation
-anchor_op :: Anchor -> AnchorOperation
-anchor_op (EpaSpan _ _) = UnchangedAnchor
-anchor_op (EpaDelta dp _) = MovedAnchor dp
-
-
--- | If tools modify the parsed source, the 'MovedAnchor' variant can
--- directly provide the spacing for this item relative to the previous
--- one when printing. This allows AST fragments with a particular
--- anchor to be freely moved, without worrying about recalculating the
--- appropriate anchor span.
-data AnchorOperation = UnchangedAnchor
- | MovedAnchor DeltaPos
- deriving (Data, Eq, Show)
-
-
-spanAsAnchor :: SrcSpan -> Anchor
+spanAsAnchor :: SrcSpan -> EpaLocation
spanAsAnchor (RealSrcSpan s b) = EpaSpan s b
spanAsAnchor _ = noSpanAnchor
-realSpanAsAnchor :: RealSrcSpan -> Anchor
+realSpanAsAnchor :: RealSrcSpan -> EpaLocation
realSpanAsAnchor s = EpaSpan s Strict.Nothing -- AZ:DANGER
-noSpanAnchor :: Anchor
+noSpanAnchor :: EpaLocation
noSpanAnchor = EpaDelta (SameLine 0) []
-- ---------------------------------------------------------------------
@@ -574,7 +552,7 @@ data EpAnnComments = EpaComments
, followingComments :: ![LEpaComment] }
deriving (Data, Eq)
-type LEpaComment = GenLocated Anchor EpaComment
+type LEpaComment = GenLocated EpaLocation EpaComment
emptyComments :: EpAnnComments
emptyComments = EpaComments []
@@ -680,7 +658,7 @@ data AnnListItem
-- keywords such as 'where'.
data AnnList
= AnnList {
- al_anchor :: Maybe Anchor, -- ^ start point of a list having layout
+ al_anchor :: Maybe EpaLocation, -- ^ start point of a list having layout
al_open :: Maybe AddEpAnn,
al_close :: Maybe AddEpAnn,
al_rest :: [AddEpAnn], -- ^ context, such as 'where' keyword
@@ -1022,7 +1000,7 @@ realSpanFromAnns as = go Nothing as
go acc (AddEpAnn _ (EpaSpan s _):rest) = go (combine acc s) rest
go acc (AddEpAnn _ (EpaDelta _ _):rest) = go acc rest
-widenAnchor :: Anchor -> [AddEpAnn] -> Anchor
+widenAnchor :: EpaLocation -> [AddEpAnn] -> EpaLocation
widenAnchor (EpaSpan s b) as = EpaSpan (widenRealSpan s as) b
widenAnchor a@(EpaDelta _ _) as = case (realSpanFromAnns as) of
Nothing -> a
@@ -1031,11 +1009,11 @@ widenAnchor a@(EpaDelta _ _) as = case (realSpanFromAnns as) of
-- widenAnchorR :: Anchor -> RealSrcSpan -> Anchor
-- widenAnchorR (Anchor s op) r = Anchor (combineRealSrcSpans s r) op
-widenAnchorR :: Anchor -> RealSrcSpan -> Anchor
+widenAnchorR :: EpaLocation -> RealSrcSpan -> EpaLocation
widenAnchorR (EpaSpan s bs) r = EpaSpan (combineRealSrcSpans s r) bs
widenAnchorR (EpaDelta _ _) r = EpaSpan r Strict.Nothing -- AZ:DANGER
-widenAnchorS :: Anchor -> SrcSpan -> Anchor
+widenAnchorS :: EpaLocation -> SrcSpan -> EpaLocation
widenAnchorS (EpaSpan s bs) (RealSrcSpan r br) = EpaSpan (combineRealSrcSpans s r) (bs <> br)
widenAnchorS (EpaDelta _ _) (RealSrcSpan r b) = EpaSpan r b
widenAnchorS anc _ = anc
@@ -1266,18 +1244,11 @@ instance (Outputable a) => Outputable (EpAnn a) where
instance Outputable NoEpAnns where
ppr NoEpAnns = text "NoEpAnns"
--- instance Outputable Anchor where
--- ppr (Anchor a o) = text "Anchor" <+> ppr a <+> ppr o
-
-instance Outputable AnchorOperation where
- ppr UnchangedAnchor = text "UnchangedAnchor"
- ppr (MovedAnchor d) = text "MovedAnchor" <+> ppr d
-
instance Outputable DeltaPos where
ppr (SameLine c) = text "SameLine" <+> ppr c
ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c
-instance Outputable (GenLocated Anchor EpaComment) where
+instance Outputable (GenLocated EpaLocation EpaComment) where
ppr (L l c) = text "L" <+> ppr l <+> ppr c
instance Outputable EpAnnComments where
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -3674,6 +3674,10 @@ allocateComments ss comment_q =
in
(comment_q', reverse newAnns)
+anchor :: EpaLocation -> RealSrcSpan
+anchor (EpaSpan r _) = r
+anchor (EpaDelta _ _) = panic "anchor"
+
allocatePriorComments
:: RealSrcSpan
-> [LEpaComment]
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -483,13 +483,13 @@ add_where an@(AddEpAnn _ (EpaSpan rs rb)) EpAnnNotUsed cs
add_where (AddEpAnn _ (EpaDelta _ _)) _ _ = panic "add_where"
-- EpaDelta should only be used for transformations
-valid_anchor :: Anchor -> Bool
+valid_anchor :: EpaLocation -> Bool
valid_anchor (EpaSpan _ _) = True
valid_anchor (EpaDelta _ _) = False
-- If the decl list for where binds is empty, the anchor ends up
-- invalid. In this case, use the parent one
-patch_anchor :: RealSrcSpan -> Anchor -> Anchor
+patch_anchor :: RealSrcSpan -> EpaLocation -> EpaLocation
patch_anchor r (EpaDelta _ _) = EpaSpan r Strict.Nothing -- AZ:DANGER
patch_anchor r1 (EpaSpan r0 b0) = EpaSpan r b0
where
@@ -500,9 +500,9 @@ fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed
fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)
= (EpAnn (widenAnchor anchor (map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs)
--- | The 'Anchor' for a stmtlist is based on either the location or
+-- | The 'EpaLocation' for a stmtlist is based on either the location or
-- the first semicolon annotion.
-stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Maybe Anchor
+stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Maybe EpaLocation
stmtsAnchor (L (RealSrcSpan l br) ((ConsOL (AddEpAnn _ (EpaSpan r bs)) _), _))
= Just $ widenAnchorS (EpaSpan l br) (RealSrcSpan r bs)
stmtsAnchor (L (RealSrcSpan l br) _) = Just $ EpaSpan l br
@@ -1042,13 +1042,20 @@ checkTyClHdr is_cls ty
newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN
newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) =
let
- lr = combineRealSrcSpans (realSrcSpan l) (anchor as)
+ lr = case as of
+ EpaSpan r _ -> combineRealSrcSpans (realSrcSpan l) r
+ EpaDelta _ _ -> realSrcSpan l -- This should not occur while parsing
an = (EpAnn (EpaSpan lr Strict.Nothing) (NameAnn NameParens o (srcSpan2e l) c []) cs) --AZ:DANGER
in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
newAnns _ EpAnnNotUsed = panic "missing AnnParen"
newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) =
let
- lr = combineRealSrcSpans (anchor ap) (anchor as)
+ -- lr = combineRealSrcSpans (anchor ap) (anchor as)
+ lr = case (ap, as) of
+ (EpaSpan pr _pb, EpaSpan sr _sb) -> combineRealSrcSpans pr sr
+ (EpaSpan pr _pb, EpaDelta _sr _sb) -> pr
+ (EpaDelta _ _pb, EpaSpan sr _sb) -> sr
+ (EpaDelta _ _pb, EpaDelta _r _sb) -> panic "newAnns" -- Should not happen while parsing
an = (EpAnn (ap Semi.<> as) (NameAnn NameParens o (srcSpan2e l) c ta) (csp Semi.<> cs))
in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -110,6 +110,7 @@ defaultEPState = EPState
, dPriorEndPosition = (1,1)
, uAnchorSpan = badRealSrcSpan
, uExtraDP = Nothing
+ , pAcceptSpan = False
, epComments = []
, epCommentsApplied = []
}
@@ -168,8 +169,15 @@ data EPState = EPState
{ uAnchorSpan :: !RealSrcSpan -- ^ in pre-changed AST
-- reference frame, from
-- Annotation
- , uExtraDP :: !(Maybe Anchor) -- ^ Used to anchor a
+ , uExtraDP :: !(Maybe EpaLocation) -- ^ Used to anchor a
-- list
+ , pAcceptSpan :: Bool -- ^ When we have processed an
+ -- entry of EpaDelta, accept the
+ -- next `EpaSpan` start as the
+ -- current output position. i.e. do
+ -- not advance epPos. Achieved by
+ -- setting dPriorEndPosition to the
+ -- end of the span.
-- Print phase
, epPos :: !Pos -- ^ Current output position
@@ -213,14 +221,14 @@ data CanUpdateAnchor = CanUpdateAnchor
| NoCanUpdateAnchor
deriving (Eq, Show)
-data Entry = Entry Anchor EpAnnComments FlushComments CanUpdateAnchor
+data Entry = Entry EpaLocation EpAnnComments FlushComments CanUpdateAnchor
| NoEntryVal
-- | For flagging whether to capture comments in an EpaDelta or not
data CaptureComments = CaptureComments
| NoCaptureComments
-mkEntry :: Anchor -> EpAnnComments -> Entry
+mkEntry :: EpaLocation -> EpAnnComments -> Entry
mkEntry anc cs = Entry anc cs NoFlushComments CanUpdateAnchor
instance HasEntry (SrcSpanAnn' (EpAnn an)) where
@@ -254,6 +262,7 @@ cua NoCanUpdateAnchor _ = return []
-- | "Enter" an annotation, by using the associated 'anchor' field as
-- the new reference point for calculating all DeltaPos positions.
+-- This is the heart of the exact printing process.
--
-- This is combination of the ghc=exactprint Delta.withAST and
-- Print.exactPC functions and effectively does the delta processing
@@ -266,10 +275,19 @@ enterAnn NoEntryVal a = do
debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a)
return r
enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
+ acceptSpan <- getAcceptSpan
+ setAcceptSpan False
+ case anchor' of
+ EpaDelta _ _ -> setAcceptSpan True
+ EpaSpan _ _ -> return ()
p <- getPosP
debugM $ "enterAnn:starting:(p,a) =" ++ show (p, astId a)
-- debugM $ "enterAnn:(cs) =" ++ showGhc (cs)
- let curAnchor = anchor anchor' -- As a base for the current AST element
+ -- let curAnchor = anchor anchor' -- As a base for the current AST element
+ priorAnchor <- getAnchorU
+ let curAnchor = case anchor' of -- As a base for the current AST element
+ EpaSpan r _ -> r
+ EpaDelta _ _ -> priorAnchor
debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor)
case canUpdateAnchor of
CanUpdateAnchor -> pushAppliedComments
@@ -279,14 +297,17 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
printComments curAnchor
priorCs <- cua canUpdateAnchor takeAppliedComments -- no pop
-- -------------------------
- case anchor_op anchor' of
- MovedAnchor dp -> do
+ case anchor' of
+ EpaDelta dp _ -> do
debugM $ "enterAnn: MovedAnchor:" ++ show dp
-- Set the original anchor as prior end, so the rest of this AST
-- fragment has a reference
setPriorEndNoLayoutD (ss2pos curAnchor)
_ -> do
- return ()
+ if acceptSpan
+ then setPriorEndNoLayoutD (ss2pos curAnchor)
+ else return ()
+
-- -------------------------
if ((fst $ fst $ rs2range curAnchor) >= 0)
then
@@ -318,8 +339,8 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
-- changed.
off (ss2delta priorEndAfterComments curAnchor)
debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor)
- let edp'' = case anchor_op anchor' of
- MovedAnchor dp -> dp
+ let edp'' = case anchor' of
+ EpaDelta dp _ -> dp
_ -> edp'
-- ---------------------------------------------
-- let edp = edp''
@@ -341,7 +362,6 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart
modify (\s -> s { dPriorEndPosition = spanStart } ))
- debugM $ "enterAnn: (anchor_op, curAnchor):" ++ show (anchor_op anchor', rs2range curAnchor)
debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp)
p0 <- getPosP
d <- getPriorEndD
@@ -468,7 +488,7 @@ withPpr a = do
-- 'ppr'.
class (Typeable a) => ExactPrint a where
getAnnotationEntry :: a -> Entry
- setAnnotationAnchor :: a -> Anchor -> EpAnnComments -> a
+ setAnnotationAnchor :: a -> EpaLocation -> EpAnnComments -> a
exact :: (Monad m, Monoid w) => a -> EP w m a
-- ---------------------------------------------------------------------
@@ -783,7 +803,7 @@ limportDeclAnnPackage k annImp = fmap (\new -> annImp { importDeclAnnPackage = n
-- data AnnList
-- = AnnList {
--- al_anchor :: Maybe Anchor, -- ^ start point of a list having layout
+-- al_anchor :: Maybe EpaLocation, -- ^ start point of a list having layout
-- al_open :: Maybe AddEpAnn,
-- al_close :: Maybe AddEpAnn,
-- al_rest :: [AddEpAnn], -- ^ context, such as 'where' keyword
@@ -1235,12 +1255,12 @@ printComments ss = do
printOneComment :: (Monad m, Monoid w) => Comment -> EP w m ()
printOneComment c@(Comment _str loc _r _mo) = do
debugM $ "printOneComment:c=" ++ showGhc c
- dp <-case anchor_op loc of
- MovedAnchor dp -> return dp
- _ -> do
+ dp <-case loc of
+ EpaDelta dp _ -> return dp
+ EpaSpan r _ -> do
pe <- getPriorEndD
- let dp = ss2delta pe (anchor loc)
- debugM $ "printOneComment:(dp,pe,anchor loc)=" ++ showGhc (dp,pe,ss2pos $ anchor loc)
+ let dp = ss2delta pe r
+ debugM $ "printOneComment:(dp,pe,epaLocationToPos loc)=" ++ showGhc (dp,pe,epaLocationToPos loc)
adjustDeltaForOffsetM dp
mep <- getExtraDP
dp' <- case mep of
@@ -1256,7 +1276,7 @@ printOneComment c@(Comment _str loc _r _mo) = do
-- End of debug printing
-- setPriorEndD (ss2posEnd (anchor loc))
updateAndApplyComment c dp'
- printQueuedComment (anchor loc) c dp'
+ printQueuedComment c dp'
-- | For comment-related deltas starting on a new line we have an
-- off-by-one problem. Adjust
@@ -1334,7 +1354,7 @@ commentAllocation ss = do
-- RealSrcSpan, which affects comparison, as the Ord instance for
-- RealSrcSpan compares the file first. So we sort via ss2pos
-- TODO: this is inefficient, use Pos all the way through
- let (earlier,later) = partition (\(Comment _str loc _r _mo) -> (ss2pos $ anchor loc) <= (ss2pos ss)) cs
+ let (earlier,later) = partition (\(Comment _str loc _r _mo) -> (epaLocationToPos loc) <= (ss2pos ss)) cs
putUnallocatedComments later
-- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later)
return earlier
@@ -2967,7 +2987,7 @@ instance ExactPrint (HsExpr GhcPs) where
exact (HsUntypedBracket an (DecBrL a e)) = do
an0 <- markEpAnnLMS an lidl AnnOpen (Just "[d|")
- an1 <- markEpAnnL an lidl AnnOpenC
+ an1 <- markEpAnnL an0 lidl AnnOpenC
e' <- markAnnotated e
an2 <- markEpAnnL an1 lidl AnnCloseC
an3 <- markEpAnnL an2 lidl AnnCloseQ -- "|]"
@@ -4136,7 +4156,7 @@ instance ExactPrint (LocatedN RdrName) where
locFromAdd :: AddEpAnn -> EpaLocation
locFromAdd (AddEpAnn _ loc) = loc
-printUnicode :: (Monad m, Monoid w) => Anchor -> RdrName -> EP w m Anchor
+printUnicode :: (Monad m, Monoid w) => EpaLocation -> RdrName -> EP w m EpaLocation
printUnicode anc n = do
let str = case (showPprUnsafe n) of
-- TODO: unicode support?
@@ -4819,8 +4839,8 @@ isGoodDeltaWithOffset dp colOffset = isGoodDelta (deltaPos l c)
-- | Print a comment, using the current layout offset to convert the
-- @DeltaPos@ to an absolute position.
-printQueuedComment :: (Monad m, Monoid w) => RealSrcSpan -> Comment -> DeltaPos -> EP w m ()
-printQueuedComment _loc Comment{commentContents} dp = do
+printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()
+printQueuedComment Comment{commentContents} dp = do
p <- getPosP
d <- getPriorEndD
colOffset <- getLayoutOffsetP
@@ -4872,10 +4892,10 @@ setPosP l = do
-- debugM $ "setPosP:" ++ show l
modify (\s -> s {epPos = l})
-getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe Anchor)
+getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe EpaLocation)
getExtraDP = gets uExtraDP
-setExtraDP :: (Monad m, Monoid w) => Maybe Anchor -> EP w m ()
+setExtraDP :: (Monad m, Monoid w) => Maybe EpaLocation -> EP w m ()
setExtraDP md = do
debugM $ "setExtraDP:" ++ show md
modify (\s -> s {uExtraDP = md})
@@ -4886,6 +4906,13 @@ getPriorEndD = gets dPriorEndPosition
getAnchorU :: (Monad m, Monoid w) => EP w m RealSrcSpan
getAnchorU = gets uAnchorSpan
+getAcceptSpan ::(Monad m, Monoid w) => EP w m Bool
+getAcceptSpan = gets pAcceptSpan
+
+setAcceptSpan ::(Monad m, Monoid w) => Bool -> EP w m ()
+setAcceptSpan f =
+ modify (\s -> s { pAcceptSpan = f })
+
setPriorEndD :: (Monad m, Monoid w) => Pos -> EP w m ()
setPriorEndD pe = do
setPriorEndNoLayoutD pe
=====================================
utils/check-exact/Main.hs
=====================================
@@ -54,7 +54,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_buil
-- "../../testsuite/tests/ghc-api/exactprint/LocToName.hs" (Just changeLocToName)
-- "../../testsuite/tests/ghc-api/exactprint/LetIn1.hs" (Just changeLetIn1)
-- "../../testsuite/tests/ghc-api/exactprint/WhereIn4.hs" (Just changeWhereIn4)
- -- "../../testsuite/tests/ghc-api/exactprint/AddDecl1.hs" (Just changeAddDecl1)
+ "../../testsuite/tests/ghc-api/exactprint/AddDecl1.hs" (Just changeAddDecl1)
-- "../../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)
@@ -194,7 +194,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_buil
-- "../../testsuite/tests/printer/Test19834.hs" Nothing
-- "../../testsuite/tests/printer/Test19840.hs" Nothing
-- "../../testsuite/tests/printer/Test19850.hs" Nothing
- "../../testsuite/tests/printer/Test20258.hs" Nothing
+ -- "../../testsuite/tests/printer/Test20258.hs" Nothing
-- "../../testsuite/tests/printer/PprLinearArrow.hs" Nothing
-- "../../testsuite/tests/printer/PprSemis.hs" Nothing
-- "../../testsuite/tests/printer/PprEmptyMostly.hs" Nothing
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -64,6 +64,10 @@ import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.LanguageExtensions as LangExt
+import qualified GHC.Data.Strict as Strict
+
+import Types
+
-- ---------------------------------------------------------------------
-- | Wrapper function which returns Annotations along with the parsed
@@ -289,7 +293,8 @@ fixModuleTrailingComments (GHC.L l p) = GHC.L l p'
let
pc = GHC.priorComments cs
fc = GHC.getFollowingComments cs
- bf (GHC.L anc _) = GHC.anchor anc > ss
+ -- bf (GHC.L anc _) = GHC.anchor anc > ss
+ bf (GHC.L anc _) = compareAnchor anc (GHC.EpaSpan ss Strict.Nothing) == GT
(prior,f) = break bf fc
cs'' = GHC.EpaCommentsBalanced (pc <> prior) f
in cs''
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -202,6 +202,7 @@ captureLineSpacing (de1:d2:ds) = de1:captureLineSpacing (d2':ds)
d2' = setEntryDP d2 (deltaPos (l2-l1) 0)
-- ---------------------------------------------------------------------
+
captureTypeSigSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs
captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (HsWC xw ty))))
= (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc' rs') cs) ns (HsWC xw ty'))))
@@ -211,10 +212,10 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
AddEpAnn kw dca = dc
`debug` ("captureTypeSigSpacing: anc'=" ++ (showAst $ last ns))
rd = case last ns of
- L (SrcSpanAnn EpAnnNotUsed ll) _ -> realSrcSpan ll
- L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor?
+ L (SrcSpanAnn EpAnnNotUsed ll) _ -> ss2posEnd $ realSrcSpan ll
+ L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> epaLocationToPosEnd anc'
dc' = case dca of
- EpaSpan r _ -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) [])
+ EpaSpan r _ -> AddEpAnn kw (EpaDelta (ss2delta rd r) [])
EpaDelta _ _ -> AddEpAnn kw dca
-- ---------------------------------
@@ -538,7 +539,7 @@ balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do
-- + move the interior ones to the first match,
-- + move the trailing ones to the last match.
let
- split = splitCommentsEnd (realSrcSpan $ locA lf) (epAnnComments $ ann lf)
+ split = splitCommentsEnd (srcAnn2epaLocation lf) (epAnnComments $ ann lf)
split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sortEpaComments $ priorComments split))
before = sortEpaComments $ priorComments split2
@@ -595,7 +596,7 @@ balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do
-- ---------------------------------
(EpAnn anc an lgc) = ag
- lgc' = splitCommentsEnd (realSrcSpan $ locA lg) $ addCommentOrigDeltas lgc
+ lgc' = splitCommentsEnd (srcAnn2epaLocation lg) $ addCommentOrigDeltas lgc
ag' = if moved
then EpAnn anc an lgc'
else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move))
@@ -672,50 +673,49 @@ balanceComments' la1 la2 = do
la2' = L an2' s
-- | Like commentsDeltas, but calculates the delta from the end of the anchor, not the start
-trailingCommentsDeltas :: RealSrcSpan -> [LEpaComment]
+trailingCommentsDeltas :: EpaLocation -> [LEpaComment]
-> [(Int, LEpaComment)]
trailingCommentsDeltas _ [] = []
-trailingCommentsDeltas anc (la@(L l _):las)
- = deltaComment anc la : trailingCommentsDeltas (anchor l) las
+trailingCommentsDeltas r (la@(L l _):las)
+ = deltaComment r la : trailingCommentsDeltas l las
where
- deltaComment anc' (L loc c) = (abs(ll - al), L loc c)
+ deltaComment r' (L loc c) = (abs(ll - al), L loc c)
where
- (al,_) = ss2posEnd anc'
- (ll,_) = ss2pos (anchor loc)
+ (al,_) = epaLocationToPosEnd r'
+ (ll,_) = epaLocationToPos loc
-- AZ:TODO: this is identical to commentsDeltas
-priorCommentsDeltas :: RealSrcSpan -> [LEpaComment]
+priorCommentsDeltas :: EpaLocation -> [LEpaComment]
-> [(Int, LEpaComment)]
priorCommentsDeltas anc cs = go anc (reverse $ sortEpaComments cs)
where
- go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)]
+ go :: EpaLocation -> [LEpaComment] -> [(Int, LEpaComment)]
go _ [] = []
- go anc' (la@(L l _):las) = deltaComment anc' la : go (anchor l) las
+ go anc' (la@(L l _):las) = deltaComment anc' la : go l las
- deltaComment :: RealSrcSpan -> LEpaComment -> (Int, LEpaComment)
+ deltaComment :: EpaLocation -> LEpaComment -> (Int, LEpaComment)
deltaComment anc' (L loc c) = (abs(ll - al), L loc c)
where
- (al,_) = ss2pos anc'
- (ll,_) = ss2pos (anchor loc)
-
+ (al,_) = epaLocationToPos anc'
+ (ll,_) = epaLocationToPos loc
-- ---------------------------------------------------------------------
-- | Split comments into ones occuring before the end of the reference
-- span, and those after it.
-splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments
+splitCommentsEnd :: EpaLocation -> EpAnnComments -> EpAnnComments
splitCommentsEnd p (EpaComments cs) = cs'
where
- cmp (L (EpaSpan l _b) _) = ss2pos l > ss2posEnd p
- cmp (L (EpaDelta _ _) _) = ss2pos placeholderRealSpan > ss2posEnd p
+ cmp (L (EpaSpan l _b) _) = ss2pos l > epaLocationToPosEnd p
+ cmp (L (EpaDelta _ _) _) = ss2pos placeholderRealSpan > epaLocationToPosEnd p
(before, after) = break cmp cs
cs' = case after of
[] -> EpaComments cs
_ -> EpaCommentsBalanced before after
splitCommentsEnd p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts'
where
- cmp (L (EpaSpan l _b) _) = ss2pos l > ss2posEnd p
- cmp (L (EpaDelta _ _) _) = ss2pos placeholderRealSpan > ss2posEnd p
+ cmp (L (EpaSpan l _b) _) = ss2pos l > epaLocationToPosEnd p
+ cmp (L (EpaDelta _ _) _) = ss2pos placeholderRealSpan > epaLocationToPosEnd p
(before, after) = break cmp cs
cs' = before
ts' = after <> ts
@@ -745,10 +745,10 @@ splitCommentsStart p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts'
moveLeadingComments :: (Data t, Data u, Monoid t, Monoid u)
=> LocatedAn t a -> SrcAnn u -> (LocatedAn t a, SrcAnn u)
moveLeadingComments from@(L (SrcSpanAnn EpAnnNotUsed _) _) to = (from, to)
-moveLeadingComments (L la a) lb = (L la' a, lb')
+moveLeadingComments (L la@(SrcSpanAnn (EpAnn l _ _)_) a) lb = (L la' a, lb')
`debug` ("moveLeadingComments: (before, after, la', lb'):" ++ showAst (before, after, la', lb'))
where
- split = splitCommentsEnd (realSrcSpan $ locA la) (epAnnComments $ ann la)
+ split = splitCommentsEnd l (epAnnComments $ ann la)
before = sortEpaComments $ priorComments split
after = sortEpaComments $ getFollowingComments split
@@ -777,11 +777,11 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs)
-- TODO: this is replicating functionality in ExactPrint. Sort out the
-- import loop`
-anchorFromLocatedA :: LocatedA a -> RealSrcSpan
-anchorFromLocatedA (L (SrcSpanAnn an loc) _)
+anchorFromLocatedA :: LocatedA a -> EpaLocation
+anchorFromLocatedA (L (SrcSpanAnn an _) _)
= case an of
- EpAnnNotUsed -> realSrcSpan loc
- (EpAnn anc _ _) -> anchor anc
+ EpAnnNotUsed -> EpaDelta (SameLine 0) []
+ (EpAnn anc _ _) -> anc
-- | A GHC comment includes the span of the preceding token. Take an
-- original comment, and convert the 'Anchor to have a have a
@@ -836,7 +836,7 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do
(csp,csf) = case anc1 of
EpaComments cs -> ([],cs)
EpaCommentsBalanced p f -> (p,f)
- (move',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchor anc) csf)
+ (move',stay') = break (simpleBreak 0) (trailingCommentsDeltas anc csf)
move = map snd move'
stay = map snd stay'
cs1 = EpaCommentsBalanced csp stay
@@ -918,8 +918,12 @@ insertAt :: (HasDecls ast)
insertAt f t decl = do
oldDecls <- hsDecls t
oldDeclsb <- balanceCommentsList oldDecls
+ `debug` ( "oldDecls:" ++ showAst oldDecls)
let oldDecls' = map commentsOrigDeltasDecl oldDeclsb
- replaceDecls t (f decl oldDecls')
+ `debug` ("oldDeclsb:" ++ showAst oldDeclsb)
+ r <- replaceDecls t (f decl oldDecls')
+ `debug` ("oldDecls':" ++ showAst oldDecls')
+ return r
-- |Insert a declaration at the beginning or end of the subdecls of the given
-- AST item
=====================================
utils/check-exact/Types.hs
=====================================
@@ -31,7 +31,7 @@ data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)
data Comment = Comment
{
commentContents :: !String -- ^ The contents of the comment including separators
- , commentAnchor :: !Anchor
+ , commentAnchor :: !EpaLocation
, commentPriorTok :: !RealSrcSpan
, commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.
}
@@ -45,10 +45,20 @@ instance Ord Comment where
-- When we have CPP injected comments with a fake filename, or LINE
-- pragma, the file name changes, so we need to compare the
-- locations only, with out the filename.
- compare (Comment _ ss1 _ _) (Comment _ ss2 _ _) = compare (ss2pos $ anchor ss1) (ss2pos $ anchor ss2)
+ compare (Comment _ ss1 _ _) (Comment _ ss2 _ _) = compareAnchor ss1 ss2
where
ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss)
+compareAnchor :: EpaLocation -> EpaLocation -> Ordering
+compareAnchor a1 a2 = go a1 a2
+ where
+ ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss)
+
+ go (EpaSpan r1 _) (EpaSpan r2 _) = compare (ss2pos r1) (ss2pos r2)
+ go (EpaSpan _ _) (EpaDelta _ _) = GT
+ go (EpaDelta _ _) (EpaSpan _ _) = LT
+ go (EpaDelta _ _) (EpaDelta _ _) = EQ
+
instance Outputable Comment where
ppr x = text (show x)
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -47,8 +47,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.
@@ -136,6 +136,18 @@ adjustDeltaForOffset (LayoutStartCol colOffset) (DifferentLine l c)
-- ---------------------------------------------------------------------
+srcAnn2epaLocation :: SrcAnn a -> EpaLocation
+srcAnn2epaLocation (SrcSpanAnn EpAnnNotUsed _) = EpaDelta (SameLine 0) []
+srcAnn2epaLocation (SrcSpanAnn (EpAnn anc _ _) _) = anc
+
+epaLocationToPos :: EpaLocation -> Pos
+epaLocationToPos (EpaSpan r _) = ss2pos r
+epaLocationToPos (EpaDelta _ _) = (0,0)
+
+epaLocationToPosEnd :: EpaLocation -> Pos
+epaLocationToPosEnd (EpaSpan r _) = ss2posEnd r
+epaLocationToPosEnd (EpaDelta _ _) = (0,0)
+
ss2pos :: RealSrcSpan -> Pos
ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss)
@@ -229,11 +241,11 @@ mkEpaComments priorCs postCs
comment2LEpaComment :: Comment -> LEpaComment
comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r
-mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment
+mkLEpaComment :: String -> EpaLocation -> RealSrcSpan -> LEpaComment
mkLEpaComment "" anc r = (L anc (GHC.EpaComment (EpaEofComment) r))
mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r))
-mkComment :: String -> Anchor -> RealSrcSpan -> Comment
+mkComment :: String -> EpaLocation -> RealSrcSpan -> Comment
mkComment c anc r = Comment c anc r Nothing
-- Windows comments include \r in them from the lexer.
@@ -244,7 +256,7 @@ normaliseCommentText (x:xs) = x:normaliseCommentText xs
-- |Must compare without span filenames, for CPP injected comments with fake filename
cmpComments :: Comment -> Comment -> Ordering
-cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
+cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compareAnchor l1 l2
-- |Sort, comparing without span filenames, for CPP injected comments with fake filename
sortComments :: [Comment] -> [Comment]
@@ -254,7 +266,7 @@ sortComments cs = sortBy cmpComments cs
sortEpaComments :: [LEpaComment] -> [LEpaComment]
sortEpaComments cs = sortBy cmp cs
where
- cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
+ cmp (L l1 _) (L l2 _) = compareAnchor l1 l2
-- | Makes a comment which originates from a specific keyword.
mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
@@ -271,8 +283,8 @@ isKWComment c = isJust (commentOrigin c)
noKWComments :: [Comment] -> [Comment]
noKWComments = filter (\c -> not (isKWComment c))
-sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a]
-sortAnchorLocated = sortBy (compare `on` (anchor . getLoc))
+sortAnchorLocated :: [GenLocated EpaLocation a] -> [GenLocated EpaLocation a]
+sortAnchorLocated = sortBy (compareAnchor `on` getLoc)
-- | Calculates the distance from the start of a string to the end of
-- a string.
@@ -325,11 +337,12 @@ name2String = showPprUnsafe
locatedAnAnchor :: LocatedAn a t -> RealSrcSpan
locatedAnAnchor (L (SrcSpanAnn EpAnnNotUsed l) _) = realSrcSpan l
-locatedAnAnchor (L (SrcSpanAnn (EpAnn a _ _) _) _) = anchor a
+locatedAnAnchor (L (SrcSpanAnn (EpAnn (EpaSpan r _) _ _) _) _) = r
+locatedAnAnchor _ = error "locatedAnAnchor"
-- ---------------------------------------------------------------------
-setAnchorAn :: (Default an) => LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a
+setAnchorAn :: (Default an) => LocatedAn an a -> EpaLocation -> EpAnnComments -> LocatedAn an a
setAnchorAn (L (SrcSpanAnn EpAnnNotUsed l) a) anc cs
= (L (SrcSpanAnn (EpAnn anc Orphans.def cs) l) a)
-- `debug` ("setAnchorAn: anc=" ++ showAst anc)
@@ -337,15 +350,15 @@ setAnchorAn (L (SrcSpanAnn (EpAnn _ an _) l) a) anc cs
= (L (SrcSpanAnn (EpAnn anc an cs) l) a)
-- `debug` ("setAnchorAn: anc=" ++ showAst anc)
-setAnchorEpa :: (Default an) => EpAnn an -> Anchor -> EpAnnComments -> EpAnn an
+setAnchorEpa :: (Default an) => EpAnn an -> EpaLocation -> EpAnnComments -> EpAnn an
setAnchorEpa EpAnnNotUsed anc cs = EpAnn anc Orphans.def cs
setAnchorEpa (EpAnn _ an _) anc cs = EpAnn anc an cs
-setAnchorEpaL :: EpAnn AnnList -> Anchor -> EpAnnComments -> EpAnn AnnList
+setAnchorEpaL :: EpAnn AnnList -> EpaLocation -> EpAnnComments -> EpAnn AnnList
setAnchorEpaL EpAnnNotUsed anc cs = EpAnn anc mempty cs
setAnchorEpaL (EpAnn _ an _) anc cs = EpAnn anc (an {al_anchor = Nothing}) cs
-setAnchorHsModule :: HsModule GhcPs -> Anchor -> EpAnnComments -> HsModule GhcPs
+setAnchorHsModule :: HsModule GhcPs -> EpaLocation -> EpAnnComments -> HsModule GhcPs
setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} }
where
-- anc' = anc { anchor_op = UnchangedAnchor }
@@ -378,7 +391,7 @@ addEpAnnLoc (AddEpAnn _ l) = l
-- TODO: move this to GHC
-- AZ:Remove this
-anchorToEpaLocation :: Anchor -> EpaLocation
+anchorToEpaLocation :: EpaLocation -> EpaLocation
anchorToEpaLocation = id
-- ---------------------------------------------------------------------
@@ -406,7 +419,7 @@ To be absolutely sure, we make the delta versions use -ve values.
-}
-hackSrcSpanToAnchor :: SrcSpan -> Anchor
+hackSrcSpanToAnchor :: SrcSpan -> EpaLocation
hackSrcSpanToAnchor (UnhelpfulSpan s) = error $ "hackSrcSpanToAnchor : UnhelpfulSpan:" ++ show s
hackSrcSpanToAnchor (RealSrcSpan r b)
= case b of
@@ -418,7 +431,7 @@ hackSrcSpanToAnchor (RealSrcSpan r b)
_ -> EpaSpan r b
-- TODO:AZ get rid of this
-hackAnchorToSrcSpan :: Anchor -> SrcSpan
+hackAnchorToSrcSpan :: EpaLocation -> SrcSpan
hackAnchorToSrcSpan (EpaSpan r b) = RealSrcSpan r b
hackAnchorToSrcSpan _ = error $ "hackAnchorToSrcSpan"
=====================================
utils/check-ppr/Main.hs
=====================================
@@ -102,6 +102,10 @@ getPragmas (L _ (HsModule { hsmodExt = XModulePs { hsmodAnn = anns' } })) = prag
pragmas = filter (\c -> isPrefixOf "{-#" c ) comments'
pragmaStr = intercalate "\n" pragmas
+anchor :: EpaLocation -> (Int,Int)
+anchor (EpaSpan r _) = (srcSpanStartLine r,srcSpanStartCol r)
+anchor (EpaDelta _ _) = (0,0) -- Should not happen for newly-parsed files
+
pp :: (Outputable a) => a -> String
pp a = showPprUnsafe a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/15c72cf788ca8e7f31663eaedb8201ba33e0ec50...414268f575a2ce424b7ac994d32155444a2a6ac0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/15c72cf788ca8e7f31663eaedb8201ba33e0ec50...414268f575a2ce424b7ac994d32155444a2a6ac0
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/20221208/af14e0f4/attachment-0001.html>
More information about the ghc-commits
mailing list