ghc-exactprint 1.12.0.0 → 1.12.1.0
raw patch · 3 files changed
+93/−75 lines, 3 filesdep ~mtl
Dependency ranges changed: mtl
Files
- ChangeLog +2/−0
- ghc-exactprint.cabal +2/−2
- src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +89/−73
ChangeLog view
@@ -1,3 +1,5 @@+2026-09-22 v1.12.1.0+ * Fix space leak in the EP monad: use CPS RWST and a chunked writer (#152, @xich) 2025-01-21 v1.12.0.0 * Harmonise layout processing so we do not have a special case for the top level This is a breaking change, in that the hand-crafted
ghc-exactprint.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-exactprint-version: 1.12.0.0+version: 1.12.1.0 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 9.2.1, this library provides a means to round trip any code that can@@ -59,7 +59,7 @@ , containers >= 0.5 && < 0.8 , ghc >= 9.12 && < 9.13 , ghc-boot >= 9.12 && < 9.13- , mtl >= 2.2.1 && < 2.5+ , mtl >= 2.3 && < 2.5 , syb >= 0.5 && < 0.8 default-language: Haskell2010
src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs view
@@ -62,7 +62,7 @@ import Control.Monad (forM, when, unless) import Control.Monad.Identity (Identity(..)) import qualified Control.Monad.Reader as Reader-import Control.Monad.RWS (MonadReader, RWST, evalRWST, tell, modify, get, gets, ask)+import Control.Monad.RWS.CPS (MonadReader, RWST, evalRWST, tell, modify', get, gets, ask) import Control.Monad.Trans (lift) import Data.Data ( Data ) import Data.Dynamic@@ -100,7 +100,7 @@ type EP w m a = RWST (EPOptions m w) (EPWriter w) EPState m a -runEP :: (Monad m)+runEP :: (Monad m, Monoid w) => EPOptions m w -> EP w m a -> m (a, w) runEP epReader action = do@@ -158,15 +158,31 @@ deltaOptions :: EPOptions Identity () deltaOptions = epOptions (\_ -> return ()) (\_ -> return ()) -data EPWriter a = EPWriter- { output :: !a }+-- Note: EPWriter+--+-- We use the CPS 'RWST' to be strict in the writer type. However, this+-- makes performance beholden to the behavior of 'mappend' on the chosen+-- type. For commonly-used types such as 'String' and 'Text', repeatedly+-- appending to a growing accumulator results in quadratic cost. Instead,+-- we store the writer as a reversed list of items so 'tell' is a constant+-- time 'cons'. We then 'mconcat' the items in 'output', since 'mconcat'+-- implementations for common monoids are optimized to be linear time.+--+-- We do not use 'Endo' because it still builds a tree of mappends,+-- whereas 'mconcat' for 'Text'/'ByteString' can allocate a single+-- buffer upfront. We do not use 'Builder' because it would be exposed+-- to the public-facing API.+newtype EPWriter a = EPWriter { chunks :: [a] } -instance Monoid w => Semigroup (EPWriter w) where- (EPWriter a) <> (EPWriter b) = EPWriter (a <> b)+output :: Monoid a => EPWriter a -> a+output = mconcat . reverse . chunks -instance Monoid w => Monoid (EPWriter w) where- mempty = EPWriter mempty+instance Semigroup (EPWriter w) where+ EPWriter a <> EPWriter b = EPWriter (b ++ a) +instance Monoid (EPWriter w) where+ mempty = EPWriter []+ data EPState = EPState { uAnchorSpan :: !RealSrcSpan -- ^ in pre-changed AST -- reference frame, from@@ -375,7 +391,7 @@ astId :: (Typeable a) => a -> String astId a = show (typeOf a) -cua :: (Monad m, Monoid w) => CanUpdateAnchor -> EP w m [a] -> EP w m [a]+cua :: (Monad m) => CanUpdateAnchor -> EP w m [a] -> EP w m [a] cua CanUpdateAnchor f = f cua CanUpdateAnchorOnly _ = return [] cua NoCanUpdateAnchor _ = return []@@ -490,7 +506,7 @@ let spanStart = ss2pos curAnchor when (priorEndAfterComments < spanStart) (do debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart- modify (\s -> s { dPriorEndPosition = spanStart } ))+ modify' (\s -> s { dPriorEndPosition = spanStart } )) debugM $ "enterAnn: (anchor', curAnchor):" ++ show (anchor', rs2range curAnchor) -- debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp)@@ -585,7 +601,7 @@ -- --------------------------------------------------------------------- -addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m ()+addCommentsA :: (Monad m) => [LEpaComment] -> EP w m () addCommentsA csNew = addComments False (concatMap tokComment csNew) {-@@ -604,7 +620,7 @@ also means that the first entry comment that has moved should not have a line offset. -}-addComments :: (Monad m, Monoid w) => Bool -> [Comment] -> EP w m ()+addComments :: (Monad m) => Bool -> [Comment] -> EP w m () addComments sortNeeded csNew = do debugM $ "addComments:csNew" ++ show csNew cs <- getUnallocatedComments@@ -639,7 +655,7 @@ -- --------------------------------------------------------------------- -epTokensToComments :: (Monad m, Monoid w)+epTokensToComments :: (Monad m) => String -> [EpToken tok] -> EP w m () epTokensToComments kw toks = addComments True (concatMap (\tok ->@@ -1287,11 +1303,11 @@ -- --------------------------------------------------------------------- -markLensFun' :: (Monad m, Monoid w)+markLensFun' :: (Monad m) => EpAnn ann -> Lens ann t -> (t -> EP w m t) -> EP w m (EpAnn ann) markLensFun' epann l f = markLensFun epann (lepa . l) f -markLensFun :: (Monad m, Monoid w)+markLensFun :: (Monad m) => ann -> Lens ann t -> (t -> EP w m t) -> EP w m ann markLensFun a l f = do t' <- f (view l a)@@ -1404,7 +1420,7 @@ updateAndApplyComment c dp' printQueuedComment c dp' -updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()+updateAndApplyComment :: (Monad m) => Comment -> DeltaPos -> EP w m () updateAndApplyComment (Comment str anc pp mo) dp = do applyComment (Comment str anc' pp mo) where@@ -1415,7 +1431,7 @@ -- --------------------------------------------------------------------- -commentAllocationBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment]+commentAllocationBefore :: (Monad m) => RealSrcSpan -> EP w m [Comment] commentAllocationBefore ss = do cs <- getUnallocatedComments -- Note: The CPP comment injection may change the file name in the@@ -1431,7 +1447,7 @@ -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) return earlier -commentAllocationIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment]+commentAllocationIn :: (Monad m) => RealSrcSpan -> EP w m [Comment] commentAllocationIn ss = do cs <- getUnallocatedComments -- Note: The CPP comment injection may change the file name in the@@ -2610,7 +2626,7 @@ b' <- markAnnotated b return (toDyn b') -withSortKey :: (Monad m, Monoid w)+withSortKey :: (Monad m) => AnnSortKey DeclTag -> [(DeclTag, [(RealSrcSpan, EP w m Dynamic)])] -> EP w m (AnnSortKey DeclTag, [Dynamic]) withSortKey annSortKey xs = do@@ -4869,16 +4885,16 @@ ------------------------------------------------------------------------ -setLayoutBoth :: (Monad m, Monoid w) => EP w m a -> EP w m a+setLayoutBoth :: (Monad m) => EP w m a -> EP w m a setLayoutBoth k = do oldLHS <- getLayoutOffsetD oldAnchorOffset <- getLayoutOffsetP debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset)- modify (\a -> a { dMarkLayout = True+ modify' (\a -> a { dMarkLayout = True , pMarkLayout = True } ) let reset = do debugM $ "setLayoutBoth:reset: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset)- modify (\a -> a { dMarkLayout = False+ modify' (\a -> a { dMarkLayout = False , dLHS = oldLHS , pMarkLayout = False , pLHS = oldAnchorOffset} )@@ -4886,137 +4902,137 @@ ------------------------------------------------------------------------ -getPosP :: (Monad m, Monoid w) => EP w m Pos+getPosP :: (Monad m) => EP w m Pos getPosP = gets epPos -setPosP :: (Monad m, Monoid w) => Pos -> EP w m ()+setPosP :: (Monad m) => Pos -> EP w m () setPosP l = do debugM $ "setPosP:" ++ show l- modify (\s -> s {epPos = l})+ modify' (\s -> s {epPos = l}) -getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe EpaLocation)+getExtraDP :: (Monad m) => EP w m (Maybe EpaLocation) getExtraDP = gets uExtraDP -setExtraDP :: (Monad m, Monoid w) => Maybe EpaLocation -> EP w m ()+setExtraDP :: (Monad m) => Maybe EpaLocation -> EP w m () setExtraDP md = do debugM $ "setExtraDP:" ++ show md- modify (\s -> s {uExtraDP = md})+ modify' (\s -> s {uExtraDP = md}) -getExtraDPReturn :: (Monad m, Monoid w) => EP w m (Maybe (SrcSpan, DeltaPos))+getExtraDPReturn :: (Monad m) => EP w m (Maybe (SrcSpan, DeltaPos)) getExtraDPReturn = gets uExtraDPReturn -setExtraDPReturn :: (Monad m, Monoid w) => Maybe (SrcSpan, DeltaPos) -> EP w m ()+setExtraDPReturn :: (Monad m) => Maybe (SrcSpan, DeltaPos) -> EP w m () setExtraDPReturn md = do debugM $ "setExtraDPReturn:" ++ show md- modify (\s -> s {uExtraDPReturn = md})+ modify' (\s -> s {uExtraDPReturn = md}) -getPriorEndD :: (Monad m, Monoid w) => EP w m Pos+getPriorEndD :: (Monad m) => EP w m Pos getPriorEndD = gets dPriorEndPosition -getAnchorU :: (Monad m, Monoid w) => EP w m RealSrcSpan+getAnchorU :: (Monad m) => EP w m RealSrcSpan getAnchorU = gets uAnchorSpan -getAcceptSpan ::(Monad m, Monoid w) => EP w m Bool+getAcceptSpan ::(Monad m) => EP w m Bool getAcceptSpan = gets pAcceptSpan -setAcceptSpan ::(Monad m, Monoid w) => Bool -> EP w m ()+setAcceptSpan ::(Monad m) => Bool -> EP w m () setAcceptSpan f =- modify (\s -> s { pAcceptSpan = f })+ modify' (\s -> s { pAcceptSpan = f }) -setPriorEndD :: (Monad m, Monoid w) => Pos -> EP w m ()+setPriorEndD :: (Monad m) => Pos -> EP w m () setPriorEndD pe = do setPriorEndNoLayoutD pe -setPriorEndNoLayoutD :: (Monad m, Monoid w) => Pos -> EP w m ()+setPriorEndNoLayoutD :: (Monad m) => Pos -> EP w m () setPriorEndNoLayoutD pe = do debugM $ "setPriorEndNoLayoutD:pe=" ++ show pe- modify (\s -> s { dPriorEndPosition = pe })+ modify' (\s -> s { dPriorEndPosition = pe }) -setPriorEndASTD :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()+setPriorEndASTD :: (Monad m) => RealSrcSpan -> EP w m () setPriorEndASTD pe = setPriorEndASTPD (rs2range pe) -setPriorEndASTPD :: (Monad m, Monoid w) => (Pos,Pos) -> EP w m ()+setPriorEndASTPD :: (Monad m) => (Pos,Pos) -> EP w m () setPriorEndASTPD pe@(fm,to) = do debugM $ "setPriorEndASTD:pe=" ++ show pe setLayoutStartD (snd fm)- modify (\s -> s { dPriorEndPosition = to } )+ modify' (\s -> s { dPriorEndPosition = to } ) -setLayoutStartD :: (Monad m, Monoid w) => Int -> EP w m ()+setLayoutStartD :: (Monad m) => Int -> EP w m () setLayoutStartD p = do EPState{dMarkLayout} <- get when dMarkLayout $ do debugM $ "setLayoutStartD: setting dLHS=" ++ show p- modify (\s -> s { dMarkLayout = False+ modify' (\s -> s { dMarkLayout = False , dLHS = LayoutStartCol p}) -getLayoutOffsetD :: (Monad m, Monoid w) => EP w m LayoutStartCol+getLayoutOffsetD :: (Monad m) => EP w m LayoutStartCol getLayoutOffsetD = gets dLHS -setAnchorU :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()+setAnchorU :: (Monad m) => RealSrcSpan -> EP w m () setAnchorU rss = do debugM $ "setAnchorU:" ++ show (rs2range rss)- modify (\s -> s { uAnchorSpan = rss })+ modify' (\s -> s { uAnchorSpan = rss }) -getEofPos :: (Monad m, Monoid w) => EP w m (Maybe (RealSrcSpan, RealSrcSpan))+getEofPos :: (Monad m) => EP w m (Maybe (RealSrcSpan, RealSrcSpan)) getEofPos = gets epEof -setEofPos :: (Monad m, Monoid w) => Maybe (RealSrcSpan, RealSrcSpan) -> EP w m ()-setEofPos l = modify (\s -> s {epEof = l})+setEofPos :: (Monad m) => Maybe (RealSrcSpan, RealSrcSpan) -> EP w m ()+setEofPos l = modify' (\s -> s {epEof = l}) -- --------------------------------------------------------------------- -getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment]+getUnallocatedComments :: (Monad m) => EP w m [Comment] getUnallocatedComments = gets epComments -putUnallocatedComments :: (Monad m, Monoid w) => [Comment] -> EP w m ()-putUnallocatedComments !cs = modify (\s -> s { epComments = cs } )+putUnallocatedComments :: (Monad m) => [Comment] -> EP w m ()+putUnallocatedComments !cs = modify' (\s -> s { epComments = cs } ) -- | Push a fresh stack frame for the applied comments gatherer-pushAppliedComments :: (Monad m, Monoid w) => EP w m ()-pushAppliedComments = modify (\s -> s { epCommentsApplied = []:(epCommentsApplied s) })+pushAppliedComments :: (Monad m) => EP w m ()+pushAppliedComments = modify' (\s -> s { epCommentsApplied = []:(epCommentsApplied s) }) -- | Return the comments applied since the last call -- takeAppliedComments, and clear them, not popping the stack-takeAppliedComments :: (Monad m, Monoid w) => EP w m [Comment]+takeAppliedComments :: (Monad m) => EP w m [Comment] takeAppliedComments = do !ccs <- gets epCommentsApplied case ccs of [] -> do- modify (\s -> s { epCommentsApplied = [] })+ modify' (\s -> s { epCommentsApplied = [] }) return [] h:t -> do- modify (\s -> s { epCommentsApplied = []:t })+ modify' (\s -> s { epCommentsApplied = []:t }) return (reverse h) -- | Return the comments applied since the last call -- takeAppliedComments, and clear them, popping the stack-takeAppliedCommentsPop :: (Monad m, Monoid w) => EP w m [Comment]+takeAppliedCommentsPop :: (Monad m) => EP w m [Comment] takeAppliedCommentsPop = do !ccs <- gets epCommentsApplied case ccs of [] -> do- modify (\s -> s { epCommentsApplied = [] })+ modify' (\s -> s { epCommentsApplied = [] }) return [] h:t -> do- modify (\s -> s { epCommentsApplied = t })+ modify' (\s -> s { epCommentsApplied = t }) return (reverse h) -- | Mark a comment as being applied. This is used to update comments -- when doing delta processing-applyComment :: (Monad m, Monoid w) => Comment -> EP w m ()+applyComment :: (Monad m) => Comment -> EP w m () applyComment c = do !ccs <- gets epCommentsApplied case ccs of- [] -> modify (\s -> s { epCommentsApplied = [[c]] } )- (h:t) -> modify (\s -> s { epCommentsApplied = (c:h):t } )+ [] -> modify' (\s -> s { epCommentsApplied = [[c]] } )+ (h:t) -> modify' (\s -> s { epCommentsApplied = (c:h):t } ) -getLayoutOffsetP :: (Monad m, Monoid w) => EP w m LayoutStartCol+getLayoutOffsetP :: (Monad m) => EP w m LayoutStartCol getLayoutOffsetP = gets pLHS -setLayoutOffsetP :: (Monad m, Monoid w) => LayoutStartCol -> EP w m ()+setLayoutOffsetP :: (Monad m) => LayoutStartCol -> EP w m () setLayoutOffsetP c = do debugM $ "setLayoutOffsetP:" ++ show c- modify (\s -> s { pLHS = c })+ modify' (\s -> s { pLHS = c }) -- ---------------------------------------------------------------------@@ -5041,7 +5057,7 @@ -- --------------------------------------------------------------------- -adjustDeltaForOffsetM :: (Monad m, Monoid w) => DeltaPos -> EP w m DeltaPos+adjustDeltaForOffsetM :: (Monad m) => DeltaPos -> EP w m DeltaPos adjustDeltaForOffsetM dp = do colOffset <- getLayoutOffsetD return (adjustDeltaForOffset colOffset dp)@@ -5049,13 +5065,13 @@ -- --------------------------------------------------------------------- -- Printing functions -printString :: (Monad m, Monoid w) => Bool -> String -> EP w m ()+printString :: (Monad m) => Bool -> String -> EP w m () printString layout str = do EPState{epPos = (_,c), pMarkLayout} <- get EPOptions{epTokenPrint, epWhitespacePrint} <- ask when (pMarkLayout && layout) $ do debugM $ "printString: setting pLHS to " ++ show c- modify (\s -> s { pLHS = LayoutStartCol c, pMarkLayout = False } )+ modify' (\s -> s { pLHS = LayoutStartCol c, pMarkLayout = False } ) -- Advance position, taking care of any newlines in the string let strDP = dpFromString str@@ -5080,8 +5096,8 @@ -- if not layout && c == 0- then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s}- else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s}+ then lift (epWhitespacePrint str) >>= \s -> tell (EPWriter [s])+ else lift (epTokenPrint str) >>= \s -> tell (EPWriter [s]) -------------------------------------------------------- @@ -5093,7 +5109,7 @@ -------------------------------------------------------- -newLine :: (Monad m, Monoid w) => EP w m ()+newLine :: (Monad m) => EP w m () newLine = do (l,_) <- getPosP (ld,_) <- getPriorEndD