From ab67a794dbd8c70bdde0a680023d6094808dfde9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 28 Apr 2023 18:06:20 +0000 Subject: [PATCH] Fix retaining newlines between do statements --- data/10-structured/expression-do.blt | 9 ++++ .../Brittany/Internal/S3_ToBriDocTools.hs | 46 +++++++++++++------ .../Brittany/Internal/S4_WriteBriDoc.hs | 2 +- .../Brittany/Internal/StepOrchestrate.hs | 3 +- .../Brittany/Internal/ToBriDoc/Decl.hs | 7 ++- .../Brittany/Internal/ToBriDoc/Expr.hs | 6 ++- .../Brittany/Internal/ToBriDoc/Stmt.hs | 2 +- source/test-suite/Main.hs | 9 ++-- 8 files changed, 60 insertions(+), 24 deletions(-) diff --git a/data/10-structured/expression-do.blt b/data/10-structured/expression-do.blt index a45bbf6..5bda8ed 100644 --- a/data/10-structured/expression-do.blt +++ b/data/10-structured/expression-do.blt @@ -15,3 +15,12 @@ func = do func = do let x = 13 stmt x + +#test do empty lines +func = do + + let x = 13 + + y <- monadic + + stmt (x + y) diff --git a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs index 5a41a01..10886a4 100644 --- a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs +++ b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs @@ -226,21 +226,28 @@ hasAnyCommentsBelow = hasCommentsBetween :: Data ast => ast - -> Maybe GHC.RealSrcLoc - -> Maybe GHC.RealSrcLoc + -> Maybe GHC.RealSrcSpan + -> Maybe GHC.RealSrcSpan -> Bool hasCommentsBetween ast left right = do - getAny $ SYB.everything - (<>) - (SYB.mkQ - (Any False) - (\(L (GHC.Anchor pos _) _ :: LEpaComment) -> Any - ( (maybe True (GHC.realSrcSpanStart pos >=) left) - && (maybe True (GHC.realSrcSpanEnd pos <=) right) + getAny + $ SYB.everything + (<>) + (SYB.mkQ + (Any False) + (\(L (GHC.Anchor pos _) _ :: LEpaComment) -> Any + ( ( maybe True + (\l -> GHC.realSrcSpanStart pos >= GHC.realSrcSpanEnd l) + left + ) + && (maybe True + (\l -> GHC.realSrcSpanEnd pos <= GHC.realSrcSpanStart l) + right + ) + ) ) ) - ) - ast + ast startsWithComments :: EpAnn a -> Bool startsWithComments = \case @@ -627,11 +634,11 @@ instance DocHandleComms GHC.SrcSpan (ToBriDocM BriDocNumbered) where -- CLASS ObtainAnnPos ---------------------------------------------------------- class ObtainAnnPos key ann where - obtainAnnPos :: ann -> key -> Maybe GHC.RealSrcLoc + obtainAnnPos :: ann -> key -> Maybe GHC.RealSrcSpan instance ObtainAnnPos AnnKeywordId GHC.AddEpAnn where obtainAnnPos (GHC.AddEpAnn eKW loc) kw = if eKW == kw - then Just (epaLocationRealSrcSpanStart loc) + then Just (GHC.epaLocationRealSrcSpan loc) else Nothing instance ObtainAnnPos AnnKeywordId (EpAnn GHC.AnnsModule) where @@ -648,7 +655,7 @@ instance ObtainAnnPos AnnKeywordId [GHC.AddEpAnn] where obtainAnnPos list kw = case [ loc | GHC.AddEpAnn eKW loc <- list, eKW == kw ] of [] -> Nothing - locs -> Just (epaLocationRealSrcSpanStart $ minimum locs) + locs -> Just (GHC.epaLocationRealSrcSpan $ minimum locs) instance ObtainAnnPos AnnKeywordId (EpAnn [GHC.AddEpAnn]) where obtainAnnPos EpAnnNotUsed _kw = Nothing @@ -679,7 +686,8 @@ instance ObtainAnnDeltaPos (EpAnn GHC.AnnsModule) where obtainAnnDeltaPos = \case EpAnnNotUsed -> \_kw -> Nothing EpAnn _ (GHC.AnnsModule l annList) epaComms -> \kw -> do - loc <- obtainAnnPos l kw <|> obtainAnnPos annList kw + loc <- GHC.realSrcSpanStart + <$> (obtainAnnPos l kw <|> obtainAnnPos annList kw) let pos = (GHC.srcLocLine loc, GHC.srcLocCol loc) pure $ ExactPrint.pos2delta (maximum $ (1, 1) : @@ -704,6 +712,14 @@ instance DocFlushCommsPost (Maybe GHC.RealSrcLoc) (ToBriDocM BriDocNumbered) whe bd <- bdm pure (i1, BDFlushCommentsPost loc shouldMark bd) +instance DocFlushCommsPost (Maybe GHC.RealSrcSpan) (ToBriDocM BriDocNumbered) where + docFlushCommsPost shouldMark = \case + Nothing -> id + Just loc -> \bdm -> do + i1 <- allocNodeIndex + bd <- bdm + pure (i1, BDFlushCommentsPost (GHC.realSrcSpanEnd loc) shouldMark bd) + instance DocFlushCommsPost ann (ToBriDocM BriDocNumbered) => DocFlushCommsPost ann (ToBriDocM [BriDocNumbered]) where docFlushCommsPost shouldMark loc bdm = do diff --git a/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs b/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs index cb7a597..40d2e50 100644 --- a/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs +++ b/source/library/Language/Haskell/Brittany/Internal/S4_WriteBriDoc.hs @@ -291,7 +291,7 @@ layoutBriDocM = \case PlannedNone -> PlannedNone PlannedSameline i -> PlannedDelta n (_lstate_curY s + i) PlannedNewline{} -> PlannedNewline n - PlannedDelta{} -> PlannedNewline n + PlannedDelta _ i -> PlannedDelta n i } layoutBriDocM bd BDFlushCommentsPost loc shouldMark bd -> do diff --git a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs index 0e78fcf..6da4220 100644 --- a/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs +++ b/source/library/Language/Haskell/Brittany/Internal/StepOrchestrate.hs @@ -25,6 +25,7 @@ import GHC ( EpaCommentTok , LHsDecl , SrcSpanAnn'(SrcSpanAnn) ) +import qualified GHC.Types.SrcLoc as GHC import qualified GHC.OldList as List import GHC.Types.SrcLoc ( srcSpanFileName_maybe ) import qualified Language.Haskell.GHC.ExactPrint @@ -68,7 +69,7 @@ processModule traceFunc conf inlineConf parsedModule = do FinalList moduleElementsStream = splitModule shouldReformatHead parsedModule - (obtainAnnPos (GHC.hsmodAnn $ GHC.unLoc parsedModule) GHC.AnnWhere) + (fmap GHC.realSrcSpanStart $ obtainAnnPos (GHC.hsmodAnn $ GHC.unLoc parsedModule) GHC.AnnWhere) ((out, errs), debugStrings) = runIdentity $ MultiRWSS.runMultiRWSTNil diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs index 28b8b02..5683d18 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs @@ -904,7 +904,12 @@ layoutClsInst (L declLoc _) cid = do layoutInstanceHead = case cid_ext cid of (EpAnn annAnchor addEpAnns (EpaComments comms), sortKey) -> do let posWhere = obtainAnnPos addEpAnns AnnWhere - let (commsBefore, commsAfter) = partition (\(L anch _) -> (Just $ GHC.realSrcSpanStart $ anchor anch) < posWhere) comms + let (commsBefore, commsAfter) = + partition + (\(L anch _) -> + (Just $ GHC.realSrcSpanStart $ anchor anch) + < fmap GHC.realSrcSpanStart posWhere) + comms docHandleComms (reverse commsAfter) $ briDocByExactNoComment $ L declLoc diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs index b66d31e..9d2b5fd 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs @@ -649,7 +649,11 @@ layoutExpr lexpr@(L _ expr) = do stmtDocs <- docHandleComms stmtEpAnn $ do stmts `forM` docHandleListElemComms (callLayouter layout_stmt) docSetParSpacing $ docAddBaseY BrIndentRegularForce $ docPar - (docHandleComms locDo $ docLit $ Text.pack "do") + ( docFlushCommsPost True locDo + $ docHandleComms locDo + $ docLit + $ Text.pack "do" + ) ( docSetBaseAndIndent $ docNonBottomSpacing $ docLines diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs index e5219b2..5561ab1 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs @@ -20,7 +20,7 @@ layoutStmt lstmt@(L _ stmt) = do indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indentAmount :: Int <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack - case stmt of + docFlushCommsPost True lstmt $ case stmt of LastStmt NoExtField body Nothing _ -> do -- at least the "|" of a monadcomprehension for _some_ reason -- is connected to the _body_ of the "result" stmt. So we need diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index 3604b81..7720ee6 100644 --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -245,16 +245,17 @@ main = do | _ <- Parsec.try $ Parsec.string "#expected" , _ <- Parsec.eof ] + , [ NormalLine mempty + | _ <- Parsec.many $ Parsec.oneOf " \t" + , _ <- Parsec.try $ Parsec.string "" + , _ <- Parsec.eof + ] , [ CommentLine | _ <- Parsec.many $ Parsec.oneOf " \t" , _ <- Parsec.optional $ Parsec.string "##" <* many (Parsec.noneOf "\r\n") , _ <- Parsec.eof ] - , [ NormalLine mempty - | _ <- Parsec.try $ Parsec.string "" - , _ <- Parsec.eof - ] ] lineMapper :: Text -> InputLine lineMapper line = case Parsec.runParser specialLineParser () "" line of