Remove unnecessary indentation from list comprehensions

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:

data/examples/declaration/value/function/comprehension/transform-monad-out.hs

@@ -5,14 +5,14 @@ quux' xs ys =
   [ ( x,
       y
     )
-    | x <- xs,
+  | x <- xs,
-      y <- ys,
+    y <- ys,
-      then group by
+    then group by
-        -- First comment
+      -- First comment
-        ( x
+      ( x
-            + y
+          + y
-        )
+      )
-      using
+    using
-        -- Second comment
+      -- Second comment
-        groupWith -- Third comment
+      groupWith -- Third comment
   ]

data/examples/declaration/value/function/comprehension/transform-multi-line1-out.hs

@@ -4,9 +4,9 @@ foo' xs ys =
   [ ( x,
       y
     )
-    | x <- xs,
+  | x <- xs,
-      y <- ys,
+    y <- ys,
-      then
+    then
-        -- First comment
+      -- First comment
-        reverse -- Second comment
+      reverse -- Second comment
   ]

data/examples/declaration/value/function/comprehension/transform-multi-line2-out.hs

@@ -4,13 +4,13 @@ bar' xs ys =
   [ ( x,
       y
     )
-    | x <- xs,
+  | x <- xs,
-      y <- ys,
+    y <- ys,
-      then
+    then
-        -- First comment
+      -- First comment
-        sortWith
+      sortWith
-      by
+    by
-        ( x
+      ( x
-            + y -- Second comment
+          + y -- Second comment
-        )
+      )
   ]

data/examples/declaration/value/function/comprehension/transform-multi-line3-out.hs

@@ -4,9 +4,9 @@ baz' xs ys =
   [ ( x,
       y
     )
-    | x <- xs,
+  | x <- xs,
-      y <- ys,
+    y <- ys,
-      then group using
+    then group using
-        -- First comment
+      -- First comment
-        permutations -- Second comment
+      permutations -- Second comment
   ]

data/examples/declaration/value/function/comprehension/transform-multi-line4-out.hs

@@ -4,14 +4,14 @@ quux' xs ys =
   [ ( x,
       y
     )
-    | x <- xs,
+  | x <- xs,
-      y <- ys,
+    y <- ys,
-      then group by
+    then group by
-        -- First comment
+      -- First comment
-        ( x
+      ( x
-            + y
+          + y
-        )
+      )
-      using
+    using
-        -- Second comment
+      -- Second comment
-        groupWith -- Third comment
+      groupWith -- Third comment
   ]

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 <-
+  | a <-
-        x, -- Bar
+      x, -- Bar
-      b <- y, -- Baz
+    b <- y, -- Baz
-      any even [a, b],
+    any even [a, b],
-      c <-
+    c <-
-        z
+      z
-          * z ^ 2, -- Bar baz
+        * z ^ 2, -- Bar baz
-      d <-
+    d <-
-        w
+      w
-          + w, -- Baz bar
+        + w, -- Baz bar
-      all
+    all
-        even
+      even
-        [ a,
+      [ a,
-          b,
+        b,
-          c,
+        c,
-          d
+        d
-        ]
+      ]
   ]
 
 a = do
+  d <-
+    [ x + 1
+    | x <- b
+    ]
+
   [ c
     | c <- d
     ]
 
 trans =
   [ x
-    | x <- xs,
+  | x <- xs,
-      then
+    then
-        reverse,
+      reverse,
-      then
+    then
-        reverse
+      reverse
   ]

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 ]
 

data/examples/declaration/value/function/parallel-comprehensions-complex-out.hs

@@ -10,26 +10,26 @@ baz x y z w =
       i,
       j
     )
-    | a <- -- Foo 1
+  | a <- -- Foo 1
-        x, -- Foo 2
+      x, -- Foo 2
-      b <- -- Bar 1
+    b <- -- Bar 1
-        y, -- Bar 2
+      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
+        + b, -- Bar bar 2
-        == 0
+        -- Bar bar 3
-    | c <- -- Baz 1
+    j <- -- Bar baz 1
-        z
+      a + b -- Bar baz 2
-          * 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
   ]

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 y = noLocA $ HsApp EpAnnNotUsed a1 (nlHsPar a2),
-                 let r = Replace Expr (toSSA e) [("a", toSSA a1), ("b", toSSA a2)] "a (b)"
+               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],
+             | L _ (OpApp _ (L locPar (HsPar _ _ o1@(L locNoPar (OpApp _ _ (isDot -> True) _)) _)) o2 v3) <- [x],
-                 varToStr o2 == "<$>",
+               varToStr o2 == "<$>",
-                 let y = noLocA (OpApp EpAnnNotUsed o1 o2 v3) :: LHsExpr GhcPs,
+               let y = noLocA (OpApp EpAnnNotUsed o1 o2 v3) :: LHsExpr GhcPs,
 
   Formatting is not idempotent.
   Please, consider reporting the bug.

src/Ormolu/Printer/Meat/Declaration/Data.hs

@@ -239,8 +239,8 @@ p_conDecl singleRecCon ConDeclH98 {..} =
 
     conNameWithContextSpn =
       [ RealSrcSpan real Strict.Nothing
-        | EpaSpan (RealSrcSpan real _) <-
+      | EpaSpan (RealSrcSpan real _) <-
-            mapMaybe (matchAddEpAnn AnnForall) con_ext
+          mapMaybe (matchAddEpAnn AnnForall) con_ext
       ]
         <> fmap getLocA con_ex_tvs
         <> maybeToList (fmap getLocA con_mb_cxt)

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
+p_stmt' s placer render = \case
-  LastStmt _ body _ _ -> located body render
+  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
+          p_stmts S isApp exprPlacement (p_hsExpr' NotApplicand) 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
     case doFlavor of
       DoExpr moduleName -> doBody moduleName "do"
       MDoExpr moduleName -> doBody moduleName "mdo"
-      ListComp -> compBody
+      ListComp -> p_listComp s es
-      MonadComp -> compBody
+      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 ->