1{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3{-# LANGUAGE DeriveFunctor #-} 4{-# LANGUAGE FlexibleInstances #-} 5 6module GHC.Parser.Annotation ( 7 -- * Core Exact Print Annotation types 8 AnnKeywordId(..), 9 EpaComment(..), EpaCommentTok(..), 10 IsUnicodeSyntax(..), 11 unicodeAnn, 12 HasE(..), 13 14 -- * In-tree Exact Print Annotations 15 AddEpAnn(..), 16 EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn, 17 DeltaPos(..), deltaPos, getDeltaLine, 18 19 EpAnn(..), Anchor(..), AnchorOperation(..), 20 spanAsAnchor, realSpanAsAnchor, 21 noAnn, 22 23 -- ** Comments in Annotations 24 25 EpAnnComments(..), LEpaComment, emptyComments, 26 getFollowingComments, setFollowingComments, setPriorComments, 27 EpAnnCO, 28 29 -- ** Annotations in 'GenLocated' 30 LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP, 31 SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN, 32 SrcSpanAnn'(..), SrcAnn, 33 34 -- ** Annotation data types used in 'GenLocated' 35 36 AnnListItem(..), AnnList(..), 37 AnnParen(..), ParenType(..), parenTypeKws, 38 AnnPragma(..), 39 AnnContext(..), 40 NameAnn(..), NameAdornment(..), 41 NoEpAnns(..), 42 AnnSortKey(..), 43 44 -- ** Trailing annotations in lists 45 TrailingAnn(..), addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN, 46 47 -- ** Utilities for converting between different 'GenLocated' when 48 -- ** we do not care about the annotations. 49 la2na, na2la, n2l, l2n, l2l, la2la, 50 reLoc, reLocA, reLocL, reLocC, reLocN, 51 52 la2r, realSrcSpan, 53 54 -- ** Building up annotations 55 extraToAnnList, reAnn, 56 reAnnL, reAnnC, 57 addAnns, addAnnsA, widenSpan, widenAnchor, widenAnchorR, widenLocatedAn, 58 59 -- ** Querying annotations 60 getLocAnn, 61 epAnnAnns, epAnnAnnsL, 62 annParen2AddEpAnn, 63 epAnnComments, 64 65 -- ** Working with locations of annotations 66 sortLocatedA, 67 mapLocA, 68 combineLocsA, 69 combineSrcSpansA, 70 addCLocA, addCLocAA, 71 72 -- ** Constructing 'GenLocated' annotation types when we do not care 73 -- about annotations. 74 noLocA, getLocA, 75 noSrcSpanA, 76 noAnnSrcSpan, 77 78 -- ** Working with comments in annotations 79 noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn, 80 addCommentsToEpAnn, setCommentsEpAnn, 81 transferAnnsA, commentsOnlyA, removeCommentsA, 82 83 placeholderRealSpan, 84 ) where 85 86import GHC.Prelude 87 88import Data.Data 89import Data.Function (on) 90import Data.List (sortBy) 91import Data.Semigroup 92import GHC.Data.FastString 93import GHC.Types.Name 94import GHC.Types.SrcLoc 95import GHC.Utils.Binary 96import GHC.Utils.Outputable hiding ( (<>) ) 97import GHC.Utils.Panic 98 99{- 100Note [exact print annotations] 101~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 102Given a parse tree of a Haskell module, how can we reconstruct 103the original Haskell source code, retaining all whitespace and 104source code comments? We need to track the locations of all 105elements from the original source: this includes keywords such as 106'let' / 'in' / 'do' etc as well as punctuation such as commas and 107braces, and also comments. We collectively refer to this 108metadata as the "exact print annotations". 109 110NON-COMMENT ELEMENTS 111 112Intuitively, every AST element directly contains a bag of keywords 113(keywords can show up more than once in a node: a semicolon i.e. newline 114can show up multiple times before the next AST element), each of which 115needs to be associated with its location in the original source code. 116 117These keywords are recorded directly in the AST element in which they 118occur, for the GhcPs phase. 119 120For any given element in the AST, there is only a set number of 121keywords that are applicable for it (e.g., you'll never see an 122'import' keyword associated with a let-binding.) The set of allowed 123keywords is documented in a comment associated with the constructor 124of a given AST element, although the ground truth is in GHC.Parser 125and GHC.Parser.PostProcess (which actually add the annotations). 126 127COMMENT ELEMENTS 128 129We associate comments with the lowest (most specific) AST element 130enclosing them 131 132PARSER STATE 133 134There are three fields in PState (the parser state) which play a role 135with annotation comments. 136 137> comment_q :: [LEpaComment], 138> header_comments :: Maybe [LEpaComment], 139> eof_pos :: Maybe (RealSrcSpan, RealSrcSpan), -- pos, gap to prior token 140 141The 'comment_q' field captures comments as they are seen in the token stream, 142so that when they are ready to be allocated via the parser they are 143available. 144 145The 'header_comments' capture the comments coming at the top of the 146source file. They are moved there from the `comment_q` when comments 147are allocated for the first top-level declaration. 148 149The 'eof_pos' captures the final location in the file, and the 150location of the immediately preceding token to the last location, so 151that the exact-printer can work out how far to advance to add the 152trailing whitespace. 153 154PARSER EMISSION OF ANNOTATIONS 155 156The parser interacts with the lexer using the functions 157 158> getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments 159> getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments 160> getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments 161 162The 'getCommentsFor' function is the one used most often. It takes 163the AST element SrcSpan and removes and returns any comments in the 164'comment_q' that are inside the span. 'allocateComments' in 'Lexer' is 165responsible for making sure we only return comments that actually fit 166in the 'SrcSpan'. 167 168The 'getPriorCommentsFor' function is used for top-level declarations, 169and removes and returns any comments in the 'comment_q' that either 170precede or are included in the given SrcSpan. This is to ensure that 171preceding documentation comments are kept together with the 172declaration they belong to. 173 174The 'getFinalCommentsFor' function is called right at the end when EOF 175is hit. This drains the 'comment_q' completely, and returns the 176'header_comments', remaining 'comment_q' entries and the 177'eof_pos'. These values are inserted into the 'HsModule' AST element. 178 179The wiki page describing this feature is 180https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations 181 182-} 183 184-- -------------------------------------------------------------------- 185 186-- | Exact print annotations exist so that tools can perform source to 187-- source conversions of Haskell code. They are used to keep track of 188-- the various syntactic keywords that are not otherwise captured in the 189-- AST. 190-- 191-- The wiki page describing this feature is 192-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations 193-- https://gitlab.haskell.org/ghc/ghc/-/wikis/implementing-trees-that-grow/in-tree-api-annotations 194-- 195-- Note: in general the names of these are taken from the 196-- corresponding token, unless otherwise noted 197-- See note [exact print annotations] above for details of the usage 198data AnnKeywordId 199 = AnnAnyclass 200 | AnnAs 201 | AnnAt 202 | AnnBang -- ^ '!' 203 | AnnBackquote -- ^ '`' 204 | AnnBy 205 | AnnCase -- ^ case or lambda case 206 | AnnClass 207 | AnnClose -- ^ '\#)' or '\#-}' etc 208 | AnnCloseB -- ^ '|)' 209 | AnnCloseBU -- ^ '|)', unicode variant 210 | AnnCloseC -- ^ '}' 211 | AnnCloseQ -- ^ '|]' 212 | AnnCloseQU -- ^ '|]', unicode variant 213 | AnnCloseP -- ^ ')' 214 | AnnClosePH -- ^ '\#)' 215 | AnnCloseS -- ^ ']' 216 | AnnColon 217 | AnnComma -- ^ as a list separator 218 | AnnCommaTuple -- ^ in a RdrName for a tuple 219 | AnnDarrow -- ^ '=>' 220 | AnnDarrowU -- ^ '=>', unicode variant 221 | AnnData 222 | AnnDcolon -- ^ '::' 223 | AnnDcolonU -- ^ '::', unicode variant 224 | AnnDefault 225 | AnnDeriving 226 | AnnDo 227 | AnnDot -- ^ '.' 228 | AnnDotdot -- ^ '..' 229 | AnnElse 230 | AnnEqual 231 | AnnExport 232 | AnnFamily 233 | AnnForall 234 | AnnForallU -- ^ Unicode variant 235 | AnnForeign 236 | AnnFunId -- ^ for function name in matches where there are 237 -- multiple equations for the function. 238 | AnnGroup 239 | AnnHeader -- ^ for CType 240 | AnnHiding 241 | AnnIf 242 | AnnImport 243 | AnnIn 244 | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr' 245 | AnnInstance 246 | AnnLam 247 | AnnLarrow -- ^ '<-' 248 | AnnLarrowU -- ^ '<-', unicode variant 249 | AnnLet 250 | AnnLollyU -- ^ The '⊸' unicode arrow 251 | AnnMdo 252 | AnnMinus -- ^ '-' 253 | AnnModule 254 | AnnNewtype 255 | AnnName -- ^ where a name loses its location in the AST, this carries it 256 | AnnOf 257 | AnnOpen -- ^ '{-\# DEPRECATED' etc. Opening of pragmas where 258 -- the capitalisation of the string can be changed by 259 -- the user. The actual text used is stored in a 260 -- 'SourceText' on the relevant pragma item. 261 | AnnOpenB -- ^ '(|' 262 | AnnOpenBU -- ^ '(|', unicode variant 263 | AnnOpenC -- ^ '{' 264 | AnnOpenE -- ^ '[e|' or '[e||' 265 | AnnOpenEQ -- ^ '[|' 266 | AnnOpenEQU -- ^ '[|', unicode variant 267 | AnnOpenP -- ^ '(' 268 | AnnOpenS -- ^ '[' 269 | AnnOpenPH -- ^ '(\#' 270 | AnnDollar -- ^ prefix '$' -- TemplateHaskell 271 | AnnDollarDollar -- ^ prefix '$$' -- TemplateHaskell 272 | AnnPackageName 273 | AnnPattern 274 | AnnPercent -- ^ '%' -- for HsExplicitMult 275 | AnnPercentOne -- ^ '%1' -- for HsLinearArrow 276 | AnnProc 277 | AnnQualified 278 | AnnRarrow -- ^ '->' 279 | AnnRarrowU -- ^ '->', unicode variant 280 | AnnRec 281 | AnnRole 282 | AnnSafe 283 | AnnSemi -- ^ ';' 284 | AnnSimpleQuote -- ^ ''' 285 | AnnSignature 286 | AnnStatic -- ^ 'static' 287 | AnnStock 288 | AnnThen 289 | AnnThTyQuote -- ^ double ''' 290 | AnnTilde -- ^ '~' 291 | AnnType 292 | AnnUnit -- ^ '()' for types 293 | AnnUsing 294 | AnnVal -- ^ e.g. INTEGER 295 | AnnValStr -- ^ String value, will need quotes when output 296 | AnnVbar -- ^ '|' 297 | AnnVia -- ^ 'via' 298 | AnnWhere 299 | Annlarrowtail -- ^ '-<' 300 | AnnlarrowtailU -- ^ '-<', unicode variant 301 | Annrarrowtail -- ^ '->' 302 | AnnrarrowtailU -- ^ '->', unicode variant 303 | AnnLarrowtail -- ^ '-<<' 304 | AnnLarrowtailU -- ^ '-<<', unicode variant 305 | AnnRarrowtail -- ^ '>>-' 306 | AnnRarrowtailU -- ^ '>>-', unicode variant 307 deriving (Eq, Ord, Data, Show) 308 309instance Outputable AnnKeywordId where 310 ppr x = text (show x) 311 312-- | Certain tokens can have alternate representations when unicode syntax is 313-- enabled. This flag is attached to those tokens in the lexer so that the 314-- original source representation can be reproduced in the corresponding 315-- 'EpAnnotation' 316data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax 317 deriving (Eq, Ord, Data, Show) 318 319-- | Convert a normal annotation into its unicode equivalent one 320unicodeAnn :: AnnKeywordId -> AnnKeywordId 321unicodeAnn AnnForall = AnnForallU 322unicodeAnn AnnDcolon = AnnDcolonU 323unicodeAnn AnnLarrow = AnnLarrowU 324unicodeAnn AnnRarrow = AnnRarrowU 325unicodeAnn AnnDarrow = AnnDarrowU 326unicodeAnn Annlarrowtail = AnnlarrowtailU 327unicodeAnn Annrarrowtail = AnnrarrowtailU 328unicodeAnn AnnLarrowtail = AnnLarrowtailU 329unicodeAnn AnnRarrowtail = AnnRarrowtailU 330unicodeAnn AnnOpenB = AnnOpenBU 331unicodeAnn AnnCloseB = AnnCloseBU 332unicodeAnn AnnOpenEQ = AnnOpenEQU 333unicodeAnn AnnCloseQ = AnnCloseQU 334unicodeAnn ann = ann 335 336 337-- | Some template haskell tokens have two variants, one with an `e` the other 338-- not: 339-- 340-- > [| or [e| 341-- > [|| or [e|| 342-- 343-- This type indicates whether the 'e' is present or not. 344data HasE = HasE | NoE 345 deriving (Eq, Ord, Data, Show) 346 347-- --------------------------------------------------------------------- 348 349data EpaComment = 350 EpaComment 351 { ac_tok :: EpaCommentTok 352 , ac_prior_tok :: RealSrcSpan 353 -- ^ The location of the prior token, used in exact printing. The 354 -- 'EpaComment' appears as an 'LEpaComment' containing its 355 -- location. The difference between the end of the prior token 356 -- and the start of this location is used for the spacing when 357 -- exact printing the comment. 358 } 359 deriving (Eq, Ord, Data, Show) 360 361data EpaCommentTok = 362 -- Documentation annotations 363 EpaDocCommentNext String -- ^ something beginning '-- |' 364 | EpaDocCommentPrev String -- ^ something beginning '-- ^' 365 | EpaDocCommentNamed String -- ^ something beginning '-- $' 366 | EpaDocSection Int String -- ^ a section heading 367 | EpaDocOptions String -- ^ doc options (prune, ignore-exports, etc) 368 | EpaLineComment String -- ^ comment starting by "--" 369 | EpaBlockComment String -- ^ comment in {- -} 370 | EpaEofComment -- ^ empty comment, capturing 371 -- location of EOF 372 373 -- See #19697 for a discussion of EpaEofComment's use and how it 374 -- should be removed in favour of capturing it in the location for 375 -- 'Located HsModule' in the parser. 376 377 deriving (Eq, Ord, Data, Show) 378-- Note: these are based on the Token versions, but the Token type is 379-- defined in GHC.Parser.Lexer and bringing it in here would create a loop 380 381instance Outputable EpaComment where 382 ppr x = text (show x) 383 384-- --------------------------------------------------------------------- 385 386-- | Captures an annotation, storing the @'AnnKeywordId'@ and its 387-- location. The parser only ever inserts @'EpaLocation'@ fields with a 388-- RealSrcSpan being the original location of the annotation in the 389-- source file. 390-- The @'EpaLocation'@ can also store a delta position if the AST has been 391-- modified and needs to be pretty printed again. 392-- The usual way an 'AddEpAnn' is created is using the 'mj' ("make 393-- jump") function, and then it can be inserted into the appropriate 394-- annotation. 395data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq) 396 397-- | The anchor for an @'AnnKeywordId'@. The Parser inserts the 398-- @'EpaSpan'@ variant, giving the exact location of the original item 399-- in the parsed source. This can be replaced by the @'EpaDelta'@ 400-- version, to provide a position for the item relative to the end of 401-- the previous item in the source. This is useful when editing an 402-- AST prior to exact printing the changed one. The list of comments 403-- in the @'EpaDelta'@ variant captures any comments between the prior 404-- output and the thing being marked here, since we cannot otherwise 405-- sort the relative order. 406data EpaLocation = EpaSpan !RealSrcSpan 407 | EpaDelta !DeltaPos ![LEpaComment] 408 deriving (Data,Eq,Ord) 409 410-- | Spacing between output items when exact printing. It captures 411-- the spacing from the current print position on the page to the 412-- position required for the thing about to be printed. This is 413-- either on the same line in which case is is simply the number of 414-- spaces to emit, or it is some number of lines down, with a given 415-- column offset. The exact printing algorithm keeps track of the 416-- column offset pertaining to the current anchor position, so the 417-- `deltaColumn` is the additional spaces to add in this case. See 418-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for 419-- details. 420data DeltaPos 421 = SameLine { deltaColumn :: !Int } 422 | DifferentLine 423 { deltaLine :: !Int, -- ^ deltaLine should always be > 0 424 deltaColumn :: !Int 425 } deriving (Show,Eq,Ord,Data) 426 427-- | Smart constructor for a 'DeltaPos'. It preserves the invariant 428-- that for the 'DifferentLine' constructor 'deltaLine' is always > 0. 429deltaPos :: Int -> Int -> DeltaPos 430deltaPos l c = case l of 431 0 -> SameLine c 432 _ -> DifferentLine l c 433 434getDeltaLine :: DeltaPos -> Int 435getDeltaLine (SameLine _) = 0 436getDeltaLine (DifferentLine r _) = r 437 438-- | Used in the parser only, extract the 'RealSrcSpan' from an 439-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the 440-- partial function is safe. 441epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan 442epaLocationRealSrcSpan (EpaSpan r) = r 443epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan" 444 445epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation 446epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) 447epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) 448 449instance Outputable EpaLocation where 450 ppr (EpaSpan r) = text "EpaSpan" <+> ppr r 451 ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs 452 453instance Outputable AddEpAnn where 454 ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss 455 456instance Ord AddEpAnn where 457 compare (AddEpAnn kw1 loc1) (AddEpAnn kw2 loc2) = compare (loc1, kw1) (loc2,kw2) 458 459-- --------------------------------------------------------------------- 460 461-- | The exact print annotations (EPAs) are kept in the HsSyn AST for 462-- the GhcPs phase. We do not always have EPAs though, only for code 463-- that has been parsed as they do not exist for generated 464-- code. This type captures that they may be missing. 465-- 466-- A goal of the annotations is that an AST can be edited, including 467-- moving subtrees from one place to another, duplicating them, and so 468-- on. This means that each fragment must be self-contained. To this 469-- end, each annotated fragment keeps track of the anchor position it 470-- was originally captured at, being simply the start span of the 471-- topmost element of the ast fragment. This gives us a way to later 472-- re-calculate all Located items in this layer of the AST, as well as 473-- any annotations captured. The comments associated with the AST 474-- fragment are also captured here. 475-- 476-- The 'ann' type parameter allows this general structure to be 477-- specialised to the specific set of locations of original exact 478-- print annotation elements. So for 'HsLet' we have 479-- 480-- type instance XLet GhcPs = EpAnn AnnsLet 481-- data AnnsLet 482-- = AnnsLet { 483-- alLet :: EpaLocation, 484-- alIn :: EpaLocation 485-- } deriving Data 486-- 487-- The spacing between the items under the scope of a given EpAnn is 488-- normally derived from the original 'Anchor'. But if a sub-element 489-- is not in its original position, the required spacing can be 490-- directly captured in the 'anchor_op' field of the 'entry' Anchor. 491-- This allows us to freely move elements around, and stitch together 492-- new AST fragments out of old ones, and have them still printed out 493-- in a precise way. 494data EpAnn ann 495 = EpAnn { entry :: Anchor 496 -- ^ Base location for the start of the syntactic element 497 -- holding the annotations. 498 , anns :: ann -- ^ Annotations added by the Parser 499 , comments :: EpAnnComments 500 -- ^ Comments enclosed in the SrcSpan of the element 501 -- this `EpAnn` is attached to 502 } 503 | EpAnnNotUsed -- ^ No Annotation for generated code, 504 -- e.g. from TH, deriving, etc. 505 deriving (Data, Eq, Functor) 506 507-- | An 'Anchor' records the base location for the start of the 508-- syntactic element holding the annotations, and is used as the point 509-- of reference for calculating delta positions for contained 510-- annotations. 511-- It is also normally used as the reference point for the spacing of 512-- the element relative to its container. If it is moved, that 513-- relationship is tracked in the 'anchor_op' instead. 514 515data Anchor = Anchor { anchor :: RealSrcSpan 516 -- ^ Base location for the start of 517 -- the syntactic element holding 518 -- the annotations. 519 , anchor_op :: AnchorOperation } 520 deriving (Data, Eq, Show) 521 522-- | If tools modify the parsed source, the 'MovedAnchor' variant can 523-- directly provide the spacing for this item relative to the previous 524-- one when printing. This allows AST fragments with a particular 525-- anchor to be freely moved, without worrying about recalculating the 526-- appropriate anchor span. 527data AnchorOperation = UnchangedAnchor 528 | MovedAnchor DeltaPos 529 deriving (Data, Eq, Show) 530 531 532spanAsAnchor :: SrcSpan -> Anchor 533spanAsAnchor s = Anchor (realSrcSpan s) UnchangedAnchor 534 535realSpanAsAnchor :: RealSrcSpan -> Anchor 536realSpanAsAnchor s = Anchor s UnchangedAnchor 537 538-- --------------------------------------------------------------------- 539 540-- | When we are parsing we add comments that belong a particular AST 541-- element, and print them together with the element, interleaving 542-- them into the output stream. But when editing the AST to move 543-- fragments around it is useful to be able to first separate the 544-- comments into those occuring before the AST element and those 545-- following it. The 'EpaCommentsBalanced' constructor is used to do 546-- this. The GHC parser will only insert the 'EpaComments' form. 547data EpAnnComments = EpaComments 548 { priorComments :: ![LEpaComment] } 549 | EpaCommentsBalanced 550 { priorComments :: ![LEpaComment] 551 , followingComments :: ![LEpaComment] } 552 deriving (Data, Eq) 553 554type LEpaComment = GenLocated Anchor EpaComment 555 556emptyComments :: EpAnnComments 557emptyComments = EpaComments [] 558 559-- --------------------------------------------------------------------- 560-- Annotations attached to a 'SrcSpan'. 561-- --------------------------------------------------------------------- 562 563-- | The 'SrcSpanAnn\'' type wraps a normal 'SrcSpan', together with 564-- an extra annotation type. This is mapped to a specific `GenLocated` 565-- usage in the AST through the `XRec` and `Anno` type families. 566data SrcSpanAnn' a = SrcSpanAnn { ann :: a, locA :: SrcSpan } 567 deriving (Data, Eq) 568-- See Note [XRec and Anno in the AST] 569 570-- | We mostly use 'SrcSpanAnn\'' with an 'EpAnn\'' 571type SrcAnn ann = SrcSpanAnn' (EpAnn ann) 572 573type LocatedA = GenLocated SrcSpanAnnA 574type LocatedN = GenLocated SrcSpanAnnN 575 576type LocatedL = GenLocated SrcSpanAnnL 577type LocatedP = GenLocated SrcSpanAnnP 578type LocatedC = GenLocated SrcSpanAnnC 579 580type SrcSpanAnnA = SrcAnn AnnListItem 581type SrcSpanAnnN = SrcAnn NameAnn 582 583type SrcSpanAnnL = SrcAnn AnnList 584type SrcSpanAnnP = SrcAnn AnnPragma 585type SrcSpanAnnC = SrcAnn AnnContext 586 587-- | General representation of a 'GenLocated' type carrying a 588-- parameterised annotation type. 589type LocatedAn an = GenLocated (SrcAnn an) 590 591{- 592Note [XRec and Anno in the AST] 593~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 594 595The exact print annotations are captured directly inside the AST, using 596TTG extension points. However certain annotations need to be captured 597on the Located versions too. While there is a general form for these, 598captured in the type SrcSpanAnn', there are also specific usages in 599different contexts. 600 601Some of the particular use cases are 602 6031) RdrNames, which can have additional items such as backticks or parens 604 6052) Items which occur in lists, and the annotation relates purely 606to its usage inside a list. 607 608See the section above this note for the rest. 609 610The Anno type family maps the specific SrcSpanAnn' variant for a given 611item. 612 613So 614 615 type instance XRec (GhcPass p) a = GenLocated (Anno a) a 616 type instance Anno RdrName = SrcSpanAnnN 617 type LocatedN = GenLocated SrcSpanAnnN 618 619meaning we can have type LocatedN RdrName 620 621-} 622 623-- --------------------------------------------------------------------- 624-- Annotations for items in a list 625-- --------------------------------------------------------------------- 626 627-- | Captures the location of punctuation occuring between items, 628-- normally in a list. It is captured as a trailing annotation. 629data TrailingAnn 630 = AddSemiAnn EpaLocation -- ^ Trailing ';' 631 | AddCommaAnn EpaLocation -- ^ Trailing ',' 632 | AddVbarAnn EpaLocation -- ^ Trailing '|' 633 | AddRarrowAnn EpaLocation -- ^ Trailing '->' 634 | AddRarrowAnnU EpaLocation -- ^ Trailing '->', unicode variant 635 | AddLollyAnnU EpaLocation -- ^ Trailing '⊸' 636 deriving (Data,Eq, Ord) 637 638instance Outputable TrailingAnn where 639 ppr (AddSemiAnn ss) = text "AddSemiAnn" <+> ppr ss 640 ppr (AddCommaAnn ss) = text "AddCommaAnn" <+> ppr ss 641 ppr (AddVbarAnn ss) = text "AddVbarAnn" <+> ppr ss 642 ppr (AddRarrowAnn ss) = text "AddRarrowAnn" <+> ppr ss 643 ppr (AddRarrowAnnU ss) = text "AddRarrowAnnU" <+> ppr ss 644 ppr (AddLollyAnnU ss) = text "AddLollyAnnU" <+> ppr ss 645 646-- | Annotation for items appearing in a list. They can have one or 647-- more trailing punctuations items, such as commas or semicolons. 648data AnnListItem 649 = AnnListItem { 650 lann_trailing :: [TrailingAnn] 651 } 652 deriving (Data, Eq) 653 654-- --------------------------------------------------------------------- 655-- Annotations for the context of a list of items 656-- --------------------------------------------------------------------- 657 658-- | Annotation for the "container" of a list. This captures 659-- surrounding items such as braces if present, and introductory 660-- keywords such as 'where'. 661data AnnList 662 = AnnList { 663 al_anchor :: Maybe Anchor, -- ^ start point of a list having layout 664 al_open :: Maybe AddEpAnn, 665 al_close :: Maybe AddEpAnn, 666 al_rest :: [AddEpAnn], -- ^ context, such as 'where' keyword 667 al_trailing :: [TrailingAnn] -- ^ items appearing after the 668 -- list, such as '=>' for a 669 -- context 670 } deriving (Data,Eq) 671 672-- --------------------------------------------------------------------- 673-- Annotations for parenthesised elements, such as tuples, lists 674-- --------------------------------------------------------------------- 675 676-- | exact print annotation for an item having surrounding "brackets", such as 677-- tuples or lists 678data AnnParen 679 = AnnParen { 680 ap_adornment :: ParenType, 681 ap_open :: EpaLocation, 682 ap_close :: EpaLocation 683 } deriving (Data) 684 685-- | Detail of the "brackets" used in an 'AnnParen' exact print annotation. 686data ParenType 687 = AnnParens -- ^ '(', ')' 688 | AnnParensHash -- ^ '(#', '#)' 689 | AnnParensSquare -- ^ '[', ']' 690 deriving (Eq, Ord, Data) 691 692-- | Maps the 'ParenType' to the related opening and closing 693-- AnnKeywordId. Used when actually printing the item. 694parenTypeKws :: ParenType -> (AnnKeywordId, AnnKeywordId) 695parenTypeKws AnnParens = (AnnOpenP, AnnCloseP) 696parenTypeKws AnnParensHash = (AnnOpenPH, AnnClosePH) 697parenTypeKws AnnParensSquare = (AnnOpenS, AnnCloseS) 698 699-- --------------------------------------------------------------------- 700 701-- | Exact print annotation for the 'Context' data type. 702data AnnContext 703 = AnnContext { 704 ac_darrow :: Maybe (IsUnicodeSyntax, EpaLocation), 705 -- ^ location and encoding of the '=>', if present. 706 ac_open :: [EpaLocation], -- ^ zero or more opening parentheses. 707 ac_close :: [EpaLocation] -- ^ zero or more closing parentheses. 708 } deriving (Data) 709 710 711-- --------------------------------------------------------------------- 712-- Annotations for names 713-- --------------------------------------------------------------------- 714 715-- | exact print annotations for a 'RdrName'. There are many kinds of 716-- adornment that can be attached to a given 'RdrName'. This type 717-- captures them, as detailed on the individual constructors. 718data NameAnn 719 -- | Used for a name with an adornment, so '`foo`', '(bar)' 720 = NameAnn { 721 nann_adornment :: NameAdornment, 722 nann_open :: EpaLocation, 723 nann_name :: EpaLocation, 724 nann_close :: EpaLocation, 725 nann_trailing :: [TrailingAnn] 726 } 727 -- | Used for @(,,,)@, or @(#,,,#)# 728 | NameAnnCommas { 729 nann_adornment :: NameAdornment, 730 nann_open :: EpaLocation, 731 nann_commas :: [EpaLocation], 732 nann_close :: EpaLocation, 733 nann_trailing :: [TrailingAnn] 734 } 735 -- | Used for @()@, @(##)@, @[]@ 736 | NameAnnOnly { 737 nann_adornment :: NameAdornment, 738 nann_open :: EpaLocation, 739 nann_close :: EpaLocation, 740 nann_trailing :: [TrailingAnn] 741 } 742 -- | Used for @->@, as an identifier 743 | NameAnnRArrow { 744 nann_name :: EpaLocation, 745 nann_trailing :: [TrailingAnn] 746 } 747 -- | Used for an item with a leading @'@. The annotation for 748 -- unquoted item is stored in 'nann_quoted'. 749 | NameAnnQuote { 750 nann_quote :: EpaLocation, 751 nann_quoted :: SrcSpanAnnN, 752 nann_trailing :: [TrailingAnn] 753 } 754 -- | Used when adding a 'TrailingAnn' to an existing 'LocatedN' 755 -- which has no Api Annotation (via the 'EpAnnNotUsed' constructor. 756 | NameAnnTrailing { 757 nann_trailing :: [TrailingAnn] 758 } 759 deriving (Data, Eq) 760 761-- | A 'NameAnn' can capture the locations of surrounding adornments, 762-- such as parens or backquotes. This data type identifies what 763-- particular pair are being used. 764data NameAdornment 765 = NameParens -- ^ '(' ')' 766 | NameParensHash -- ^ '(#' '#)' 767 | NameBackquotes -- ^ '`' 768 | NameSquare -- ^ '[' ']' 769 deriving (Eq, Ord, Data) 770 771-- --------------------------------------------------------------------- 772 773-- | exact print annotation used for capturing the locations of 774-- annotations in pragmas. 775data AnnPragma 776 = AnnPragma { 777 apr_open :: AddEpAnn, 778 apr_close :: AddEpAnn, 779 apr_rest :: [AddEpAnn] 780 } deriving (Data,Eq) 781 782-- --------------------------------------------------------------------- 783-- | Captures the sort order of sub elements. This is needed when the 784-- sub-elements have been split (as in a HsLocalBind which holds separate 785-- binds and sigs) or for infix patterns where the order has been 786-- re-arranged. It is captured explicitly so that after the Delta phase a 787-- SrcSpan is used purely as an index into the annotations, allowing 788-- transformations of the AST including the introduction of new Located 789-- items or re-arranging existing ones. 790data AnnSortKey 791 = NoAnnSortKey 792 | AnnSortKey [RealSrcSpan] 793 deriving (Data, Eq) 794 795-- --------------------------------------------------------------------- 796 797 798-- | Helper function used in the parser to add a 'TrailingAnn' items 799-- to an existing annotation. 800addTrailingAnnToL :: SrcSpan -> TrailingAnn -> EpAnnComments 801 -> EpAnn AnnList -> EpAnn AnnList 802addTrailingAnnToL s t cs EpAnnNotUsed 803 = EpAnn (spanAsAnchor s) (AnnList (Just $ spanAsAnchor s) Nothing Nothing [] [t]) cs 804addTrailingAnnToL _ t cs n = n { anns = addTrailing (anns n) 805 , comments = comments n <> cs } 806 where 807 -- See Note [list append in addTrailing*] 808 addTrailing n = n { al_trailing = al_trailing n ++ [t]} 809 810-- | Helper function used in the parser to add a 'TrailingAnn' items 811-- to an existing annotation. 812addTrailingAnnToA :: SrcSpan -> TrailingAnn -> EpAnnComments 813 -> EpAnn AnnListItem -> EpAnn AnnListItem 814addTrailingAnnToA s t cs EpAnnNotUsed 815 = EpAnn (spanAsAnchor s) (AnnListItem [t]) cs 816addTrailingAnnToA _ t cs n = n { anns = addTrailing (anns n) 817 , comments = comments n <> cs } 818 where 819 -- See Note [list append in addTrailing*] 820 addTrailing n = n { lann_trailing = lann_trailing n ++ [t] } 821 822-- | Helper function used in the parser to add a comma location to an 823-- existing annotation. 824addTrailingCommaToN :: SrcSpan -> EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn 825addTrailingCommaToN s EpAnnNotUsed l 826 = EpAnn (spanAsAnchor s) (NameAnnTrailing [AddCommaAnn l]) emptyComments 827addTrailingCommaToN _ n l = n { anns = addTrailing (anns n) l } 828 where 829 -- See Note [list append in addTrailing*] 830 addTrailing :: NameAnn -> EpaLocation -> NameAnn 831 addTrailing n l = n { nann_trailing = nann_trailing n ++ [AddCommaAnn l]} 832 833{- 834Note [list append in addTrailing*] 835~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 836The addTrailingAnnToL, addTrailingAnnToA and addTrailingCommaToN 837functions are used to add a separator for an item when it occurs in a 838list. So they are used to capture a comma, vbar, semicolon and similar. 839 840In general, a given element will have zero or one of these. In 841extreme (test) cases, there may be multiple semicolons. 842 843In exact printing we sometimes convert the EpaLocation variant for an 844trailing annotation to the EpaDelta variant, which cannot be sorted. 845 846Hence it is critical that these annotations are captured in the order 847they appear in the original source file. 848 849And so we use the less efficient list append to preserve the order, 850knowing that in most cases the original list is empty. 851-} 852 853-- --------------------------------------------------------------------- 854 855-- |Helper function (temporary) during transition of names 856-- Discards any annotations 857l2n :: LocatedAn a1 a2 -> LocatedN a2 858l2n (L la a) = L (noAnnSrcSpan (locA la)) a 859 860n2l :: LocatedN a -> LocatedA a 861n2l (L la a) = L (na2la la) a 862 863-- |Helper function (temporary) during transition of names 864-- Discards any annotations 865la2na :: SrcSpanAnn' a -> SrcSpanAnnN 866la2na l = noAnnSrcSpan (locA l) 867 868-- |Helper function (temporary) during transition of names 869-- Discards any annotations 870la2la :: LocatedAn ann1 a2 -> LocatedAn ann2 a2 871la2la (L la a) = L (noAnnSrcSpan (locA la)) a 872 873l2l :: SrcSpanAnn' a -> SrcAnn ann 874l2l l = noAnnSrcSpan (locA l) 875 876-- |Helper function (temporary) during transition of names 877-- Discards any annotations 878na2la :: SrcSpanAnn' a -> SrcAnn ann 879na2la l = noAnnSrcSpan (locA l) 880 881reLoc :: LocatedAn a e -> Located e 882reLoc (L (SrcSpanAnn _ l) a) = L l a 883 884reLocA :: Located e -> LocatedAn ann e 885reLocA (L l a) = (L (SrcSpanAnn EpAnnNotUsed l) a) 886 887reLocL :: LocatedN e -> LocatedA e 888reLocL (L l a) = (L (na2la l) a) 889 890reLocC :: LocatedN e -> LocatedC e 891reLocC (L l a) = (L (na2la l) a) 892 893reLocN :: LocatedN a -> Located a 894reLocN (L (SrcSpanAnn _ l) a) = L l a 895 896-- --------------------------------------------------------------------- 897 898realSrcSpan :: SrcSpan -> RealSrcSpan 899realSrcSpan (RealSrcSpan s _) = s 900realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary 901 where 902 l = mkRealSrcLoc (fsLit "foo") (-1) (-1) 903 904la2r :: SrcSpanAnn' a -> RealSrcSpan 905la2r l = realSrcSpan (locA l) 906 907extraToAnnList :: AnnList -> [AddEpAnn] -> AnnList 908extraToAnnList (AnnList a o c e t) as = AnnList a o c (e++as) t 909 910reAnn :: [TrailingAnn] -> EpAnnComments -> Located a -> LocatedA a 911reAnn anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem anns) cs) l) a 912 913reAnnC :: AnnContext -> EpAnnComments -> Located a -> LocatedC a 914reAnnC anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a 915 916reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (SrcAnn ann) e 917reAnnL anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a 918 919getLocAnn :: Located a -> SrcSpanAnnA 920getLocAnn (L l _) = SrcSpanAnn EpAnnNotUsed l 921 922 923getLocA :: GenLocated (SrcSpanAnn' a) e -> SrcSpan 924getLocA (L (SrcSpanAnn _ l) _) = l 925 926noLocA :: a -> LocatedAn an a 927noLocA = L (SrcSpanAnn EpAnnNotUsed noSrcSpan) 928 929noAnnSrcSpan :: SrcSpan -> SrcAnn ann 930noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l 931 932noSrcSpanA :: SrcAnn ann 933noSrcSpanA = noAnnSrcSpan noSrcSpan 934 935-- | Short form for 'EpAnnNotUsed' 936noAnn :: EpAnn a 937noAnn = EpAnnNotUsed 938 939 940addAnns :: EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] 941addAnns (EpAnn l as1 cs) as2 cs2 942 = EpAnn (widenAnchor l (as1 ++ as2)) (as1 ++ as2) (cs <> cs2) 943addAnns EpAnnNotUsed [] (EpaComments []) = EpAnnNotUsed 944addAnns EpAnnNotUsed [] (EpaCommentsBalanced [] []) = EpAnnNotUsed 945addAnns EpAnnNotUsed as cs = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) as cs 946 947-- AZ:TODO use widenSpan here too 948addAnnsA :: SrcSpanAnnA -> [TrailingAnn] -> EpAnnComments -> SrcSpanAnnA 949addAnnsA (SrcSpanAnn (EpAnn l as1 cs) loc) as2 cs2 950 = SrcSpanAnn (EpAnn l (AnnListItem (lann_trailing as1 ++ as2)) (cs <> cs2)) loc 951addAnnsA (SrcSpanAnn EpAnnNotUsed loc) [] (EpaComments []) 952 = SrcSpanAnn EpAnnNotUsed loc 953addAnnsA (SrcSpanAnn EpAnnNotUsed loc) [] (EpaCommentsBalanced [] []) 954 = SrcSpanAnn EpAnnNotUsed loc 955addAnnsA (SrcSpanAnn EpAnnNotUsed loc) as cs 956 = SrcSpanAnn (EpAnn (spanAsAnchor loc) (AnnListItem as) cs) loc 957 958-- | The annotations need to all come after the anchor. Make sure 959-- this is the case. 960widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan 961widenSpan s as = foldl combineSrcSpans s (go as) 962 where 963 go [] = [] 964 go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Nothing : go rest 965 go (AddEpAnn _ (EpaDelta _ _):rest) = go rest 966 967-- | The annotations need to all come after the anchor. Make sure 968-- this is the case. 969widenRealSpan :: RealSrcSpan -> [AddEpAnn] -> RealSrcSpan 970widenRealSpan s as = foldl combineRealSrcSpans s (go as) 971 where 972 go [] = [] 973 go (AddEpAnn _ (EpaSpan s):rest) = s : go rest 974 go (AddEpAnn _ (EpaDelta _ _):rest) = go rest 975 976widenAnchor :: Anchor -> [AddEpAnn] -> Anchor 977widenAnchor (Anchor s op) as = Anchor (widenRealSpan s as) op 978 979widenAnchorR :: Anchor -> RealSrcSpan -> Anchor 980widenAnchorR (Anchor s op) r = Anchor (combineRealSrcSpans s r) op 981 982widenLocatedAn :: SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an 983widenLocatedAn (SrcSpanAnn a l) as = SrcSpanAnn a (widenSpan l as) 984 985epAnnAnnsL :: EpAnn a -> [a] 986epAnnAnnsL EpAnnNotUsed = [] 987epAnnAnnsL (EpAnn _ anns _) = [anns] 988 989epAnnAnns :: EpAnn [AddEpAnn] -> [AddEpAnn] 990epAnnAnns EpAnnNotUsed = [] 991epAnnAnns (EpAnn _ anns _) = anns 992 993annParen2AddEpAnn :: EpAnn AnnParen -> [AddEpAnn] 994annParen2AddEpAnn EpAnnNotUsed = [] 995annParen2AddEpAnn (EpAnn _ (AnnParen pt o c) _) 996 = [AddEpAnn ai o, AddEpAnn ac c] 997 where 998 (ai,ac) = parenTypeKws pt 999 1000epAnnComments :: EpAnn an -> EpAnnComments 1001epAnnComments EpAnnNotUsed = EpaComments [] 1002epAnnComments (EpAnn _ _ cs) = cs 1003 1004-- --------------------------------------------------------------------- 1005-- sortLocatedA :: [LocatedA a] -> [LocatedA a] 1006sortLocatedA :: [GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e] 1007sortLocatedA = sortBy (leftmost_smallest `on` getLocA) 1008 1009mapLocA :: (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b 1010mapLocA f (L l a) = L (noAnnSrcSpan l) (f a) 1011 1012-- AZ:TODO: move this somewhere sane 1013 1014combineLocsA :: Semigroup a => GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a 1015combineLocsA (L a _) (L b _) = combineSrcSpansA a b 1016 1017combineSrcSpansA :: Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a 1018combineSrcSpansA (SrcSpanAnn aa la) (SrcSpanAnn ab lb) 1019 = case SrcSpanAnn (aa <> ab) (combineSrcSpans la lb) of 1020 SrcSpanAnn EpAnnNotUsed l -> SrcSpanAnn EpAnnNotUsed l 1021 SrcSpanAnn (EpAnn anc an cs) l -> 1022 SrcSpanAnn (EpAnn (widenAnchorR anc (realSrcSpan l)) an cs) l 1023 1024-- | Combine locations from two 'Located' things and add them to a third thing 1025addCLocA :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3 1026addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (getLoc b)) c 1027 1028addCLocAA :: GenLocated (SrcSpanAnn' a1) e1 -> GenLocated (SrcSpanAnn' a2) e2 -> e3 -> GenLocated (SrcAnn ann) e3 1029addCLocAA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (locA $ getLoc b)) c 1030 1031-- --------------------------------------------------------------------- 1032-- Utilities for manipulating EpAnnComments 1033-- --------------------------------------------------------------------- 1034 1035getFollowingComments :: EpAnnComments -> [LEpaComment] 1036getFollowingComments (EpaComments _) = [] 1037getFollowingComments (EpaCommentsBalanced _ cs) = cs 1038 1039setFollowingComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments 1040setFollowingComments (EpaComments ls) cs = EpaCommentsBalanced ls cs 1041setFollowingComments (EpaCommentsBalanced ls _) cs = EpaCommentsBalanced ls cs 1042 1043setPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments 1044setPriorComments (EpaComments _) cs = EpaComments cs 1045setPriorComments (EpaCommentsBalanced _ ts) cs = EpaCommentsBalanced cs ts 1046 1047-- --------------------------------------------------------------------- 1048-- Comment-only annotations 1049-- --------------------------------------------------------------------- 1050 1051-- TODO:AZ I think EpAnnCO is not needed 1052type EpAnnCO = EpAnn NoEpAnns -- ^ Api Annotations for comments only 1053 1054data NoEpAnns = NoEpAnns 1055 deriving (Data,Eq,Ord) 1056 1057noComments ::EpAnnCO 1058noComments = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) NoEpAnns emptyComments 1059 1060-- TODO:AZ get rid of this 1061placeholderRealSpan :: RealSrcSpan 1062placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1)) 1063 1064comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO 1065comment loc cs = EpAnn (Anchor loc UnchangedAnchor) NoEpAnns cs 1066 1067-- --------------------------------------------------------------------- 1068-- Utilities for managing comments in an `EpAnn a` structure. 1069-- --------------------------------------------------------------------- 1070 1071-- | Add additional comments to a 'SrcAnn', used for manipulating the 1072-- AST prior to exact printing the changed one. 1073addCommentsToSrcAnn :: (Monoid ann) => SrcAnn ann -> EpAnnComments -> SrcAnn ann 1074addCommentsToSrcAnn (SrcSpanAnn EpAnnNotUsed loc) cs 1075 = SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs) loc 1076addCommentsToSrcAnn (SrcSpanAnn (EpAnn a an cs) loc) cs' 1077 = SrcSpanAnn (EpAnn a an (cs <> cs')) loc 1078 1079-- | Replace any existing comments on a 'SrcAnn', used for manipulating the 1080-- AST prior to exact printing the changed one. 1081setCommentsSrcAnn :: (Monoid ann) => SrcAnn ann -> EpAnnComments -> SrcAnn ann 1082setCommentsSrcAnn (SrcSpanAnn EpAnnNotUsed loc) cs 1083 = SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs) loc 1084setCommentsSrcAnn (SrcSpanAnn (EpAnn a an _) loc) cs 1085 = SrcSpanAnn (EpAnn a an cs) loc 1086 1087-- | Add additional comments, used for manipulating the 1088-- AST prior to exact printing the changed one. 1089addCommentsToEpAnn :: (Monoid a) 1090 => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a 1091addCommentsToEpAnn loc EpAnnNotUsed cs 1092 = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs 1093addCommentsToEpAnn _ (EpAnn a an ocs) ncs = EpAnn a an (ocs <> ncs) 1094 1095-- | Replace any existing comments, used for manipulating the 1096-- AST prior to exact printing the changed one. 1097setCommentsEpAnn :: (Monoid a) 1098 => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a 1099setCommentsEpAnn loc EpAnnNotUsed cs 1100 = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs 1101setCommentsEpAnn _ (EpAnn a an _) cs = EpAnn a an cs 1102 1103-- | Transfer comments and trailing items from the annotations in the 1104-- first 'SrcSpanAnnA' argument to those in the second. 1105transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA) 1106transferAnnsA from@(SrcSpanAnn EpAnnNotUsed _) to = (from, to) 1107transferAnnsA (SrcSpanAnn (EpAnn a an cs) l) to 1108 = ((SrcSpanAnn (EpAnn a mempty emptyComments) l), to') 1109 where 1110 to' = case to of 1111 (SrcSpanAnn EpAnnNotUsed loc) 1112 -> SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) an cs) loc 1113 (SrcSpanAnn (EpAnn a an' cs') loc) 1114 -> SrcSpanAnn (EpAnn a (an' <> an) (cs' <> cs)) loc 1115 1116-- | Remove the exact print annotations payload, leaving only the 1117-- anchor and comments. 1118commentsOnlyA :: Monoid ann => SrcAnn ann -> SrcAnn ann 1119commentsOnlyA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc 1120commentsOnlyA (SrcSpanAnn (EpAnn a _ cs) loc) = (SrcSpanAnn (EpAnn a mempty cs) loc) 1121 1122-- | Remove the comments, leaving the exact print annotations payload 1123removeCommentsA :: SrcAnn ann -> SrcAnn ann 1124removeCommentsA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc 1125removeCommentsA (SrcSpanAnn (EpAnn a an _) loc) 1126 = (SrcSpanAnn (EpAnn a an emptyComments) loc) 1127 1128-- --------------------------------------------------------------------- 1129-- Semigroup instances, to allow easy combination of annotaion elements 1130-- --------------------------------------------------------------------- 1131 1132instance (Semigroup an) => Semigroup (SrcSpanAnn' an) where 1133 (SrcSpanAnn a1 l1) <> (SrcSpanAnn a2 l2) = SrcSpanAnn (a1 <> a2) (combineSrcSpans l1 l2) 1134 -- The critical part about the location is its left edge, and all 1135 -- annotations must follow it. So we combine them which yields the 1136 -- largest span 1137 1138instance (Semigroup a) => Semigroup (EpAnn a) where 1139 EpAnnNotUsed <> x = x 1140 x <> EpAnnNotUsed = x 1141 (EpAnn l1 a1 b1) <> (EpAnn l2 a2 b2) = EpAnn (l1 <> l2) (a1 <> a2) (b1 <> b2) 1142 -- The critical part about the anchor is its left edge, and all 1143 -- annotations must follow it. So we combine them which yields the 1144 -- largest span 1145 1146instance Ord Anchor where 1147 compare (Anchor s1 _) (Anchor s2 _) = compare s1 s2 1148 1149instance Semigroup Anchor where 1150 Anchor r1 o1 <> Anchor r2 _ = Anchor (combineRealSrcSpans r1 r2) o1 1151 1152instance Semigroup EpAnnComments where 1153 EpaComments cs1 <> EpaComments cs2 = EpaComments (cs1 ++ cs2) 1154 EpaComments cs1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) as2 1155 EpaCommentsBalanced cs1 as1 <> EpaComments cs2 = EpaCommentsBalanced (cs1 ++ cs2) as1 1156 EpaCommentsBalanced cs1 as1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) (as1++as2) 1157 1158 1159instance (Monoid a) => Monoid (EpAnn a) where 1160 mempty = EpAnnNotUsed 1161 1162instance Semigroup AnnListItem where 1163 (AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2) 1164 1165instance Monoid AnnListItem where 1166 mempty = AnnListItem [] 1167 1168 1169instance Semigroup AnnList where 1170 (AnnList a1 o1 c1 r1 t1) <> (AnnList a2 o2 c2 r2 t2) 1171 = AnnList (a1 <> a2) (c o1 o2) (c c1 c2) (r1 <> r2) (t1 <> t2) 1172 where 1173 -- Left biased combination for the open and close annotations 1174 c Nothing x = x 1175 c x Nothing = x 1176 c f _ = f 1177 1178instance Monoid AnnList where 1179 mempty = AnnList Nothing Nothing Nothing [] [] 1180 1181instance Semigroup NameAnn where 1182 _ <> _ = panic "semigroup nameann" 1183 1184instance Monoid NameAnn where 1185 mempty = NameAnnTrailing [] 1186 1187 1188instance Semigroup AnnSortKey where 1189 NoAnnSortKey <> x = x 1190 x <> NoAnnSortKey = x 1191 AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2) 1192 1193instance Monoid AnnSortKey where 1194 mempty = NoAnnSortKey 1195 1196instance (Outputable a) => Outputable (EpAnn a) where 1197 ppr (EpAnn l a c) = text "EpAnn" <+> ppr l <+> ppr a <+> ppr c 1198 ppr EpAnnNotUsed = text "EpAnnNotUsed" 1199 1200instance Outputable Anchor where 1201 ppr (Anchor a o) = text "Anchor" <+> ppr a <+> ppr o 1202 1203instance Outputable AnchorOperation where 1204 ppr UnchangedAnchor = text "UnchangedAnchor" 1205 ppr (MovedAnchor d) = text "MovedAnchor" <+> ppr d 1206 1207instance Outputable DeltaPos where 1208 ppr (SameLine c) = text "SameLine" <+> ppr c 1209 ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c 1210 1211instance Outputable (GenLocated Anchor EpaComment) where 1212 ppr (L l c) = text "L" <+> ppr l <+> ppr c 1213 1214instance Outputable EpAnnComments where 1215 ppr (EpaComments cs) = text "EpaComments" <+> ppr cs 1216 ppr (EpaCommentsBalanced cs ts) = text "EpaCommentsBalanced" <+> ppr cs <+> ppr ts 1217 1218instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where 1219 getName (L l a) = getName (L (locA l) a) 1220 1221instance Outputable AnnContext where 1222 ppr (AnnContext a o c) = text "AnnContext" <+> ppr a <+> ppr o <+> ppr c 1223 1224instance Outputable AnnSortKey where 1225 ppr NoAnnSortKey = text "NoAnnSortKey" 1226 ppr (AnnSortKey ls) = text "AnnSortKey" <+> ppr ls 1227 1228instance Outputable IsUnicodeSyntax where 1229 ppr = text . show 1230 1231instance Binary a => Binary (LocatedL a) where 1232 -- We do not serialise the annotations 1233 put_ bh (L l x) = do 1234 put_ bh (locA l) 1235 put_ bh x 1236 1237 get bh = do 1238 l <- get bh 1239 x <- get bh 1240 return (L (noAnnSrcSpan l) x) 1241 1242instance (Outputable a) => Outputable (SrcSpanAnn' a) where 1243 ppr (SrcSpanAnn a l) = text "SrcSpanAnn" <+> ppr a <+> ppr l 1244 1245instance (Outputable a, Outputable e) 1246 => Outputable (GenLocated (SrcSpanAnn' a) e) where 1247 ppr = pprLocated 1248 1249instance Outputable AnnListItem where 1250 ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts 1251 1252instance Outputable NameAdornment where 1253 ppr NameParens = text "NameParens" 1254 ppr NameParensHash = text "NameParensHash" 1255 ppr NameBackquotes = text "NameBackquotes" 1256 ppr NameSquare = text "NameSquare" 1257 1258instance Outputable NameAnn where 1259 ppr (NameAnn a o n c t) 1260 = text "NameAnn" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t 1261 ppr (NameAnnCommas a o n c t) 1262 = text "NameAnnCommas" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t 1263 ppr (NameAnnOnly a o c t) 1264 = text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t 1265 ppr (NameAnnRArrow n t) 1266 = text "NameAnnRArrow" <+> ppr n <+> ppr t 1267 ppr (NameAnnQuote q n t) 1268 = text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t 1269 ppr (NameAnnTrailing t) 1270 = text "NameAnnTrailing" <+> ppr t 1271 1272instance Outputable AnnList where 1273 ppr (AnnList a o c r t) 1274 = text "AnnList" <+> ppr a <+> ppr o <+> ppr c <+> ppr r <+> ppr t 1275 1276instance Outputable AnnPragma where 1277 ppr (AnnPragma o c r) = text "AnnPragma" <+> ppr o <+> ppr c <+> ppr r 1278