From 72c9e4c3abdc0e2e312ddad202a24f1628777ebb Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 18 Mar 2023 17:48:06 +0000 Subject: [PATCH] Fix block-comment delta position special case --- .../Brittany/Internal/S3_ToBriDocTools.hs | 2 +- .../Brittany/Internal/S4_WriteBriDoc.hs | 28 ++++++++++--------- .../Brittany/Internal/StepOrchestrate.hs | 10 +++---- .../Brittany/Internal/ToBriDoc/Module.hs | 1 - .../Internal/WriteBriDoc/Operators.hs | 27 ++++++++++++------ 5 files changed, 40 insertions(+), 28 deletions(-) diff --git a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs index ee289b4..b4724bd 100644 --- a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs +++ b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs @@ -660,7 +660,7 @@ instance ObtainAnnDeltaPos (EpAnn GHC.AnnsModule) where loc <- obtainAnnPos l kw <|> obtainAnnPos annList kw let pos = (GHC.srcLocLine loc, GHC.srcLocCol loc) pure $ ExactPrint.pos2delta - (maximum $ (0, 1) : + (maximum $ (1, 1) : [ ExactPrint.ss2posEnd $ GHC.anchor anch | L anch _ <- case epaComms of EpaCommentsBalanced cs1 cs2 -> cs1 ++ cs2 diff --git a/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs b/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs index 64281a1..74598fa 100644 --- a/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs +++ b/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs @@ -52,8 +52,8 @@ import Language.Haskell.Brittany.Internal.Components.BriDoc -- import Language.Haskell.Brittany.Internal.S3_ToBriDocTools -ppBriDoc :: BriDocNumbered -> PPMLocal () -ppBriDoc briDoc = do +ppBriDoc :: BriDocNumbered -> Bool -> PPMLocal () +ppBriDoc briDoc flush = do -- first step: transform the briDoc. briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do -- Note that briDoc is BriDocNumbered, but state type is BriDoc. @@ -107,6 +107,7 @@ ppBriDoc briDoc = do $ MultiRWSS.withMultiStateS ([] :: [LEpaComment]) $ do layoutBriDocM briDoc' + when flush layoutFlushLine case _lstate_plannedSpace state' of PlannedNone -> if _lstate_curY state' == 0 then pure () @@ -302,21 +303,22 @@ takeBefore loc = do printComments :: LayoutConstraints m => [GHC.LEpaComment] -> m () printComments comms = do - let addComment s anchor prior = do + let addComment isBlock s anchor prior = do case anchor of Anchor span UnchangedAnchor -> layoutWriteComment True + isBlock (ExactPrint.ss2deltaEnd prior span) 1 (Text.pack s) Anchor _span (MovedAnchor dp) -> - layoutWriteComment False dp 1 (Text.pack s) - comms `forM_` \case - L anch (EpaComment (EpaDocCommentNext s) prior) -> addComment s anch prior - L anch (EpaComment (EpaDocCommentPrev s) prior) -> addComment s anch prior - L anch (EpaComment (EpaDocCommentNamed s) prior) -> addComment s anch prior - L anch (EpaComment (EpaDocSection _ s) prior) -> addComment s anch prior - L anch (EpaComment (EpaDocOptions s) prior) -> addComment s anch prior - L anch (EpaComment (EpaLineComment s) prior) -> addComment s anch prior - L anch (EpaComment (EpaBlockComment s) prior) -> addComment s anch prior - L _anch (EpaComment (EpaEofComment) _prior) -> pure () + layoutWriteComment False isBlock dp 1 (Text.pack s) + comms `forM_` \(L anch (EpaComment tok prior) ) -> case tok of + EpaDocCommentNext s -> addComment False s anch prior + EpaDocCommentPrev s -> addComment False s anch prior + EpaDocCommentNamed s -> addComment False s anch prior + EpaDocSection _ s -> addComment False s anch prior + EpaDocOptions s -> addComment False s anch prior + EpaLineComment s -> addComment False s anch prior + EpaBlockComment s -> addComment True s anch prior + EpaEofComment -> pure () diff --git a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs index cd92ad6..d7f3d68 100644 --- a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs +++ b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs @@ -82,7 +82,7 @@ processModule traceFunc conf inlineConf parsedModule = do bdMay <- ppModuleHead modHead case bdMay of Nothing -> pure () - Just bd -> ppBriDoc bd + Just bd -> ppBriDoc bd True MEPrettyModuleHead (L loc modHead) -> wrapNonDeclToBriDoc $ do case modHead of HsModule epAnn _layoutInfo Nothing Nothing _ _ _ _ -> do @@ -92,7 +92,7 @@ processModule traceFunc conf inlineConf parsedModule = do docFlushRemaining (srcSpanFileName_maybe loc) $ docHandleComms epAnn docSeparator - ppBriDoc bd + ppBriDoc bd True HsModule _ _layoutInfo Nothing Just{} _ _ _ _ -> error "brittany internal error: exports without module name" HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do @@ -102,7 +102,7 @@ processModule traceFunc conf inlineConf parsedModule = do docFlushRemaining (srcSpanFileName_maybe loc) $ moduleNameExportBridoc epAnn n les - ppBriDoc bd + ppBriDoc bd True MEImportDecl importDecl immediateAfterComms -> wrapNonDeclToBriDoc $ do (bd, _) <- @@ -111,7 +111,7 @@ processModule traceFunc conf inlineConf parsedModule = do ( layoutImport importDecl : map commentToDoc immediateAfterComms ) - ppBriDoc bd + ppBriDoc bd False MEDecl decl immediateAfterComms -> do let declConfig = getDeclConfig conf inlineConf decl MultiRWSS.withMultiReader declConfig @@ -225,7 +225,7 @@ ppToplevelDecl decl immediateAfterComms = do (r, errorCount) <- briDocMToPPM $ docSeq (innerDoc : map commentToDoc immediateAfterComms) if errorCount == 0 then pure (r, 0) else briDocMToPPM $ briDocByExact decl - ppBriDoc bd + ppBriDoc bd False let commCntIn = connectedCommentCount decl commCntOut <- mGet when (commCntIn /= commCntOut) $ if commCntOut < commCntIn diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs index 9128a94..eb497b5 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Module.hs @@ -39,7 +39,6 @@ moduleNameExportBridoc epAnn modName les = do Nothing -> id Just SameLine{} -> id Just (DifferentLine 0 _) -> id - Just (DifferentLine 1 _) -> id Just dp -> docAddEntryDelta dp docHandleComms epAnn $ docHandleComms posModule $ runFilteredAlternative $ do addAlternativeCond allowSingleLine $ docSeq diff --git a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs index 256f37e..64530ad 100644 --- a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs +++ b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs @@ -16,6 +16,7 @@ module Language.Haskell.Brittany.Internal.WriteBriDoc.Operators , layoutIndentLevelPop , layoutWriteNewline , layoutWriteComment + , layoutFlushLine ) where @@ -111,11 +112,12 @@ layoutWriteNewline = do layoutWriteComment :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) => Bool + -> Bool -> GHC.DeltaPos -> Int -> Text -> m () -layoutWriteComment absolute dp commentLines s = do -- TODO92 we don't move to comment pos at all! +layoutWriteComment absolute isBlock dp commentLines s = do -- TODO92 we don't move to comment pos at all! let (y, x) = case dp of GHC.SameLine c -> (0, c) GHC.DifferentLine l c -> (l, c) @@ -124,15 +126,17 @@ layoutWriteComment absolute dp commentLines s = do -- TODO92 we don't move to co mTell $ Text.Builder.fromText s traceLocal ("layoutMoveToCommentPos", y, x, commentLines, _lstate_plannedSpace state, lstate_baseY state) mSet state - { _lstate_plannedSpace = case _lstate_plannedSpace state of - PlannedNone -> PlannedDelta 1 (_lstate_curY state) - PlannedSameline i -> PlannedDelta 1 (_lstate_curY state + i) - p@PlannedNewline{} -> p - p@PlannedDelta{} -> p + { _lstate_plannedSpace = if isBlock + then PlannedSameline 0 + else case _lstate_plannedSpace state of + PlannedNone -> PlannedDelta 1 (_lstate_curY state) + PlannedSameline i -> PlannedDelta 1 (_lstate_curY state + i) + p@PlannedNewline{} -> p + p@PlannedDelta{} -> p , _lstate_commentNewlines = _lstate_commentNewlines state + y + commentLines - 1 - , _lstate_curY = if y == 0 then _lstate_curY state + x - else x + , _lstate_curY = if y == 0 then _lstate_curY state + x + Text.length s + else x + Text.length s } @@ -293,6 +297,13 @@ layoutAddSepSpace = do -- (e.g. from an inserted comment restore-position task). } +layoutFlushLine + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => m () +layoutFlushLine = do + state <- mGet + when (_lstate_curY state > 0) layoutWriteEnsureNewlineBlock + -- moveToY :: MonadMultiState LayoutState m => Int -> m () -- moveToY y = mModify $ \state -> -- let