1{-# LANGUAGE CPP #-} 2{-# LANGUAGE FlexibleContexts #-} 3{-# LANGUAGE NamedFieldPuns #-} 4{-# LANGUAGE RankNTypes #-} 5{-# LANGUAGE ScopedTypeVariables #-} 6{-# LANGUAGE ViewPatterns #-} 7 8----------------------------------------------------------------------------- 9-- | 10-- Module : Language.Haskell.GHC.ExactPrint.Pretty 11-- 12-- This module adds default annotations to an AST fragment that does not have 13-- them, to be able to exactprint it in a way that preserves the orginal AST 14-- when re-parsed. 15-- 16----------------------------------------------------------------------------- 17 18module Language.Haskell.GHC.ExactPrint.Pretty 19 ( 20 addAnnotationsForPretty 21 ) where 22 23import Language.Haskell.GHC.ExactPrint.Types 24import Language.Haskell.GHC.ExactPrint.Utils 25import Language.Haskell.GHC.ExactPrint.Annotate 26 27import Control.Monad.RWS 28import Control.Monad.Trans.Free 29import Data.Generics 30import Data.List 31import Data.Ord (comparing) 32 33 34#if __GLASGOW_HASKELL__ <= 710 35import qualified BooleanFormula as GHC 36import qualified Outputable as GHC 37#endif 38import qualified GHC 39 40import qualified Data.Map as Map 41import qualified Data.Set as Set 42 43{-# ANN module "HLint: ignore Eta reduce" #-} 44{-# ANN module "HLint: ignore Redundant do" #-} 45{-# ANN module "HLint: ignore Reduce duplication" #-} 46 47-- --------------------------------------------------------------------- 48 49-- |Add any missing annotations so that the full AST element will exactprint 50-- properly when done. 51addAnnotationsForPretty :: (Annotate a) => [Comment] -> GHC.Located a -> Anns -> Anns 52addAnnotationsForPretty cs ast ans 53 = runPrettyWithComments opts cs (annotate ast) ans (0,0) 54 where 55 opts = prettyOptions NormalLayout 56 57-- --------------------------------------------------------------------- 58-- 59-- | Type used in the Pretty Monad. 60type Pretty a = RWS PrettyOptions PrettyWriter PrettyState a 61 62runPrettyWithComments :: PrettyOptions -> [Comment] -> Annotated () -> Anns -> Pos -> Anns 63runPrettyWithComments opts cs action ans priorEnd = 64 mkAnns . snd 65 . (\next -> execRWS next opts (defaultPrettyState cs priorEnd ans)) 66 . prettyInterpret $ action 67 where 68 mkAnns :: PrettyWriter -> Anns 69 mkAnns = f . dwAnns 70 f :: Monoid a => Endo a -> a 71 f = ($ mempty) . appEndo 72 73-- --------------------------------------------------------------------- 74 75-- TODO: rename this, it is the R part of the RWS 76data PrettyOptions = PrettyOptions 77 { 78 -- | Current `SrcSpan, part of current AnnKey` 79 curSrcSpan :: !GHC.SrcSpan 80 81 -- | Constuctor of current AST element, part of current AnnKey 82 , annConName :: !AnnConName 83 84 -- | Whether to use rigid or normal layout rules 85 , drRigidity :: !Rigidity 86 87 -- | Current higher level context. e.g. whether a Match is part of a 88 -- LambdaExpr or a FunBind 89 , prContext :: !AstContextSet 90 } deriving Show 91 92data PrettyWriter = PrettyWriter 93 { -- | Final list of annotations, and sort keys 94 dwAnns :: Endo (Map.Map AnnKey Annotation) 95 96 -- | Used locally to pass Keywords, delta pairs relevant to a specific 97 -- subtree to the parent. 98 , annKds :: ![(KeywordId, DeltaPos)] 99 , sortKeys :: !(Maybe [AnnSpan]) 100 , dwCapturedSpan :: !(First AnnKey) 101 , prLayoutContext :: !(ACS' AstContext) 102 } 103 104data PrettyState = PrettyState 105 { -- | Position reached when processing the last element 106 priorEndPosition :: !Pos 107 108 -- | Ordered list of comments still to be allocated 109 , apComments :: ![Comment] 110 111 , apMarkLayout :: Bool 112 , apLayoutStart :: LayoutStartCol 113 114 , apNoPrecedingSpace :: Bool 115 116 } 117 118#if __GLASGOW_HASKELL__ >= 804 119instance Semigroup PrettyWriter where 120 (<>) = mappend 121#endif 122 123instance Monoid PrettyWriter where 124 mempty = PrettyWriter mempty mempty mempty mempty mempty 125 (PrettyWriter a b e g i) `mappend` (PrettyWriter c d f h j) 126 = PrettyWriter (a <> c) (b <> d) (e <> f) (g <> h) (i <> j) 127 128-- --------------------------------------------------------------------- 129 130prettyOptions :: Rigidity -> PrettyOptions 131prettyOptions ridigity = 132 PrettyOptions 133 { curSrcSpan = GHC.noSrcSpan 134 , annConName = annGetConstr () 135 , drRigidity = ridigity 136 , prContext = defaultACS 137 } 138 139defaultPrettyState :: [Comment] -> Pos -> Anns -> PrettyState 140defaultPrettyState injectedComments priorEnd _ans = 141 PrettyState 142 { priorEndPosition = priorEnd 143 , apComments = cs ++ injectedComments 144 , apLayoutStart = 1 145 , apMarkLayout = False 146 , apNoPrecedingSpace = False 147 } 148 where 149 cs :: [Comment] 150 cs = [] 151 152-- --------------------------------------------------------------------- 153-- Free Monad Interpretation code 154 155prettyInterpret :: Annotated a -> Pretty a 156prettyInterpret = iterTM go 157 where 158 go :: AnnotationF (Pretty a) -> Pretty a 159 go (MarkPrim kwid _ next) = addPrettyAnnotation (G kwid) >> next 160 go (MarkPPOptional _kwid _ next) = next 161 go (MarkEOF next) = addEofAnnotation >> next 162 go (MarkExternal _ss akwid _ next) = addPrettyAnnotation (G akwid) >> next 163#if __GLASGOW_HASKELL__ >= 800 164 go (MarkInstead akwid kwid next) = addPrettyAnnotationsInstead akwid kwid >> next 165#endif 166 go (MarkOutside akwid kwid next) = addPrettyAnnotationsOutside akwid kwid >> next 167 -- go (MarkOutside akwid kwid next) = addPrettyAnnotation kwid >> next 168 go (MarkInside akwid next) = addPrettyAnnotationsInside akwid >> next 169 go (MarkMany akwid next) = addPrettyAnnotation (G akwid) >> next 170 go (MarkManyOptional _akwid next) = next 171 go (MarkOffsetPrim akwid n _ next) = addPrettyAnnotationLs akwid n >> next 172 go (MarkOffsetPrimOptional _akwid _n _ next) = next 173 go (WithAST lss prog next) = withAST lss (prettyInterpret prog) >> next 174 go (CountAnns kwid next) = countAnnsPretty kwid >>= next 175 go (WithSortKey kws next) = withSortKey kws >> next 176 go (WithSortKeyContexts ctx kws next) = withSortKeyContexts ctx kws >> next 177 go (SetLayoutFlag r action next) = do 178 rigidity <- asks drRigidity 179 (if r <= rigidity then setLayoutFlag else id) (prettyInterpret action) 180 next 181 go (StoreOriginalSrcSpan l key next) = storeOriginalSrcSpanPretty l key >>= next 182 go (MarkAnnBeforeAnn _ann1 _ann2 next) = next 183 go (GetSrcSpanForKw ss kw next) = getSrcSpanForKw ss kw >>= next 184#if __GLASGOW_HASKELL__ <= 710 185 go (StoreString s ss next) = storeString s ss >> next 186#endif 187 go (AnnotationsToComments kws next) = annotationsToCommentsPretty kws >> next 188#if __GLASGOW_HASKELL__ <= 710 189 go (AnnotationsToCommentsBF bf kws next) = annotationsToCommentsBFPretty bf kws >> next 190 go (FinalizeBF l next) = finalizeBFPretty l >> next 191#endif 192 193 go (SetContextLevel ctxt lvl action next) = setContextPretty ctxt lvl (prettyInterpret action) >> next 194 go (UnsetContext ctxt action next) = unsetContextPretty ctxt (prettyInterpret action) >> next 195 go (IfInContext ctxt ia ea next) = ifInContextPretty ctxt ia ea >> next 196 go (TellContext c next) = tellContext c >> next 197 198-- --------------------------------------------------------------------- 199 200addEofAnnotation :: Pretty () 201addEofAnnotation = do 202#if __GLASGOW_HASKELL__ >= 900 203 tellKd (AnnEofPos, DP (1,0)) 204#else 205 tellKd (G GHC.AnnEofPos, DP (1,0)) 206#endif 207 208-- --------------------------------------------------------------------- 209 210addPrettyAnnotation :: KeywordId -> Pretty () 211addPrettyAnnotation ann = do 212 noPrec <- gets apNoPrecedingSpace 213 ctx <- asks prContext 214 _ <- debugP ("Pretty.addPrettyAnnotation:=" ++ showGhc (ann,noPrec,ctx)) $ asks prContext 215 let 216 dp = case ann of 217 (G GHC.AnnAs) -> tellKd (ann,DP (0,1)) 218 (G GHC.AnnAt) -> tellKd (ann,DP (0,0)) 219#if __GLASGOW_HASKELL__ >= 806 220 (G GHC.AnnAnyclass) -> tellKd (ann,DP (0,1)) 221#endif 222 (G GHC.AnnBackquote) -> tellKd (ann,DP (0,1)) 223 (G GHC.AnnBang) -> tellKd (ann,DP (0,1)) 224 (G GHC.AnnBy) -> tellKd (ann,DP (0,1)) 225 (G GHC.AnnCase ) -> tellKd (ann,DP (0,1)) 226 (G GHC.AnnClass) -> tellKd (ann,DP (0,1)) 227 (G GHC.AnnClose) -> tellKd (ann,DP (0,1)) 228 (G GHC.AnnCloseC) -> tellKd (ann,DP (0,0)) 229#if __GLASGOW_HASKELL__ >= 802 230 (G GHC.AnnCloseQ) -> tellKd (ann,DP (0,1)) 231#endif 232 (G GHC.AnnDcolon) -> tellKd (ann,DP (0,1)) 233 (G GHC.AnnDeriving) -> tellKd (ann,DP (0,1)) 234 (G GHC.AnnDo) -> tellKd (ann,DP (0,1)) 235#if __GLASGOW_HASKELL__ >= 900 236 (G GHC.AnnDollar) -> tellKd (ann,DP (0,1)) 237 (G GHC.AnnDollarDollar) -> tellKd (ann,DP (0,1)) 238#endif 239 (G GHC.AnnDotdot) -> tellKd (ann,DP (0,1)) 240 (G GHC.AnnElse) -> tellKd (ann,DP (1,2)) 241 (G GHC.AnnEqual) -> tellKd (ann,DP (0,1)) 242 (G GHC.AnnExport) -> tellKd (ann,DP (0,1)) 243 (G GHC.AnnFamily) -> tellKd (ann,DP (0,1)) 244 (G GHC.AnnForall) -> tellKd (ann,DP (0,1)) 245 (G GHC.AnnGroup) -> tellKd (ann,DP (0,1)) 246 (G GHC.AnnHiding) -> tellKd (ann,DP (0,1)) 247 (G GHC.AnnIf) -> tellKd (ann,DP (0,1)) 248 (G GHC.AnnImport) -> tellKd (ann,DP (0,1)) 249 (G GHC.AnnIn) -> tellKd (ann,DP (1,0)) 250 (G GHC.AnnInstance) -> tellKd (ann,DP (0,1)) 251 (G GHC.AnnLam) -> tellKd (ann,DP (0,1)) 252 (G GHC.AnnLet) -> tellKd (ann,DP (0,1)) 253#if __GLASGOW_HASKELL__ >= 900 254 -- (G GHC.AnnLolly) -> tellKd (ann,DP (0,1)) 255 (G GHC.AnnLollyU) -> tellKd (ann,DP (0,1)) 256 (G GHC.AnnPercentOne) -> tellKd (ann,DP (0,1)) 257 (G GHC.AnnPercent) -> tellKd (ann,DP (0,1)) 258#endif 259 (G GHC.AnnMinus) -> tellKd (ann,DP (0,1)) -- need to separate from preceding operator 260 (G GHC.AnnModule) -> tellKd (ann,DP (0,1)) 261 (G GHC.AnnNewtype) -> tellKd (ann,DP (0,1)) 262 (G GHC.AnnOf) -> tellKd (ann,DP (0,1)) 263 (G GHC.AnnOpenC) -> tellKd (ann,DP (0,0)) 264 (G GHC.AnnOpenP) -> tellKd (ann,DP (0,1)) 265 (G GHC.AnnOpenS) -> tellKd (ann,DP (0,1)) 266#if __GLASGOW_HASKELL__ < 900 267 (G GHC.AnnOpenPE) -> tellKd (ann,DP (0,1)) 268 (G GHC.AnnOpenPTE) -> tellKd (ann,DP (0,1)) 269#endif 270 (G GHC.AnnQualified) -> tellKd (ann,DP (0,1)) 271 (G GHC.AnnRarrow) -> tellKd (ann,DP (0,1)) 272#if __GLASGOW_HASKELL__ > 710 273 (G GHC.AnnRarrowU) -> tellKd (ann,DP (0,1)) 274#endif 275 (G GHC.AnnRole) -> tellKd (ann,DP (0,1)) 276 (G GHC.AnnSafe) -> tellKd (ann,DP (0,1)) 277#if __GLASGOW_HASKELL__ >= 806 278 (G GHC.AnnStock) -> tellKd (ann,DP (0,1)) 279#endif 280 (G GHC.AnnSimpleQuote) -> tellKd (ann,DP (0,1)) 281#if __GLASGOW_HASKELL__ < 900 282 (G GHC.AnnThIdSplice) -> tellKd (ann,DP (0,1)) 283 (G GHC.AnnThIdTySplice) -> tellKd (ann,DP (0,1)) 284#endif 285 (G GHC.AnnThTyQuote) -> tellKd (ann,DP (0,1)) 286 (G GHC.AnnThen) -> tellKd (ann,DP (1,2)) 287 (G GHC.AnnTilde) -> tellKd (ann,DP (0,1)) 288 (G GHC.AnnType) -> tellKd (ann,DP (0,1)) 289 (G GHC.AnnUsing) -> tellKd (ann,DP (0,1)) 290 (G GHC.AnnVal) -> tellKd (ann,DP (0,1)) 291 (G GHC.AnnValStr) -> tellKd (ann,DP (0,1)) 292 (G GHC.AnnVbar) -> tellKd (ann,DP (0,1)) 293#if __GLASGOW_HASKELL__ >= 806 294 (G GHC.AnnVia) -> tellKd (ann,DP (0,1)) 295#endif 296 (G GHC.AnnWhere) -> tellKd (ann,DP (1,2)) 297#if __GLASGOW_HASKELL__ >= 800 298 AnnTypeApp -> tellKd (ann,DP (0,1)) 299#endif 300 _ -> tellKd (ann,DP (0,0)) 301 fromNoPrecedingSpace (tellKd (ann,DP (0,0))) dp 302 303-- --------------------------------------------------------------------- 304 305#if __GLASGOW_HASKELL__ >= 800 306addPrettyAnnotationsInstead :: GHC.AnnKeywordId -> KeywordId -> Pretty () 307addPrettyAnnotationsInstead _akwid AnnSemiSep = return () 308addPrettyAnnotationsInstead _akwid kwid = addPrettyAnnotation kwid 309#endif 310 311-- --------------------------------------------------------------------- 312 313addPrettyAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Pretty () 314addPrettyAnnotationsOutside _akwid AnnSemiSep = return () 315addPrettyAnnotationsOutside _akwid kwid = addPrettyAnnotation kwid 316 317-- --------------------------------------------------------------------- 318 319addPrettyAnnotationsInside :: GHC.AnnKeywordId -> Pretty () 320addPrettyAnnotationsInside _ann = return () 321 322-- --------------------------------------------------------------------- 323 324addPrettyAnnotationLs :: GHC.AnnKeywordId -> Int -> Pretty () 325addPrettyAnnotationLs ann _off = addPrettyAnnotation (G ann) 326 327-- --------------------------------------------------------------------- 328 329#if __GLASGOW_HASKELL__ <= 710 330getUnallocatedComments :: Pretty [Comment] 331getUnallocatedComments = gets apComments 332 333putUnallocatedComments :: [Comment] -> Pretty () 334putUnallocatedComments cs = modify (\s -> s { apComments = cs } ) 335#endif 336 337-- --------------------------------------------------------------------- 338 339#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) 340withSrcSpanPretty :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b 341withSrcSpanPretty (GHC.dL->GHC.L l a) action = do 342#else 343withSrcSpanPretty :: Data a => GHC.Located a -> Pretty b -> Pretty b 344withSrcSpanPretty (GHC.L l a) action = do 345#endif 346 -- peek into the current state of the output, to extract the layout context 347 -- flags passed up from subelements of the AST. 348 (_,w) <- listen (return () :: Pretty ()) 349 350 _ <- debugP ("withSrcSpanPretty: prLayoutContext w=" ++ show (prLayoutContext w) ) (return ()) 351 352 local (\s -> s { curSrcSpan = l 353 , annConName = annGetConstr a 354 -- , prContext = pushAcs (prContext s) 355 , prContext = (pushAcs (prContext s)) <> (prLayoutContext w) 356 }) 357 action 358 359-- --------------------------------------------------------------------- 360 361-- | Enter a new AST element. Maintain SrcSpan stack 362#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) 363withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) 364 => a 365 -> Pretty b -> Pretty b 366withAST lss@(GHC.dL->GHC.L ss t) action = do 367#else 368withAST :: Data a 369 => GHC.Located a 370 -> Pretty b -> Pretty b 371withAST lss@(GHC.L ss t) action = do 372#endif 373 return () `debug` ("Pretty.withAST:enter 1:(ss)=" ++ showGhc (ss,showConstr (toConstr t))) 374 -- Calculate offset required to get to the start of the SrcSPan 375 -- off <- gets apLayoutStart 376 withSrcSpanPretty lss $ do 377 return () `debug` ("Pretty.withAST:enter:(ss)=" ++ showGhc (ss,showConstr (toConstr t))) 378 379 let maskWriter s = s { annKds = [] 380 , sortKeys = Nothing 381 , dwCapturedSpan = mempty 382 -- , prLayoutContext = pushAcs (prLayoutContext s) 383 } 384 385#if __GLASGOW_HASKELL__ <= 710 386 let spanStart = ss2pos ss 387 cs <- do 388 if GHC.isGoodSrcSpan ss 389 then 390 commentAllocation (priorComment spanStart) return 391 else 392 return [] 393#else 394 let cs = [] 395#endif 396 397 -- ctx <- debugP ("Pretty.withAST:cs:(ss,cs,uncs)=" ++ showGhc (ss,cs,uncs)) $ asks prContext 398 ctx <- asks prContext 399 400 noPrec <- gets apNoPrecedingSpace 401 edp <- debugP ("Pretty.withAST:enter:(ss,constr,noPrec,ctx)=" ++ showGhc (ss,showConstr (toConstr t),noPrec,ctx)) $ entryDpFor ctx t 402 -- edp <- entryDpFor ctx t 403 404 let ctx1 = debugP ("Pretty.withAST:edp:(ss,constr,edp)=" ++ showGhc (ss,showConstr (toConstr t),edp)) ctx 405 -- (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel]) ctx1 406 (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel,InTypeApp]) ctx1 407 then 408 -- debugP ("Pretty.withAST:setNoPrecedingSpace") $ 409 censor maskWriter (listen (setNoPrecedingSpace action)) 410 else 411 -- debugP ("Pretty.withAST:setNoPrecedingSpace") $ 412 censor maskWriter (listen action) 413 414 let kds = annKds w 415 an = Ann 416 { annEntryDelta = edp 417 , annPriorComments = cs 418 , annFollowingComments = [] -- only used in Transform and Print 419 , annsDP = kds 420 , annSortKey = sortKeys w 421 , annCapturedSpan = getFirst $ dwCapturedSpan w 422 } 423 424 addAnnotationsPretty an 425 `debug` ("Pretty.withAST:(annkey,an)=" ++ show (mkAnnKey lss,an)) 426 return res 427 428-- --------------------------------------------------------------------- 429 430entryDpFor :: Typeable a => AstContextSet -> a -> Pretty DeltaPos 431entryDpFor ctx a = (def `extQ` grhs) a 432 where 433 lineDefault = if inAcs (Set.singleton AdvanceLine) ctx 434 then 1 else 0 435 noAdvanceLine = inAcs (Set.singleton NoAdvanceLine) ctx && 436 inAcs (Set.singleton ListStart) ctx 437 438 def :: a -> Pretty DeltaPos 439 def _ = 440 debugP ("entryDpFor:(topLevel,listStart,inList,noAdvanceLine,ctx)=" ++ show (topLevel,listStart,inList,noAdvanceLine,ctx)) $ 441 if noAdvanceLine 442 then (if inTypeApp then return (DP (0,0)) else return (DP (0,1))) 443 -- then (if inTypeApp then error "inTypeAp" else return (DP (0,1))) 444 else 445 if listStart 446 then return (DP (1,2)) 447 else if inList 448 then if topLevel then return (DP (2,0)) else return (DP (1,0)) 449 else if topLevel then return (DP (2,0)) else return (DP (lineDefault,0)) 450 451 topLevel = inAcs (Set.singleton TopLevel) ctx 452 listStart = inAcs (Set.singleton ListStart) ctx 453 && not (inAcs (Set.singleton TopLevel) ctx) 454 inList = inAcs (Set.singleton ListItem) ctx 455 inLambda = inAcs (Set.singleton LambdaExpr) ctx 456 inTypeApp = inAcs (Set.singleton InTypeApp) ctx 457 458 grhs :: GHC.GRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Pretty DeltaPos 459 grhs _ = do 460 if inLambda 461 then return (DP (0,1)) 462 else return (DP (1,2)) 463 464-- --------------------------------------------------------------------- 465 466fromNoPrecedingSpace :: Pretty a -> Pretty a -> Pretty a 467fromNoPrecedingSpace def lay = do 468 PrettyState{apNoPrecedingSpace} <- get 469 -- ctx <- asks prContext 470 if apNoPrecedingSpace 471 then do 472 modify (\s -> s { apNoPrecedingSpace = False 473 }) 474 debugP ("fromNoPrecedingSpace:def") def 475 -- def 476 else 477 -- lay 478 debugP ("fromNoPrecedingSpace:lay") lay 479 480 481-- --------------------------------------------------------------------- 482 483-- |Add some annotation to the currently active SrcSpan 484addAnnotationsPretty :: Annotation -> Pretty () 485addAnnotationsPretty ann = do 486 l <- ask 487 return () `debug` ("addAnnotationsPretty:=" ++ showGhc (curSrcSpan l,prContext l)) 488 tellFinalAnn (getAnnKey l,ann) 489 490getAnnKey :: PrettyOptions -> AnnKey 491getAnnKey PrettyOptions {curSrcSpan, annConName} 492 = AnnKey (rs curSrcSpan) annConName 493 494-- --------------------------------------------------------------------- 495 496countAnnsPretty :: GHC.AnnKeywordId -> Pretty Int 497countAnnsPretty _ann = return 0 498 499-- --------------------------------------------------------------------- 500 501withSortKey :: [(AnnSpan, Annotated b)] -> Pretty () 502withSortKey kws = 503 let order = sortBy (comparing fst) kws 504 in do 505 tellSortKey (map fst order) 506 mapM_ (prettyInterpret . snd) order 507 508withSortKeyContexts :: ListContexts -> [(AnnSpan, Annotated ())] -> Pretty () 509withSortKeyContexts ctxts kws = 510 let order = sortBy (comparing fst) kws 511 in do 512 tellSortKey (map fst order) 513 withSortKeyContextsHelper prettyInterpret ctxts order 514 515-- --------------------------------------------------------------------- 516 517storeOriginalSrcSpanPretty :: GHC.SrcSpan -> AnnKey -> Pretty AnnKey 518storeOriginalSrcSpanPretty _s key = do 519 tellCapturedSpan key 520 return key 521 522-- --------------------------------------------------------------------- 523 524getSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> Pretty GHC.SrcSpan 525getSrcSpanForKw ss _kw = return ss 526 527-- --------------------------------------------------------------------- 528 529#if __GLASGOW_HASKELL__ <= 710 530storeString :: String -> GHC.SrcSpan -> Pretty () 531storeString s _ss = addPrettyAnnotation (AnnString s) 532#endif 533 534-- --------------------------------------------------------------------- 535 536setLayoutFlag :: Pretty () -> Pretty () 537setLayoutFlag action = do 538 oldLay <- gets apLayoutStart 539 modify (\s -> s { apMarkLayout = True } ) 540 let reset = modify (\s -> s { apMarkLayout = False 541 , apLayoutStart = oldLay }) 542 action <* reset 543 544-- --------------------------------------------------------------------- 545 546setNoPrecedingSpace :: Pretty a -> Pretty a 547setNoPrecedingSpace action = do 548 oldVal <- gets apNoPrecedingSpace 549 modify (\s -> s { apNoPrecedingSpace = True } ) 550 let reset = modify (\s -> s { apNoPrecedingSpace = oldVal }) 551 action <* reset 552 553-- --------------------------------------------------------------------- 554 555setContextPretty :: Set.Set AstContext -> Int -> Pretty () -> Pretty () 556setContextPretty ctxt lvl = 557 local (\s -> s { prContext = setAcsWithLevel ctxt lvl (prContext s) } ) 558 559unsetContextPretty :: AstContext -> Pretty () -> Pretty () 560unsetContextPretty ctxt = 561 local (\s -> s { prContext = unsetAcs ctxt (prContext s) } ) 562 563 564ifInContextPretty :: Set.Set AstContext -> Annotated () -> Annotated () -> Pretty () 565ifInContextPretty ctxt ifAction elseAction = do 566 cur <- asks prContext 567 let inContext = inAcs ctxt cur 568 if inContext 569 then prettyInterpret ifAction 570 else prettyInterpret elseAction 571 572-- --------------------------------------------------------------------- 573 574annotationsToCommentsPretty :: [GHC.AnnKeywordId] -> Pretty () 575annotationsToCommentsPretty _kws = return () 576 577-- --------------------------------------------------------------------- 578 579#if __GLASGOW_HASKELL__ <= 710 580annotationsToCommentsBFPretty :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> Pretty () 581annotationsToCommentsBFPretty bf _kws = do 582 -- cs <- gets apComments 583 cs <- debugP ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) $ gets apComments 584 -- return$ debugP ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) () 585 -- error ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) 586 let 587 kws = makeBooleanFormulaAnns bf 588 newComments = map (uncurry mkKWComment ) kws 589 putUnallocatedComments (cs ++ newComments) 590 591 592finalizeBFPretty :: GHC.SrcSpan -> Pretty () 593finalizeBFPretty _ss = do 594 commentAllocation (const True) (mapM_ (uncurry addPrettyComment)) 595 return () 596#endif 597 598-- --------------------------------------------------------------------- 599#if __GLASGOW_HASKELL__ <= 710 600-- |Split the ordered list of comments into ones that occur prior to 601-- the give SrcSpan and the rest 602priorComment :: Pos -> Comment -> Bool 603priorComment start c = (ss2pos . commentIdentifier $ c) < start 604 605-- TODO:AZ: We scan the entire comment list here. It may be better to impose an 606-- invariant that the comments are sorted, and consume them as the pos 607-- advances. It then becomes a process of using `takeWhile p` rather than a full 608-- partition. 609allocateComments :: (Comment -> Bool) -> [Comment] -> ([Comment], [Comment]) 610allocateComments = partition 611#endif 612 613-- --------------------------------------------------------------------- 614 615#if __GLASGOW_HASKELL__ <= 710 616commentAllocation :: (Comment -> Bool) 617 -> ([(Comment, DeltaPos)] -> Pretty a) 618 -> Pretty a 619commentAllocation p k = do 620 cs <- getUnallocatedComments 621 let (allocated,cs') = allocateComments p cs 622 putUnallocatedComments cs' 623 k =<< mapM makeDeltaComment (sortBy (comparing commentIdentifier) allocated) 624 625makeDeltaComment :: Comment -> Pretty (Comment, DeltaPos) 626makeDeltaComment c = do 627 return (c, DP (0,1)) 628 629addPrettyComment :: Comment -> DeltaPos -> Pretty () 630addPrettyComment d p = do 631 tellKd (AnnComment d, p) 632#endif 633 634-- --------------------------------------------------------------------- 635 636-- Writer helpers 637 638tellFinalAnn :: (AnnKey, Annotation) -> Pretty () 639tellFinalAnn (k, v) = 640 tell (mempty { dwAnns = Endo (Map.insert k v) }) 641 642tellCapturedSpan :: AnnKey -> Pretty () 643tellCapturedSpan key = tell ( mempty { dwCapturedSpan = First $ Just key }) 644 645tellKd :: (KeywordId, DeltaPos) -> Pretty () 646tellKd kd = tell (mempty { annKds = [kd] }) 647 648tellSortKey :: [AnnSpan] -> Pretty () 649tellSortKey xs = tell (mempty { sortKeys = Just xs } ) 650 651tellContext :: Set.Set AstContext -> Pretty () 652tellContext lc = tell (mempty { prLayoutContext = setAcsWithLevel lc 2 mempty} ) 653