From f13a82964a909e56a6cebf527601b76e80f17ffe Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 5 Apr 2023 14:28:19 +0000 Subject: [PATCH] Partially restore retaining-empty-lines behaviour Currently works for do blocks, multi-line list literals, and lambda-case cases (apart from top-level blank lines that never got ignored). --- data/15-regressions.blt | 3 +- .../Brittany/Internal/Components/BriDoc.hs | 62 +++++++------ .../Brittany/Internal/S3_ToBriDocTools.hs | 57 +++++++++--- .../Brittany/Internal/S4_WriteBriDoc.hs | 51 ++++++---- .../Brittany/Internal/ToBriDoc/DataDecl.hs | 4 +- .../Brittany/Internal/ToBriDoc/Decl.hs | 30 +++--- .../Brittany/Internal/ToBriDoc/Expr.hs | 3 +- .../Brittany/Internal/ToBriDoc/Type.hs | 2 +- .../Internal/Transformations/T1_Alt.hs | 8 +- .../Internal/Transformations/T2_Floating.hs | 92 +++++++++++++------ .../Internal/Transformations/T4_Columns.hs | 18 ++-- .../Internal/Transformations/T5_Indent.hs | 4 +- .../Haskell/Brittany/Internal/Utils.hs | 2 +- .../Internal/WriteBriDoc/AlignmentAlgo.hs | 4 +- .../Internal/WriteBriDoc/Operators.hs | 26 ++++++ .../Brittany/Internal/WriteBriDoc/Types.hs | 2 + 16 files changed, 251 insertions(+), 117 deletions(-) diff --git a/data/15-regressions.blt b/data/15-regressions.blt index 40e9502..e1ca647 100644 --- a/data/15-regressions.blt +++ b/data/15-regressions.blt @@ -116,7 +116,8 @@ func = do let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets'' -- default local dir target if there's no given target - utargets'' = "foo" + utargets'' = "foo" + asd = True return () #test list comprehension comment placement diff --git a/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs b/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs index 7a666b7..4397484 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Components/BriDoc.hs @@ -69,9 +69,11 @@ data BriDocW (w :: IsWrapped) -- queue to be later flushed when the markers are reached | BDFlushCommentsPrior RealSrcLoc (BriDocRec w) -- process comments before loc from the queue - | BDFlushCommentsPost RealSrcLoc (BriDocRec w) + | BDFlushCommentsPost RealSrcLoc Bool (BriDocRec w) -- process comments before loc from the queue, but flow to end of - -- child-nodes + -- child-nodes. The boolean determines whether we set this location for + -- purposes of multiple-line DP calculations. This determines whether + -- empty lines after this element will be retained in the output. | BDEntryDelta DeltaPos (BriDocRec w) -- Move to the specified delta position before rendering the inner -- element. Currently this only ever respects newlines, i.e. Sameline @@ -124,8 +126,8 @@ instance Uniplate.Uniplate BriDoc where plate BDQueueComments |- comms |* bd uniplate (BDFlushCommentsPrior loc bd) = plate BDFlushCommentsPrior |- loc |* bd - uniplate (BDFlushCommentsPost loc bd) = - plate BDFlushCommentsPost |- loc |* bd + uniplate (BDFlushCommentsPost loc shouldMark bd) = + plate BDFlushCommentsPost |- loc |- shouldMark |* bd uniplate (BDEntryDelta dp bd ) = plate BDEntryDelta |- dp |* bd uniplate (BDLines lines ) = plate BDLines ||* lines uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd @@ -155,7 +157,7 @@ briDocSeqSpine = \case BDPlain{} -> () BDQueueComments _comms bd -> briDocSeqSpine bd BDFlushCommentsPrior _loc bd -> briDocSeqSpine bd - BDFlushCommentsPost _loc bd -> briDocSeqSpine bd + BDFlushCommentsPost _loc _m bd -> briDocSeqSpine bd BDEntryDelta _dp bd -> briDocSeqSpine bd BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd @@ -176,31 +178,31 @@ isNotEmpty _ = True -- TODO: rename to "dropLabels" ? unwrapBriDocNumbered :: BriDocNumbered -> BriDoc unwrapBriDocNumbered tpl = case snd tpl of - BDEmpty -> BDEmpty - BDLit t -> BDLit t - BDSeq list -> BDSeq $ rec <$> list - BDCols sig list -> BDCols sig $ rec <$> list - BDSeparator -> BDSeparator - BDAddBaseY ind bd -> BDAddBaseY ind $ rec bd - BDBaseYPushCur bd -> BDBaseYPushCur $ rec bd - BDIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd - BDIndentLevelPop bd -> BDIndentLevelPop $ rec bd - BDPar ind line indented -> BDPar ind (rec line) (rec indented) - BDAlt alts -> BDAlt $ rec <$> alts -- not that this will happen - BDForwardLineMode bd -> BDForwardLineMode $ rec bd - BDExternal c t -> BDExternal c t - BDPlain t -> BDPlain t - BDQueueComments comms bd -> BDQueueComments comms $ rec bd - BDFlushCommentsPrior loc bd -> BDFlushCommentsPrior loc $ rec bd - BDFlushCommentsPost loc bd -> BDFlushCommentsPost loc $ rec bd - BDEntryDelta dp bd -> BDEntryDelta dp $ rec bd - BDLines lines -> BDLines $ rec <$> lines - BDEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDForceMultiline bd -> BDForceMultiline $ rec bd - BDForceSingleline bd -> BDForceSingleline $ rec bd - BDNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd - BDSetParSpacing bd -> BDSetParSpacing $ rec bd - BDForceParSpacing bd -> BDForceParSpacing $ rec bd + BDEmpty -> BDEmpty + BDLit t -> BDLit t + BDSeq list -> BDSeq $ rec <$> list + BDCols sig list -> BDCols sig $ rec <$> list + BDSeparator -> BDSeparator + BDAddBaseY ind bd -> BDAddBaseY ind $ rec bd + BDBaseYPushCur bd -> BDBaseYPushCur $ rec bd + BDIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd + BDIndentLevelPop bd -> BDIndentLevelPop $ rec bd + BDPar ind line indented -> BDPar ind (rec line) (rec indented) + BDAlt alts -> BDAlt $ rec <$> alts -- not that this will happen + BDForwardLineMode bd -> BDForwardLineMode $ rec bd + BDExternal c t -> BDExternal c t + BDPlain t -> BDPlain t + BDQueueComments comms bd -> BDQueueComments comms $ rec bd + BDFlushCommentsPrior loc bd -> BDFlushCommentsPrior loc $ rec bd + BDFlushCommentsPost loc mrk bd -> BDFlushCommentsPost loc mrk $ rec bd + BDEntryDelta dp bd -> BDEntryDelta dp $ rec bd + BDLines lines -> BDLines $ rec <$> lines + BDEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd + BDForceMultiline bd -> BDForceMultiline $ rec bd + BDForceSingleline bd -> BDForceSingleline $ rec bd + BDNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd + BDSetParSpacing bd -> BDSetParSpacing $ rec bd + BDForceParSpacing bd -> BDForceParSpacing $ rec bd BDDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd where rec = unwrapBriDocNumbered diff --git a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs index b4724bd..770af17 100644 --- a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs +++ b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs @@ -474,7 +474,7 @@ docAddEntryDelta dp bdm = do allocateNode (BDEntryDelta dp bd) docFlushRemaining :: FastString -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docFlushRemaining fileThing = docFlushCommsPost +docFlushRemaining fileThing = docFlushCommsPost False (Just $ GHC.mkRealSrcLoc fileThing 999999 999999) -- CLASS DocHandleComms -------------------------------------------------------- @@ -671,28 +671,36 @@ instance ObtainAnnDeltaPos (EpAnn GHC.AnnsModule) where ) pos -class DocFlushCommsPost a where - docFlushCommsPost :: Maybe GHC.RealSrcLoc -> a -> a +class DocFlushCommsPost ann a where + docFlushCommsPost :: Bool -> ann -> a -> a -instance DocFlushCommsPost (ToBriDocM BriDocNumbered) where - docFlushCommsPost = \case +instance DocFlushCommsPost (Maybe GHC.RealSrcLoc) (ToBriDocM BriDocNumbered) where + docFlushCommsPost shouldMark = \case Nothing -> id - Just span -> \bdm -> do + Just loc -> \bdm -> do i1 <- allocNodeIndex bd <- bdm - pure (i1, BDFlushCommentsPost span bd) + pure (i1, BDFlushCommentsPost loc shouldMark bd) -instance DocFlushCommsPost (ToBriDocM [BriDocNumbered]) where - docFlushCommsPost loc bdm = do +instance DocFlushCommsPost ann (ToBriDocM BriDocNumbered) + => DocFlushCommsPost ann (ToBriDocM [BriDocNumbered]) where + docFlushCommsPost shouldMark loc bdm = do bds <- bdm case bds of [] -> do - e <- docFlushCommsPost loc docEmpty + e <- docFlushCommsPost shouldMark loc docEmpty pure [e] _ -> do - e <- docFlushCommsPost loc (pure $ List.last bds) + e <- docFlushCommsPost shouldMark loc (pure $ List.last bds) pure (List.init bds ++ [e]) +instance DocFlushCommsPost (Maybe GHC.RealSrcLoc) a + => DocFlushCommsPost (LocatedA ast) a where + docFlushCommsPost shouldMark (L ann _) = + docFlushCommsPost shouldMark $ case GHC.locA ann of + GHC.RealSrcSpan s _ -> Just $ GHC.realSrcSpanEnd s + GHC.UnhelpfulSpan{} -> Nothing + unknownNodeError :: (Data a, Data (GHC.Anno a), Outputable (GHC.Anno a)) => String @@ -737,7 +745,32 @@ docHandleListElemComms -> ToBriDocM BriDocNumbered docHandleListElemComms layouter e = case obtainListElemStartCommaLocs e of (posStart, posComma) -> - docHandleComms posStart $ docFlushCommsPost posComma $ layouter e + docHandleComms posStart $ docFlushCommsPost True posComma $ layouter e + +docHandleListElemCommsProperPost + :: (LocatedA ast -> ToBriDocM BriDocNumbered) + -> [LocatedA ast] + -> ToBriDocM [(Maybe GHC.RealSrcLoc, ToBriDocM BriDocNumbered)] +docHandleListElemCommsProperPost layouter es = case es of + [] -> pure [] + (e1 : rest) -> case obtainListElemStartCommaLocs e1 of + (posStart, posComma) -> do + res <- go posComma rest + pure + $ ( Nothing + , docFlushCommsPost True e1 $ docHandleComms posStart $ layouter e1 + ) + : res + where + go _intoComma [] = pure [] + go intoComma (e1 : rest) = case obtainListElemStartCommaLocs e1 of + (posStart, posComma) -> do + res <- go posComma rest + pure + $ ( intoComma + , docFlushCommsPost True e1 $ docHandleComms posStart $ layouter e1 + ) + : res epaLocationRealSrcSpanStart :: GHC.EpaLocation -> GHC.RealSrcLoc epaLocationRealSrcSpanStart = GHC.realSrcSpanStart . GHC.epaLocationRealSrcSpan diff --git a/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs b/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs index 74598fa..dd6fa59 100644 --- a/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs +++ b/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs @@ -31,6 +31,8 @@ import GHC ( Anchor(Anchor) , LEpaComment , RealSrcLoc , DeltaPos(SameLine, DifferentLine) + , srcLocLine + , srcLocCol ) import GHC.Types.SrcLoc ( realSrcSpanEnd ) import qualified GHC.OldList as List @@ -101,6 +103,7 @@ ppBriDoc briDoc flush = do , _lstate_indLevelLinger = 0 , _lstate_plannedSpace = PlannedNone , _lstate_commentNewlines = 0 + , _lstate_markerForDelta = Nothing } state' <- MultiRWSS.withMultiStateS state @@ -124,6 +127,7 @@ layoutBriDocM = \case BDEmpty -> do return () -- can it be that simple BDLit t -> do + layoutSetMarker Nothing layoutRemoveIndentLevelLinger layoutWriteAppend t BDSeq list -> do @@ -271,9 +275,25 @@ layoutBriDocM = \case comms <- takeBefore loc printComments comms mModify (\s -> s + CommentCounter (length comms)) + do + marker <- mGet <&> _lstate_markerForDelta + mModify $ \s -> s { _lstate_markerForDelta = Nothing } + case marker of + Nothing -> pure () + Just m -> do + let p1 = (srcLocLine m, srcLocCol m) + let p2 = (srcLocLine loc, srcLocCol loc) + -- traceShow (ExactPrint.pos2delta p1 p2) $ pure () + case ExactPrint.pos2delta p1 p2 of + SameLine{} -> pure () + DifferentLine n _ -> layoutWriteNewlines n layoutBriDocM bd - BDFlushCommentsPost loc bd -> do + BDFlushCommentsPost loc shouldMark bd -> do layoutBriDocM bd + if shouldMark then + layoutSetMarker $ Just loc + else + layoutSetMarker Nothing comms <- takeBefore loc mModify (\s -> s + CommentCounter (length comms)) printComments comms @@ -305,20 +325,19 @@ printComments :: LayoutConstraints m => [GHC.LEpaComment] -> m () printComments comms = 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) -> + Anchor span UnchangedAnchor -> do + let dp = ExactPrint.ss2deltaEnd prior span + layoutWriteComment True isBlock dp 1 (Text.pack s) + layoutUpdateMarker $ realSrcSpanEnd span + Anchor span (MovedAnchor dp) -> do 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 + layoutUpdateMarker $ realSrcSpanEnd span + 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 () + 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/ToBriDoc/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs index 95a8a58..0793648 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs @@ -471,7 +471,7 @@ createNamesAndTypeDoc :: LConDeclField GhcPs -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) createNamesAndTypeDoc lField@(L _ (ConDeclField epAnn names t _)) = - ( docFlushCommsPost posColon + ( docFlushCommsPost False posColon $ docHandleComms posStart $ docHandleComms epAnn $ docSeq @@ -479,7 +479,7 @@ createNamesAndTypeDoc lField@(L _ (ConDeclField epAnn names t _)) = L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName ] - , docFlushCommsPost posComma (layoutType t) + , docFlushCommsPost True posComma (layoutType t) ) where (posStart, posComma) = obtainListElemStartCommaLocs lField diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs index 997e99b..b461a01 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs @@ -18,6 +18,7 @@ import qualified GHC.OldList as List import GHC.Types.Basic (Activation(..), InlinePragma(..), InlineSpec(..), RuleMatchInfo(..)) import GHC.Types.SrcLoc (Located, getLoc, unLoc) +import qualified GHC import qualified GHC.Types.SrcLoc as GHC import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.S3_ToBriDocTools @@ -240,7 +241,7 @@ layoutGrhs (L _ (GRHS epAnn guards body)) = do let posArrow = obtainAnnPos epAnn AnnRarrow guardDocs <- case guards of [] -> pure [] - _ -> docFlushCommsPost posArrow $ layoutStmt `mapM` guards + _ -> docFlushCommsPost False posArrow $ layoutStmt `mapM` guards bodyDoc <- layoutExpr body return (docHandleComms epAnn, guardDocs, bodyDoc) @@ -255,12 +256,16 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = let (GRHSs _ grhss whereBinds) = m_grhss match patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match + let matchEndLoc = case GHC.locA $ GHC.getLoc lmatch of + GHC.RealSrcSpan s _ -> Just $ GHC.realSrcSpanEnd s + GHC.UnhelpfulSpan{} -> Nothing mIdDoc <- case match of Match epAnn (FunRhs matchId _ _) _ _ -> - fmap Just $ docHandleComms epAnn $ do - t <- lrdrNameToTextAnn matchId - let t' = fixPatternBindIdentifier match t - docLit t' + fmap Just + $ docHandleComms epAnn $ do + t <- lrdrNameToTextAnn matchId + let t' = fixPatternBindIdentifier match t + docLit t' _ -> pure Nothing patDoc <- docHandleComms lmatch $ case (mIdDoc, patDocs) of (Just idDoc, p1 : p2 : pr) | isInfix -> if null pr @@ -295,13 +300,14 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = -- let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) let alignmentToken = if null pats then Nothing else funId let hasComments = hasAnyCommentsBelow lmatch - layoutPatternBindFinal - alignmentToken - binderDoc - (Just patDoc) - (Right grhss) - mWhereDocs - hasComments + docFlushCommsPost True matchEndLoc + $ layoutPatternBindFinal + alignmentToken + binderDoc + (Just patDoc) + (Right grhss) + mWhereDocs + hasComments fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text fixPatternBindIdentifier match idStr = go $ m_ctxt match diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs index b411dce..8a96955 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs @@ -1106,7 +1106,8 @@ recordExpression dotdot wrapO wrapDD wrapC indentPolicy _lexpr nameDoc nameLayou if pun then pure $ Left (posStart, fnameDoc) else do - expDoc <- shareDoc $ docFlushCommsPost posComma $ layoutExpr rFExpr + expDoc <- + shareDoc $ docFlushCommsPost True posComma $ layoutExpr rFExpr pure $ Right (posStart, fnameDoc, expDoc) fieldTuple1 <- mkFieldTuple rF1 fieldTupleR <- rFr `forM` mkFieldTuple diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs index e982996..3cdad5b 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Type.hs @@ -77,7 +77,7 @@ splitArrowType ltype@(L _ typ) = case typ of EpAnn _ AddVbarAnn{} _ -> error "brittany internal error: HsFunTy EpAnn" EpAnn _ (AddRarrowAnn loc) _ -> - docFlushCommsPost (Just $ epaLocationRealSrcSpanStart loc) + docFlushCommsPost True (Just $ epaLocationRealSrcSpanStart loc) EpAnn _ AddRarrowAnnU{} _ -> error "brittany internal error: HsFunTy EpAnn" EpAnn _ AddLollyAnnU{} _ -> diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs index 38fe7aa..b86e8e9 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T1_Alt.hs @@ -301,8 +301,8 @@ transformAlts = -- > bd' <- rec bd -- not sure if the lineModeDecay is relevant any longer though.. reWrap . BDFlushCommentsPrior loc <$> rec bd - BDFlushCommentsPost loc bd -> - reWrap . BDFlushCommentsPost loc <$> rec bd + BDFlushCommentsPost loc shouldMark bd -> + reWrap . BDFlushCommentsPost loc shouldMark <$> rec bd BDLines [] -> return $ reWrap BDEmpty -- evil transformation. or harmless. BDLines (l : lr) -> do ind <- _acp_indent <$> mGet @@ -487,7 +487,7 @@ getSpacing !bridoc = rec bridoc _ -> VerticalSpacing 999 VerticalSpacingParNone False BDQueueComments _comms bd -> rec bd BDFlushCommentsPrior _loc bd -> rec bd - BDFlushCommentsPost _loc bd -> rec bd + BDFlushCommentsPost _loc _shouldMark bd -> rec bd BDEntryDelta _dp bd -> rec bd BDLines [] -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False @@ -789,7 +789,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc ] BDQueueComments _comms bd -> rec bd BDFlushCommentsPrior _loc bd -> rec bd - BDFlushCommentsPost _loc bd -> rec bd + BDFlushCommentsPost _loc _shouldMark bd -> rec bd BDEntryDelta _dp bd -> rec bd BDLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDLines ls@(_ : _) -> do diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs index 5791279..daf2fa5 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T2_Floating.hs @@ -31,6 +31,8 @@ transformSimplifyFloating = stepBO .> stepFull -- prior floating in BDFlushCommentsPrior loc1 (BDFlushCommentsPrior loc2 x) -> Just $ BDFlushCommentsPrior (max loc1 loc2) x + BDFlushCommentsPrior loc1 (BDFlushCommentsPost loc2 shouldMark2 x) -> + Just $ BDFlushCommentsPost loc2 shouldMark2 (BDFlushCommentsPrior loc1 x) BDFlushCommentsPrior loc1 (BDPar ind line indented) -> Just $ BDPar ind (BDFlushCommentsPrior loc1 line) indented BDFlushCommentsPrior loc1 (BDSeq (l : lr)) -> @@ -43,32 +45,57 @@ transformSimplifyFloating = stepBO .> stepFull Just $ BDAddBaseY indent $ BDFlushCommentsPrior loc1 x BDFlushCommentsPrior loc1 (BDDebug s x) -> Just $ BDDebug s $ BDFlushCommentsPrior loc1 x + BDFlushCommentsPrior loc1 (BDQueueComments comms1 x) -> + Just $ BDQueueComments comms1 $ BDFlushCommentsPrior loc1 x _ -> Nothing descendCommsPost = transformDownMay $ \case -- post floating in - BDFlushCommentsPost loc1 (BDFlushCommentsPost loc2 x) -> - Just $ BDFlushCommentsPost (max loc1 loc2) x - BDFlushCommentsPost loc1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDFlushCommentsPost loc1 indented - BDFlushCommentsPost loc1 (BDSeq list) -> + BDFlushCommentsPost loc1 mark1 (BDFlushCommentsPost loc2 mark2 x) -> + Just $ BDFlushCommentsPost (max loc1 loc2) (mark1 || mark2) x + BDFlushCommentsPost loc1 shouldMark1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDFlushCommentsPost loc1 shouldMark1 indented + BDFlushCommentsPost loc1 shouldMark1 (BDSeq list) -> Just $ BDSeq $ List.init list - ++ [BDFlushCommentsPost loc1 $ List.last list] - BDFlushCommentsPost loc1 (BDLines list) -> + ++ [BDFlushCommentsPost loc1 shouldMark1 $ List.last list] + BDFlushCommentsPost loc1 shouldMark1 (BDLines list) -> Just $ BDLines $ List.init list - ++ [BDFlushCommentsPost loc1 $ List.last list] - BDFlushCommentsPost loc1 (BDCols sig cols) -> + ++ [BDFlushCommentsPost loc1 shouldMark1 $ List.last list] + BDFlushCommentsPost loc1 shouldMark1 (BDCols sig cols) -> Just $ BDCols sig $ List.init cols - ++ [BDFlushCommentsPost loc1 $ List.last cols] - BDFlushCommentsPost loc1 (BDAddBaseY indent x) -> - Just $ BDAddBaseY indent $ BDFlushCommentsPost loc1 x - BDFlushCommentsPost loc1 (BDDebug s x) -> - Just $ BDDebug s $ BDFlushCommentsPost loc1 x + ++ [BDFlushCommentsPost loc1 shouldMark1 $ List.last cols] + BDFlushCommentsPost loc1 shouldMark1 (BDIndentLevelPop x) -> + Just $ BDIndentLevelPop (BDFlushCommentsPost loc1 shouldMark1 x) + BDFlushCommentsPost loc1 shouldMark1 (BDIndentLevelPushCur x) -> + Just $ BDIndentLevelPushCur (BDFlushCommentsPost loc1 shouldMark1 x) + BDFlushCommentsPost loc1 shouldMark1 (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDFlushCommentsPost loc1 shouldMark1 x) + BDFlushCommentsPost loc1 shouldMark1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDFlushCommentsPost loc1 shouldMark1 x + BDFlushCommentsPost loc1 shouldMark1 (BDDebug s x) -> + Just $ BDDebug s $ BDFlushCommentsPost loc1 shouldMark1 x + _ -> Nothing + descendQueueComments = transformDownMay $ \case + -- queue comments floating in + BDQueueComments comms1 (BDQueueComments comms2 x) -> + Just $ BDQueueComments (comms1 ++ comms2) x + BDQueueComments comms1 (BDPar ind line indented) -> + Just $ BDPar ind (BDQueueComments comms1 line) indented + BDQueueComments comms1 (BDSeq (l : lr)) -> + Just $ BDSeq (BDQueueComments comms1 l : lr) + BDQueueComments comms1 (BDLines (l : lr)) -> + Just $ BDLines (BDQueueComments comms1 l : lr) + BDQueueComments comms1 (BDCols sig (l : lr)) -> + Just $ BDCols sig (BDQueueComments comms1 l : lr) + BDQueueComments comms1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDQueueComments comms1 x + BDQueueComments comms1 (BDDebug s x) -> + Just $ BDDebug s $ BDQueueComments comms1 x _ -> Nothing descendBYPush = transformDownMay $ \case BDBaseYPushCur (BDCols sig cols@(_ : _)) -> @@ -114,8 +141,8 @@ transformSimplifyFloating = stepBO .> stepFull Just $ BDPar (mergeIndents ind1 ind2) line indented BDAddBaseY ind (BDFlushCommentsPrior loc x) -> Just $ BDFlushCommentsPrior loc (BDAddBaseY ind x) - BDAddBaseY ind (BDFlushCommentsPost loc x) -> - Just $ BDFlushCommentsPost loc (BDAddBaseY ind x) + BDAddBaseY ind (BDFlushCommentsPost loc shouldMark x) -> + Just $ BDFlushCommentsPost loc shouldMark (BDAddBaseY ind x) BDAddBaseY ind (BDQueueComments comms x) -> Just $ BDQueueComments comms (BDAddBaseY ind x) BDAddBaseY ind (BDSeq list) -> @@ -151,6 +178,7 @@ transformSimplifyFloating = stepBO .> stepFull BDSeq xs -> BDSeq (dropWhile (\case BDEmpty -> True; _ -> False) xs) x@BDFlushCommentsPrior{} -> descendCommsPrior x x@BDFlushCommentsPost{} -> descendCommsPost x + x@BDQueueComments{} -> descendQueueComments x x@BDAddBaseY{} -> descendAddB x x@BDBaseYPushCur{} -> descendBYPush x x@BDEntryDelta{} -> descendEntryDelta x @@ -186,8 +214,10 @@ transformSimplifyFloating = stepBO .> stepFull -- BDEnsureIndent indent (BDLines lines) -> -- Just $ BDLines $ BDEnsureIndent indent <$> lines -- flush-prior floating in - BDFlushCommentsPrior loc (BDPar ind line indented) -> - Just $ BDPar ind (BDFlushCommentsPrior loc line) indented + BDFlushCommentsPrior loc1 (BDFlushCommentsPrior loc2 x) -> + Just $ BDFlushCommentsPrior (max loc1 loc2) x + BDFlushCommentsPrior loc1 (BDFlushCommentsPost loc2 shouldMark2 x) -> + Just $ BDFlushCommentsPost loc2 shouldMark2 (BDFlushCommentsPrior loc1 x) BDFlushCommentsPrior loc (BDSeq (l : lr)) -> Just $ BDSeq (BDFlushCommentsPrior loc l : lr) BDFlushCommentsPrior loc (BDLines (l : lr)) -> @@ -195,14 +225,24 @@ transformSimplifyFloating = stepBO .> stepFull BDFlushCommentsPrior loc (BDCols sig (l : lr)) -> Just $ BDCols sig (BDFlushCommentsPrior loc l : lr) -- flush-post floating in - BDFlushCommentsPost comms1 (BDPar ind line indented) -> - Just $ BDPar ind line $ BDFlushCommentsPost comms1 indented - BDFlushCommentsPost loc (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] - BDFlushCommentsPost loc (BDLines list) -> Just - $ BDLines $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] - BDFlushCommentsPost loc (BDCols sig list) -> Just - $ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] + BDFlushCommentsPost loc1 mark1 (BDPar ind line indented) -> + Just $ BDPar ind line $ BDFlushCommentsPost loc1 mark1 indented + BDFlushCommentsPost loc1 mark1 (BDSeq list) -> + Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc1 mark1 $ List.last list] + BDFlushCommentsPost loc1 mark1 (BDLines list) -> + Just $ BDLines $ List.init list ++ [BDFlushCommentsPost loc1 mark1 $ List.last list] + BDFlushCommentsPost loc1 mark1 (BDCols sig list) -> + Just $ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc1 mark1 $ List.last list] + BDFlushCommentsPost loc1 mark1 (BDIndentLevelPop x) -> + Just $ BDIndentLevelPop (BDFlushCommentsPost loc1 mark1 x) + BDFlushCommentsPost loc1 mark1 (BDIndentLevelPushCur x) -> + Just $ BDIndentLevelPushCur (BDFlushCommentsPost loc1 mark1 x) + BDFlushCommentsPost loc1 mark1 (BDBaseYPushCur x) -> + Just $ BDBaseYPushCur (BDFlushCommentsPost loc1 mark1 x) + BDFlushCommentsPost loc1 mark1 (BDAddBaseY indent x) -> + Just $ BDAddBaseY indent $ BDFlushCommentsPost loc1 mark1 x + BDFlushCommentsPost loc1 mark1 (BDDebug s x) -> + Just $ BDDebug s $ BDFlushCommentsPost loc1 mark1 x -- entry-delta floating in BDEntryDelta dp (BDPar ind line indented) -> Just $ BDPar ind (BDEntryDelta dp line) indented diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs index d46a796..fab8d20 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T4_Columns.hs @@ -33,7 +33,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case (\case BDSeparator -> True BDFlushCommentsPrior _ BDSeparator -> True - BDFlushCommentsPost _ BDSeparator -> True + BDFlushCommentsPost _ _ BDSeparator -> True _ -> False ) rest @@ -57,12 +57,16 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDFlushCommentsPrior loc (BDCols sig (l : lr)) -> Just $ BDCols sig (BDFlushCommentsPrior loc l : lr) -- flush-post floating in - BDFlushCommentsPost loc (BDSeq list) -> - Just $ BDSeq $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] - BDFlushCommentsPost loc (BDLines list) -> Just - $ BDLines $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] - BDFlushCommentsPost loc (BDCols sig list) -> Just - $ BDCols sig $ List.init list ++ [BDFlushCommentsPost loc $ List.last list] + BDFlushCommentsPost loc shouldMark (BDSeq list) -> + Just + $ BDSeq + $ List.init list ++ [BDFlushCommentsPost loc shouldMark $ List.last list] + BDFlushCommentsPost loc shouldMark (BDLines list) -> Just + $ BDLines + $ List.init list ++ [BDFlushCommentsPost loc shouldMark $ List.last list] + BDFlushCommentsPost loc shouldMark (BDCols sig list) -> Just + $ BDCols sig + $ List.init list ++ [BDFlushCommentsPost loc shouldMark $ List.last list] -- ensureIndent float-in -- not sure if the following rule is necessary; tests currently are -- unaffected. diff --git a/source/library/Language/Haskell/Brittany/Internal/Transformations/T5_Indent.hs b/source/library/Language/Haskell/Brittany/Internal/Transformations/T5_Indent.hs index 3f1ee73..bb7489b 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Transformations/T5_Indent.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Transformations/T5_Indent.hs @@ -42,8 +42,8 @@ transformSimplifyIndent = Uniplate.rewrite $ \case BDLines [l] -> Just l BDAddBaseY i (BDFlushCommentsPrior c x) -> Just $ BDFlushCommentsPrior c (BDAddBaseY i x) - BDAddBaseY i (BDFlushCommentsPost c x) -> - Just $ BDFlushCommentsPost c (BDAddBaseY i x) + BDAddBaseY i (BDFlushCommentsPost c sm x) -> + Just $ BDFlushCommentsPost c sm (BDAddBaseY i x) BDAddBaseY i (BDSeq l) -> Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l] BDAddBaseY i (BDCols sig l) -> diff --git a/source/library/Language/Haskell/Brittany/Internal/Utils.hs b/source/library/Language/Haskell/Brittany/Internal/Utils.hs index 962c401..ec86c02 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Utils.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Utils.hs @@ -249,7 +249,7 @@ briDocToDoc = astToDoc . removeAnnotations where removeAnnotations = Uniplate.transform $ \case BDFlushCommentsPrior _ x -> x - BDFlushCommentsPost _ x -> x + BDFlushCommentsPost _ _ x -> x BDQueueComments _ x -> x x -> x diff --git a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs index 168dbb9..5cfa242 100644 --- a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs +++ b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs @@ -409,7 +409,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDPlain t -> return $ Text.length t BDQueueComments _ bd -> rec bd BDFlushCommentsPrior _ bd -> rec bd - BDFlushCommentsPost _ bd -> rec bd + BDFlushCommentsPost _ _ bd -> rec bd BDLines ls@(_ : _) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x @@ -446,7 +446,7 @@ briDocIsMultiLine briDoc = rec briDoc BDPlain _ -> True BDQueueComments _ bd -> rec bd BDFlushCommentsPrior _ bd -> rec bd - BDFlushCommentsPost _ bd -> rec bd + BDFlushCommentsPost _ _ bd -> rec bd BDEntryDelta _dp bd -> rec bd BDLines (_ : _ : _) -> True BDLines [_] -> False diff --git a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs index 2ef7a15..6117fc2 100644 --- a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs +++ b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Operators.hs @@ -15,8 +15,11 @@ module Language.Haskell.Brittany.Internal.WriteBriDoc.Operators , layoutIndentLevelPushCur , layoutIndentLevelPop , layoutWriteNewline + , layoutWriteNewlines , layoutWriteComment , layoutFlushLine + , layoutSetMarker + , layoutUpdateMarker ) where @@ -26,6 +29,7 @@ import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as Text.Builder import qualified GHC.OldList as List import qualified GHC.Parser.Annotation as GHC +import GHC ( RealSrcLoc ) import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.WriteBriDoc.Types @@ -93,6 +97,17 @@ layoutWriteNewline = do { _lstate_plannedSpace = PlannedNewline 1 } +layoutWriteNewlines + :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) + => Int + -> m () +layoutWriteNewlines n = do + traceLocal ("layoutWriteNewlines") + state <- mGet + mSet $ state + { _lstate_plannedSpace = PlannedNewline n + } + -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m -- , MonadMultiWriter (Seq String) m) => Int -> m () -- layoutMoveToIndentCol i = do @@ -322,6 +337,17 @@ layoutFlushLine = do state <- mGet when (_lstate_curY state > 0) layoutWriteEnsureNewlineBlock +layoutSetMarker :: (MonadMultiState LayoutState m) => Maybe RealSrcLoc -> m () +layoutSetMarker markerMay = + mModify $ \s -> s { _lstate_markerForDelta = markerMay } + +layoutUpdateMarker :: (MonadMultiState LayoutState m) => RealSrcLoc -> m () +layoutUpdateMarker marker = mModify $ \s -> s + { _lstate_markerForDelta = case _lstate_markerForDelta s of + Nothing -> Nothing + Just _ -> Just marker + } + -- moveToY :: MonadMultiState LayoutState m => Int -> m () -- moveToY y = mModify $ \state -> -- let diff --git a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Types.hs b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Types.hs index 716c54f..35849be 100644 --- a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/Types.hs @@ -7,6 +7,7 @@ import Language.Haskell.Brittany.Internal.Prelude import qualified Safe import GHC ( LEpaComment + , RealSrcLoc ) import qualified Data.Text.Lazy.Builder as TextL.Builder @@ -60,6 +61,7 @@ data LayoutState = LayoutState -- But the worst effect at the moment would -- be that we introduce less newlines on -- moveToKWDP, which seems harmless enough. + , _lstate_markerForDelta :: Maybe RealSrcLoc } lstate_baseY :: LayoutState -> Int