Remove unnecessary indentation from list comprehensions

2024-07-07 09:26:22 +03:00 · 2024-06-02 16:05:28 -07:00 · 2024-06-02 16:05:28 -07:00 · 5c816dee59
commit 5c816dee59
parent 27ec3fba23
12 changed files with 157 additions and 122 deletions
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@ -6,6 +6,9 @@
 * Don't require a trailing newline in `.ormolu` files. [Issue
  1122](https://github.com/tweag/ormolu/issues/1122).

+* Remove unnecessary indentation from list comprehensions. [Issue
+  966](https://github.com/tweag/ormolu/issues/966).
+
 ## Ormolu 0.7.5.0

 * Switched to `ghc-lib-parser-9.10`, with the following new syntactic features/behaviors:
--- a/data/examples/declaration/value/function/comprehension/transform-monad-out.hs
+++ b/data/examples/declaration/value/function/comprehension/transform-monad-out.hs
@ -5,14 +5,14 @@ quux' xs ys =
  [ ( x,
      y
    )
-    | x <- xs,
-      y <- ys,
-      then group by
-        -- First comment
-        ( x
-            + y
-        )
-      using
-        -- Second comment
-        groupWith -- Third comment
+  | x <- xs,
+    y <- ys,
+    then group by
+      -- First comment
+      ( x
+          + y
+      )
+    using
+      -- Second comment
+      groupWith -- Third comment
  ]
--- a/data/examples/declaration/value/function/comprehension/transform-multi-line1-out.hs
+++ b/data/examples/declaration/value/function/comprehension/transform-multi-line1-out.hs
@ -4,9 +4,9 @@ foo' xs ys =
  [ ( x,
      y
    )
-    | x <- xs,
-      y <- ys,
-      then
-        -- First comment
-        reverse -- Second comment
+  | x <- xs,
+    y <- ys,
+    then
+      -- First comment
+      reverse -- Second comment
  ]
--- a/data/examples/declaration/value/function/comprehension/transform-multi-line2-out.hs
+++ b/data/examples/declaration/value/function/comprehension/transform-multi-line2-out.hs
@ -4,13 +4,13 @@ bar' xs ys =
  [ ( x,
      y
    )
-    | x <- xs,
-      y <- ys,
-      then
-        -- First comment
-        sortWith
-      by
-        ( x
-            + y -- Second comment
-        )
+  | x <- xs,
+    y <- ys,
+    then
+      -- First comment
+      sortWith
+    by
+      ( x
+          + y -- Second comment
+      )
  ]
--- a/data/examples/declaration/value/function/comprehension/transform-multi-line3-out.hs
+++ b/data/examples/declaration/value/function/comprehension/transform-multi-line3-out.hs
@ -4,9 +4,9 @@ baz' xs ys =
  [ ( x,
      y
    )
-    | x <- xs,
-      y <- ys,
-      then group using
-        -- First comment
-        permutations -- Second comment
+  | x <- xs,
+    y <- ys,
+    then group using
+      -- First comment
+      permutations -- Second comment
  ]
--- a/data/examples/declaration/value/function/comprehension/transform-multi-line4-out.hs
+++ b/data/examples/declaration/value/function/comprehension/transform-multi-line4-out.hs
@ -4,14 +4,14 @@ quux' xs ys =
  [ ( x,
      y
    )
-    | x <- xs,
-      y <- ys,
-      then group by
-        -- First comment
-        ( x
-            + y
-        )
-      using
-        -- Second comment
-        groupWith -- Third comment
+  | x <- xs,
+    y <- ys,
+    then group by
+      -- First comment
+      ( x
+          + y
+      )
+    using
+      -- Second comment
+      groupWith -- Third comment
  ]
--- a/data/examples/declaration/value/function/list-comprehensions-out.hs
+++ b/data/examples/declaration/value/function/list-comprehensions-out.hs
@ -4,35 +4,40 @@ bar x y = [(a, b) | a <- x, even a, b <- y, a != b]

 barbaz x y z w =
  [ (a, b, c, d) -- Foo
-    | a <-
-        x, -- Bar
-      b <- y, -- Baz
-      any even [a, b],
-      c <-
-        z
-          * z ^ 2, -- Bar baz
-      d <-
-        w
-          + w, -- Baz bar
-      all
-        even
-        [ a,
-          b,
-          c,
-          d
-        ]
+  | a <-
+      x, -- Bar
+    b <- y, -- Baz
+    any even [a, b],
+    c <-
+      z
+        * z ^ 2, -- Bar baz
+    d <-
+      w
+        + w, -- Baz bar
+    all
+      even
+      [ a,
+        b,
+        c,
+        d
+      ]
  ]

 a = do
+  d <-
+    [ x + 1
+    | x <- b
+    ]
+
  [ c
    | c <- d
    ]

 trans =
  [ x
-    | x <- xs,
-      then
-        reverse,
-      then
-        reverse
+  | x <- xs,
+    then
+      reverse,
+    then
+      reverse
  ]
--- a/data/examples/declaration/value/function/list-comprehensions.hs
+++ b/data/examples/declaration/value/function/list-comprehensions.hs
@ -22,6 +22,11 @@ barbaz x y z w = [
  ]

 a = do
+  d <-
+    [ x + 1
+      | x <- b
+        ]
+
  [ c
      | c <- d ]

--- a/data/examples/declaration/value/function/parallel-comprehensions-complex-out.hs
+++ b/data/examples/declaration/value/function/parallel-comprehensions-complex-out.hs
@ -10,26 +10,26 @@ baz x y z w =
      i,
      j
    )
-    | a <- -- Foo 1
-        x, -- Foo 2
-      b <- -- Bar 1
-        y, -- Bar 2
+  | a <- -- Foo 1
+      x, -- Foo 2
+    b <- -- Bar 1
+      y, -- Bar 2
+    a
+      `mod` b -- Value
+      == 0
+  | c <- -- Baz 1
+      z
+        * z -- Baz 2
+        -- Baz 3
+  | d <- w -- Other
+  | e <- x * x -- Foo bar
+  | f <- -- Foo baz 1
+      y + y -- Foo baz 2
+  | h <- z + z * w ^ 2 -- Bar foo
+  | i <- -- Bar bar 1
      a
-        `mod` b -- Value
-        == 0
-    | c <- -- Baz 1
-        z
-          * z -- Baz 2
-          -- Baz 3
-    | d <- w -- Other
-    | e <- x * x -- Foo bar
-    | f <- -- Foo baz 1
-        y + y -- Foo baz 2
-    | h <- z + z * w ^ 2 -- Bar foo
-    | i <- -- Bar bar 1
-        a
-          + b, -- Bar bar 2
-          -- Bar bar 3
-      j <- -- Bar baz 1
-        a + b -- Bar baz 2
+        + b, -- Bar bar 2
+        -- Bar bar 3
+    j <- -- Bar baz 1
+      a + b -- Bar baz 2
  ]
