ormolu 0.7.5.0 → 0.7.6.0

raw patch · 27 files changed

+525/−254 lines, 27 filesdep +choicePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: choice

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• data/examples/declaration/data/infix-haddocks-out.hs +51/−0
• data/examples/declaration/data/infix-haddocks.hs +43/−0
• data/examples/declaration/value/function/comprehension/transform-monad-out.hs +10/−10
• data/examples/declaration/value/function/comprehension/transform-multi-line1-out.hs +5/−5
• data/examples/declaration/value/function/comprehension/transform-multi-line2-out.hs +9/−9
• data/examples/declaration/value/function/comprehension/transform-multi-line3-out.hs +5/−5
• data/examples/declaration/value/function/comprehension/transform-multi-line4-out.hs +10/−10
• data/examples/declaration/value/function/list-comprehensions-out.hs +31/−17
• data/examples/declaration/value/function/list-comprehensions.hs +12/−0
• data/examples/declaration/value/function/parallel-comprehensions-complex-out.hs +21/−21
• ormolu.cabal +3/−1
• src/Ormolu/Fixity/Internal.hs +5/−2
• src/Ormolu/Fixity/Parser.hs +2/−6
• src/Ormolu/Printer/Internal.hs +5/−2
• src/Ormolu/Printer/Meat/Common.hs +5/−2
• src/Ormolu/Printer/Meat/Declaration.hs +6/−4
• src/Ormolu/Printer/Meat/Declaration/Data.hs +125/−95
• src/Ormolu/Printer/Meat/Declaration/Value.hs +130/−53
• src/Ormolu/Printer/Meat/ImportExport.hs +6/−3
• src/Ormolu/Printer/Meat/Module.hs +4/−1
• src/Ormolu/Printer/Meat/Type.hs +5/−2
• src/Ormolu/Printer/Operators.hs +4/−2
• tests/Ormolu/CabalInfoSpec.hs +2/−2
• tests/Ormolu/Fixity/ParserSpec.hs +7/−0
• tests/Ormolu/FixitySpec.hs +4/−1
• tests/Ormolu/OpTreeSpec.hs +4/−1

@@ -1,3 +1,14 @@+## Ormolu 0.7.6.0++* Fix Haddock comments on infix constructors+  [Issue 758](https://github.com/tweag/ormolu/issues/758).++* 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:

