Fix layouting for OpApps with comments (fixes 159)

src-literatetests/15-regressions.blt

@@ -630,3 +630,10 @@ dsfnjKeekbwwbosbOfakxqRsiyix cnehokzozwbVaguvu migbnaRwutbz =
         xoheccewfWoeyiagOkfodiq sEmo quc = case migbnaRwutbz of
             Afogmf -> xgeqe (OfBkkuih quc) (Ciitog quc) sEmo
     in QabqyilexuiNizzhsQuxxac migbnaRwutbz (hwaTihhjt lhowvscIiozgqe)
+
+#test issue 159
+spec = do
+  it "creates a snapshot at the given level" . withGraph runDB $ do
+    lift $ do
+      studentDiagnosticReadingLevel updatedStudent `shouldBe` Just 10 -- x
+      elaSnapshotReadingLevel snapshot `shouldBe` 12

src/Language/Haskell/Brittany/Internal/LayouterBasics.hs

@@ -57,6 +57,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
   , allocateNode
   , docSharedWrapper
   , hasAnyCommentsBelow
+  , hasAnyCommentsConnected
   , hasAnnKeyword
   )
 where
@@ -266,6 +267,9 @@ filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
 filterAnns ast =
   Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
 
+-- | True if there are any comments that are
+-- a) connected to any node below (in AST sense) the given node AND
+-- b) after (in source code order) the node.
 hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
 hasAnyCommentsBelow ast@(L l _) = do
   anns <- filterAnns ast <$> mAsk
@@ -275,6 +279,18 @@ hasAnyCommentsBelow ast@(L l _) = do
     $ Map.elems
     $ anns
 
+-- | True if there are any comments that are
+-- connected to any node below (in AST sense) the given node
+hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
+hasAnyCommentsConnected ast = do
+  anns <- filterAnns ast <$> mAsk
+  return
+    $ not
+    $ null
+    $ (=<<) extractAllComments
+    $ Map.elems
+    $ anns
+
 hasAnnKeyword
   :: (Data a, MonadMultiReader (Map AnnKey Annotation) m)
   => Located a

src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs

@@ -236,14 +236,21 @@ layoutExpr lexpr@(L _ expr) = do
                                               ]
       opLastDoc   <- docSharedWrapper layoutExpr expOp
       expLastDoc  <- docSharedWrapper layoutExpr expRight
-      hasComments <- hasAnyCommentsBelow lexpr
+      allowSinglelinePar <- do
+        hasComLeft <- hasAnyCommentsConnected expLeft
+        hasComOp   <- hasAnyCommentsConnected expOp
+        pure $ not hasComLeft && not hasComOp
       let allowPar = case (expOp, expRight) of
             (L _ (HsVar (L _ (Unqual occname))), _)
               | occNameString occname == "$" -> True
             (_, L _ (HsApp _ (L _ HsVar{}))) -> False
             _ -> True
       runFilteredAlternative $ do
-        addAlternativeCond (not hasComments)
+        -- > one + two + three
+        -- or
+        -- > one + two + case x of
+        -- >   _ -> three
+        addAlternativeCond allowSinglelinePar
           $ docSeq
           [ appSep $ docForceSingleline leftOperandDoc
           , docSeq
@@ -265,6 +272,9 @@ layoutExpr lexpr@(L _ expr) = do
         --      $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])
         --       ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]
         --     )
+        -- > one
+        -- >   + two
+        -- >   + three
         addAlternative $
           docPar
             leftOperandDoc
@@ -300,7 +310,10 @@ layoutExpr lexpr@(L _ expr) = do
         addAlternative
           $ docAddBaseY BrIndentRegular
           $ docPar
-              expDocLeft
+              expDocLeft -- TODO: this is not forced to single-line, which has
+                         -- certain.. interesting consequences.
+                         -- At least, the "two-line" label is not entirely
+                         -- accurate.
               ( docForceSingleline
               $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]
               )
@@ -773,7 +786,7 @@ layoutExpr lexpr@(L _ expr) = do
             [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
             , docLit $ Text.pack "}"
             ]
-      docAlt
+      docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free
         [  docSeq
         $  [docNodeAnnKW lexpr Nothing nameDoc, docSeparator]
         ++ line1 docForceSingleline
@@ -829,7 +842,7 @@ layoutExpr lexpr@(L _ expr) = do
             [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty
             , docLit $ Text.pack "}"
             ]
-      docAlt
+      docAlt -- TODO: make this addFilteredAlternative and a hanging layout when Free
         [  docSeq
         $  [docNodeAnnKW lexpr Nothing nameDoc, docSeparator]
         ++ line1 docForceSingleline

src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs

@@ -440,7 +440,11 @@ getSpacing !bridoc = rec bridoc
       BDFPar{} -> error "BDPar with indent in getSpacing"
       BDFAlt [] -> error "empty BDAlt"
       BDFAlt (alt:_) -> rec alt
-      BDFForceMultiline  bd -> rec bd
+      BDFForceMultiline  bd -> do
+        mVs <- rec bd
+        return $ mVs >>= _vs_paragraph .> \case
+          VerticalSpacingParNone -> LineModeInvalid
+          _  -> mVs
       BDFForceSingleline bd -> do
         mVs <- rec bd
         return $ mVs >>= _vs_paragraph .> \case
@@ -686,7 +690,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
         BDFAlt alts -> do
           r <- rec `mapM` alts
           return $ filterAndLimit =<< r
-        BDFForceMultiline  bd -> rec bd
+        BDFForceMultiline  bd -> do
+          mVs <- filterAndLimit <$> rec bd
+          return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs
         BDFForceSingleline bd -> do
           mVs <- filterAndLimit <$> rec bd
           return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs