1{-# LANGUAGE CPP #-} 2{-# LANGUAGE ConstraintKinds #-} 3{-# LANGUAGE DeriveDataTypeable #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE FlexibleInstances #-} 6{-# LANGUAGE GeneralizedNewtypeDeriving #-} 7{-# LANGUAGE NamedFieldPuns #-} 8{-# LANGUAGE RankNTypes #-} 9{-# LANGUAGE ScopedTypeVariables #-} 10{-# LANGUAGE TypeSynonymInstances #-} 11{-# LANGUAGE ViewPatterns #-} 12module Language.Haskell.GHC.ExactPrint.Types 13 ( -- * Core Types 14 Anns 15 , emptyAnns 16 , Annotation(..) 17 , annNone 18 19 , KeywordId(..) 20 , Comment(..) 21 -- * Positions 22 , Pos 23 , DeltaPos(..) 24 , deltaRow, deltaColumn 25 -- * AnnKey 26 , AnnSpan 27 , AnnKey(..) 28 , mkAnnKey 29 , AnnConName(..) 30 , annGetConstr 31#if __GLASGOW_HASKELL__ >= 900 32 , badRealSrcSpan 33#endif 34 35 -- * Other 36 37 , Rigidity(..) 38 , AstContext(..),AstContextSet,defaultACS 39 , ACS'(..) 40 , ListContexts(..) 41 42 -- * For managing compatibility 43 , Constraints 44 45 -- * GHC version compatibility 46 , GhcPs 47 , GhcRn 48 , GhcTc 49 50#if __GLASGOW_HASKELL__ > 804 51 , noExt 52#endif 53 54 -- * Internal Types 55 , LayoutStartCol(..) 56 , declFun 57 58 ) where 59 60import Data.Data (Data, Typeable, toConstr,cast) 61-- import Data.Generics 62 63import qualified GHC 64#if __GLASGOW_HASKELL__ >= 900 65import GHC.Data.FastString as GHC 66import GHC.Driver.Session as GHC 67import GHC.Types.SrcLoc as GHC 68import GHC.Utils.Outputable as GHC 69#else 70import qualified DynFlags as GHC 71import qualified Outputable as GHC 72#endif 73 74import qualified Data.Map as Map 75import qualified Data.Set as Set 76 77-- --------------------------------------------------------------------- 78 79#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) 80type Constraints a = (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a) 81#else 82type Constraints a = (Data a) 83#endif 84 85-- --------------------------------------------------------------------- 86 87-- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted 88-- from an @AnnKeywordId@ because the annotation must be interleaved into the 89-- stream and does not have a well-defined position 90data Comment = Comment 91 { 92 commentContents :: !String -- ^ The contents of the comment including separators 93 94 -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is 95 -- the thing we use to decide where in the output stream the comment should 96 -- go. 97 , commentIdentifier :: !AnnSpan -- ^ Needed to uniquely identify two comments with the same contents 98 , commentOrigin :: !(Maybe GHC.AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly. 99 } 100 deriving (Eq,Typeable,Data,Ord) 101instance Show Comment where 102 show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showGhc ss ++ " " ++ show o ++ ")" 103 104instance GHC.Outputable Comment where 105 ppr x = GHC.text (show x) 106 107type Pos = (Int,Int) 108 109-- | A relative positions, row then column 110newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data) 111 112deltaRow, deltaColumn :: DeltaPos -> Int 113deltaRow (DP (r, _)) = r 114deltaColumn (DP (_, c)) = c 115 116 117-- | Marks the start column of a layout block. 118newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int } 119 deriving (Eq, Num) 120 121instance Show LayoutStartCol where 122 show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")" 123 124 125annNone :: Annotation 126annNone = Ann (DP (0,0)) [] [] [] Nothing Nothing 127 128data Annotation = Ann 129 { 130 -- The first three fields relate to interfacing up into the AST 131 annEntryDelta :: !DeltaPos 132 -- ^ Offset used to get to the start of the SrcSpan, from whatever the prior 133 -- output was, including all annPriorComments (field below). 134 , annPriorComments :: ![(Comment, DeltaPos)] 135 -- ^ Comments coming after the last non-comment output of the preceding 136 -- element but before the SrcSpan being annotated by this Annotation. If 137 -- these are changed then annEntryDelta (field above) must also change to 138 -- match. 139 , annFollowingComments :: ![(Comment, DeltaPos)] 140 -- ^ Comments coming after the last output for the element subject to this 141 -- Annotation. These will only be added by AST transformations, and care 142 -- must be taken not to disturb layout of following elements. 143 144 -- The next three fields relate to interacing down into the AST 145 , annsDP :: ![(KeywordId, DeltaPos)] 146 -- ^ Annotations associated with this element. 147#if __GLASGOW_HASKELL__ >= 900 148 , annSortKey :: !(Maybe [GHC.RealSrcSpan]) 149#else 150 , annSortKey :: !(Maybe [GHC.SrcSpan]) 151#endif 152 -- ^ Captures the sort order of sub elements. This is needed when the 153 -- sub-elements have been split (as in a HsLocalBind which holds separate 154 -- binds and sigs) or for infix patterns where the order has been 155 -- re-arranged. It is captured explicitly so that after the Delta phase a 156 -- SrcSpan is used purely as an index into the annotations, allowing 157 -- transformations of the AST including the introduction of new Located 158 -- items or re-arranging existing ones. 159 , annCapturedSpan :: !(Maybe AnnKey) 160 -- ^ Occasionally we must calculate a SrcSpan for an unlocated list of 161 -- elements which we must remember for the Print phase. e.g. the statements 162 -- in a HsLet or HsDo. These must be managed as a group because they all 163 -- need eo be vertically aligned for the Haskell layout rules, and this 164 -- guarantees this property in the presence of AST edits. 165 166 } deriving (Typeable,Eq) 167 168instance Show Annotation where 169 show (Ann dp comments fcomments ans sk csp) 170 = "(Ann (" ++ show dp ++ ") " ++ show comments ++ " " 171 ++ show fcomments ++ " " 172 ++ show ans ++ " " ++ showGhc sk ++ " " 173 ++ showGhc csp ++ ")" 174 175 176-- | This structure holds a complete set of annotations for an AST 177type Anns = Map.Map AnnKey Annotation 178 179emptyAnns :: Anns 180emptyAnns = Map.empty 181 182-- | For every @Located a@, use the @SrcSpan@ and constructor name of 183-- a as the key, to store the standard annotation. 184-- These are used to maintain context in the AP and EP monads 185data AnnKey = AnnKey AnnSpan AnnConName 186 deriving (Eq, Ord, Data) 187 188-- | From GHC 9.0 the ParsedSource uses RealSrcSpan instead of SrcSpan. 189-- Compatibility type 190#if __GLASGOW_HASKELL__ >= 900 191type AnnSpan = GHC.RealSrcSpan 192#else 193type AnnSpan = GHC.SrcSpan 194#endif 195 196-- More compact Show instance 197instance Show AnnKey where 198 show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn 199 200 201#if __GLASGOW_HASKELL__ >= 900 202mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey 203mkAnnKeyPrim (GHC.L (GHC.RealSrcSpan l _) a) = AnnKey l (annGetConstr a) 204mkAnnKeyPrim (GHC.L _ a) = AnnKey badRealSrcSpan (annGetConstr a) 205#elif __GLASGOW_HASKELL__ > 806 206mkAnnKeyPrim :: (Constraints a) 207 => a -> AnnKey 208mkAnnKeyPrim (GHC.dL->GHC.L l a) = AnnKey l (annGetConstr a) 209#else 210mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey 211mkAnnKeyPrim (GHC.L l a) = AnnKey l (annGetConstr a) 212#endif 213 214 215#if __GLASGOW_HASKELL__ >= 900 216badRealSrcSpan :: GHC.RealSrcSpan 217badRealSrcSpan = GHC.mkRealSrcSpan bad bad 218 where 219 bad = GHC.mkRealSrcLoc (GHC.fsLit "ghc-exactprint-nospan") 0 0 220#endif 221 222#if __GLASGOW_HASKELL__ <= 802 223type GhcPs = GHC.RdrName 224type GhcRn = GHC.Name 225type GhcTc = GHC.Id 226#else 227type GhcPs = GHC.GhcPs 228type GhcRn = GHC.GhcRn 229type GhcTc = GHC.GhcTc 230#endif 231 232 233#if __GLASGOW_HASKELL__ > 808 234noExt :: GHC.NoExtField 235noExt = GHC.NoExtField 236#elif __GLASGOW_HASKELL__ > 804 237noExt :: GHC.NoExt 238noExt = GHC.noExt 239#endif 240 241-- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise. 242#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) 243mkAnnKey :: (Constraints a) => a -> AnnKey 244#else 245mkAnnKey :: (Data a) => GHC.Located a -> AnnKey 246#endif 247mkAnnKey ld = 248 case cast ld :: Maybe (GHC.LHsDecl GhcPs) of 249 Just d -> declFun mkAnnKeyPrim d 250 Nothing -> mkAnnKeyPrim ld 251 252-- Holds the name of a constructor 253data AnnConName = CN { unConName :: String } 254 deriving (Eq, Ord, Data) 255 256-- More compact show instance 257instance Show AnnConName where 258 show (CN s) = "CN " ++ show s 259 260annGetConstr :: (Data a) => a -> AnnConName 261annGetConstr a = CN (show $ toConstr a) 262 263-- | The different syntactic elements which are not represented in the 264-- AST. 265data KeywordId = G GHC.AnnKeywordId -- ^ A normal keyword 266 | AnnSemiSep -- ^ A separating comma 267#if __GLASGOW_HASKELL__ >= 900 268 | AnnEofPos 269#endif 270#if __GLASGOW_HASKELL__ >= 800 271 | AnnTypeApp -- ^ Visible type application annotation 272#endif 273 | AnnComment Comment 274 | AnnString String -- ^ Used to pass information from 275 -- Delta to Print when we have to work 276 -- out details from the original 277 -- SrcSpan. 278#if __GLASGOW_HASKELL__ <= 710 279 | AnnUnicode GHC.AnnKeywordId -- ^ Used to indicate that we should print using unicode syntax if possible. 280#endif 281 deriving (Eq, Ord, Data) 282 283instance Show KeywordId where 284 show (G gc) = "(G " ++ show gc ++ ")" 285 show AnnSemiSep = "AnnSemiSep" 286#if __GLASGOW_HASKELL__ >= 900 287 show AnnEofPos = "AnnEofPos" 288#endif 289#if __GLASGOW_HASKELL__ >= 800 290 show AnnTypeApp = "AnnTypeApp" 291#endif 292 show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")" 293 show (AnnString s) = "(AnnString " ++ s ++ ")" 294#if __GLASGOW_HASKELL__ <= 710 295 show (AnnUnicode gc) = "(AnnUnicode " ++ show gc ++ ")" 296#endif 297 298-- --------------------------------------------------------------------- 299 300instance GHC.Outputable KeywordId where 301 ppr k = GHC.text (show k) 302 303instance GHC.Outputable AnnConName where 304 ppr tr = GHC.text (show tr) 305 306instance GHC.Outputable Annotation where 307 ppr a = GHC.text (show a) 308 309instance GHC.Outputable AnnKey where 310 ppr a = GHC.text (show a) 311 312instance GHC.Outputable DeltaPos where 313 ppr a = GHC.text (show a) 314 315-- --------------------------------------------------------------------- 316-- 317-- Flag used to control whether we use rigid or normal layout rules. 318-- NOTE: check is done via comparison of enumeration order, be careful with any changes 319data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show) 320{- 321 322Rigidity logic. The same type is used for two different things 323 3241. As a flag in Annotate to the "SetLayoutFlag" operation, which specifies 325 NormalLayout - Layout should be captured unconditionally 326 327 RigidLayout - Layout should be captured or not depending on a parameter kept 328 in the interpreter Read state 329 3302. As the controlling parameter for the optional (Rigid) layout 331 332The nett effect is the following, where flag is the hard-coded flag value in 333Annotate, and param is the interpreter param set when the interpreter is run 334 335 flag | param | result 336 -------------+--------------+-------------------- 337 NormalLayout | either | layout captured 338 RigidLayout | NormalLayout | layout NOT captured 339 RigidLayout | RigidLayout | layout captured 340 341The flag is only used on HsIf and HsCase 342 343So 344 345 state | HsCase | HsIf 346 ----------------------------|-----------+------ 347 before rigidity flag (AZ) | no layout | layout 348 param NormalLayout | no layout | no layout 349 param RigidLayout | layout | layout 350 ----------------------------+-----------+------- 351 desired future HaRe | no layout | layout 352 desired future apply-refact | layout | layout 353-} 354 355-- --------------------------------------------------------------------- 356 357data ACS' a = ACS 358 { acs :: !(Map.Map a Int) -- ^ how many levels each AstContext should 359 -- propagate down the AST. Removed when it hits zero 360 } deriving (Show) 361 362#if __GLASGOW_HASKELL__ >= 804 363instance Semigroup (ACS' AstContext) where 364 (<>) = mappend 365#endif 366 367instance Monoid (ACS' AstContext) where 368 mempty = ACS mempty 369 -- ACS a `mappend` ACS b = ACS (a `mappend` b) 370 ACS a `mappend` ACS b = ACS (Map.unionWith max a b) 371 -- For Data.Map, mappend == union, which is a left-biased replace for key collisions 372 373type AstContextSet = ACS' AstContext 374-- data AstContextSet = ACS 375-- { acs :: !(Map.Map AstContext Int) -- ^ how many levels each AstContext should 376-- -- propagate down the AST. Removed when it 377-- -- hits zero 378-- } deriving (Show) 379 380defaultACS :: AstContextSet 381defaultACS = ACS Map.empty 382 383-- instance GHC.Outputable AstContextSet where 384instance (Show a) => GHC.Outputable (ACS' a) where 385 ppr x = GHC.text $ show x 386 387data AstContext = LambdaExpr 388 | CaseAlt 389 | NoPrecedingSpace 390 | HasHiding 391 | AdvanceLine 392 | NoAdvanceLine 393 | Intercalate -- This item may have a list separator following 394 | InIE -- possible 'type' or 'pattern' 395 | PrefixOp 396 | PrefixOpDollar 397 | InfixOp -- RdrName may be used as an infix operator 398 | ListStart -- Identifies first element of a list in layout, so its indentation can me managed differently 399 | ListItem -- Identifies subsequent elements of a list in layout 400 | TopLevel -- top level declaration 401 | NoDarrow 402 | AddVbar 403 | Deriving 404 | Parens -- TODO: Not currently used? 405 | ExplicitNeverActive 406 | InGadt 407 | InRecCon 408 | InClassDecl 409 | InSpliceDecl 410 | LeftMost -- Is this the leftmost operator in a chain of OpApps? 411 | InTypeApp -- HsTyVar in a TYPEAPP context. Has AnnAt 412 -- TODO:AZ: do we actually need this? 413 -- TODO:AZ this is actually tight prefix 414 415 -- Next four used to identify current list context 416 | CtxOnly 417 | CtxFirst 418 | CtxMiddle 419 | CtxLast 420 | CtxPos Int -- 0 for first, increasing for subsequent 421 422 -- Next are used in tellContext to push context up the tree 423 | FollowingLine 424 deriving (Eq, Ord, Show) 425 426 427data ListContexts = LC { lcOnly,lcInitial,lcMiddle,lcLast :: !(Set.Set AstContext) } 428 deriving (Eq,Show) 429 430-- --------------------------------------------------------------------- 431 432-- data LayoutContext = FollowingLine -- ^Indicates that an item such as a SigD 433-- -- should not have blank lines after it 434-- deriving (Eq, Ord, Show) 435 436-- --------------------------------------------------------------------- 437 438declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GhcPs -> b 439 440#if __GLASGOW_HASKELL__ > 804 441declFun f (GHC.L l de) = 442 case de of 443 GHC.TyClD _ d -> f (GHC.L l d) 444 GHC.InstD _ d -> f (GHC.L l d) 445 GHC.DerivD _ d -> f (GHC.L l d) 446 GHC.ValD _ d -> f (GHC.L l d) 447 GHC.SigD _ d -> f (GHC.L l d) 448#if __GLASGOW_HASKELL__ > 808 449 GHC.KindSigD _ d -> f (GHC.L l d) 450#endif 451 GHC.DefD _ d -> f (GHC.L l d) 452 GHC.ForD _ d -> f (GHC.L l d) 453 GHC.WarningD _ d -> f (GHC.L l d) 454 GHC.AnnD _ d -> f (GHC.L l d) 455 GHC.RuleD _ d -> f (GHC.L l d) 456 GHC.SpliceD _ d -> f (GHC.L l d) 457 GHC.DocD _ d -> f (GHC.L l d) 458 GHC.RoleAnnotD _ d -> f (GHC.L l d) 459 GHC.XHsDecl _ -> error "declFun:XHsDecl" 460#else 461declFun f (GHC.L l de) = 462 case de of 463 GHC.TyClD d -> f (GHC.L l d) 464 GHC.InstD d -> f (GHC.L l d) 465 GHC.DerivD d -> f (GHC.L l d) 466 GHC.ValD d -> f (GHC.L l d) 467 GHC.SigD d -> f (GHC.L l d) 468 GHC.DefD d -> f (GHC.L l d) 469 GHC.ForD d -> f (GHC.L l d) 470 GHC.WarningD d -> f (GHC.L l d) 471 GHC.AnnD d -> f (GHC.L l d) 472 GHC.RuleD d -> f (GHC.L l d) 473 GHC.VectD d -> f (GHC.L l d) 474 GHC.SpliceD d -> f (GHC.L l d) 475 GHC.DocD d -> f (GHC.L l d) 476 GHC.RoleAnnotD d -> f (GHC.L l d) 477#if __GLASGOW_HASKELL__ < 711 478 GHC.QuasiQuoteD d -> f (GHC.L l d) 479#endif 480#endif 481 482-- --------------------------------------------------------------------- 483 484-- Duplicated here so it can be used in show instances 485showGhc :: (GHC.Outputable a) => a -> String 486showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags 487 488-- --------------------------------------------------------------------- 489 490