@@ -0,0 +1,51 @@+{- https://github.com/tweag/ormolu/issues/758 -}++data A+  = -- | Docs for :#+    A :# A++data WithDocs+  = forall left right.+    (Show left) =>+    -- | Docs for left arg+    left+      -- | Docs for op+      :*:+      -- | Docs for right arg+      right++data MixedDocs+  = forall left right.+    (Show left) =>+    left -- ^ before+      :*:+      -- | after+      right++data DocPartial+  = Left -- ^ left docs+    -- on multiple+    -- lines+      :*:+      Right+  | -- | op+    Left+      :*:+      Right+  | Left+      :*:+      -- | right+      Right+  | -- | op+    Left+      :*:+      Right+  | -- | op+    Left+      :*:+      Right++data NoDocs+  = Left+      :*:+      Right

@@ -0,0 +1,43 @@+{- https://github.com/tweag/ormolu/issues/758 -}++data A = A :# A -- ^ Docs for :#++data WithDocs+  = forall left right.+    Show left =>+    left -- ^ Docs for left arg+    :*: -- ^ Docs for op+    right -- ^ Docs for right arg++data MixedDocs+  -- | before+  = forall left right.+    Show left =>+    left :*: right+  -- ^ after++data DocPartial+  = Left -- ^ left docs+         -- on multiple+         -- lines+      :*: Right+  | Left+      :*: -- ^ op+      Right+  | Left+      :*:+      -- | right+      Right+  | -- | op+    Left+      :*:+      Right+  | Left+      :*:+      Right+    -- ^ op++data NoDocs+  = Left+    :*:+    Right

@@ -5,14 +5,14 @@   [ ( 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   ]

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

@@ -4,13 +4,13 @@   [ ( 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+      )   ]

@@ -4,9 +4,9 @@   [ ( 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   ]

@@ -4,14 +4,14 @@   [ ( 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   ]

@@ -4,26 +4,40 @@  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+  ]

@@ -22,5 +22,17 @@   ]  a = do+  d <-+    [ x + 1+      | x <- b+        ]+   [ c       | c <- d ]++trans =+  [ x+  | x <- xs+  , then reverse+  , then reverse+  ]

@@ -10,26 +10,26 @@       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   ]

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               ormolu-version:            0.7.5.0+version:            0.7.6.0 license:            BSD-3-Clause license-file:       LICENSE.md maintainer:         Mark Karpov <mark.karpov@tweag.io>@@ -105,6 +105,7 @@         base >=4.14 && <5,         binary >=0.8 && <0.9,         bytestring >=0.2 && <0.13,+        choice >=0.2.4.1 && <0.3,         containers >=0.5 && <0.8,         deepseq >=1.4 && <1.6,         directory ^>=1.3,@@ -175,6 +176,7 @@         Cabal-syntax >=3.12 && <3.13,         QuickCheck >=2.14,         base >=4.14 && <5,+        choice >=0.2.4.1 && <0.3,         containers >=0.5 && <0.8,         directory ^>=1.3,         filepath >=1.2 && <1.6,

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-}@@ -33,6 +34,8 @@ import Data.Binary (Binary) import Data.ByteString.Short (ShortByteString) import Data.ByteString.Short qualified as SBS+import Data.Choice (Choice)+import Data.Choice qualified as Choice import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map)@@ -259,7 +262,7 @@ -- | Get a 'FixityApproximation' of an operator. inferFixity ::   -- | Whether to print debug info regarding fixity inference-  Bool ->+  Choice "debug" ->   -- | Operator name   RdrName ->   -- | Module fixity map@@ -267,7 +270,7 @@   -- | The resulting fixity approximation   FixityApproximation inferFixity debug rdrName (ModuleFixityMap m) =-  if debug+  if Choice.isTrue debug     then       trace         (renderFixityJustification opName moduleName m result)

@@ -90,14 +90,10 @@     (FixityOverrides . Map.fromList . mconcat)     (ModuleReexports . Map.map NE.sort . Map.fromListWith (<>))     . partitionEithers-    <$> many configLine+    <$> (configLine `sepEndBy` (void eol *> hidden space))     <* eof   where-    configLine = do-      x <- eitherP pFixity pModuleReexport-      void eol-      hidden space-      return x+    configLine = eitherP pFixity pModuleReexport  -- | Parse a single fixity declaration, such as --

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -59,6 +60,8 @@ import Control.Monad.Reader import Control.Monad.State.Strict import Data.Bool (bool)+import Data.Choice (Choice)+import Data.Choice qualified as Choice import Data.Coerce import Data.Functor ((<&>)) import Data.List (find)@@ -393,8 +396,8 @@  -- | Retrieve whether we should print out certain debug information while -- printing.-askDebug :: R Bool-askDebug = R (asks rcDebug)+askDebug :: R (Choice "debug")+askDebug = R (asks (Choice.fromBool . rcDebug))  inciBy :: Int -> R () -> R () inciBy step (R m) = R (local modRC m)

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}@@ -18,6 +19,8 @@ where  import Control.Monad+import Data.Choice (Choice)+import Data.Choice qualified as Choice import Data.Text qualified as T import GHC.Data.FastString import GHC.Hs.Binds@@ -152,7 +155,7 @@   -- | Haddock style   HaddockStyle ->   -- | Finish the doc string with a newline-  Bool ->+  Choice "endNewline" ->   -- | The 'LHsDoc' to render   LHsDoc GhcPs ->   R ()@@ -175,7 +178,7 @@       else newline >> txt "--"     space     unless (T.null x) (txt x)-  when needsNewline newline+  when (Choice.isTrue needsNewline) newline   case l of     UnhelpfulSpan _ ->       -- It's often the case that the comment itself doesn't have a span

