From 2fef44559e2d79dd2689a3b1537e52495d97bbd3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 18 Apr 2023 17:15:41 +0000 Subject: [PATCH] Fix comments moving after "where" --- data/15-regressions.blt | 34 +++++++++ .../Brittany/Internal/ToBriDoc/Decl.hs | 46 ++++++------ .../Brittany/Internal/ToBriDoc/Expr.hs | 28 +++++--- .../Brittany/Internal/ToBriDoc/Stmt.hs | 11 +-- .../Haskell/Brittany/Internal/Types.hs | 6 +- .../Internal/WriteBriDoc/AlignmentAlgo.hs | 70 +++++++++---------- 6 files changed, 120 insertions(+), 75 deletions(-) diff --git a/data/15-regressions.blt b/data/15-regressions.blt index 7112f36..792f320 100644 --- a/data/15-regressions.blt +++ b/data/15-regressions.blt @@ -895,3 +895,37 @@ fieldWith -> ToBriDocM BriDocNumbered ) -> [ToBriDocM BriDocNumbered] + +#test comment-before-where +briDocLineLength briDoc = flip StateS.evalState False $ go briDoc + -- the state encodes whether a separator was already + -- appended at the current position. + where + go = \case + BDEmpty -> return $ 0 + BDLit t -> StateS.put False $> Text.length t + BDSeq bds -> sum <$> go `mapM` bds + +#test where-funbind-no-empty-lines +alignColsLines layoutBriDocM bridocs = do -- colInfos `forM_` \colInfo -> do + -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs)) + case () of + _ -> do + -- tellDebugMess ("colInfos:\n" ++ List.unlines [ "> " ++ prettyColInfos "> " x | x <- colInfos]) + -- tellDebugMess ("processedMap: " ++ show processedMap) + sequence_ + $ List.intersperse layoutWriteEnsureNewlineBlock + $ colInfos <&> processInfo layoutBriDocM colMax processedMap + where + (colInfos, finalState) = + StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0) + -- maxZipper :: [Int] -> [Int] -> [Int] + -- maxZipper [] ys = ys + -- maxZipper xs [] = xs + -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr + colAggregation :: [Int] -> Int + colAggregation [] = 0 -- this probably cannot happen the way we call + -- this function, because _cbs_map only ever + -- contains nonempty Seqs. + colAggregation xs = maximum [ x | x <- xs, x <= minimum xs + alignMax' ] + where alignMax' = max 0 alignMax diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs index 55b3e31..04cd4ee 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs @@ -182,7 +182,7 @@ layoutIPBind lipbind@(L _ bind) = case bind of binderDoc (Just ipName) (Left expr) - Nothing + (id, Nothing) hasComments @@ -196,7 +196,8 @@ bindOrSigtoSrcSpan (BagSig (L (SrcSpanAnn _ l) _)) = l layoutLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> ToBriDocM - ( Maybe + ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered + , Maybe ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered , [BriDocNumbered] ) @@ -207,23 +208,23 @@ layoutLocalBinds binds = case binds of -- x@(HsValBinds (ValBindsIn{})) -> -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x HsValBinds epAnn (ValBinds _ bindlrs sigs) -> do - let locWhere = obtainAnnPos epAnn AnnWhere - let unordered = - [ BagBind b | b <- Data.Foldable.toList bindlrs ] - ++ [ BagSig s | s <- sigs ] - ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered - ds <- docHandleComms epAnn $ join <$> ordered `forM` \case - BagBind b -> either id return <$> layoutBind b - BagSig s@(L _ sig) -> do - doc <- layoutSig s sig - pure [doc] - pure $ Just (docHandleComms locWhere, ds) + let locWhere = obtainAnnPos epAnn AnnWhere + let unordered = + [ BagBind b | b <- Data.Foldable.toList bindlrs ] + ++ [ BagSig s | s <- sigs ] + ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered + ds <- join <$> ordered `forM` \case + BagBind b -> either id return <$> layoutBind b + BagSig s@(L _ sig) -> do + doc <- layoutSig s sig + pure [doc] + pure $ (docHandleComms epAnn, Just (docHandleComms locWhere, ds)) -- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" HsIPBinds epAnn (IPBinds _ bb) -> do - ds <- docHandleComms epAnn $ mapM layoutIPBind bb - pure $ Just (id, ds) -- TODO92 do we need to replace id? - EmptyLocalBinds NoExtField -> return $ Nothing + ds <- mapM layoutIPBind bb + pure $ (docHandleComms epAnn, Just (id, ds)) -- TODO92 do we need to replace id? + EmptyLocalBinds NoExtField -> return $ (id, Nothing) layoutGrhs :: LGRHS GhcPs (LHsExpr GhcPs) @@ -323,14 +324,15 @@ layoutPatternBindFinal -> BriDocNumbered -> Maybe BriDocNumbered -> Either (LHsExpr GhcPs) [LGRHS GhcPs (LHsExpr GhcPs)] - -> ( Maybe + -> ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered + , Maybe ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered , [BriDocNumbered] ) ) -> Bool -> ToBriDocM BriDocNumbered -layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses mWhereDocs hasComments +layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses (wrapBinds, mWhereDocs) hasComments = do let patPartInline = case mPatDoc of @@ -354,14 +356,14 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses mWhereDocs hasCo Just (wrapWhere, [w]) -> pure . pure <$> docAlt [ docEnsureIndent BrIndentRegular $ docSeq - [ wrapWhere $ docLit $ Text.pack "where" + [ wrapBinds $ wrapWhere $ docLit $ Text.pack "where" , docSeparator , docForceSingleline $ return w ] , -- docMoveToKWDP annKeyWhere AnnWhere False -- TODO92 docEnsureIndent whereIndent $ docLines - [ docLit $ Text.pack "where" + [ wrapBinds $ wrapWhere $ docLit $ Text.pack "where" , docEnsureIndent whereIndent $ docSetIndentLevel $ docNonBottomSpacing @@ -373,7 +375,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses mWhereDocs hasCo -- $ docMoveToKWDP annKeyWhere AnnWhere False -- TODO92 $ docEnsureIndent whereIndent $ docLines - [ wrapWhere $ docLit $ Text.pack "where" + [ wrapBinds $ wrapWhere $ docLit $ Text.pack "where" , docEnsureIndent whereIndent $ docSetIndentLevel $ docNonBottomSpacing @@ -397,7 +399,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauses mWhereDocs hasCo Nothing -> Just docEmpty Just (wrapWhere, [w]) -> Just $ docSeq [ docSeparator - , wrapWhere $ appSep $ docLit $ Text.pack "where" + , wrapBinds $ wrapWhere $ appSep $ docLit $ Text.pack "where" , docSetIndentLevel $ docForceSingleline $ return w ] _ -> Nothing diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs index 8473b88..1c2c60a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs @@ -585,7 +585,7 @@ layoutExpr lexpr@(L _ expr) = do binderDoc Nothing (Right cases) - Nothing + (id, Nothing) hasComments ) HsLet epAnn binds exp1 -> docHandleComms epAnn $ do @@ -593,7 +593,7 @@ layoutExpr lexpr@(L _ expr) = do let hasComments = hasAnyCommentsBelow lexpr let wrapLet = docHandleComms spanLet let wrapIn = docHandleComms spanIn - mBindDocs <- callLayouter layout_localBinds binds + (wrapBinds, mBindDocs) <- callLayouter layout_localBinds binds let ifIndentFreeElse :: a -> a -> a ifIndentFreeElse x y = case indentPolicy of IndentPolicyLeft -> y @@ -614,7 +614,7 @@ layoutExpr lexpr@(L _ expr) = do Just [bindDoc] -> runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq [ appSep $ letDoc - , appSep $ docForceSingleline (pure bindDoc) + , wrapBinds $ appSep $ docForceSingleline (pure bindDoc) , appSep $ inDoc , docForceSingleline expDoc1 ] @@ -622,11 +622,13 @@ layoutExpr lexpr@(L _ expr) = do [ docAlt [ docSeq [ appSep $ letDoc - , ifIndentFreeElse docSetBaseAndIndent docForceSingleline + , wrapBinds + $ ifIndentFreeElse docSetBaseAndIndent docForceSingleline $ pure bindDoc ] - , docAddBaseY BrIndentRegular - $ docPar (letDoc) (docSetBaseAndIndent $ pure bindDoc) + , docAddBaseY BrIndentRegular $ docPar + (letDoc) + (wrapBinds $ docSetBaseAndIndent $ pure bindDoc) ] , docAlt [ docSeq @@ -658,7 +660,9 @@ layoutExpr lexpr@(L _ expr) = do let noHangingBinds = [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar (letDoc) - (docSetBaseAndIndent $ docLines $ pure <$> bindDocs) + ( wrapBinds + $ docSetBaseAndIndent $ docLines $ pure <$> bindDocs + ) , docSeq [ wrapIn $ docLit $ Text.pack "in " , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1 @@ -671,7 +675,7 @@ layoutExpr lexpr@(L _ expr) = do [ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $ docSeq [ appSep $ letDoc - , docSetBaseAndIndent $ docLines $ pure <$> bindDocs + , wrapBinds $ docSetBaseAndIndent $ docLines $ pure <$> bindDocs ] , docSeq [ appSep $ wrapIn $ docLit $ Text.pack "in " @@ -682,12 +686,13 @@ layoutExpr lexpr@(L _ expr) = do [ -- TODO92 docNodeAnnKW lexpr (Just AnnLet) $ docAddBaseY BrIndentRegular $ docPar (letDoc) - (docSetBaseAndIndent $ docLines $ pure <$> bindDocs) + (wrapBinds $ docSetBaseAndIndent $ docLines $ pure <$> bindDocs) , docAddBaseY BrIndentRegular $ docPar (inDoc) (docSetBaseY $ expDoc1) ] _ -> docSeq - [ docForceSingleline $ docSeq [letDoc, docSeparator, inDoc] + [ docForceSingleline $ docSeq + [letDoc, docSeparator, wrapBinds $ inDoc] , docSeparator , expDoc1 ] @@ -696,10 +701,11 @@ layoutExpr lexpr@(L _ expr) = do docHandleComms epAnn $ do case stmtCtx of DoExpr _ -> do + let locDo = obtainAnnPos epAnn AnnDo stmtDocs <- docHandleComms stmtEpAnn $ do stmts `forM` docHandleListElemComms (callLayouter layout_stmt) docSetParSpacing $ docAddBaseY BrIndentRegularForce $ docPar - (docLit $ Text.pack "do") + (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 c4d6d5a..4083199 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs +++ b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Stmt.hs @@ -49,7 +49,8 @@ layoutStmt lstmt@(L _ stmt) = do LetStmt epAnn binds -> docHandleComms epAnn $ do let isFree = indentPolicy == IndentPolicyFree let indentFourPlus = indentAmount >= 4 - callLayouter layout_localBinds binds >>= \case + (wrapBinds, bindrDocsMay) <- callLayouter layout_localBinds binds + case bindrDocsMay of Nothing -> docLit $ Text.pack "let" -- i just tested the above, and it is indeed allowed. heh. Just (_, []) -> docLit $ Text.pack "let" -- this probably never happens @@ -65,13 +66,13 @@ layoutStmt lstmt@(L _ stmt) = do IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent | otherwise -> docForceSingleline - in f $ return bindDoc + in wrapBinds $ f $ return bindDoc ] , -- let -- bind = expr docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) + (wrapBinds $ docSetBaseAndIndent $ return bindDoc) ] Just (_, bindDocs) -> runFilteredAlternative $ do -- let aaa = expra @@ -83,7 +84,7 @@ layoutStmt lstmt@(L _ stmt) = do f = if indentFourPlus then docEnsureIndent BrIndentRegular else docSetBaseAndIndent - in f $ docLines $ return <$> bindDocs + in wrapBinds $ f $ docLines $ return <$> bindDocs ] -- let -- aaa = expra @@ -93,7 +94,7 @@ layoutStmt lstmt@(L _ stmt) = do $ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + (wrapBinds $ docSetBaseAndIndent $ docLines $ return <$> bindDocs) RecStmt epAnn (L _ stmts) _ _ _ _ _ -> docHandleComms epAnn $ runFilteredAlternative $ do -- rec stmt1 diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs index e7a7bc1..7d8ce6a 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/source/library/Language/Haskell/Brittany/Internal/Types.hs @@ -218,7 +218,8 @@ data Layouters = Layouters -> BriDocNumbered -> Maybe BriDocNumbered -> Either (GHC.LHsExpr GhcPs) [GHC.LGRHS GhcPs (GHC.LHsExpr GhcPs)] - -> ( Maybe + -> ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered + , Maybe ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered , [BriDocNumbered] ) @@ -228,7 +229,8 @@ data Layouters = Layouters , layout_localBinds :: GHC.HsLocalBindsLR GhcPs GhcPs -> ToBriDocM - ( Maybe + ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered + , Maybe ( ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered , [BriDocNumbered] ) diff --git a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs index dfd91b4..1153794 100644 --- a/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs +++ b/source/library/Language/Haskell/Brittany/Internal/WriteBriDoc/AlignmentAlgo.hs @@ -386,68 +386,68 @@ withAlloc lastFlag f = do return info briDocLineLength :: BriDoc -> Int -briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc +briDocLineLength briDoc = flip StateS.evalState False $ go briDoc -- the state encodes whether a separator was already -- appended at the current position. where - rec = \case + go = \case BDEmpty -> return $ 0 BDLit t -> StateS.put False $> Text.length t - BDSeq bds -> sum <$> rec `mapM` bds - BDCols _ bds -> sum <$> rec `mapM` bds + BDSeq bds -> sum <$> go `mapM` bds + BDCols _ bds -> sum <$> go `mapM` bds BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd - BDPar _ line _ -> rec line + BDAddBaseY _ bd -> go bd + BDBaseYPushCur bd -> go bd + BDIndentLevelPushCur bd -> go bd + BDIndentLevelPop bd -> go bd + BDPar _ line _ -> go line BDAlt{} -> error "briDocLineLength BDAlt" - BDForceAlt _ bd -> rec bd - BDForwardLineMode bd -> rec bd + BDForceAlt _ bd -> go bd + BDForwardLineMode bd -> go bd BDExternal _ t -> return $ Text.length t BDPlain t -> return $ Text.length t - BDQueueComments _ bd -> rec bd - BDFlushCommentsPrior _ bd -> rec bd - BDFlushCommentsPost _ _ bd -> rec bd + BDQueueComments _ bd -> go bd + BDFlushCommentsPrior _ bd -> go bd + BDFlushCommentsPost _ _ bd -> go bd BDLines ls@(_ : _) -> do x <- StateS.get - return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDEntryDelta _dp bd -> rec bd + return $ maximum $ ls <&> \l -> StateS.evalState (go l) x + BDEntryDelta _dp bd -> go bd BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDDebug _ bd -> rec bd + BDEnsureIndent _ bd -> go bd + BDDebug _ bd -> go bd briDocIsMultiLine :: BriDoc -> Bool -briDocIsMultiLine briDoc = rec briDoc +briDocIsMultiLine briDoc = go briDoc where - rec :: BriDoc -> Bool - rec = \case + go :: BriDoc -> Bool + go = \case BDEmpty -> False BDLit _ -> False - BDSeq bds -> any rec bds - BDCols _ bds -> any rec bds + BDSeq bds -> any go bds + BDCols _ bds -> any go bds BDSeparator -> False - BDAddBaseY _ bd -> rec bd - BDBaseYPushCur bd -> rec bd - BDIndentLevelPushCur bd -> rec bd - BDIndentLevelPop bd -> rec bd + BDAddBaseY _ bd -> go bd + BDBaseYPushCur bd -> go bd + BDIndentLevelPushCur bd -> go bd + BDIndentLevelPop bd -> go bd BDPar{} -> True BDAlt{} -> error "briDocIsMultiLine BDAlt" - BDForceAlt _ bd -> rec bd - BDForwardLineMode bd -> rec bd + BDForceAlt _ bd -> go bd + BDForwardLineMode bd -> go bd BDExternal _ t | [_] <- Text.lines t -> False BDExternal{} -> True BDPlain t | [_] <- Text.lines t -> False BDPlain _ -> True - BDQueueComments _ bd -> rec bd - BDFlushCommentsPrior _ bd -> rec bd - BDFlushCommentsPost _ _ bd -> rec bd - BDEntryDelta _dp bd -> rec bd + BDQueueComments _ bd -> go bd + BDFlushCommentsPrior _ bd -> go bd + BDFlushCommentsPost _ _ bd -> go bd + BDEntryDelta _dp bd -> go bd BDLines (_ : _ : _) -> True BDLines [_] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" - BDEnsureIndent _ bd -> rec bd - BDDebug _ bd -> rec bd + BDEnsureIndent _ bd -> go bd + BDDebug _ bd -> go bd briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo briDocToColInfo lastFlag = \case