Allow special layout for HsApp with HsDo/HsSpiceE args

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
+  <BLANKLINE>
+  let x = 13
+  <BLANKLINE>
+  y <- monadic
+  <BLANKLINE>
+  stmt (x + y)

data/15-regressions.blt

@@ -306,15 +306,14 @@ parserCompactLocation =
   [ try
     $ [ ParseRelAbs (Text.Read.read digits) _ _
       | digits <- many1 digit
-      , rel1 :: Maybe (Either Int (Ratio Int)) <-
+      , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe
-        optionMaybe
+        [ case divPart of
-          [ case divPart of
+            Nothing -> Left $ Text.Read.read digits
-              Nothing -> Left $ Text.Read.read digits
+            Just ddigits ->
-              Just ddigits ->
+              Right $ Text.Read.read digits % Text.Read.read ddigits
-                Right $ Text.Read.read digits % Text.Read.read ddigits
+        | digits  <- many1 digit
-          | digits  <- many1 digit
+        , divPart <- optionMaybe (string "/" *> many1 digit)
-          , divPart <- optionMaybe (string "/" *> many1 digit)
+        ]
-          ]
       ]
   ]
 
@@ -938,3 +937,22 @@ tzejubuVxairoy
   -- foo bar
   => CUR.Ozuzcak zub
   -> m ()
+
+#test allow par-spacing for HsApp HsDo
+func = other $ meep
+  do
+    abc
+    def
+  (some other very long linnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnne)
+
+#test allow par-spacing for HsApp HsDo
+func = other $ meep
+  [ x | x <- myList ]
+  (some other very long linnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnne)
+
+#test allow par-spacing for HsApp HsSpliceE
+{-# LANGUAGE QuasiQuotes #-}
+func = other $ meep
+  [q|hello
+     world|]
+  (some other very long linnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnne)

data/30-tests-context-free.blt

@@ -1252,15 +1252,14 @@ parserCompactLocation =
   [ try
     $ [ ParseRelAbs (Text.Read.read digits) _ _
       | digits <- many1 digit
-      , rel1 :: Maybe (Either Int (Ratio Int)) <-
+      , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe
-        optionMaybe
+        [ case divPart of
-          [ case divPart of
+            Nothing -> Left $ Text.Read.read digits
-              Nothing -> Left $ Text.Read.read digits
+            Just ddigits ->
-              Just ddigits ->
+              Right $ Text.Read.read digits % Text.Read.read ddigits
-                Right $ Text.Read.read digits % Text.Read.read ddigits
+        | digits <- many1 digit
-          | digits <- many1 digit
+        , divPart <- optionMaybe (string "/" *> many1 digit)
-          , divPart <- optionMaybe (string "/" *> many1 digit)
+        ]
-          ]
       ]
   ]
 

source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs

@@ -226,21 +226,28 @@ hasAnyCommentsBelow =
 hasCommentsBetween
   :: Data ast
   => ast
-  -> Maybe GHC.RealSrcLoc
+  -> Maybe GHC.RealSrcSpan
-  -> Maybe GHC.RealSrcLoc
+  -> Maybe GHC.RealSrcSpan
   -> Bool
 hasCommentsBetween ast left right = do
-  getAny $ SYB.everything
+  getAny
-    (<>)
+    $ SYB.everything
-    (SYB.mkQ
+      (<>)
-      (Any False)
+      (SYB.mkQ
-      (\(L (GHC.Anchor pos _) _ :: LEpaComment) -> Any
+        (Any False)
-        (  (maybe True (GHC.realSrcSpanStart pos >=) left)
+        (\(L (GHC.Anchor pos _) _ :: LEpaComment) -> Any
-        && (maybe True (GHC.realSrcSpanEnd pos <=) right)
+          (  ( 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

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

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

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

source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Expr.hs

@@ -194,6 +194,8 @@ layoutExpr lexpr@(L _ expr) = do
                 (_, L _ ExplicitTuple{}) -> True
                 (_, L _ ExplicitList{}) -> True
                 (_, L _ HsPar{}) -> True
+                (_, L _ HsDo{}) -> True
+                (_, L _ HsSpliceE{}) -> True
                 _ -> False
           let wrap = if all checkAllowPar paramEs then docSetParSpacing else id
           wrap $ docAddBaseY BrIndentRegular $ docPar
@@ -649,7 +651,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

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

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 "<BLANKLINE>"
+        , _ <- 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 "<BLANKLINE>"
-        , _ <- Parsec.eof
-        ]
       ]
     lineMapper :: Text -> InputLine
     lineMapper line = case Parsec.runParser specialLineParser () "" line of