Fix comments moving after "where"

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

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]
            )
@@ -212,18 +213,18 @@ layoutLocalBinds binds = case binds of
           [ 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
+    ds <- 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)
+    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
+    ds <- mapM layoutIPBind bb
-    pure $ Just (id, ds) -- TODO92 do we need to replace id?
+    pure $ (docHandleComms epAnn, Just (id, ds)) -- TODO92 do we need to replace id?
-  EmptyLocalBinds NoExtField -> return $ Nothing
+  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

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
+              , docAddBaseY BrIndentRegular $ docPar
-                $ docPar (letDoc) (docSetBaseAndIndent $ pure bindDoc)
+                  (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

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

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]
              )

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
+    BDSeq bds -> sum <$> go `mapM` bds
-    BDCols _ bds -> sum <$> rec `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
+    BDAddBaseY _ bd -> go bd
-    BDBaseYPushCur bd -> rec bd
+    BDBaseYPushCur bd -> go bd
-    BDIndentLevelPushCur bd -> rec bd
+    BDIndentLevelPushCur bd -> go bd
-    BDIndentLevelPop bd -> rec bd
+    BDIndentLevelPop bd -> go bd
-    BDPar _ line _ -> rec line
+    BDPar _ line _ -> go line
     BDAlt{} -> error "briDocLineLength BDAlt"
-    BDForceAlt _ bd -> rec bd
+    BDForceAlt _ bd -> go bd
-    BDForwardLineMode bd -> rec bd
+    BDForwardLineMode bd -> go bd
     BDExternal _ t -> return $ Text.length t
     BDPlain t -> return $ Text.length t
-    BDQueueComments _ bd -> rec bd
+    BDQueueComments _ bd -> go bd
-    BDFlushCommentsPrior _ bd -> rec bd
+    BDFlushCommentsPrior _ bd -> go bd
-    BDFlushCommentsPost _ _ bd -> rec bd
+    BDFlushCommentsPost _ _ bd -> go bd
     BDLines ls@(_ : _) -> do
       x <- StateS.get
-      return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
+      return $ maximum $ ls <&> \l -> StateS.evalState (go l) x
-    BDEntryDelta _dp bd -> rec bd
+    BDEntryDelta _dp bd -> go bd
     BDLines [] -> error "briDocLineLength BDLines []"
-    BDEnsureIndent _ bd -> rec bd
+    BDEnsureIndent _ bd -> go bd
-    BDDebug _ bd -> rec bd
+    BDDebug _ bd -> go bd
 
 briDocIsMultiLine :: BriDoc -> Bool
-briDocIsMultiLine briDoc = rec briDoc
+briDocIsMultiLine briDoc = go briDoc
  where
-  rec :: BriDoc -> Bool
+  go :: BriDoc -> Bool
-  rec = \case
+  go = \case
     BDEmpty -> False
     BDLit _ -> False
-    BDSeq bds -> any rec bds
+    BDSeq bds -> any go bds
-    BDCols _ bds -> any rec bds
+    BDCols _ bds -> any go bds
     BDSeparator -> False
-    BDAddBaseY _ bd -> rec bd
+    BDAddBaseY _ bd -> go bd
-    BDBaseYPushCur bd -> rec bd
+    BDBaseYPushCur bd -> go bd
-    BDIndentLevelPushCur bd -> rec bd
+    BDIndentLevelPushCur bd -> go bd
-    BDIndentLevelPop bd -> rec bd
+    BDIndentLevelPop bd -> go bd
     BDPar{} -> True
     BDAlt{} -> error "briDocIsMultiLine BDAlt"
-    BDForceAlt _ bd -> rec bd
+    BDForceAlt _ bd -> go bd
-    BDForwardLineMode bd -> rec 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
+    BDQueueComments _ bd -> go bd
-    BDFlushCommentsPrior _ bd -> rec bd
+    BDFlushCommentsPrior _ bd -> go bd
-    BDFlushCommentsPost _ _ bd -> rec bd
+    BDFlushCommentsPost _ _ bd -> go bd
-    BDEntryDelta _dp bd -> rec bd
+    BDEntryDelta _dp bd -> go bd
     BDLines (_ : _ : _) -> True
     BDLines [_] -> False
     BDLines [] -> error "briDocIsMultiLine BDLines []"
-    BDEnsureIndent _ bd -> rec bd
+    BDEnsureIndent _ bd -> go bd
-    BDDebug _ bd -> rec bd
+    BDDebug _ bd -> go bd
 
 briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
 briDocToColInfo lastFlag = \case