--- a/expected-failures/hlint.txt
+++ b/expected-failures/hlint.txt
@ -14,8 +14,8 @@ src/Extension.hs
  Please, consider reporting the bug.
 src/Hint/Bracket.hs
@@ -265,8 +265,11 @@
-                 let y = noLocA $ HsApp EpAnnNotUsed a1 (nlHsPar a2),
-                 let r = Replace Expr (toSSA e) [("a", toSSA a1), ("b", toSSA a2)] "a (b)"
+               let y = noLocA $ HsApp EpAnnNotUsed a1 (nlHsPar a2),
+               let r = Replace Expr (toSSA e) [("a", toSSA a1), ("b", toSSA a2)] "a (b)"
             ]
 -         ++ [ (suggest "Redundant bracket" (reLoc x) (reLoc y) [r]) {ideaSpan -- Special case of (v1 . v2) <$> v3
 -                                                                     = locA locPar}
@ -24,9 +24,9 @@ src/Hint/Bracket.hs
 +                  =
 +                    locA locPar
 +                }
-               | L _ (OpApp _ (L locPar (HsPar _ _ o1@(L locNoPar (OpApp _ _ (isDot -> True) _)) _)) o2 v3) <- [x],
-                 varToStr o2 == "<$>",
-                 let y = noLocA (OpApp EpAnnNotUsed o1 o2 v3) :: LHsExpr GhcPs,
+             | L _ (OpApp _ (L locPar (HsPar _ _ o1@(L locNoPar (OpApp _ _ (isDot -> True) _)) _)) o2 v3) <- [x],
+               varToStr o2 == "<$>",
+               let y = noLocA (OpApp EpAnnNotUsed o1 o2 v3) :: LHsExpr GhcPs,

  Formatting is not idempotent.
  Please, consider reporting the bug.
