[Git][ghc/ghc][master] 2 commits: EPA: Use EpaLocation in WarningTxt
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Apr 8 20:08:08 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
3b7b0c1c by Alan Zimmerman at 2024-04-08T16:07:27-04:00
EPA: Use EpaLocation in WarningTxt
This allows us to use an EpDelta if needed when using makeDeltaAst.
- - - - -
12b997df by Alan Zimmerman at 2024-04-08T16:07:27-04:00
EPA: Move DeltaPos and EpaLocation' into GHC.Types.SrcLoc
This allows us to use a NoCommentsLocation for the possibly trailing
comma location in a StringLiteral.
This in turn allows us to correctly roundtrip via makeDeltaAst.
- - - - -
8 changed files:
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Types/SourceText.hs
- compiler/GHC/Types/SrcLoc.hs
- compiler/GHC/Unit/Module/Warnings.hs
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -595,8 +595,8 @@ fromIfaceWarnings = \case
fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
fromIfaceWarningTxt = \case
- IfWarningTxt mb_cat src strs -> WarningTxt (noLoc . fromWarningCategory <$> mb_cat) src (noLoc <$> map fromIfaceStringLiteralWithNames strs)
- IfDeprecatedTxt src strs -> DeprecatedTxt src (noLoc <$> map fromIfaceStringLiteralWithNames strs)
+ IfWarningTxt mb_cat src strs -> WarningTxt (noLocA . fromWarningCategory <$> mb_cat) src (noLocA <$> map fromIfaceStringLiteralWithNames strs)
+ IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs)
fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn
fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names)
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1964,9 +1964,9 @@ maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }
(AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}
| {- empty -} { Nothing }
-warning_category :: { Maybe (Located InWarningCategory) }
- : 'in' STRING { Just (sLL $1 $> $ InWarningCategory (epTok $1) (getSTRINGs $2)
- (sL1 $2 $ mkWarningCategory (getSTRING $2))) }
+warning_category :: { Maybe (LocatedE InWarningCategory) }
+ : 'in' STRING { Just (reLoc $ sLL $1 $> $ InWarningCategory (epTok $1) (getSTRINGs $2)
+ (reLoc $ sL1 $2 $ mkWarningCategory (getSTRING $2))) }
| {- empty -} { Nothing }
warnings :: { OrdList (LWarnDecl GhcPs) }
@@ -4131,8 +4131,8 @@ getSCC lt = do let s = getSTRING lt
then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC
else return s
-stringLiteralToHsDocWst :: Located StringLiteral -> Located (WithHsDocIdentifiers StringLiteral GhcPs)
-stringLiteralToHsDocWst = lexStringLiteral parseIdentifier
+stringLiteralToHsDocWst :: Located StringLiteral -> LocatedE (WithHsDocIdentifiers StringLiteral GhcPs)
+stringLiteralToHsDocWst sl = reLoc $ lexStringLiteral parseIdentifier sl
-- Utilities for combining source spans
comb2 :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan
@@ -4560,7 +4560,7 @@ addTrailingCommaN (L anns a) span = do
addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral
addTrailingCommaS (L l sl) span
- = L (widenSpan l [AddEpAnn AnnComma span]) (sl { sl_tc = Just (epaLocationRealSrcSpan span) })
+ = L (widenSpan l [AddEpAnn AnnComma span]) (sl { sl_tc = Just (epaToNoCommentsLocation span) })
-- -------------------------------------
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -454,27 +454,8 @@ instance Outputable EpaComment where
-- annotation.
data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq)
--- | The anchor for an @'AnnKeywordId'@. The Parser inserts the
--- @'EpaSpan'@ variant, giving the exact location of the original item
--- in the parsed source. This can be replaced by the @'EpaDelta'@
--- version, to provide a position for the item relative to the end of
--- the previous item in the source. This is useful when editing an
--- AST prior to exact printing the changed one. The list of comments
--- in the @'EpaDelta'@ variant captures any comments between the prior
--- output and the thing being marked here, since we cannot otherwise
--- sort the relative order.
-
-data EpaLocation' a = EpaSpan !SrcSpan
- | EpaDelta !DeltaPos !a
- deriving (Data,Eq,Show)
-
type EpaLocation = EpaLocation' [LEpaComment]
-type NoCommentsLocation = EpaLocation' NoComments
-
-data NoComments = NoComments
- deriving (Data,Eq,Ord,Show)
-
epaToNoCommentsLocation :: EpaLocation -> NoCommentsLocation
epaToNoCommentsLocation (EpaSpan ss) = EpaSpan ss
epaToNoCommentsLocation (EpaDelta dp []) = EpaDelta dp NoComments
@@ -492,34 +473,6 @@ data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation
instance Outputable a => Outputable (GenLocated TokenLocation a) where
ppr (L _ x) = ppr x
--- | Spacing between output items when exact printing. It captures
--- the spacing from the current print position on the page to the
--- position required for the thing about to be printed. This is
--- either on the same line in which case is is simply the number of
--- spaces to emit, or it is some number of lines down, with a given
--- column offset. The exact printing algorithm keeps track of the
--- column offset pertaining to the current anchor position, so the
--- `deltaColumn` is the additional spaces to add in this case. See
--- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for
--- details.
-data DeltaPos
- = SameLine { deltaColumn :: !Int }
- | DifferentLine
- { deltaLine :: !Int, -- ^ deltaLine should always be > 0
- deltaColumn :: !Int
- } deriving (Show,Eq,Ord,Data)
-
--- | Smart constructor for a 'DeltaPos'. It preserves the invariant
--- that for the 'DifferentLine' constructor 'deltaLine' is always > 0.
-deltaPos :: Int -> Int -> DeltaPos
-deltaPos l c = case l of
- 0 -> SameLine c
- _ -> DifferentLine l c
-
-getDeltaLine :: DeltaPos -> Int
-getDeltaLine (SameLine _) = 0
-getDeltaLine (DifferentLine r _) = r
-
-- | Used in the parser only, extract the 'RealSrcSpan' from an
-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the
-- partial function is safe.
@@ -527,13 +480,6 @@ epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan
epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r
epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan"
-instance Outputable NoComments where
- ppr NoComments = text "NoComments"
-
-instance (Outputable a) => Outputable (EpaLocation' a) where
- ppr (EpaSpan r) = text "EpaSpan" <+> ppr r
- ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs
-
instance Outputable AddEpAnn where
ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss
@@ -1419,10 +1365,6 @@ instance (Outputable a) => Outputable (EpAnn a) where
instance Outputable NoEpAnns where
ppr NoEpAnns = text "NoEpAnns"
-instance Outputable DeltaPos where
- ppr (SameLine c) = text "SameLine" <+> ppr c
- ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c
-
instance Outputable (GenLocated NoCommentsLocation EpaComment) where
ppr (L l c) = text "L" <+> ppr l <+> ppr c
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -310,7 +310,7 @@ rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn)
rnWarningTxt (WarningTxt mb_cat st wst) = do
forM_ mb_cat $ \(L _ (InWarningCategory _ _ (L loc cat))) ->
unless (validWarningCategory cat) $
- addErrAt loc (TcRnInvalidWarningCategory cat)
+ addErrAt (locA loc) (TcRnInvalidWarningCategory cat)
wst' <- traverse (traverse rnHsDoc) wst
pure (WarningTxt mb_cat st wst')
rnWarningTxt (DeprecatedTxt st wst) = do
=====================================
compiler/GHC/Types/SourceText.hs
=====================================
@@ -305,17 +305,13 @@ data StringLiteral = StringLiteral
{ sl_st :: SourceText, -- literal raw source.
-- See Note [Literal source text]
sl_fs :: FastString, -- literal string value
- sl_tc :: Maybe RealSrcSpan -- Location of
+ sl_tc :: Maybe NoCommentsLocation
+ -- Location of
-- possible
-- trailing comma
-- AZ: if we could have a LocatedA
-- StringLiteral we would not need sl_tc, but
-- that would cause import loops.
-
- -- AZ:2: sl_tc should be an EpaAnchor, to allow
- -- editing and reprinting the AST. Need a more
- -- robust solution.
-
} deriving Data
instance Eq StringLiteral where
=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -109,6 +109,10 @@ module GHC.Types.SrcLoc (
mkSrcSpanPs,
combineRealSrcSpans,
psLocatedToLocated,
+
+ -- * Exact print locations
+ EpaLocation'(..), NoCommentsLocation, NoComments(..),
+ DeltaPos(..), deltaPos, getDeltaLine,
) where
import GHC.Prelude
@@ -894,3 +898,70 @@ psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b)
mkSrcSpanPs :: PsSpan -> SrcSpan
mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b)
+
+-- ---------------------------------------------------------------------
+-- The following section contains basic types related to exact printing.
+-- See https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for
+-- details.
+-- This is only s subset, to prevent import loops. The balance are in
+-- GHC.Parser.Annotation
+-- ---------------------------------------------------------------------
+
+
+-- | The anchor for an @'AnnKeywordId'@. The Parser inserts the
+-- @'EpaSpan'@ variant, giving the exact location of the original item
+-- in the parsed source. This can be replaced by the @'EpaDelta'@
+-- version, to provide a position for the item relative to the end of
+-- the previous item in the source. This is useful when editing an
+-- AST prior to exact printing the changed one. The list of comments
+-- in the @'EpaDelta'@ variant captures any comments between the prior
+-- output and the thing being marked here, since we cannot otherwise
+-- sort the relative order.
+
+data EpaLocation' a = EpaSpan !SrcSpan
+ | EpaDelta !DeltaPos !a
+ deriving (Data,Eq,Show)
+
+type NoCommentsLocation = EpaLocation' NoComments
+
+data NoComments = NoComments
+ deriving (Data,Eq,Ord,Show)
+
+-- | Spacing between output items when exact printing. It captures
+-- the spacing from the current print position on the page to the
+-- position required for the thing about to be printed. This is
+-- either on the same line in which case is is simply the number of
+-- spaces to emit, or it is some number of lines down, with a given
+-- column offset. The exact printing algorithm keeps track of the
+-- column offset pertaining to the current anchor position, so the
+-- `deltaColumn` is the additional spaces to add in this case. See
+-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for
+-- details.
+data DeltaPos
+ = SameLine { deltaColumn :: !Int }
+ | DifferentLine
+ { deltaLine :: !Int, -- ^ deltaLine should always be > 0
+ deltaColumn :: !Int
+ } deriving (Show,Eq,Ord,Data)
+
+-- | Smart constructor for a 'DeltaPos'. It preserves the invariant
+-- that for the 'DifferentLine' constructor 'deltaLine' is always > 0.
+deltaPos :: Int -> Int -> DeltaPos
+deltaPos l c = case l of
+ 0 -> SameLine c
+ _ -> DifferentLine l c
+
+getDeltaLine :: DeltaPos -> Int
+getDeltaLine (SameLine _) = 0
+getDeltaLine (DifferentLine r _) = r
+
+instance Outputable NoComments where
+ ppr NoComments = text "NoComments"
+
+instance (Outputable a) => Outputable (EpaLocation' a) where
+ ppr (EpaSpan r) = text "EpaSpan" <+> ppr r
+ ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs
+
+instance Outputable DeltaPos where
+ ppr (SameLine c) = text "SameLine" <+> ppr c
+ ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c
=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -121,11 +121,11 @@ data InWarningCategory
= InWarningCategory
{ iwc_in :: !(EpToken "in"),
iwc_st :: !SourceText,
- iwc_wc :: (Located WarningCategory)
+ iwc_wc :: (LocatedE WarningCategory)
} deriving Data
fromWarningCategory :: WarningCategory -> InWarningCategory
-fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLoc wc)
+fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc)
-- See Note [Warning categories]
@@ -201,14 +201,14 @@ type LWarningTxt pass = XRec pass (WarningTxt pass)
-- reason/explanation from a WARNING or DEPRECATED pragma
data WarningTxt pass
= WarningTxt
- (Maybe (Located InWarningCategory))
+ (Maybe (LocatedE InWarningCategory))
-- ^ Warning category attached to this WARNING pragma, if any;
-- see Note [Warning categories]
SourceText
- [Located (WithHsDocIdentifiers StringLiteral pass)]
+ [LocatedE (WithHsDocIdentifiers StringLiteral pass)]
| DeprecatedTxt
SourceText
- [Located (WithHsDocIdentifiers StringLiteral pass)]
+ [LocatedE (WithHsDocIdentifiers StringLiteral pass)]
deriving Generic
-- | To which warning category does this WARNING or DEPRECATED pragma belong?
@@ -218,7 +218,7 @@ warningTxtCategory (WarningTxt (Just (L _ (InWarningCategory _ _ (L _ cat)))) _
warningTxtCategory _ = defaultWarningCategory
-- | The message that the WarningTxt was specified to output
-warningTxtMessage :: WarningTxt p -> [Located (WithHsDocIdentifiers StringLiteral p)]
+warningTxtMessage :: WarningTxt p -> [LocatedE (WithHsDocIdentifiers StringLiteral p)]
warningTxtMessage (WarningTxt _ _ m) = m
warningTxtMessage (DeprecatedTxt _ m) = m
@@ -260,7 +260,7 @@ instance Outputable (WarningTxt pass) where
NoSourceText -> pp_ws ds
SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
-pp_ws :: [Located (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
+pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
pp_ws [l] = ppr $ unLoc l
pp_ws ws
= text "["
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -711,6 +711,11 @@ printStringAtMLocL (EpAnn anc an cs) l s = do
printStringAtAA :: (Monad m, Monoid w) => EpaLocation -> String -> EP w m EpaLocation
printStringAtAA el str = printStringAtAAC CaptureComments el str
+printStringAtNC :: (Monad m, Monoid w) => NoCommentsLocation -> String -> EP w m NoCommentsLocation
+printStringAtNC el str = do
+ el' <- printStringAtAAC NoCaptureComments (noCommentsToEpaLocation el) str
+ return (epaToNoCommentsLocation el')
+
printStringAtAAL :: (Monad m, Monoid w)
=> a -> Lens a EpaLocation -> String -> EP w m a
printStringAtAAL an l str = do
@@ -2117,10 +2122,10 @@ instance ExactPrint StringLiteral where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact l@(StringLiteral src fs mcomma) = do
+ exact (StringLiteral src fs mcomma) = do
printSourceTextAA src (show (unpackFS fs))
- mapM_ (\r -> printStringAtRs r ",") mcomma
- return l
+ mcomma' <- mapM (\r -> printStringAtNC r ",") mcomma
+ return (StringLiteral src fs mcomma')
-- ---------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbb91a6371308fffca926f0ab45ae0a14e7c6847...12b997df559365e6188824fb10f5f61c2e9075e4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fbb91a6371308fffca926f0ab45ae0a14e7c6847...12b997df559365e6188824fb10f5f61c2e9075e4
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/20240408/62d45479/attachment-0001.html>
More information about the ghc-commits
mailing list