@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-}@@ -10,6 +11,7 @@   ) where +import Data.Choice (pattern Without) import Data.List (sort) import Data.List.NonEmpty (NonEmpty (..), (<|)) import Data.List.NonEmpty qualified as NE@@ -124,10 +126,10 @@   SpliceD _ x -> p_spliceDecl x   DocD _ docDecl ->     case docDecl of-      DocCommentNext str -> p_hsDoc Pipe False str-      DocCommentPrev str -> p_hsDoc Caret False str-      DocCommentNamed name str -> p_hsDoc (Named name) False str-      DocGroup n str -> p_hsDoc (Asterisk n) False str+      DocCommentNext str -> p_hsDoc Pipe (Without #endNewline) str+      DocCommentPrev str -> p_hsDoc Caret (Without #endNewline) str+      DocCommentNamed name str -> p_hsDoc (Named name) (Without #endNewline) str+      DocGroup n str -> p_hsDoc (Asterisk n) (Without #endNewline) str   RoleAnnotD _ x -> p_roleAnnot x   KindSigD _ s -> p_standaloneKindSig s 

@@ -1,7 +1,10 @@ {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-}  -- | Renedring of data type declarations.@@ -11,9 +14,11 @@ where  import Control.Monad+import Data.Choice (Choice, pattern Is, pattern Isn't, pattern With)+import Data.Choice qualified as Choice import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE-import Data.Maybe (isJust, mapMaybe, maybeToList)+import Data.Maybe (isJust, isNothing, mapMaybe, maybeToList) import Data.Void import GHC.Data.Strict qualified as Strict import GHC.Hs@@ -94,9 +99,12 @@             breakpoint             txt "where"           breakpoint-          sepSemi (located' (p_conDecl False)) dd_cons'+          sepSemi (located' (p_conDecl (Isn't #singleRecCon))) dd_cons'         else switchLayout (getLocA name : (getLocA <$> dd_cons')) . inci $ do-          let singleConstRec = isSingleConstRec dd_cons'+          let singleRecCon =+                case dd_cons' of+                  [L _ ConDeclH98 {con_args = RecCon {}}] -> Is #singleRecCon+                  _ -> Isn't #singleRecCon               compactLayoutAroundEquals =                 onTheSameLine                   (getLocA name)@@ -107,7 +115,7 @@           if hasHaddocks dd_cons'             then newline             else-              if singleConstRec && compactLayoutAroundEquals+              if Choice.isTrue singleRecCon && compactLayoutAroundEquals                 then space                 else breakpoint           equals@@ -118,87 +126,64 @@                   then newline >> txt "|" >> space                   else space >> txt "|" >> space               sitcc' =-                if hasHaddocks dd_cons' || not singleConstRec+                if hasHaddocks dd_cons' || Choice.isFalse singleRecCon                   then sitcc                   else id-          sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons'+          sep s (sitcc' . located' (p_conDecl singleRecCon)) dd_cons'   unless (null dd_derivs) breakpoint   inci $ sep newline (located' p_hsDerivingClause) dd_derivs -p_conDecl ::-  Bool ->-  ConDecl GhcPs ->-  R ()-p_conDecl singleConstRec = \case-  ConDeclGADT {..} -> do-    mapM_ (p_hsDoc Pipe True) con_doc-    let conDeclSpn =-          fmap getLocA (NE.toList con_names)-            <> [getLocA con_bndrs]-            <> maybeToList (fmap getLocA con_mb_cxt)-            <> conArgsSpans-          where-            conArgsSpans = case con_g_args of-              PrefixConGADT NoExtField xs -> getLocA . hsScaledThing <$> xs-              RecConGADT _ x -> [getLocA x]-    switchLayout conDeclSpn $ do-      let c :| cs = con_names-      p_rdrName c-      unless (null cs) . inci $ do-        commaDel-        sep commaDel p_rdrName cs-      inci $ do-        let conTy = case con_g_args of-              PrefixConGADT NoExtField xs ->-                let go (HsScaled a b) t = addCLocA t b (HsFunTy NoExtField a b t)-                 in foldr go con_res_ty xs-              RecConGADT _ r ->-                addCLocA r con_res_ty $-                  HsFunTy-                    NoExtField-                    (HsUnrestrictedArrow noAnn)-                    (la2la $ HsRecTy noAnn <$> r)-                    con_res_ty-            qualTy = case con_mb_cxt of-              Nothing -> conTy-              Just qs ->-                addCLocA qs conTy $-                  HsQualTy NoExtField qs conTy-            quantifiedTy :: LHsType GhcPs-            quantifiedTy =-              addCLocA con_bndrs qualTy $-                hsOuterTyVarBndrsToHsType (unLoc con_bndrs) qualTy-        space-        txt "::"-        if hasDocStrings (unLoc con_res_ty)-          then newline-          else breakpoint-        located quantifiedTy p_hsType-  ConDeclH98 {..} -> do-    mapM_ (p_hsDoc Pipe True) con_doc-    let conNameSpn = getLocA con_name-        conNameWithContextSpn =-          [ RealSrcSpan real Strict.Nothing-            | EpaSpan (RealSrcSpan real _) <--                mapMaybe (matchAddEpAnn AnnForall) con_ext-          ]-            <> fmap getLocA con_ex_tvs-            <> maybeToList (fmap getLocA con_mb_cxt)-            <> [conNameSpn]-        conDeclSpn = conNameSpn : conArgsSpans-          where-            conArgsSpans = case con_args of-              PrefixCon [] xs -> getLocA . hsScaledThing <$> xs-              PrefixCon (v : _) _ -> absurd v-              RecCon l -> [getLocA l]-              InfixCon x y -> getLocA . hsScaledThing <$> [x, y]-    switchLayout conNameWithContextSpn $ do-      when con_forall $ do-        p_forallBndrs ForAllInvis p_hsTyVarBndr con_ex_tvs-        breakpoint-      forM_ con_mb_cxt p_lhsContext-    switchLayout conDeclSpn $ case con_args of-      PrefixCon [] xs -> do+p_conDecl :: Choice "singleRecCon" -> ConDecl GhcPs -> R ()+p_conDecl _ ConDeclGADT {..} = do+  mapM_ (p_hsDoc Pipe (With #endNewline)) con_doc+  switchLayout conDeclSpn $ do+    let c :| cs = con_names+    p_rdrName c+    unless (null cs) . inci $ do+      commaDel+      sep commaDel p_rdrName cs+    inci $ do+      let conTy = case con_g_args of+            PrefixConGADT NoExtField xs ->+              let go (HsScaled a b) t = addCLocA t b (HsFunTy NoExtField a b t)+               in foldr go con_res_ty xs+            RecConGADT _ r ->+              addCLocA r con_res_ty $+                HsFunTy+                  NoExtField+                  (HsUnrestrictedArrow noAnn)+                  (la2la $ HsRecTy noAnn <$> r)+                  con_res_ty+          qualTy = case con_mb_cxt of+            Nothing -> conTy+            Just qs ->+              addCLocA qs conTy $+                HsQualTy NoExtField qs conTy+          quantifiedTy :: LHsType GhcPs+          quantifiedTy =+            addCLocA con_bndrs qualTy $+              hsOuterTyVarBndrsToHsType (unLoc con_bndrs) qualTy+      space+      txt "::"+      if hasDocStrings (unLoc con_res_ty)+        then newline+        else breakpoint+      located quantifiedTy p_hsType+  where+    conDeclSpn =+      fmap getLocA (NE.toList con_names)+        <> [getLocA con_bndrs]+        <> maybeToList (fmap getLocA con_mb_cxt)+        <> conArgsSpans+    conArgsSpans = case con_g_args of+      PrefixConGADT NoExtField xs -> getLocA . hsScaledThing <$> xs+      RecConGADT _ x -> [getLocA x]+p_conDecl singleRecCon ConDeclH98 {..} =+  case con_args of+    PrefixCon (_ :: [Void]) xs -> do+      renderConDoc+      renderContext+      switchLayout conDeclSpn $ do         p_rdrName con_name         let args = hsScaledThing <$> xs             argsHaveDocs = conArgsHaveHaddocks args@@ -206,19 +191,71 @@         unless (null xs) delimiter         inci . sitcc $           sep delimiter (sitcc . located' p_hsType) args-      PrefixCon (v : _) _ -> absurd v-      RecCon l -> do+    RecCon l -> do+      renderConDoc+      renderContext+      switchLayout conDeclSpn $ do         p_rdrName con_name         breakpoint-        inciIf (not singleConstRec) (located l p_conDeclFields)-      InfixCon (HsScaled _ x) (HsScaled _ y) -> do-        located x p_hsType-        breakpoint+        inciIf (Choice.isFalse singleRecCon) (located l p_conDeclFields)+    InfixCon (HsScaled _ l) (HsScaled _ r) -> do+      -- manually render these+      let (lType, larg_doc) = splitDocTy l+      let (rType, rarg_doc) = splitDocTy r++      -- the constructor haddock can go on top of the entire constructor+      -- only if neither argument has haddocks+      let putConDocOnTop = isNothing larg_doc && isNothing rarg_doc++      when putConDocOnTop renderConDoc+      renderContext+      switchLayout conDeclSpn $ do+        -- the left arg haddock can use pipe only if the infix constructor has docs+        if isJust con_doc+          then do+            mapM_ (p_hsDoc Pipe (With #endNewline)) larg_doc+            located lType p_hsType+            breakpoint+          else do+            located lType p_hsType+            case larg_doc of+              Just doc -> space >> p_hsDoc Caret (With #endNewline) doc+              Nothing -> breakpoint         inci $ do+          unless putConDocOnTop renderConDoc           p_rdrName con_name-          space-          located y p_hsType+          case rarg_doc of+            Just doc -> newline >> p_hsDoc Pipe (With #endNewline) doc+            Nothing -> breakpoint+          located rType p_hsType+  where+    renderConDoc = mapM_ (p_hsDoc Pipe (With #endNewline)) con_doc+    renderContext =+      switchLayout conNameWithContextSpn $ do+        when con_forall $ do+          p_forallBndrs ForAllInvis p_hsTyVarBndr con_ex_tvs+          breakpoint+        forM_ con_mb_cxt p_lhsContext +    conNameWithContextSpn =+      [ RealSrcSpan real Strict.Nothing+      | EpaSpan (RealSrcSpan real _) <-+          mapMaybe (matchAddEpAnn AnnForall) con_ext+      ]+        <> fmap getLocA con_ex_tvs+        <> maybeToList (fmap getLocA con_mb_cxt)+        <> [conNameSpn]+    conDeclSpn = conNameSpn : conArgsSpans+    conNameSpn = getLocA con_name+    conArgsSpans = case con_args of+      PrefixCon (_ :: [Void]) xs -> getLocA . hsScaledThing <$> xs+      RecCon l -> [getLocA l]+      InfixCon x y -> getLocA . hsScaledThing <$> [x, y]++    splitDocTy = \case+      L _ (HsDocTy _ ty doc) -> (ty, Just doc)+      ty -> (ty, Nothing)+ p_lhsContext ::   LHsContext GhcPs ->   R ()@@ -282,13 +319,6 @@ isInfix = \case   Infix -> True   Prefix -> False--isSingleConstRec :: [LConDecl GhcPs] -> Bool-isSingleConstRec [(L _ ConDeclH98 {..})] =-  case con_args of-    RecCon _ -> True-    _ -> False-isSingleConstRec _ = False  hasHaddocks :: [LConDecl GhcPs] -> Bool hasHaddocks = any (f . unLoc)

@@ -382,7 +382,7 @@     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 @@         _ -> 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,22 +443,22 @@           | 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     sitcc $ p_hsLocalBinds binds   ParStmt {} ->-    -- 'ParStmt' should always be eliminated in 'gatherStmt' already, such+    -- 'ParStmt' should always be eliminated in 'gatherStmts' already, such     -- that it never occurs in 'p_stmt''. Consequently, handling it here     -- would be redundant.     notImplemented "ParStmt"   TransStmt {..} ->     -- 'TransStmt' only needs to account for render printing itself, since     -- pretty printing of relevant statements (e.g., in 'trS_stmts') is-    -- handled through 'gatherStmt'.+    -- handled through 'gatherStmts'.     case (trS_form, trS_by) of       (ThenForm, Nothing) -> do         txt "then"@@ -486,25 +487,26 @@   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).@@ -516,17 +518,6 @@   inciApplicand isApp . located es $     sepSemi p_stmtExt . attachRelativePos -gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]-gatherStmt (L _ (ParStmt _ block _ _)) =-  foldr ((<>) . gatherStmtBlock) [] block-gatherStmt (L s stmt@TransStmt {..}) =-  foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]])-gatherStmt stmt = [[stmt]]--gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]]-gatherStmtBlock (ParStmtBlock _ stmts _ _) =-  foldr (liftAppend . gatherStmt) [] stmts- p_hsLocalBinds :: HsLocalBinds GhcPs -> R () p_hsLocalBinds = \case   HsValBinds epAnn (ValBinds _ bag lsigs) -> pseudoLocated epAnn $ do@@ -754,30 +745,12 @@     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 = foldr (liftAppend . gatherStmt) [] 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 $@@ -878,6 +851,118 @@     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:+--+-- @+-- [ a + b + c + d+-- | a <- as, let b = a + a+-- | c <- cs+-- | d <- ds, then sort by f+-- ]+-- @+--+-- is parsed as roughly:+--+-- @+-- [ ParStmt+--     [ ParStmtBlock+--         [ BindStmt [| a <- as |]+--         , LetStmt  [| let b = a + a |]+--         ]+--     , ParStmtBlock+--         [ BindStmt [| c <- cs |]+--         ]+--     , ParStmtBlock+--         [ TransStmt+--             [ BindStmt [| d <- ds |]+--             ]+--             [| then sort by f |]+--         ]+--     ]+-- , LastStmt [| a + b + c + d |]+-- ]+-- @+--+-- The final expression is parsed out in p_body, and the rest is passed+-- to this function. This function takes the above tree as input and+-- normalizes it into:+--+-- @+-- [ [ BindStmt [| a <- as |]+--   , LetStmt  [| let b = a + a |]+--   ]+-- , [ BindStmt [| c <- cs |]+--   ]+-- , [ BindStmt [| d <- ds |]+--   , TransStmt [] [| then sortWith by f |]+--   ]+-- ]+-- @+--+-- Notes:+--   * The number of elements in the outer list is the number of pipes in+--     the comprehension; i.e. 1 unless -XParallelListComp is enabled+gatherStmts :: [ExprLStmt GhcPs] -> [[ExprLStmt GhcPs]]+gatherStmts = \case+  -- When -XParallelListComp is enabled + list comprehension has+  -- multiple pipes, input will have exactly 1 element, and it+  -- will be ParStmt.+  [L _ (ParStmt _ blocks _ _)] ->+    [ concatMap collectNonParStmts stmts+    | ParStmtBlock _ stmts _ _ <- blocks+    ]+  -- Otherwise, list will not contain any ParStmt+  stmts ->+    [ concatMap collectNonParStmts stmts+    ]+  where+    collectNonParStmts = \case+      L _ ParStmt {} -> unexpected "ParStmt"+      stmt@(L _ TransStmt {trS_stmts}) -> concatMap collectNonParStmts trS_stmts ++ [stmt]+      stmt -> [stmt]++    unexpected label = error $ "Unexpected " <> label <> "! Please file a bug."+ p_patSynBind :: PatSynBind GhcPs GhcPs -> R () p_patSynBind PSB {..} = do   let rhs conSpans = do@@ -1280,14 +1365,6 @@ layoutToBraces = \case   SingleLine -> useBraces   MultiLine -> id---- | Append each element in both lists with semigroups. If one list is shorter--- than the other, return the rest of the longer list unchanged.-liftAppend :: (Semigroup a) => [a] -> [a] -> [a]-liftAppend [] [] = []-liftAppend [] (y : ys) = y : ys-liftAppend (x : xs) [] = x : xs-liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys  getGRHSSpan :: GRHS GhcPs (LocatedA body) -> SrcSpan getGRHSSpan (GRHS _ guards body) =

@@ -1,5 +1,7 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-}  -- | Rendering of import and export lists.@@ -10,6 +12,7 @@ where  import Control.Monad+import Data.Choice (pattern Without) import Data.Foldable (for_, traverse_) import GHC.Hs import GHC.LanguageExtensions.Type@@ -122,9 +125,9 @@       FirstPos -> return ()       MiddlePos -> newline       LastPos -> newline-    p_hsDoc (Asterisk n) False str+    p_hsDoc (Asterisk n) (Without #endNewline) str   IEDoc NoExtField str ->-    p_hsDoc Pipe False str+    p_hsDoc Pipe (Without #endNewline) str   IEDocNamed NoExtField str -> p_hsDocName str   where     p_comma =@@ -144,7 +147,7 @@     p_exportDoc :: Maybe (ExportDoc GhcPs) -> R ()     p_exportDoc = traverse_ $ \exportDoc -> do       breakpoint-      p_hsDoc Caret False exportDoc+      p_hsDoc Caret (Without #endNewline) exportDoc  ieExportDoc :: IE GhcPs -> Maybe (ExportDoc GhcPs) ieExportDoc = \case

@@ -1,4 +1,6 @@+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-}  -- | Rendering of modules.@@ -8,6 +10,7 @@ where  import Control.Monad+import Data.Choice (pattern With) import GHC.Hs hiding (comment) import GHC.Types.SrcLoc import Ormolu.Parser.CommentStream@@ -45,7 +48,7 @@       Nothing -> return ()       Just hsmodName' -> do         located hsmodName' $ \name -> do-          forM_ hsmodHaddockModHeader (p_hsDoc Pipe True)+          forM_ hsmodHaddockModHeader (p_hsDoc Pipe (With #endNewline))           p_hsmodName name         breakpoint         forM_ hsmodDeprecMessage $ \w -> do

@@ -1,5 +1,7 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} @@ -19,6 +21,7 @@   ) where +import Data.Choice (pattern With) import GHC.Hs hiding (isPromoted) import GHC.Types.SourceText import GHC.Types.SrcLoc@@ -131,7 +134,7 @@     inci (located k p_hsType)   HsSpliceTy _ splice -> p_hsUntypedSplice DollarSplice splice   HsDocTy _ t str -> do-    p_hsDoc Pipe True str+    p_hsDoc Pipe (With #endNewline) str     located t p_hsType   HsBangTy _ (HsSrcBang _ u s) t -> do     case u of@@ -259,7 +262,7 @@  p_conDeclField :: ConDeclField GhcPs -> R () p_conDeclField ConDeclField {..} = do-  mapM_ (p_hsDoc Pipe True) cd_fld_doc+  mapM_ (p_hsDoc Pipe (With #endNewline)) cd_fld_doc   sitcc $     sep       commaDel

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternSynonyms #-} @@ -13,6 +14,7 @@   ) where +import Data.Choice (Choice) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import GHC.Parser.Annotation@@ -92,7 +94,7 @@ -- re-associate it using this function before printing. reassociateOpTree ::   -- | Whether to print debug info regarding fixity inference-  Bool ->+  Choice "debug" ->   -- | How to get name of an operator   (op -> Maybe RdrName) ->   -- | Fixity Map@@ -110,7 +112,7 @@ -- about its fixity (extracted from the specified fixity map). addFixityInfo ::   -- | Whether to print debug info regarding fixity inference-  Bool ->+  Choice "debug" ->   -- | Fixity map for operators   ModuleFixityMap ->   -- | How to get the name of an operator

@@ -36,7 +36,7 @@       mentioned `shouldBe` True       unPackageName ciPackageName `shouldBe` "ormolu"       ciDynOpts `shouldBe` [DynOption "-XGHC2021"]-      Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "ansi-terminal", "array", "base", "binary", "bytestring", "containers", "deepseq", "directory", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "syb", "text"]+      Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "ansi-terminal", "array", "base", "binary", "bytestring", "choice", "containers", "deepseq", "directory", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "syb", "text"]       ciCabalFilePath `shouldSatisfy` isAbsolute       makeRelativeToCurrentDirectory ciCabalFilePath `shouldReturn` "ormolu.cabal"     it "extracts correct cabal info from ormolu.cabal for tests/Ormolu/PrinterSpec.hs" $ do@@ -44,7 +44,7 @@       mentioned `shouldBe` True       unPackageName ciPackageName `shouldBe` "ormolu"       ciDynOpts `shouldBe` [DynOption "-XGHC2021"]-      Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "QuickCheck", "base", "containers", "directory", "filepath", "ghc-lib-parser", "hspec", "hspec-megaparsec", "megaparsec", "ormolu", "path", "path-io", "temporary", "text"]+      Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "QuickCheck", "base", "choice", "containers", "directory", "filepath", "ghc-lib-parser", "hspec", "hspec-megaparsec", "megaparsec", "ormolu", "path", "path-io", "temporary", "text"]       ciCabalFilePath `shouldSatisfy` isAbsolute       makeRelativeToCurrentDirectory ciCabalFilePath `shouldReturn` "ormolu.cabal"     it "handles correctly files that are not mentioned in ormolu.cabal" $ do

@@ -60,6 +60,13 @@           [ "infixr 9  .",             "infixr 5  ++"           ]+    it "parses inputs without a trailing newline" $+      parseDotOrmolu ""+        `shouldSucceedOn` T.intercalate+          "\n"+          [ "infixr 9  .",+            "infixr 5  ++"+          ]     it "fails with correct parse error (keyword wrong second line)" $       parseDotOrmolu "" "infixr 5 .\nfoobar 5 $"         `shouldFailWith` err

@@ -1,8 +1,11 @@+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Ormolu.FixitySpec (spec) where +import Data.Choice (pattern Without) import Data.Function ((&)) import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict qualified as Map@@ -261,7 +264,7 @@   where     actualResult =       fmap-        (\(k, _) -> (k, inferFixity False k resultMap))+        (\(k, _) -> (k, inferFixity (Without #debug) k resultMap))         expectedResult     resultMap =       moduleFixityMap

@@ -1,8 +1,11 @@+{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}  module Ormolu.OpTreeSpec (spec) where +import Data.Choice (pattern Without) import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T@@ -31,7 +34,7 @@     removeOpInfo (OpNode x) = OpNode x     removeOpInfo (OpBranches exprs ops) =       OpBranches (removeOpInfo <$> exprs) (opiOp <$> ops)-    actualOutputTree = reassociateOpTree False convertName modFixityMap inputTree+    actualOutputTree = reassociateOpTree (Without #debug) convertName modFixityMap inputTree     modFixityMap = ModuleFixityMap (Map.map Given (Map.fromList fixities))     convertName = Just . mkRdrUnqual . mkOccName varName . T.unpack . unOpName