--- a/src/Ormolu/Printer/Meat/Declaration/Data.hs
+++ b/src/Ormolu/Printer/Meat/Declaration/Data.hs
@ -239,8 +239,8 @@ p_conDecl singleRecCon ConDeclH98 {..} =

    conNameWithContextSpn =
      [ RealSrcSpan real Strict.Nothing
-        | EpaSpan (RealSrcSpan real _) <-
-            mapMaybe (matchAddEpAnn AnnForall) con_ext
+      | EpaSpan (RealSrcSpan real _) <-
+          mapMaybe (matchAddEpAnn AnnForall) con_ext
      ]
        <> fmap getLocA con_ex_tvs
        <> maybeToList (fmap getLocA con_mb_cxt)
--- a/src/Ormolu/Printer/Meat/Declaration/Value.hs
+++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs
@ -382,7 +382,7 @@ p_hsCmd' isApp s = \case
    p_let p_hsCmd localBinds c
  HsCmdDo _ es -> do
    txt "do"
-    p_stmts isApp cmdPlacement (p_hsCmd' NotApplicand S) es
+    p_stmts S isApp cmdPlacement (p_hsCmd' NotApplicand) es

 -- | Print a top-level command.
 p_hsCmdTop :: BracketStyle -> HsCmdTop GhcPs -> R ()
@ -418,21 +418,22 @@ withSpacing f l = located l $ \x -> do
        _ -> setSpanMark (StatementSpan currentSpn)

 p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
-p_stmt = p_stmt' exprPlacement p_hsExpr
+p_stmt = p_stmt' N exprPlacement (p_hsExpr' NotApplicand)

 p_stmt' ::
  ( Anno (Stmt GhcPs (LocatedA body)) ~ SrcSpanAnnA,
    Anno [LocatedA (Stmt GhcPs (LocatedA body))] ~ SrcSpanAnnL
  ) =>
+  BracketStyle ->
  -- | Placer
  (body -> Placement) ->
  -- | Render
-  (body -> R ()) ->
+  (BracketStyle -> body -> R ()) ->
  -- | Statement to render
  Stmt GhcPs (LocatedA body) ->
  R ()
-p_stmt' placer render = \case
-  LastStmt _ body _ _ -> located body render
+p_stmt' s placer render = \case
+  LastStmt _ body _ _ -> located body (render s)
  BindStmt _ p f@(getLocA -> l) -> do
    located p p_pat
    space
@ -442,9 +443,9 @@ p_stmt' placer render = \case
          | isOneLineSpan (mkSrcSpan (srcSpanEnd loc) (srcSpanStart l)) = placer (unLoc f)
          | otherwise = Normal
    switchLayout [loc, l] $
-      placeHanging placement (located f render)
+      placeHanging placement (located f (render N))
  ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer
-  BodyStmt _ body _ _ -> located body render
+  BodyStmt _ body _ _ -> located body (render s)
  LetStmt _ binds -> do
    txt "let"
    space
@ -486,25 +487,26 @@ p_stmt' placer render = \case
  RecStmt {..} -> do
    txt "rec"
    space
-    sitcc . located recS_stmts $ sepSemi (withSpacing (p_stmt' placer render))
+    sitcc . located recS_stmts $ sepSemi (withSpacing (p_stmt' s placer render))

 p_stmts ::
  ( Anno (Stmt GhcPs (LocatedA body)) ~ SrcSpanAnnA,
    Anno [LocatedA (Stmt GhcPs (LocatedA body))] ~ SrcSpanAnnL
  ) =>
+  BracketStyle ->
  IsApplicand ->
  -- | Placer
  (body -> Placement) ->
  -- | Render
-  (body -> R ()) ->
+  (BracketStyle -> body -> R ()) ->
  -- | Statements to render
  LocatedL [LocatedA (Stmt GhcPs (LocatedA body))] ->
  R ()
-p_stmts isApp placer render es = do
+p_stmts s isApp placer render es = do
  breakpoint
  ub <- layoutToBraces <$> getLayout
  let p_stmtExt (relPos, stmt) =
-        ub' $ withSpacing (p_stmt' placer render) stmt
+        ub' $ withSpacing (p_stmt' s placer render) stmt
        where
          -- We need to set brace usage information for all but the last
          -- statement (e.g.in the case of nested do blocks).
@ -743,30 +745,12 @@ p_hsExpr' isApp s = \case
    let doBody moduleName header = do
          forM_ moduleName $ \m -> atom m *> txt "."
          txt header
-          p_stmts isApp exprPlacement (p_hsExpr' NotApplicand S) es
-        compBody = brackets s . located es $ \xs -> do
-          let p_parBody =
-                sep
-                  (breakpoint >> txt "|" >> space)
-                  p_seqBody
-              p_seqBody =
-                sitcc
-                  . sep
-                    commaDel
-                    (located' (sitcc . p_stmt))
-              stmts = init xs
-              yield = last xs
-              lists = gatherStmts stmts
-          located yield p_stmt
-          breakpoint
-          txt "|"
-          space
-          p_parBody lists
+          p_stmts S isApp exprPlacement (p_hsExpr' NotApplicand) es
    case doFlavor of
      DoExpr moduleName -> doBody moduleName "do"
      MDoExpr moduleName -> doBody moduleName "mdo"
-      ListComp -> compBody
-      MonadComp -> compBody
+      ListComp -> p_listComp s es
+      MonadComp -> p_listComp s es
      GhciStmtCtxt -> notImplemented "GhciStmtCtxt"
  ExplicitList _ xs ->
    brackets s $
@ -867,6 +851,44 @@ p_hsExpr' isApp s = \case
    space
    located hswc_body p_hsType

+-- | Print a list comprehension.
+--
+-- BracketStyle should be N except in a do-block, which must be S or else it's a parse error.
+p_listComp :: BracketStyle -> GenLocated SrcSpanAnnL [ExprLStmt GhcPs] -> R ()
+p_listComp s es = sitcc (vlayout singleLine multiLine)
+  where
+    singleLine = do
+      txt "["
+      body
+      txt "]"
+    multiLine = do
+      txt "[" >> space
+      (if s == S then sitcc else id) $ do
+        body
+        newline
+        txt "]"
+
+    body = located es p_body
+    p_body xs = do
+      let (stmts, yield) =
+            -- TODO: use unsnoc when require GHC 9.8+
+            case xs of
+              [] -> error $ "list comprehension unexpectedly had no expressions"
+              _ -> (init xs, last xs)
+      sitcc $ located yield p_stmt
+      breakpoint
+      txt "|"
+      space
+      p_bodyParallels (gatherStmts stmts)
+
+    -- print the list of list comprehension sections, e.g.
+    -- [ "| x <- xs, y <- ys, let z = x <> y", "| a <- f z" ]
+    p_bodyParallels = sep (breakpoint >> txt "|" >> space) (sitcc . p_bodyParallelStmts)
+
+    -- print a list comprehension section within a pipe, e.g.
+    -- [ "x <- xs", "y <- ys", "let z = x <> y" ]
+    p_bodyParallelStmts = sep commaDel (located' (sitcc . p_stmt))
+
 -- | Gather the set of statements in a list comprehension.
 --
 -- For example, this code:
@ -927,7 +949,7 @@ gatherStmts = \case
  -- will be ParStmt.
  [L _ (ParStmt _ blocks _ _)] ->
    [ concatMap collectNonParStmts stmts
-      | ParStmtBlock _ stmts _ _ <- blocks
+    | ParStmtBlock _ stmts _ _ <- blocks
    ]
  -- Otherwise, list will not contain any ParStmt
  stmts ->