fourmolu 0.15.0.0 → 0.16.0.0

raw patch · 70 files changed

+834/−388 lines, 70 filesdep +terminal-sizedep ~Cabal-syntaxdep ~containersdep ~filepathPVP ok

version bump matches the API change (PVP)

Dependencies added: terminal-size

Dependency ranges changed: Cabal-syntax, containers, filepath, ghc-lib-parser, optparse-applicative, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +20/−0
• README.md +2/−0
• app/Main.hs +48/−31
• data/examples/declaration/signature/fixity/infix-four-out.hs +2/−0
• data/examples/declaration/signature/fixity/infix-out.hs +2/−0
• data/examples/declaration/signature/fixity/infix.hs +2/−0
• data/examples/declaration/signature/fixity/infixl-four-out.hs +2/−0
• data/examples/declaration/signature/fixity/infixl-out.hs +2/−0
• data/examples/declaration/signature/fixity/infixl.hs +2/−0
• data/examples/declaration/signature/fixity/infixr-four-out.hs +2/−0
• data/examples/declaration/signature/fixity/infixr-out.hs +2/−0
• data/examples/declaration/signature/fixity/infixr.hs +2/−0
• data/examples/declaration/value/function/pragmas-four-out.hs +1/−1
• data/examples/declaration/value/function/pragmas-out.hs +1/−1
• data/examples/declaration/value/function/required-type-arguments-four-out.hs +17/−0
• data/examples/declaration/value/function/required-type-arguments-out.hs +21/−0
• data/examples/declaration/value/function/required-type-arguments.hs +13/−0
• data/examples/declaration/value/function/type-abstractions-four-out.hs +9/−0
• data/examples/declaration/value/function/type-abstractions-out.hs +9/−0
• data/examples/declaration/value/function/type-abstractions.hs +8/−0
• data/examples/declaration/warning/warning-multiline-four-out.hs +9/−0
• data/examples/declaration/warning/warning-multiline-out.hs +9/−0
• data/examples/declaration/warning/warning-multiline.hs +8/−0
• data/examples/declaration/warning/warning-single-line-four-out.hs +8/−2
• data/examples/declaration/warning/warning-single-line-out.hs +10/−2
• data/examples/declaration/warning/warning-single-line.hs +8/−2
• data/examples/import/docstrings-after-exports-four-out.hs +11/−0
• data/examples/import/docstrings-after-exports-out.hs +12/−0
• data/examples/import/docstrings-after-exports.hs +11/−0
• data/fourmolu/import-export/input-multi.hs +15/−0
• data/fourmolu/import-export/output-ImportExportDiffFriendly.hs +15/−0
• data/fourmolu/import-export/output-ImportExportLeading.hs +15/−0
• data/fourmolu/import-export/output-ImportExportTrailing.hs +15/−0
• extract-hackage-info/hackage-info.bin binary
• fourmolu.cabal +19/−18
• src/Ormolu.hs +5/−5
• src/Ormolu/Config.hs +24/−22
• src/Ormolu/Diff/ParseResult.hs +30/−5
• src/Ormolu/Diff/Text.hs +4/−1
• src/Ormolu/Fixity/Imports.hs +4/−4
• src/Ormolu/Fixity/Parser.hs +11/−0
• src/Ormolu/Imports.hs +23/−18
• src/Ormolu/Parser.hs +1/−1
• src/Ormolu/Parser/CommentStream.hs +4/−3
• src/Ormolu/Printer/Combinators.hs +7/−6
• src/Ormolu/Printer/Internal.hs +12/−0
• src/Ormolu/Printer/Meat/Common.hs +19/−13
• src/Ormolu/Printer/Meat/Declaration.hs +6/−4
• src/Ormolu/Printer/Meat/Declaration/Data.hs +15/−13
• src/Ormolu/Printer/Meat/Declaration/Foreign.hs +1/−1
• src/Ormolu/Printer/Meat/Declaration/Instance.hs +12/−4
• src/Ormolu/Printer/Meat/Declaration/OpTree.hs +1/−2
• src/Ormolu/Printer/Meat/Declaration/Signature.hs +5/−4
• src/Ormolu/Printer/Meat/Declaration/Value.hs +108/−91
• src/Ormolu/Printer/Meat/Declaration/Warning.hs +10/−14
• src/Ormolu/Printer/Meat/ImportExport.hs +52/−20
• src/Ormolu/Printer/Meat/Module.hs +1/−1
• src/Ormolu/Printer/Meat/Type.hs +12/−12
• src/Ormolu/Printer/Operators.hs +3/−2
• src/Ormolu/Printer/SpanStream.hs +5/−3
• src/Ormolu/Terminal.hs +2/−2
• src/Ormolu/Utils.hs +0/−17
• src/Ormolu/Utils/Fixity.hs +3/−2
• src/Ormolu/Utils/IO.hs +1/−29
• tests/Ormolu/CabalInfoSpec.hs +1/−1
• tests/Ormolu/Config/PrinterOptsSpec.hs +4/−4
• tests/Ormolu/Diff/TextSpec.hs +4/−4
• tests/Ormolu/Integration/CLISpec.hs +69/−6
• tests/Ormolu/Integration/Utils.hs +38/−8
• tests/Ormolu/PrinterSpec.hs +5/−9

@@ -1,3 +1,23 @@+## Fourmolu 0.16.0.0++* Allow specifying path to configuration file with `--config` ([#396](https://github.com/fourmolu/fourmolu/issues/396))++### Upstream changes:++#### Ormolu 0.7.5.0++* Switched to `ghc-lib-parser-9.10`, with the following new syntactic features/behaviors:+  * GHC proposal [#575](https://github.com/ghc-proposals/ghc-proposals/blob/10290a668608d608c3f6c6010be265cf7a02e1fc/proposals/0575-deprecated-instances.rst): deprecated instances.+  * GHC proposal [#281](https://github.com/ghc-proposals/ghc-proposals/blob/10290a668608d608c3f6c6010be265cf7a02e1fc/proposals/0281-visible-forall.rst): visible forall in types of terms.+    Enabled by `RequiredTypeArguments` (enabled by default).+  * `LinearTypes`: `let` and `where` bindings can now be linear, in particular have multiplicity annotations.+  * Using `forall` as an identifier is now a parse error.+  * GHC proposal [#65](https://github.com/ghc-proposals/ghc-proposals/blob/10290a668608d608c3f6c6010be265cf7a02e1fc/proposals/0065-type-infix.rst): namespacing fixity declarations for type names and WARNING/DEPRECATED pragmas.+  * `TypeAbstractions` now supports `@`-binders in lambdas and function equations.+  * Support for the `GHC2024` language.++* Updated to `Cabal-syntax-3.12`.+ ## Fourmolu 0.15.0.0  * Add `single-deriving-parens` configuration option to determine if `deriving` clauses of a single type should be parenthesized ([#386](https://github.com/fourmolu/fourmolu/pull/386))

@@ -205,6 +205,8 @@ `--end-line` command line options. `--start-line` defaults to the beginning of the file, while `--end-line` defaults to the end. +Note that the selected region needs to be parseable Haskell code on its own.+ ### Exit codes  Exit code | Meaning

@@ -15,7 +15,7 @@ import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.Set qualified as Set-import Data.Text.IO qualified as TIO+import Data.Text.IO.Utf8 qualified as T.Utf8 import Data.Version (showVersion) import Data.Yaml qualified as Yaml import Distribution.ModuleName (ModuleName)@@ -30,8 +30,8 @@ import Ormolu.Terminal import Ormolu.Utils (showOutputable) import Ormolu.Utils.Fixity-import Ormolu.Utils.IO import Paths_fourmolu (version)+import System.Console.Terminal.Size qualified as Terminal import System.Directory import System.Exit (ExitCode (..), exitWith) import System.FilePath qualified as FP@@ -40,13 +40,8 @@ -- | Entry point of the program. main :: IO () main = do-  opts@Opts {..} <- execParser optsParserInfo--  cwd <- getCurrentDirectory-  cfg <- case optInputFiles of-    [] -> mkConfig cwd opts-    ["-"] -> mkConfig cwd opts-    file : _ -> mkConfig file opts+  opts@Opts {..} <- runParser optsParserInfo+  cfg <- resolveConfig opts    let formatOne' =         formatOne@@ -75,27 +70,34 @@                 else 102    exitWith exitCode+  where+    runParser p = do+      termWidth <- maybe 100 Terminal.width <$> Terminal.size+      customExecParser (prefs $ helpIndent 35 <> columns termWidth) p  -- | Build the full config, by adding 'PrinterOpts' from a file, if found.-mkConfig :: FilePath -> Opts -> IO (Config RegionIndices)-mkConfig path Opts {optQuiet, optConfig = cliConfig, optPrinterOpts = cliPrinterOpts} = do+resolveConfig :: Opts -> IO (Config RegionIndices)+resolveConfig opts@(Opts {optConfig = cliConfig, optPrinterOpts = cliPrinterOpts}) = do   fourmoluConfig <--    loadConfigFile path >>= \case-      ConfigLoaded f cfg -> do-        outputInfo $ "Loaded config from: " <> f-        outputDebug $ unwords ["*** CONFIG FILE ***", show cfg]-        pure cfg-      ConfigParseError f e -> do-        outputError . unlines $-          [ "Failed to load " <> f <> ":",-            Yaml.prettyPrintParseException e-          ]-        exitWith $ ExitFailure 400-      ConfigNotFound searchDirs -> do+    findConfigFile' >>= \case+      Left ConfigNotFound {searchDirs} -> do         outputDebug . unlines $           ("No " ++ show configFileName ++ " found in any of:")             : map ("  " ++) searchDirs         pure emptyConfig+      Right configPath ->+        Yaml.decodeFileEither configPath >>= \case+          Left e -> do+            outputError . unlines $+              [ "Failed to load " <> configPath <> ":",+                Yaml.prettyPrintParseException e+              ]+            exitWith $ ExitFailure 400+          Right cfg -> do+            outputInfo $ "Loaded config from: " <> configPath+            outputDebug $ unwords ["*** CONFIG FILE ***", show cfg]+            pure cfg+   return $     cliConfig       { cfgPrinterOpts =@@ -115,9 +117,17 @@             ]       }   where+    findConfigFile' = do+      cwd <- getCurrentDirectory+      case optInputFiles opts of+        _ | Just configPath <- optConfigFilePath opts -> pure $ Right configPath+        [] -> findConfigFile cwd+        ["-"] -> findConfigFile cwd+        file : _ -> findConfigFile $ FP.takeDirectory file+     output = hPutStrLn stderr     outputError = output-    outputInfo = unless optQuiet . output+    outputInfo = unless (optQuiet opts) . output     outputDebug = when (cfgDebug cliConfig) . output  getHaskellFiles :: FilePath -> IO [FilePath]@@ -191,7 +201,7 @@         config <- patchConfig Nothing mcabalInfo mdotOrmolu         case mode of           Stdout -> do-            ormoluStdin config >>= TIO.putStr+            ormoluStdin config >>= T.Utf8.putStr             return ExitSuccess           InPlace -> do             hPutStrLn@@ -201,7 +211,7 @@             return (ExitFailure 101)           Check -> do             -- ormoluStdin is not used because we need the originalInput-            originalInput <- getContentsUtf8+            originalInput <- T.Utf8.getContents             let stdinRepr = "<stdin>"             formattedInput <-               ormolu config stdinRepr originalInput@@ -220,19 +230,19 @@             mdotOrmolu         case mode of           Stdout -> do-            ormoluFile config inputFile >>= TIO.putStr+            ormoluFile config inputFile >>= T.Utf8.putStr             return ExitSuccess           InPlace -> do             -- ormoluFile is not used because we need originalInput-            originalInput <- readFileUtf8 inputFile+            originalInput <- T.Utf8.readFile inputFile             formattedInput <-               ormolu config inputFile originalInput             when (formattedInput /= originalInput) $-              writeFileUtf8 inputFile formattedInput+              T.Utf8.writeFile inputFile formattedInput             return ExitSuccess           Check -> do             -- ormoluFile is not used because we need originalInput-            originalInput <- readFileUtf8 inputFile+            originalInput <- T.Utf8.readFile inputFile             formattedInput <-               ormolu config inputFile originalInput             handleDiff originalInput formattedInput inputFile@@ -274,6 +284,8 @@     optQuiet :: !Bool,     -- | Ormolu 'Config'     optConfig :: !(Config RegionIndices),+    -- | Ormolu 'Config'+    optConfigFilePath :: !(Maybe FilePath),     -- | Fourmolu 'PrinterOpts',     optPrinterOpts :: PrinterOptsPartial,     -- | Options related to info extracted from files@@ -363,6 +375,11 @@         help "Make output quieter"       ]     <*> configParser+    <*> (optional . strOption . mconcat)+      [ metavar "CONFIG_FILE",+        long "config",+        help "Path to the config file to use. If not specified, tries to discover one automatically."+      ]     <*> printerOptsParser     <*> configFileOptsParser     <*> sourceTypeParser@@ -456,7 +473,7 @@                 help "End line of the region to format (inclusive)"               ]         )-    <*> pure defaultPrinterOpts -- unused; overwritten in mkConfig+    <*> pure defaultPrinterOpts -- unused; overwritten in resolveConfig  sourceTypeParser :: Parser (Maybe SourceType) sourceTypeParser =

@@ -2,3 +2,5 @@ infix 9 <^-^>  infix 2 ->++infix 0 type <!>

@@ -3,3 +3,5 @@ infix 9 <^-^>  infix 2 ->++infix 0 type <!>

@@ -2,3 +2,5 @@ infix 9 <^-^>  infix 2 ->++infix 0 type <!>

@@ -1,2 +1,4 @@ infixl 8 *** infixl 0 $, *, +, &&, **++infixl 9 type $

@@ -1,3 +1,5 @@ infixl 8 ***  infixl 0 $, *, +, &&, **++infixl 9 type $

@@ -1,2 +1,4 @@ infixl 8 *** infixl 0 $, *, +, &&, **++infixl 9 type $

@@ -1,2 +1,4 @@ infixr 8 `Foo` infixr 0 ***, &&&++infixr 0 data $

@@ -1,3 +1,5 @@ infixr 8 `Foo`  infixr 0 ***, &&&++infixr 0 data $

@@ -1,2 +1,4 @@ infixr 8 `Foo` infixr 0 ***, &&&++infixr 0 data $

@@ -1,4 +1,4 @@-sccfoo = {-# SCC foo #-} 1+sccfoo = {-# SCC "foo" #-} 1 sccbar =     {-# SCC "barbaz" #-}     "hello"

@@ -1,4 +1,4 @@-sccfoo = {-# SCC foo #-} 1+sccfoo = {-# SCC "foo" #-} 1  sccbar =   {-# SCC "barbaz" #-}

@@ -0,0 +1,17 @@+vshow :: forall a -> (Show a) => a -> String+vshow t x = show (x :: t)++s1 = vshow Int 42+s2 = vshow Double 42++a1 = f (type (Int -> Bool))+a2 = f (type ((Read T) => T))+a3 = f (type (forall a. a))+a4 = f (type (forall a. (Read a) => String -> a))++foo =+    f+        ( type ( Maybe+                    Int+               )+        )

@@ -0,0 +1,21 @@+vshow :: forall a -> (Show a) => a -> String+vshow t x = show (x :: t)++s1 = vshow Int 42++s2 = vshow Double 42++a1 = f (type (Int -> Bool))++a2 = f (type ((Read T) => T))++a3 = f (type (forall a. a))++a4 = f (type (forall a. (Read a) => String -> a))++foo =+  f+    ( type ( Maybe+              Int+           )+    )

@@ -0,0 +1,13 @@+vshow :: forall a -> Show a => a -> String+vshow t x = show (x :: t)++s1 = vshow Int    42+s2 = vshow Double 42++a1 = f (type (Int -> Bool))+a2 = f (type (Read T => T))+a3 = f (type (forall a. a))+a4 = f (type (forall a. Read a => String -> a))++foo = f (type (Maybe+            Int))

@@ -0,0 +1,9 @@+id :: forall a. a -> a+id @t x = x :: t++f1 :: forall a. a -> forall b. b -> (a, b)+f1 @a x @b y = (x :: a, y :: b)++f2 =+    (\ @a x @b y -> (x :: a, y :: b)) ::+        forall a. a -> forall b. b -> (a, b)

@@ -0,0 +1,9 @@+id :: forall a. a -> a+id @t x = x :: t++f1 :: forall a. a -> forall b. b -> (a, b)+f1 @a x @b y = (x :: a, y :: b)++f2 =+  (\ @a x @b y -> (x :: a, y :: b)) ::+    forall a. a -> forall b. b -> (a, b)

@@ -0,0 +1,8 @@+id :: forall a. a -> a+id @t x = x :: t++f1 :: forall a. a -> forall b. b -> (a, b)+f1 @a x @b y = (x :: a, y :: b)++f2 = (\ @a x @b y -> (x :: a, y :: b) )+    :: forall a. a -> forall b. b -> (a, b)

@@ -7,3 +7,12 @@     #-} test :: IO () test = pure ()++instance+    {-# WARNING "Don't use" #-}+    Show G1 where+    show = "G1"++deriving instance+        {-# WARNING "to be removed" #-}+    Eq G2

@@ -7,3 +7,12 @@   #-} test :: IO () test = pure ()++instance+  {-# WARNING "Don't use" #-}+  Show G1 where+  show = "G1"++deriving instance+    {-# WARNING "to be removed" #-}+  Eq G2

@@ -2,3 +2,11 @@   foo ["These are bad functions", "Really bad!"] #-} test :: IO () test = pure ()++instance+  {-# WARNING "Don't use" #-}+  Show G1 where+  show = "G1"++deriving instance+  {-# WARNING "to be removed" #-} Eq G2

@@ -6,11 +6,17 @@ bar = 3 {-# DEPRECATED bar "Bar is deprecated" #-} -{-# DEPRECATED baz "Baz is also deprecated" #-}+{-# DEPRECATED data baz "Baz is also deprecated" #-} baz = 5  data Number = Number Dobule-{-# DEPRECATED Number "Use Scientific instead." #-}+{-# DEPRECATED type Number "Use Scientific instead." #-}  head (a : _) = a {-# WARNING in "x-partial" head "This function is partial..." #-}++instance {-# DEPRECATED "Don't use" #-} Show T1+instance {-# WARNING "Don't use either" #-} Show G1++deriving instance {-# DEPRECATED "to be removed" #-} Eq T2+deriving instance {-# WARNING "to be removed as well" #-} Eq G2

@@ -6,11 +6,19 @@ bar = 3 {-# DEPRECATED bar "Bar is deprecated" #-} -{-# DEPRECATED baz "Baz is also deprecated" #-}+{-# DEPRECATED data baz "Baz is also deprecated" #-} baz = 5  data Number = Number Dobule-{-# DEPRECATED Number "Use Scientific instead." #-}+{-# DEPRECATED type Number "Use Scientific instead." #-}  head (a : _) = a {-# WARNING in "x-partial" head "This function is partial..." #-}++instance {-# DEPRECATED "Don't use" #-} Show T1++instance {-# WARNING "Don't use either" #-} Show G1++deriving instance {-# DEPRECATED "to be removed" #-} Eq T2++deriving instance {-# WARNING "to be removed as well" #-} Eq G2

@@ -8,11 +8,17 @@  {-# Deprecated bar "Bar is deprecated" #-} -{-# DEPRECATED baz "Baz is also deprecated" #-}+{-# DEPRECATED data baz "Baz is also deprecated" #-} baz = 5  data Number = Number Dobule-{-# DEPRECATED Number "Use Scientific instead." #-}+{-# DEPRECATED type Number "Use Scientific instead." #-}  head (a:_) = a {-# WARNING in "x-partial" head "This function is partial..." #-}++instance {-# DEPRECATED "Don't use" #-}     Show T1 where+instance {-# WARNING "Don't use either" #-} Show G1 where++deriving instance {-# DEPRECATED "to be removed" #-}      Eq T2+deriving instance {-# WARNING "to be removed as well" #-} Eq G2

@@ -0,0 +1,11 @@+module Test (+    since1, -- ^ @since 1.0+    since2, -- ^ @since 2.0+    since3, -- ^ @since 3.0+    SinceType (..), -- ^ @since 4.0+    SinceClass (..), -- ^ @since 5.0+    Multi (..),+    -- ^ since 6.0+    -- multi+    -- line+) where

@@ -0,0 +1,12 @@+module Test+  ( since1, -- ^ @since 1.0+    since2, -- ^ @since 2.0+    since3, -- ^ @since 3.0+    SinceType (..), -- ^ @since 4.0+    SinceClass (..), -- ^ @since 5.0+    Multi (..),+    -- ^ since 6.0+    -- multi+    -- line+  )+where

@@ -0,0 +1,11 @@+module Test (+        since1, -- ^ @since 1.0+        since2  -- ^ @since 2.0+      , since3  -- ^ @since 3.0+      , SinceType(..) -- ^ @since 4.0+      , SinceClass(..) -- ^ @since 5.0+      , Multi(..)+        -- ^ since 6.0+        -- multi+        -- line+      ) where

@@ -50,3 +50,18 @@     -- * Some other thing     Foo, ) where++{- // -}++-- See data/examples/import/docstrings-after-exports.hs+module Test (+        since1, -- ^ @since 1.0+        since2  -- ^ @since 2.0+      , since3  -- ^ @since 3.0+      , SinceType(..) -- ^ @since 4.0+      , SinceClass(..) -- ^ @since 5.0+      , Multi(..)+        -- ^ since 6.0+        -- multi+        -- line+      ) where

@@ -50,3 +50,18 @@     -- * Some other thing     Foo, ) where++{- // -}++-- See data/examples/import/docstrings-after-exports.hs+module Test (+    since1, -- ^ @since 1.0+    since2, -- ^ @since 2.0+    since3, -- ^ @since 3.0+    SinceType (..), -- ^ @since 4.0+    SinceClass (..), -- ^ @since 5.0+    Multi (..),+    -- ^ since 6.0+    -- multi+    -- line+) where

@@ -50,3 +50,18 @@       -- * Some other thing     , Foo     ) where++{- // -}++-- See data/examples/import/docstrings-after-exports.hs+module Test+    ( since1 -- ^ @since 1.0+    , since2 -- ^ @since 2.0+    , since3 -- ^ @since 3.0+    , SinceType (..) -- ^ @since 4.0+    , SinceClass (..) -- ^ @since 5.0+    , Multi (..)+    -- ^ since 6.0+    -- multi+    -- line+    ) where

@@ -50,3 +50,18 @@       -- * Some other thing       Foo,     ) where++{- // -}++-- See data/examples/import/docstrings-after-exports.hs+module Test+    ( since1, -- ^ @since 1.0+      since2, -- ^ @since 2.0+      since3, -- ^ @since 3.0+      SinceType (..), -- ^ @since 4.0+      SinceClass (..), -- ^ @since 5.0+      Multi (..),+      -- ^ since 6.0+      -- multi+      -- line+    ) where

binary file changed (952236 → 989821 bytes)

@@ -1,13 +1,13 @@ cabal-version:      2.4 name:               fourmolu-version:            0.15.0.0+version:            0.16.0.0 license:            BSD-3-Clause license-file:       LICENSE.md maintainer:     Matt Parsons <parsonsmatt@gmail.com>     George Thomas <georgefsthomas@gmail.com>     Brandon Chinn <brandonchinn178@gmail.com>-tested-with:        ghc ==9.4.7 ghc ==9.6.3 ghc ==9.8.1+tested-with:        ghc ==9.6.5 ghc ==9.8.2 ghc ==9.10.1 homepage:           https://github.com/fourmolu/fourmolu bug-reports:        https://github.com/fourmolu/fourmolu/issues synopsis:           A formatter for Haskell source code@@ -105,10 +105,10 @@     other-modules:    GHC.DynFlags     default-language: GHC2021     build-depends:-        Cabal-syntax >=3.10 && <3.11,+        Cabal-syntax >=3.12 && <3.13,         Diff >=0.4 && <1,         MemoTrie >=0.6 && <0.7,-        ansi-terminal >=0.10 && <1.1,+        ansi-terminal >=0.10 && <1.2,         array >=0.5 && <0.6,         base >=4.14 && <5,         binary >=0.8 && <0.9,@@ -117,16 +117,15 @@         deepseq >=1.4 && <1.6,         directory ^>=1.3,         file-embed >=0.0.15 && <0.1,-        filepath >=1.2 && <1.5,-        ghc-lib-parser >=9.8 && <9.9,+        filepath >=1.2 && <1.6,+        ghc-lib-parser >=9.10 && <9.11,         megaparsec >=9,         mtl >=2 && <3,         syb >=0.7 && <0.8,-        text >=2 && <3,+        text >=2.1 && <3,         -- fourmolu-only deps         aeson >=1.0 && <3.0,         scientific >=0.3.2 && <1,-        yaml >=0.11.6.0 && <1      if flag(dev)         ghc-options:@@ -146,17 +145,19 @@     autogen-modules:  Paths_fourmolu     default-language: GHC2021     build-depends:-        Cabal-syntax >=3.10 && <3.11,+        Cabal-syntax >=3.12 && <3.13,         base >=4.12 && <5,-        containers >=0.5 && <0.7,+        containers >=0.5 && <0.8,         directory ^>=1.3,-        filepath >=1.2 && <1.5,-        ghc-lib-parser >=9.8 && <9.9,+        filepath >=1.2 && <1.6,+        ghc-lib-parser >=9.10 && <9.11,         optparse-applicative >=0.14 && <0.19,-        text >=2 && <3,+        text >=2.1 && <3,         th-env >=0.1.1 && <0.2,         -- fourmolu-only deps         directory >=1.3.3 && <1.4,+        optparse-applicative >=0.17,+        terminal-size >=0.1 && <0.4,         yaml >=0.11.6.0 && <1,         fourmolu @@ -187,20 +188,20 @@      default-language:   GHC2021     build-depends:-        Cabal-syntax >=3.10 && <3.11,+        Cabal-syntax >=3.12 && <3.13,         QuickCheck >=2.14,         base >=4.14 && <5,-        containers >=0.5 && <0.7,+        containers >=0.5 && <0.8,         directory ^>=1.3,-        filepath >=1.2 && <1.5,-        ghc-lib-parser >=9.8 && <9.9,+        filepath >=1.2 && <1.6,+        ghc-lib-parser >=9.10 && <9.11,         hspec >=2 && <3,         hspec-megaparsec >=2.2,         megaparsec >=9,         path >=0.6 && <0.10,         path-io >=1.4.2 && <2,         temporary ^>=1.3,-        text >=2 && <3+        text >=2.1 && <3      -- specific to fourmolu tests     other-modules:

@@ -22,8 +22,8 @@     PrinterOptsPartial,     PrinterOptsTotal,     defaultPrinterOpts,-    loadConfigFile,-    ConfigFileLoadResult (..),+    findConfigFile,+    ConfigNotFound (..),     configFileName,     resolvePrinterOpts, @@ -52,6 +52,7 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T+import Data.Text.IO.Utf8 qualified as T.Utf8 import Debug.Trace import GHC.Driver.Errors.Types import GHC.Types.Error@@ -68,7 +69,6 @@ import Ormolu.Printer import Ormolu.Utils (showOutputable) import Ormolu.Utils.Cabal qualified as CabalUtils-import Ormolu.Utils.IO import System.FilePath  -- | Format a 'Text'.@@ -165,7 +165,7 @@   -- | Resulting rendition   m Text ormoluFile cfg path =-  readFileUtf8 path >>= ormolu cfg path+  liftIO (T.Utf8.readFile path) >>= ormolu cfg path  -- | Read input from stdin and format it. --@@ -179,7 +179,7 @@   -- | Resulting rendition   m Text ormoluStdin cfg =-  getContentsUtf8 >>= ormolu cfg "<stdin>"+  liftIO T.Utf8.getContents >>= ormolu cfg "<stdin>"  -- | Refine a 'Config' by incorporating given 'SourceType', 'CabalInfo', and -- fixity overrides 'FixityMap'. You can use 'detectSourceType' to deduce

@@ -1,4 +1,5 @@ {-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -47,11 +48,11 @@     parsePrinterOptType,      -- ** Loading Fourmolu configuration-    loadConfigFile,+    ConfigNotFound (..),+    findConfigFile,     configFileName,     FourmoluConfig (..),     emptyConfig,-    ConfigFileLoadResult (..),   ) where @@ -59,13 +60,11 @@ import Data.Aeson ((.!=), (.:?)) import Data.Aeson qualified as Aeson import Data.Aeson.Types qualified as Aeson-import Data.Foldable (foldl') import Data.Functor.Identity (Identity (..)) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Set qualified as Set import Data.String (fromString)-import Data.Yaml qualified as Yaml import Distribution.Types.PackageName (PackageName) import GHC.Generics (Generic) import GHC.Types.SrcLoc qualified as GHC@@ -79,7 +78,10 @@     getXdgDirectory,     makeAbsolute,   )-import System.FilePath (splitPath, (</>))+import System.FilePath (takeDirectory)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif  -- | Type of sources that can be formatted by Ormolu. data SourceType@@ -267,25 +269,25 @@       cfgFileReexports = ModuleReexports mempty     } --- | Read options from a config file, if found.--- Looks recursively in parent folders, then in 'XdgConfig',--- for a file named /fourmolu.yaml/.-loadConfigFile :: FilePath -> IO ConfigFileLoadResult-loadConfigFile path = do-  root <- makeAbsolute path+-- | Find a fourmolu configuration file.+--+-- Looks for a file named /fourmolu.yaml/, first in the given path and+-- its parents, and then in the XDG config directory.+findConfigFile :: FilePath -> IO (Either ConfigNotFound FilePath)+findConfigFile rootDir = do+  rootDirAbs <- makeAbsolute rootDir   xdg <- getXdgDirectory XdgConfig ""-  let dirs = reverse $ xdg : scanl1 (</>) (splitPath root)-  findFile dirs configFileName >>= \case-    Nothing -> return $ ConfigNotFound dirs-    Just file ->-      either (ConfigParseError file) (ConfigLoaded file)-        <$> Yaml.decodeFileEither file+  let dirs = getParents rootDirAbs ++ [xdg]+  maybe (Left $ ConfigNotFound dirs) Right <$> findFile dirs configFileName+  where+    -- getParents "/a/b/c/" == ["/a/b/c/", "/a/b/", "/a/", "/"]+    getParents dir =+      let parentDir = takeDirectory dir+       in dir : if parentDir == dir then [] else getParents parentDir --- | The result of calling 'loadConfigFile'.-data ConfigFileLoadResult-  = ConfigLoaded FilePath FourmoluConfig-  | ConfigParseError FilePath Yaml.ParseException-  | ConfigNotFound [FilePath]+data ConfigNotFound = ConfigNotFound+  { searchDirs :: [FilePath]+  }   deriving (Show)  -- | Expected file name for YAML config.

@@ -97,17 +97,21 @@                   `extQ` considerEqual @SourceText                   `extQ` hsDocStringEq                   `extQ` importDeclQualifiedStyleEq-                  `extQ` considerEqual @(LayoutInfo GhcPs)                   `extQ` classDeclCtxEq                   `extQ` derivedTyClsParensEq                   `extQ` considerEqual @EpAnnComments -- ~ XCGRHSs GhcPs                   `extQ` considerEqual @TokenLocation -- in LHs(Uni)Token                   `extQ` considerEqual @EpaLocation+                  `extQ` considerEqual @EpLayout+                  `extQ` considerEqual @[AddEpAnn]+                  `extQ` considerEqual @AnnSig+                  `extQ` considerEqual @HsRuleAnn                   `ext2Q` forLocated                   -- unicode-related-                  `extQ` considerEqual @(HsUniToken "->" "→")-                  `extQ` considerEqual @(HsUniToken "::" "∷")-                  `extQ` considerEqual @(HsLinearArrowTokens GhcPs)+                  `extQ` considerEqual @(EpUniToken "->" "→")+                  `extQ` considerEqual @(EpUniToken "::" "∷")+                  `extQ` considerEqual @EpLinearArrow+                  `extQ` considerEqualVia' compareAnnKeywordId               )               x               y@@ -145,7 +149,10 @@       GenLocated e0 e1 ->       GenericQ ParseResultDiff     forLocated x@(L mspn _) y =-      maybe id appendSpan (cast `ext1Q` (Just . locA) $ mspn) (genericQuery x y)+      maybe id appendSpan (cast `ext1Q` (Just . epAnnLoc) $ mspn) (genericQuery x y)+      where+        epAnnLoc :: EpAnn ann -> SrcSpan+        epAnnLoc = locA     appendSpan :: SrcSpan -> ParseResultDiff -> ParseResultDiff     appendSpan s' d@(Different ss) =       case s' of@@ -165,3 +172,21 @@       (DctSingle _ ty, DctMulti _ [ty']) -> genericQuery ty ty'       (DctMulti _ [ty], DctSingle _ ty') -> genericQuery ty ty'       (x, y) -> genericQuery x y++    compareAnnKeywordId x y =+      let go = curry $ \case+            (AnnCloseB, AnnCloseBU) -> True+            (AnnCloseQ, AnnCloseQU) -> True+            (AnnDarrow, AnnDarrowU) -> True+            (AnnDcolon, AnnDcolonU) -> True+            (AnnForall, AnnForallU) -> True+            (AnnLarrow, AnnLarrowU) -> True+            (AnnOpenB, AnnOpenBU) -> True+            (AnnOpenEQ, AnnOpenEQU) -> True+            (AnnRarrow, AnnRarrowU) -> True+            (Annlarrowtail, AnnlarrowtailU) -> True+            (Annrarrowtail, AnnrarrowtailU) -> True+            (AnnLarrowtail, AnnLarrowtailU) -> True+            (AnnRarrowtail, AnnRarrowtailU) -> True+            (_, _) -> False+       in go x y || go y x || x == y

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QualifiedDo #-}@@ -17,13 +18,15 @@ import Data.Foldable (for_) import Data.IntSet (IntSet) import Data.IntSet qualified as IntSet-import Data.List (foldl') import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Text qualified as T import GHC.Types.SrcLoc import Ormolu.Terminal import Ormolu.Terminal.QualifiedDo qualified as Term+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif  ---------------------------------------------------------------------------- -- Types

@@ -69,10 +69,10 @@  ieToOccNames :: IE GhcPs -> [OccName] ieToOccNames = \case-  IEVar _ (L _ x) -> [occName x]-  IEThingAbs _ (L _ x) -> [occName x]-  IEThingAll _ (L _ x) -> [occName x] -- TODO not quite correct, but how to do better?-  IEThingWith _ (L _ x) _ xs -> occName x : fmap (occName . unLoc) xs+  IEVar _ (L _ x) _ -> [occName x]+  IEThingAbs _ (L _ x) _ -> [occName x]+  IEThingAll _ (L _ x) _ -> [occName x] -- TODO not quite correct, but how to do better?+  IEThingWith _ (L _ x) _ xs _ -> occName x : fmap (occName . unLoc) xs   _ -> []  -- | Apply given module re-exports.

@@ -45,6 +45,17 @@  type Parser = Parsec Void Text +-- TODO Support fixity namespacing?+-- https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0065-type-infix.rst+--+-- Note that currently, our fixity machinery does *not* do any namespacing:+--+--  - https://github.com/tweag/ormolu/pull/994#pullrequestreview-1396958951+--    brought this up in the past+--+--  - https://github.com/tweag/ormolu/pull/1029#issue-1718217029+--    has a concrete example (morley-prelude) where namespacing would matter+ -- | Parse textual representation of 'FixityOverrides'. parseDotOrmolu ::   -- | Location of the file we are parsing (only for parse errors)

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}@@ -14,7 +15,7 @@ import Data.Char (isAlphaNum) import Data.Foldable (toList) import Data.Function (on)-import Data.List (foldl', nubBy, sortBy, sortOn)+import Data.List (nubBy, sortBy, sortOn) import Data.Map.Strict (Map) import Data.Map.Strict qualified as M import GHC.Data.FastString@@ -25,6 +26,9 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc import Ormolu.Utils (groupBy', notImplemented, separatedByBlank, showOutputable)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif  -- | Sort, group and normalize imports. --@@ -148,33 +152,34 @@           alter = \case             Nothing -> Just . L new_l $               case new of-                IEThingWith _ n wildcard g ->-                  IEThingWith (Nothing, EpAnnNotUsed) n wildcard (normalizeWNames g)+                IEThingWith x n wildcard g _ ->+                  IEThingWith x n wildcard (normalizeWNames g) Nothing                 other -> other             Just old ->               let f = \case-                    IEVar _ n -> IEVar Nothing n-                    IEThingAbs _ _ -> new-                    IEThingAll _ n -> IEThingAll (Nothing, EpAnnNotUsed) n-                    IEThingWith _ n wildcard g ->+                    IEVar _ n _ -> IEVar Nothing n Nothing+                    IEThingAbs _ _ _ -> new+                    IEThingAll x n _ -> IEThingAll x n Nothing+                    IEThingWith _ n wildcard g _ ->                       case new of-                        IEVar _ _ ->+                        IEVar _ _ _ ->                           error "Ormolu.Imports broken presupposition"-                        IEThingAbs _ _ ->-                          IEThingWith (Nothing, EpAnnNotUsed) n wildcard g-                        IEThingAll _ n' ->-                          IEThingAll (Nothing, EpAnnNotUsed) n'-                        IEThingWith _ n' wildcard' g' ->+                        IEThingAbs x _ _ ->+                          IEThingWith x n wildcard g Nothing+                        IEThingAll x n' _ ->+                          IEThingAll x n' Nothing+                        IEThingWith x n' wildcard' g' _ ->                           let combinedWildcard =                                 case (wildcard, wildcard') of                                   (IEWildcard _, _) -> IEWildcard 0                                   (_, IEWildcard _) -> IEWildcard 0                                   _ -> NoIEWildcard                            in IEThingWith-                                (Nothing, EpAnnNotUsed)+                                x                                 n'                                 combinedWildcard                                 (normalizeWNames (g <> g'))+                                Nothing                         IEModuleContents _ _ -> notImplemented "IEModuleContents"                         IEGroup NoExtField _ _ -> notImplemented "IEGroup"                         IEDoc NoExtField _ -> notImplemented "IEDoc"@@ -197,10 +202,10 @@ -- | Project @'IEWrappedName' 'GhcPs'@ from @'IE' 'GhcPs'@. getIewn :: IE GhcPs -> IEWrappedNameOrd getIewn = \case-  IEVar _ x -> IEWrappedNameOrd (unLoc x)-  IEThingAbs _ x -> IEWrappedNameOrd (unLoc x)-  IEThingAll _ x -> IEWrappedNameOrd (unLoc x)-  IEThingWith _ x _ _ -> IEWrappedNameOrd (unLoc x)+  IEVar _ x _ -> IEWrappedNameOrd (unLoc x)+  IEThingAbs _ x _ -> IEWrappedNameOrd (unLoc x)+  IEThingAll _ x _ -> IEWrappedNameOrd (unLoc x)+  IEThingWith _ x _ _ _ -> IEWrappedNameOrd (unLoc x)   IEModuleContents _ _ -> notImplemented "IEModuleContents"   IEGroup NoExtField _ _ -> notImplemented "IEGroup"   IEDoc NoExtField _ -> notImplemented "IEDoc"

@@ -219,7 +219,7 @@         | ConstraintNever <- constraintParens -> [inner]         | otherwise -> [x]       [x@(L lx _)]-        | ConstraintAlways <- constraintParens -> [L lx (HsParTy EpAnnNotUsed x)]+        | ConstraintAlways <- constraintParens -> [L lx (HsParTy noAnn x)]         | otherwise -> [x]       xs -> xs     constraintParens = runIdentity (poSingleConstraintParens cfgPrinterOpts)

@@ -223,7 +223,7 @@  -- | Extract @'RealLocated' 'Text'@ from 'GHC.LEpaComment'. unAnnotationComment :: GHC.LEpaComment -> Maybe (RealLocated Text)-unAnnotationComment (L (GHC.Anchor anchor _) (GHC.EpaComment eck _)) =+unAnnotationComment (L epaLoc (GHC.EpaComment eck _)) =   case eck of     GHC.EpaDocComment s ->       let trigger = case s of@@ -239,9 +239,10 @@         "---" -> s         _ -> insertAt " " s 3     GHC.EpaBlockComment s -> mkL (T.pack s)-    GHC.EpaEofComment -> Nothing   where-    mkL = Just . L anchor+    mkL = case epaLoc of+      GHC.EpaSpan (RealSrcSpan s _) -> Just . L s+      _ -> const Nothing     insertAt x xs n = T.take (n - 1) xs <> x <> T.drop (n - 1) xs     haddock mtrigger =       mkL . dashPrefix . escapeHaddockTriggers . (trigger <>) <=< dropBlank

@@ -11,6 +11,7 @@     runR,     getEnclosingSpan,     getEnclosingSpanWhere,+    getEnclosingComments,     isExtensionEnabled,      -- * Combinators@@ -99,11 +100,11 @@ import Data.Text (Text) import GHC.Data.Strict qualified as Strict import GHC.LanguageExtensions.Type+import GHC.Parser.Annotation hiding (IsUnicodeSyntax (..)) import GHC.Types.SrcLoc hiding (spans) import Ormolu.Config import Ormolu.Printer.Comments import Ormolu.Printer.Internal-import Ormolu.Utils (HasSrcSpan (..), getLoc')  ---------------------------------------------------------------------------- -- Basic@@ -123,13 +124,13 @@ -- 'Located' wrapper, it should be “discharged” with a corresponding -- 'located' invocation. located ::-  (HasSrcSpan l) =>+  (HasLoc l) =>   -- | Thing to enter   GenLocated l a ->   -- | How to render inner value   (a -> R ()) ->   R ()-located (L l' a) f = case loc' l' of+located (L l' a) f = case locA l' of   UnhelpfulSpan _ -> f a   RealSrcSpan l _ -> do     spitPrecedingComments l@@ -141,7 +142,7 @@ -- virtual elements at the start and end of the source span to prevent comments -- from "floating out". encloseLocated ::-  (HasSrcSpan l) =>+  (HasLoc l) =>   GenLocated l [a] ->   ([a] -> R ()) ->   R ()@@ -150,13 +151,13 @@   f a   when (null a) $ located (L endSpan ()) pure   where-    l = getLoc' la+    l = locA la     (startLoc, endLoc) = (srcSpanStart l, srcSpanEnd l)     (startSpan, endSpan) = (mkSrcSpan startLoc startLoc, mkSrcSpan endLoc endLoc)  -- | A version of 'located' with arguments flipped. located' ::-  (HasSrcSpan l) =>+  (HasLoc l) =>   -- | How to render inner value   (a -> R ()) ->   -- | Thing to enter

@@ -42,6 +42,7 @@     trimSpanStream,     nextEltSpan,     popComment,+    getEnclosingComments,     getEnclosingSpan,     getEnclosingSpanWhere,     withEnclosingSpan,@@ -64,6 +65,7 @@ import Control.Monad.State.Strict import Data.Bool (bool) import Data.Coerce+import Data.Functor ((<&>)) import Data.Functor.Identity (runIdentity) import Data.List (find) import Data.Maybe (listToMaybe)@@ -537,6 +539,16 @@       modify $ \sc -> sc {scCommentStream = CommentStream xs}       return $ Just x     _ -> return Nothing++-- | Get the comments contained in the enclosing span.+getEnclosingComments :: R [LComment]+getEnclosingComments = do+  isEnclosed <-+    getEnclosingSpan <&> \case+      Just enclSpan -> containsSpan enclSpan+      Nothing -> const False+  CommentStream cstream <- R $ gets scCommentStream+  pure $ takeWhile (isEnclosed . getLoc) cstream  -- | Get the immediately enclosing 'RealSrcSpan'. getEnclosingSpan :: R (Maybe RealSrcSpan)

@@ -13,6 +13,7 @@     p_hsDoc,     p_hsDoc',     p_sourceText,+    p_namespaceSpec,   ) where @@ -20,6 +21,7 @@ import Data.Foldable (traverse_) import Data.Text qualified as T import GHC.Data.FastString+import GHC.Hs.Binds import GHC.Hs.Doc import GHC.Hs.Extension (GhcPs) import GHC.Hs.ImpExp@@ -67,18 +69,16 @@ p_rdrName :: LocatedN RdrName -> R () p_rdrName l = located l $ \x -> do   unboxedSums <- isExtensionEnabled UnboxedSums-  let wrapper = \case-        EpAnn {anns} -> case anns of-          NameAnnQuote {nann_quoted} -> tickPrefix . wrapper (ann nann_quoted)-          NameAnn {nann_adornment = NameParens} ->-            parens N . handleUnboxedSumsAndHashInteraction-          NameAnn {nann_adornment = NameBackquotes} -> backticks-          -- whether the `->` identifier is parenthesized-          NameAnnRArrow {nann_mopen = Just _} -> parens N-          -- special case for unboxed unit tuples-          NameAnnOnly {nann_adornment = NameParensHash} -> const $ txt "(# #)"-          _ -> id-        EpAnnNotUsed -> id+  let wrapper EpAnn {anns} = case anns of+        NameAnnQuote {nann_quoted} -> tickPrefix . wrapper nann_quoted+        NameAnn {nann_adornment = NameParens} ->+          parens N . handleUnboxedSumsAndHashInteraction+        NameAnn {nann_adornment = NameBackquotes} -> backticks+        -- whether the `->` identifier is parenthesized+        NameAnnRArrow {nann_mopen = Just _} -> parens N+        -- special case for unboxed unit tuples+        NameAnnOnly {nann_adornment = NameParensHash} -> const $ txt "(# #)"+        _ -> id        -- When UnboxedSums is enabled, `(#` is a single lexeme, so we have to       -- insert spaces when we have a parenthesized operator starting with `#`.@@ -89,7 +89,7 @@             \y -> space *> y <* space         | otherwise = id -  wrapper (ann . getLoc $ l) $ case x of+  wrapper (getLoc l) $ case x of     Unqual occName ->       atom occName     Qual mname occName ->@@ -252,3 +252,9 @@ p_sourceText = \case   NoSourceText -> pure ()   SourceText s -> atom @FastString s++p_namespaceSpec :: NamespaceSpecifier -> R ()+p_namespaceSpec = \case+  NoNamespaceSpecifier -> pure ()+  TypeNamespaceSpecifier _ -> txt "type" *> space+  DataNamespaceSpecifier _ -> txt "data" *> space

@@ -260,7 +260,7 @@ pattern AnnValuePragma n <- AnnD _ (HsAnnotation _ (ValueAnnProvenance (L _ n)) _) pattern Pattern n <- ValD _ (PatSynBind _ (PSB _ (L _ n) _ _ _)) pattern DataDeclaration n <- TyClD _ (DataDecl _ (L _ n) _ _ _)-pattern ClassDeclaration n <- TyClD _ (ClassDecl _ _ _ (L _ n) _ _ _ _ _ _ _ _)+pattern ClassDeclaration n <- TyClD _ (ClassDecl _ _ (L _ n) _ _ _ _ _ _ _ _) pattern KindSignature n <- KindSigD _ (StandaloneKindSig _ (L _ n) _) pattern FamilyDeclaration n <- TyClD _ (FamDecl _ (FamilyDecl _ _ _ (L _ n) _ _ _ _)) pattern TypeSynonym n <- TyClD _ (SynDecl _ (L _ n) _ _ _)@@ -296,7 +296,7 @@  funRdrNames :: HsDecl GhcPs -> Maybe [RdrName] funRdrNames (ValD _ (FunBind _ (L _ n) _)) = Just [n]-funRdrNames (ValD _ (PatBind _ (L _ n) _)) = Just $ patBindNames n+funRdrNames (ValD _ (PatBind _ (L _ n) _ _)) = Just $ patBindNames n funRdrNames _ = Nothing  patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName]@@ -315,9 +315,9 @@ patBindNames (WildPat _) = [] patBindNames (LazyPat _ (L _ p)) = patBindNames p patBindNames (BangPat _ (L _ p)) = patBindNames p-patBindNames (ParPat _ _ (L _ p) _) = patBindNames p+patBindNames (ParPat _ (L _ p)) = patBindNames p patBindNames (ListPat _ ps) = concatMap (patBindNames . unLoc) ps-patBindNames (AsPat _ (L _ n) _ (L _ p)) = n : patBindNames p+patBindNames (AsPat _ (L _ n) (L _ p)) = n : patBindNames p patBindNames (SumPat _ (L _ p) _ _) = patBindNames p patBindNames (ViewPat _ _ (L _ p)) = patBindNames p patBindNames (SplicePat _ _) = []@@ -326,3 +326,5 @@ patBindNames (NPat _ _ _ _) = [] patBindNames (NPlusKPat _ (L _ n) _ _ _ _) = [n] patBindNames (ConPat _ _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d)+patBindNames (EmbTyPat _ _) = []+patBindNames (InvisPat _ _) = []

@@ -13,7 +13,7 @@ import Control.Monad import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE-import Data.Maybe (isJust, maybeToList)+import Data.Maybe (isJust, mapMaybe, maybeToList) import Data.Text qualified as Text import Data.Void import GHC.Data.Strict qualified as Strict@@ -141,8 +141,8 @@             <> conArgsSpans           where             conArgsSpans = case con_g_args of-              PrefixConGADT xs -> getLocA . hsScaledThing <$> xs-              RecConGADT x _ -> [getLocA x]+              PrefixConGADT NoExtField xs -> getLocA . hsScaledThing <$> xs+              RecConGADT _ x -> [getLocA x]     switchLayout conDeclSpn $ do       let c :| cs = con_names       p_rdrName c@@ -151,23 +151,24 @@         sep commaDel p_rdrName cs       inci $ do         let conTy = case con_g_args of-              PrefixConGADT xs ->-                let go (HsScaled a b) t = addCLocAA t b (HsFunTy EpAnnNotUsed a b t)+              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 _ ->-                addCLocAA r con_res_ty $+              RecConGADT _ r ->+                addCLocA r con_res_ty $                   HsFunTy-                    EpAnnNotUsed-                    (HsUnrestrictedArrow noHsUniTok)-                    (la2la $ HsRecTy EpAnnNotUsed <$> r)+                    NoExtField+                    (HsUnrestrictedArrow noAnn)+                    (la2la $ HsRecTy noAnn <$> r)                     con_res_ty             qualTy = case con_mb_cxt of               Nothing -> conTy               Just qs ->-                addCLocAA qs conTy $+                addCLocA qs conTy $                   HsQualTy NoExtField qs conTy+            quantifiedTy :: LHsType GhcPs             quantifiedTy =-              addCLocAA con_bndrs qualTy $+              addCLocA con_bndrs qualTy $                 hsOuterTyVarBndrsToHsType (unLoc con_bndrs) qualTy         startTypeAnnotationDecl quantifiedTy id p_hsType   ConDeclH98 {..} -> do@@ -175,7 +176,8 @@     let conNameSpn = getLocA con_name         conNameWithContextSpn =           [ RealSrcSpan real Strict.Nothing-            | Just (EpaSpan real _) <- matchAddEpAnn AnnForall <$> epAnnAnns con_ext+            | EpaSpan (RealSrcSpan real _) <-+                mapMaybe (matchAddEpAnn AnnForall) con_ext           ]             <> fmap getLocA con_ex_tvs             <> maybeToList (fmap getLocA con_mb_cxt)

@@ -55,7 +55,7 @@   space   located cCallConv atom   -- Need to check for 'noLoc' for the 'safe' annotation-  when (isGoodSrcSpan $ getLoc safety) (space >> atom safety)+  when (isGoodSrcSpan $ getLocA safety) (space >> atom safety)   space   located sourceText p_sourceText 

@@ -15,6 +15,7 @@ import Data.Foldable import Data.Function (on) import Data.List (sortBy)+import Data.Maybe (maybeToList) import GHC.Hs import GHC.Types.Basic import GHC.Types.SrcLoc@@ -23,13 +24,17 @@ import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration import Ormolu.Printer.Meat.Declaration.Data import Ormolu.Printer.Meat.Declaration.TypeFamily+import Ormolu.Printer.Meat.Declaration.Warning import Ormolu.Printer.Meat.Type  p_standaloneDerivDecl :: DerivDecl GhcPs -> R ()-p_standaloneDerivDecl DerivDecl {..} = do+p_standaloneDerivDecl DerivDecl {deriv_ext = (mWarnTxt, _), ..} = do   let typesAfterInstance = located (hswc_body deriv_type) p_hsSigType       instTypes toIndent = inci $ do         txt "instance"+        for_ mWarnTxt $ \warnTxt -> do+          breakpoint+          located warnTxt p_warningTxt         breakpoint         match_overlap_mode deriv_overlap_mode breakpoint         inciIf toIndent typesAfterInstance@@ -56,7 +61,7 @@         instTypes True  p_clsInstDecl :: ClsInstDecl GhcPs -> R ()-p_clsInstDecl ClsInstDecl {..} = do+p_clsInstDecl ClsInstDecl {cid_ext = (mWarnTxt, _, _), ..} = do   txt "instance"   -- GHC's AST does not necessarily store each kind of element in source   -- location order. This happens because different declarations are stored in@@ -74,9 +79,12 @@           <$> cid_datafam_insts       allDecls =         snd <$> sortBy (leftmost_smallest `on` fst) (sigs <> vals <> tyFamInsts <> dataFamInsts)-  located cid_poly_ty $ \sigTy -> do+  switchLayout (maybeToList (getLocA <$> mWarnTxt) <> [getLocA cid_poly_ty]) $ do+    for_ mWarnTxt $ \warnTxt -> do+      breakpoint+      located warnTxt p_warningTxt     breakpoint-    inci $ do+    located cid_poly_ty $ \sigTy -> inci $ do       match_overlap_mode cid_overlap_mode breakpoint       p_hsSigType sigTy       unless (null allDecls) $ do

@@ -35,7 +35,6 @@   ) import Ormolu.Printer.Meat.Type (p_hsType) import Ormolu.Printer.Operators-import Ormolu.Utils (HasSrcSpan)  -- | Extract the operator name of the specified 'HsExpr' if this expression -- corresponds to an operator.@@ -50,7 +49,7 @@  -- | Decide if the operands of an operator chain should be hanging. opBranchPlacement ::-  (HasSrcSpan l) =>+  (HasLoc l) =>   -- | Placer function for nodes   (ty -> Placement) ->   -- | first expression of the chain

@@ -88,7 +88,7 @@   FixitySig GhcPs ->   R () p_fixSig = \case-  FixitySig NoExtField names (Fixity _ n dir) -> do+  FixitySig namespace names (Fixity _ n dir) -> do     txt $ case dir of       InfixL -> "infixl"       InfixR -> "infixr"@@ -96,6 +96,7 @@     space     atom n     space+    p_namespaceSpec namespace     sitcc $ sep commaDel p_rdrName names  p_inlineSig ::@@ -193,12 +194,12 @@  p_completeSig ::   -- | Constructors\/patterns-  Located [LocatedN RdrName] ->+  [LIdP GhcPs] ->   -- | Type   Maybe (LocatedN RdrName) ->   R ()-p_completeSig cs' mty =-  located cs' $ \cs ->+p_completeSig cs mty =+  switchLayout (getLocA <$> cs) $     pragma "COMPLETE" . inci $ do       sep commaDel p_rdrName cs       forM_ mty $ \ty -> do

@@ -72,7 +72,8 @@ p_valDecl :: HsBind GhcPs -> R () p_valDecl = \case   FunBind _ funId funMatches -> p_funBind funId funMatches-  PatBind _ pat grhss -> p_match PatternBind False NoSrcStrict [pat] grhss+  PatBind _ pat multAnn grhss ->+    p_match PatternBind False multAnn NoSrcStrict [pat] grhss   VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker   PatSynBind _ psb -> p_patSynBind psb @@ -89,7 +90,7 @@ p_matchGroup = p_matchGroup' exprPlacement p_hsExpr  p_matchGroup' ::-  ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns,+  ( Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO,     Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA   ) =>   -- | How to get body placement@@ -119,6 +120,7 @@         render         (adjustMatchGroupStyle m style)         (isInfixMatch m)+        (HsNoMultAnn NoExtField)         (matchStrictness m)         m_pats         m_grhss@@ -148,6 +150,8 @@   MatchGroupStyle ->   -- | Is this an infix match?   Bool ->+  -- | Multiplicity annotation+  HsMultAnn GhcPs ->   -- | Strictness prefix (FunBind)   SrcStrictness ->   -- | Argument patterns@@ -158,7 +162,7 @@ p_match = p_match' exprPlacement p_hsExpr  p_match' ::-  (Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns) =>+  (Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO) =>   -- | How to get body placement   (body -> Placement) ->   -- | How to print body@@ -167,6 +171,8 @@   MatchGroupStyle ->   -- | Is this an infix match?   Bool ->+  -- | Multiplicity annotation+  HsMultAnn GhcPs ->   -- | Strictness prefix (FunBind)   SrcStrictness ->   -- | Argument patterns@@ -174,7 +180,7 @@   -- | Equations   GRHSs GhcPs (LocatedA body) ->   R ()-p_match' placer render style isInfix strictness m_pats GRHSs {..} = do+p_match' placer render style isInfix multAnn strictness m_pats GRHSs {..} = do   -- Normally, since patterns may be placed in a multi-line layout, it is   -- necessary to bump indentation for the pattern group so it's more   -- indented than function name. This in turn means that indentation for@@ -182,6 +188,13 @@   -- would start with two indentation steps applied, which is ugly, so we   -- need to be a bit more clever here and bump indentation level only when   -- pattern group is multiline.+  case multAnn of+    HsNoMultAnn NoExtField -> pure ()+    HsPct1Ann _ -> txt "%1" *> space+    HsMultAnn _ ty -> do+      txt "%"+      located ty p_hsType+      space   case strictness of     NoSrcStrict -> return ()     SrcStrict -> txt "!"@@ -213,6 +226,7 @@                   LazyPat _ _ -> True                   BangPat _ _ -> True                   SplicePat _ _ -> True+                  InvisPat _ _ -> True                   _ -> False             txt "\\"             when needsSpace space@@ -363,15 +377,13 @@     located cmd (p_hsCmd' Applicand s)     breakpoint     inci $ located expr p_hsExpr-  HsCmdLam _ mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup-  HsCmdPar _ _ c _ -> parens N $ sitcc $ located c p_hsCmd+  HsCmdLam _ variant mgroup -> p_lam isApp variant cmdPlacement p_hsCmd mgroup+  HsCmdPar _ c -> parens N $ sitcc $ located c p_hsCmd   HsCmdCase _ e mgroup ->     p_case isApp cmdPlacement p_hsCmd e mgroup-  HsCmdLamCase _ variant mgroup ->-    p_lamcase isApp variant cmdPlacement p_hsCmd mgroup   HsCmdIf anns _ if' then' else' ->     p_if cmdPlacement p_hsCmd anns if' then' else'-  HsCmdLet _ letToken localBinds _ c ->+  HsCmdLet (letToken, _) localBinds c ->     p_let (s == S) p_hsCmd letToken localBinds c   HsCmdDo _ es -> do     txt "do"@@ -442,7 +454,6 @@     let letLoc =           fmap (\(AddEpAnn _ loc) -> loc)             . find (\(AddEpAnn ann _) -> ann == AnnLet)-            . epAnnAnns             $ epAnnLet     p_let' True letLoc binds Nothing   ParStmt {} ->@@ -559,11 +570,10 @@     -- of p_hsLocalBinds). Hence, we introduce a manual Located as we     -- depend on the layout being correctly set.     pseudoLocated = \case-      EpAnn {anns = AnnList {al_anchor = Just Anchor {anchor}}}-        | let sp = RealSrcSpan anchor Strict.Nothing,-          -- excluding cases where there are no bindings-          not $ isZeroWidthSpan sp ->-            located (L sp ()) . const+      EpAnn {anns = AnnList {al_anchor}}+        | -- excluding cases where there are no bindings+          not $ isZeroWidthSpan (locA al_anchor) ->+            located (L al_anchor ()) . const       _ -> id  p_ldotFieldOcc :: XRec GhcPs (DotFieldOcc GhcPs) -> R ()@@ -577,7 +587,7 @@ p_fieldOcc FieldOcc {..} = p_rdrName foLabel  p_hsFieldBind ::-  (lhs ~ GenLocated l a, HasSrcSpan l) =>+  (lhs ~ GenLocated l a, HasLoc l) =>   (lhs -> R ()) ->   HsFieldBind lhs (LHsExpr GhcPs) ->   R ()@@ -587,7 +597,7 @@     space     equals     let placement =-          if onTheSameLine (getLoc' hfbLHS) (getLocA hfbRHS)+          if onTheSameLine (getLocA hfbLHS) (getLocA hfbRHS)             then exprPlacement (unLoc hfbRHS)             else Normal     placeHanging placement (located hfbRHS p_hsExpr)@@ -626,10 +636,8 @@       HsString (SourceText stxt) _ -> p_stringLit stxt       HsStringPrim (SourceText stxt) _ -> p_stringLit stxt       r -> atom r-  HsLam _ mgroup ->-    p_matchGroup Lambda mgroup-  HsLamCase _ variant mgroup ->-    p_lamcase isApp variant exprPlacement p_hsExpr mgroup+  HsLam _ variant mgroup ->+    p_lam isApp variant exprPlacement p_hsExpr mgroup   HsApp _ f x -> do     let -- In order to format function applications with multiple parameters         -- nicer, traverse the AST to gather the function and all the@@ -687,7 +695,7 @@           sep breakpoint (located' p_hsExpr) initp         placeHanging placement $           located lastp p_hsExpr-  HsAppType _ e _ a -> do+  HsAppType _ e a -> do     located e p_hsExpr     breakpoint     inci $ do@@ -716,7 +724,7 @@     -- negated literals, as `- 1` and `-1` have differing AST.     when (negativeLiterals && isLiteral) space     located e p_hsExpr-  HsPar _ _ e _ ->+  HsPar _ e ->     parens s $ sitcc (located e (dontUseBraces . p_hsExpr))   SectionL _ x op -> do     located x p_hsExpr@@ -759,7 +767,7 @@     txt "if"     breakpoint     inciApplicand isApp $ sep newline (located' (p_grhs RightArrow)) guards-  HsLet _ letToken localBinds _ e ->+  HsLet (letToken, _) localBinds e ->     p_let (s == S) p_hsExpr letToken localBinds e   HsDo _ doFlavor es -> do     let doBody moduleName header = do@@ -857,7 +865,7 @@     located expr p_hsExpr     breakpoint'     txt "||]"-  HsUntypedBracket epAnn x -> p_hsQuote epAnn x+  HsUntypedBracket anns x -> p_hsQuote anns x   HsTypedSplice _ expr -> p_hsSpliceTH True expr DollarSplice   HsUntypedSplice _ untySplice -> p_hsUntypedSplice DollarSplice untySplice   HsProc _ p e -> do@@ -881,6 +889,10 @@       breakpoint       let inciIfS = case s of N -> id; S -> inci       inciIfS $ located x p_hsExpr+  HsEmbTy _ HsWC {hswc_body} -> do+    txt "type"+    space+    located hswc_body p_hsType  p_patSynBind :: PatSynBind GhcPs GhcPs -> R () p_patSynBind PSB {..} = do@@ -942,7 +954,7 @@       inci (rhs conSpans)  p_case ::-  ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns,+  ( Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO,     Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA   ) =>   IsApplicand ->@@ -964,13 +976,13 @@   breakpoint   inciApplicand isApp (p_matchGroup' placer render Case mgroup) -p_lamcase ::-  ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns,+p_lam ::+  ( Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO,     Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA   ) =>   IsApplicand ->-  -- | Variant (@\\case@ or @\\cases@)-  LamCaseVariant ->+  -- | Variant (@\\@ or @\\case@ or @\\cases@)+  HsLamVariant ->   -- | Placer   (body -> Placement) ->   -- | Render@@ -978,12 +990,19 @@   -- | Expression   MatchGroup GhcPs (LocatedA body) ->   R ()-p_lamcase isApp variant placer render mgroup = do-  txt $ case variant of-    LamCase -> "\\case"-    LamCases -> "\\cases"-  breakpoint-  inciApplicand isApp (p_matchGroup' placer render LambdaCase mgroup)+p_lam isApp variant placer render mgroup = do+  let mCaseTxt = case variant of+        LamSingle -> Nothing+        LamCase -> Just "\\case"+        LamCases -> Just "\\cases"+      mgs = if isJust mCaseTxt then LambdaCase else Lambda+      pMatchGroup = p_matchGroup' placer render mgs mgroup+  case mCaseTxt of+    Nothing -> pMatchGroup+    Just caseTxt -> do+      txt caseTxt+      breakpoint+      inciApplicand isApp pMatchGroup  p_if ::   -- | Placer@@ -991,7 +1010,7 @@   -- | Render   (body -> R ()) ->   -- | Annotations-  EpAnn AnnsIf ->+  AnnsIf ->   -- | If   LHsExpr GhcPs ->   -- | Then@@ -999,11 +1018,30 @@   -- | Else   LocatedA body ->   R ()-p_if placer render epAnn if' then' else' = do+p_if placer render anns if' then' else' = do   txt "if"   space   located if' p_hsExpr   breakpoint+  commentSpans <- fmap getLoc <$> getEnclosingComments+  let (thenSpan, elseSpan) = (locA aiThen, locA aiElse)+        where+          AnnsIf {aiThen, aiElse} = anns++      locatedToken tokenSpan token =+        located (L tokenSpan ()) $ \_ -> txt token++      betweenSpans spanA spanB s = spanA < s && s < spanB++      placeHangingLocated tokenSpan bodyLoc@(L _ body) = do+        let bodySpan = getLocA bodyLoc+            hasComments = fromMaybe False $ do+              tokenRealSpan <- srcSpanToRealSrcSpan tokenSpan+              bodyRealSpan <- srcSpanToRealSrcSpan bodySpan+              pure $ any (betweenSpans tokenRealSpan bodyRealSpan) commentSpans+            placement = if hasComments then Normal else placer body+        switchLayout [tokenSpan, bodySpan] $+          placeHanging placement (located bodyLoc render)   inci $ do     locatedToken thenSpan "then"     space@@ -1012,51 +1050,23 @@     locatedToken elseSpan "else"     space     placeHangingLocated elseSpan else'-  where-    (thenSpan, elseSpan, commentSpans) =-      case epAnn of-        EpAnn {anns = AnnsIf {aiThen, aiElse}, comments} ->-          ( loc' $ epaLocationRealSrcSpan aiThen,-            loc' $ epaLocationRealSrcSpan aiElse,-            map (anchor . getLoc) $-              case comments of-                EpaComments cs -> cs-                EpaCommentsBalanced pre post -> pre <> post-          )-        EpAnnNotUsed ->-          (noSrcSpan, noSrcSpan, []) -    locatedToken tokenSpan token =-      located (L tokenSpan ()) $ \_ -> txt token--    betweenSpans spanA spanB s = spanA < s && s < spanB--    placeHangingLocated tokenSpan bodyLoc@(L _ body) = do-      let bodySpan = getLoc' bodyLoc-          hasComments = fromMaybe False $ do-            tokenRealSpan <- srcSpanToRealSrcSpan tokenSpan-            bodyRealSpan <- srcSpanToRealSrcSpan bodySpan-            pure $ any (betweenSpans tokenRealSpan bodyRealSpan) commentSpans-          placement = if hasComments then Normal else placer body-      switchLayout [tokenSpan, bodySpan] $-        placeHanging placement (located bodyLoc render)- p_let ::   -- | True if in do-block   Bool ->   -- | Render   (body -> R ()) ->   -- | Annotation for the `let` block-  LHsToken "let" GhcPs ->+  EpToken "let" ->   HsLocalBinds GhcPs ->   LocatedA body ->   R () p_let inDo render letToken localBinds e = p_let' inDo letLoc localBinds $ Just (located e render)   where     letLoc =-      case getLoc letToken of-        TokenLoc loc -> Just loc-        NoTokenLoc -> Nothing+      case letToken of+        EpTok loc -> Just loc+        NoEpTok -> Nothing  p_let' ::   -- | True if in do-block@@ -1132,9 +1142,10 @@       HsValBinds epanns _ -> Just epanns       HsIPBinds epanns _ -> Just epanns       EmptyLocalBinds _ -> Nothing-    epAnnsStartLine = \case-      EpAnn {entry} -> Just (srcSpanStartLine . anchor $ entry)-      EpAnnNotUsed -> Nothing+    epAnnsStartLine epAnn =+      case entry epAnn of+        EpaSpan (RealSrcSpan r _) -> Just $ srcSpanStartLine r+        _ -> Nothing  p_pat :: Pat GhcPs -> R () p_pat = \case@@ -1143,11 +1154,11 @@   LazyPat _ pat -> do     txt "~"     located pat p_pat-  AsPat _ name _ pat -> do+  AsPat _ name pat -> do     p_rdrName name     txt "@"     located pat p_pat-  ParPat _ _ pat _ ->+  ParPat _ pat ->     located pat (parens S . sitcc . p_pat)   BangPat _ pat -> do     txt "!"@@ -1212,12 +1223,17 @@   SigPat _ pat HsPS {..} -> do     located pat p_pat     p_typeAscription (lhsTypeToSigType hsps_body)+  EmbTyPat _ (HsTP _ ty) -> do+    txt "type"+    space+    located ty p_hsType+  InvisPat _ tyPat -> p_tyPat tyPat -p_hsPatSigType :: HsPatSigType GhcPs -> R ()-p_hsPatSigType (HsPS _ ty) = txt "@" *> located ty p_hsType+p_tyPat :: HsTyPat GhcPs -> R ()+p_tyPat (HsTP _ ty) = txt "@" *> located ty p_hsType  p_hsConPatTyArg :: HsConPatTyArg GhcPs -> R ()-p_hsConPatTyArg (HsConPatTyArg _ patSigTy) = p_hsPatSigType patSigTy+p_hsConPatTyArg (HsConPatTyArg _ patSigTy) = p_tyPat patSigTy  p_pat_hsFieldBind :: HsRecField GhcPs (LPat GhcPs) -> R () p_pat_hsFieldBind HsFieldBind {..} = do@@ -1272,11 +1288,11 @@   where     decoSymbol = if isTyped then "$$" else "$" -p_hsQuote :: EpAnn [AddEpAnn] -> HsQuote GhcPs -> R ()-p_hsQuote epAnn = \case+p_hsQuote :: [AddEpAnn] -> HsQuote GhcPs -> R ()+p_hsQuote anns = \case   ExpBr _ expr -> do     let name-          | any isJust (matchAddEpAnn AnnOpenEQ <$> epAnnAnns epAnn) = ""+          | any (isJust . matchAddEpAnn AnnOpenEQ) anns = ""           | otherwise = "e"     quote name (located expr p_hsExpr)   PatBr _ pat -> located pat (quote "p" . p_pat)@@ -1387,10 +1403,9 @@ -- | Determine placement of a given command. cmdPlacement :: HsCmd GhcPs -> Placement cmdPlacement = \case-  HsCmdLam _ _ -> Hanging-  HsCmdCase _ _ _ -> Hanging-  HsCmdLamCase _ _ _ -> Hanging-  HsCmdDo _ _ -> Hanging+  HsCmdLam {} -> Hanging+  HsCmdCase {} -> Hanging+  HsCmdDo {} -> Hanging   _ -> Normal  -- | Determine placement of a top level command.@@ -1401,12 +1416,14 @@ exprPlacement :: HsExpr GhcPs -> Placement exprPlacement = \case   -- Only hang lambdas with single line parameter lists-  HsLam _ mg -> case mg of-    MG _ (L _ [L _ (Match _ _ (x : xs) _)])-      | isOneLineSpan (combineSrcSpans' $ fmap getLocA (x :| xs)) ->-          Hanging-    _ -> Normal-  HsLamCase _ _ _ -> Hanging+  HsLam _ variant mg -> case variant of+    LamSingle -> case mg of+      MG _ (L _ [L _ (Match _ _ (x : xs) _)])+        | isOneLineSpan (combineSrcSpans' $ fmap getLocA (x :| xs)) ->+            Hanging+      _ -> Normal+    LamCase -> Hanging+    LamCases -> Hanging   HsCase _ _ _ -> Hanging   HsDo _ (DoExpr _) _ -> Hanging   HsDo _ (MDoExpr _) _ -> Hanging

@@ -12,7 +12,6 @@ import Data.Text (Text) import Data.Text qualified as T import GHC.Hs-import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Unit.Module.Warnings@@ -25,24 +24,21 @@   traverse_ (located' p_warnDecl) warnings  p_warnDecl :: WarnDecl GhcPs -> R ()-p_warnDecl (Warning _ functions warningTxt) =-  p_topLevelWarning functions warningTxt--p_warningTxt :: WarningTxt GhcPs -> R ()-p_warningTxt wtxt = do-  let (pragmaText, lits) = warningText wtxt-  inci $ pragma pragmaText $ inci $ p_lits lits--p_topLevelWarning :: [LocatedN RdrName] -> WarningTxt GhcPs -> R ()-p_topLevelWarning fnames wtxt = do+p_warnDecl (Warning (namespace, _) fnames wtxt) = do   let (pragmaText, lits) = warningText wtxt-  switchLayout (fmap getLocA fnames ++ fmap getLoc lits) $+  switchLayout (fmap getLocA fnames ++ fmap getLocA lits) $     pragma pragmaText . inci $ do+      p_namespaceSpec namespace       sep commaDel p_rdrName fnames       breakpoint       p_lits lits -warningText :: WarningTxt GhcPs -> (Text, [Located StringLiteral])+p_warningTxt :: WarningTxt GhcPs -> R ()+p_warningTxt wtxt = do+  let (pragmaText, lits) = warningText wtxt+  inci $ pragma pragmaText $ inci $ p_lits lits++warningText :: WarningTxt GhcPs -> (Text, [LocatedE StringLiteral]) warningText = \case   WarningTxt mcat _ lits -> ("WARNING" <> T.pack cat, fmap hsDocString <$> lits)     where@@ -52,7 +48,7 @@         Nothing -> ""   DeprecatedTxt _ lits -> ("DEPRECATED", fmap hsDocString <$> lits) -p_lits :: [Located StringLiteral] -> R ()+p_lits :: [LocatedE StringLiteral] -> R () p_lits = \case   [l] -> atom l   ls -> brackets N $ sep commaDel atom ls

@@ -10,7 +10,7 @@ where  import Control.Monad-import Data.Foldable (for_)+import Data.Foldable (for_, traverse_) import Data.List (inits) import Data.Text qualified as T import GHC.Hs@@ -29,8 +29,13 @@     layout <- getLayout     sep       breakpoint-      (\(isAllPrevDoc, p, l) -> sitcc (located l (p_lie layout isAllPrevDoc p)))+      (\(isAllPrevDoc, p, l) -> sitcc (located (addDocSrcSpan l) (p_lie layout isAllPrevDoc p)))       (withAllPrevDoc $ attachRelativePos xs)+  where+    -- In order to correctly set the layout when a doc comment is present.+    addDocSrcSpan lie@(L l ie) = case ieExportDoc ie of+      Nothing -> lie+      Just (L l' _) -> L (l <> noAnnSrcSpan l') ie  p_hsmodImport :: ImportDecl GhcPs -> R () p_hsmodImport ImportDecl {..} = do@@ -79,31 +84,37 @@  p_lie :: Layout -> Bool -> RelativePos -> IE GhcPs -> R () p_lie encLayout isAllPrevDoc relativePos = \case-  IEVar mwarn l1 -> do+  IEVar mwarn l1 exportDoc -> do     for_ mwarn $ \warnTxt -> do       located warnTxt p_warningTxt       breakpoint     withComma $       located l1 p_ieWrappedName-  IEThingAbs _ l1 ->+    p_exportDoc exportDoc+  IEThingAbs _ l1 exportDoc -> do     withComma $       located l1 p_ieWrappedName-  IEThingAll _ l1 -> withComma $ do-    located l1 p_ieWrappedName-    space-    txt "(..)"-  IEThingWith _ l1 w xs -> sitcc . withComma $ do-    located l1 p_ieWrappedName-    breakIfNotDiffFriendly-    inci $ do-      let names :: [R ()]-          names = located' p_ieWrappedName <$> xs-      parens' False . sep commaDelImportExport sitcc $-        case w of-          NoIEWildcard -> names-          IEWildcard n ->-            let (before, after) = splitAt n names-             in before ++ [txt ".."] ++ after+    p_exportDoc exportDoc+  IEThingAll _ l1 exportDoc -> do+    withComma $ do+      located l1 p_ieWrappedName+      space+      txt "(..)"+    p_exportDoc exportDoc+  IEThingWith _ l1 w xs exportDoc -> sitcc $ do+    withComma $ do+      located l1 p_ieWrappedName+      breakIfNotDiffFriendly+      inci $ do+        let names :: [R ()]+            names = located' p_ieWrappedName <$> xs+        parens' False . sep commaDelImportExport sitcc $+          case w of+            NoIEWildcard -> names+            IEWildcard n ->+              let (before, after) = splitAt n names+               in before ++ [txt ".."] ++ after+    p_exportDoc exportDoc   IEModuleContents _ l1 ->     withComma $       located l1 p_hsmodName@@ -138,6 +149,16 @@                 SinglePos -> m                 _ -> comma >> space >> m             Trailing -> m >> comma++    -- This is used to support `@since` annotations for (re)exported items. It+    -- /must/ use caret style comments, see+    -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12098 and+    -- https://github.com/haskell/haddock/issues/1629#issuecomment-1931354411.+    p_exportDoc :: Maybe (ExportDoc GhcPs) -> R ()+    p_exportDoc = traverse_ $ \exportDoc -> do+      breakpoint+      p_hsDoc Caret False exportDoc+     indentDoc m = do       commaStyle <- getCommaStyle       case commaStyle of@@ -147,6 +168,17 @@             SinglePos -> m             FirstPos -> m             _ -> inciBy 2 m++ieExportDoc :: IE GhcPs -> Maybe (ExportDoc GhcPs)+ieExportDoc = \case+  IEVar _ _ doc -> doc+  IEThingAbs _ _ doc -> doc+  IEThingAll _ _ doc -> doc+  IEThingWith _ _ _ _ doc -> doc+  IEModuleContents {} -> Nothing+  IEGroup {} -> Nothing+  IEDoc {} -> Nothing+  IEDocNamed {} -> Nothing  ---------------------------------------------------------------------------- 

@@ -104,6 +104,6 @@           (epaLocationRealSrcSpan moduleLoc, epaLocationRealSrcSpan whereLoc)         anns -> error $ "Module had unexpected annotations: " ++ showSDocUnsafe (ppr anns)     exportClosePSpan = do-      AddEpAnn AnnCloseP loc <- al_close . anns . ann . getLoc =<< hsmodExports+      AddEpAnn AnnCloseP loc <- al_close . anns . getLoc =<< hsmodExports       Just $ epaLocationRealSrcSpan loc     isOnSameLine token1 token2 = srcSpanEndLine token1 == srcSpanStartLine token2

@@ -84,7 +84,7 @@       breakpoint       inci $         sep breakpoint (located' p_hsType) args-  HsAppKindTy _ ty _ kd -> sitcc $ do+  HsAppKindTy _ ty kd -> sitcc $ do     -- The first argument is the location of the "@..." part. Not 100% sure,     -- but I think we can ignore it as long as we use 'located' on both the     -- type and the kind.@@ -98,7 +98,7 @@           case arrow of             HsUnrestrictedArrow _ -> token'rarrow             HsLinearArrow _ -> token'lolly-            HsExplicitMult _ mult _ -> do+            HsExplicitMult _ mult -> do               txt "%"               p_hsTypeR (unLoc mult)               space@@ -200,14 +200,14 @@     p_hsTypeR m = p_hsType' multilineArgs m  startTypeAnnotation ::-  (HasSrcSpan l) =>+  (HasLoc l) =>   GenLocated l a ->   (a -> R ()) ->   R () startTypeAnnotation = startTypeAnnotation' breakpoint breakpoint  startTypeAnnotationDecl ::-  (HasSrcSpan l) =>+  (HasLoc l) =>   GenLocated l a ->   (a -> HsType GhcPs) ->   (a -> R ()) ->@@ -222,7 +222,7 @@     lItem  startTypeAnnotation' ::-  (HasSrcSpan l) =>+  (HasLoc l) =>   R () ->   R () ->   GenLocated l a ->@@ -279,7 +279,7 @@ instance IsTyVarBndrFlag (HsBndrVis GhcPs) where   isInferred _ = False   p_tyVarBndrFlag = \case-    HsBndrRequired -> pure ()+    HsBndrRequired NoExtField -> pure ()     HsBndrInvisible _ -> txt "@"  p_hsTyVarBndr :: (IsTyVarBndrFlag flag) => HsTyVarBndr flag GhcPs -> R ()@@ -297,7 +297,7 @@  -- | Render several @forall@-ed variables. p_forallBndrs ::-  (HasSrcSpan l) =>+  (HasLoc l) =>   ForAllVisibility ->   (a -> R ()) ->   [GenLocated l a] ->@@ -306,10 +306,10 @@   p_forallBndrsStart p tyvars   p_forallBndrsEnd vis -p_forallBndrsStart :: (HasSrcSpan l) => (a -> R ()) -> [GenLocated l a] -> R ()+p_forallBndrsStart :: (HasLoc l) => (a -> R ()) -> [GenLocated l a] -> R () p_forallBndrsStart _ [] = token'forall p_forallBndrsStart p tyvars = do-  switchLayout (getLoc' <$> tyvars) $ do+  switchLayout (locA <$> tyvars) $ do     token'forall     breakpoint     inci $ do@@ -354,7 +354,7 @@  p_lhsTypeArg :: LHsTypeArg GhcPs -> R () p_lhsTypeArg = \case-  HsValArg ty -> located ty p_hsType+  HsValArg NoExtField ty -> located ty p_hsType   -- first argument is the SrcSpan of the @,   -- but the @ always has to be directly before the type argument   HsTypeArg _ ty -> txt "@" *> located ty p_hsType@@ -376,8 +376,8 @@ hsOuterTyVarBndrsToHsType obndrs ty = case obndrs of   HsOuterImplicit NoExtField -> unLoc ty   HsOuterExplicit _ bndrs ->-    HsForAllTy NoExtField (mkHsForAllInvisTele EpAnnNotUsed bndrs) ty+    HsForAllTy NoExtField (mkHsForAllInvisTele noAnn bndrs) ty  lhsTypeToSigType :: LHsType GhcPs -> LHsSigType GhcPs lhsTypeToSigType ty =-  reLocA . L (getLocA ty) . HsSig NoExtField (HsOuterImplicit NoExtField) $ ty+  L (getLoc ty) . HsSig NoExtField (HsOuterImplicit NoExtField) $ ty

@@ -15,6 +15,7 @@  import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE+import GHC.Parser.Annotation import GHC.Types.Name.Reader import GHC.Types.SrcLoc import Ormolu.Fixity@@ -81,8 +82,8 @@         _ -> False  -- | Return combined 'SrcSpan's of all elements in this 'OpTree'.-opTreeLoc :: (HasSrcSpan l) => OpTree (GenLocated l a) b -> SrcSpan-opTreeLoc (OpNode n) = getLoc' n+opTreeLoc :: (HasLoc l) => OpTree (GenLocated l a) b -> SrcSpan+opTreeLoc (OpNode n) = getHasLoc n opTreeLoc (OpBranches exprs _) =   combineSrcSpans' . fmap opTreeLoc $ exprs 

@@ -33,7 +33,7 @@   SpanStream     . sortOn realSrcSpanStart     . toList-    $ everything mappend (const mempty `ext2Q` queryLocated `ext1Q` querySrcSpanAnn) a+    $ everything mappend (const mempty `ext2Q` queryLocated `ext1Q` queryEpAnn) a   where     queryLocated ::       (Data e0) =>@@ -41,7 +41,9 @@       Seq RealSrcSpan     queryLocated (L mspn _) =       maybe mempty srcSpanToRealSrcSpanSeq (cast mspn :: Maybe SrcSpan)-    querySrcSpanAnn :: SrcSpanAnn' a -> Seq RealSrcSpan-    querySrcSpanAnn = srcSpanToRealSrcSpanSeq . locA++    queryEpAnn :: EpAnn ann -> Seq RealSrcSpan+    queryEpAnn = srcSpanToRealSrcSpanSeq . locA+     srcSpanToRealSrcSpanSeq =       Seq.fromList . maybeToList . srcSpanToRealSrcSpan

@@ -30,7 +30,7 @@ import Data.Sequence qualified as Seq import Data.Text (Text) import Data.Text qualified as T-import Data.Text.IO qualified as T+import Data.Text.IO.Utf8 qualified as T.Utf8 import GHC.Utils.Outputable (Outputable) import Ormolu.Utils (showOutputable) import System.Console.ANSI@@ -76,7 +76,7 @@       where         go (TermOutput (Const nodes)) =           forM_ nodes $ \case-            OutputText s -> T.hPutStr handle s+            OutputText s -> T.Utf8.hPutStr handle s             WithColor color term -> withSGR [SetColor Foreground Dull color] (go term)             WithBold term -> withSGR [SetConsoleIntensity BoldIntensity] (go term) 

@@ -14,8 +14,6 @@     separatedByBlankNE,     onTheSameLine,     groupBy',-    HasSrcSpan (..),-    getLoc',     matchAddEpAnn,     textToStringBuffer,     ghcModuleNameToCabal,@@ -165,21 +163,6 @@     if x `eq` y       then (x :| y : ys) : zs       else pure x : (y :| ys) : zs--class HasSrcSpan l where-  loc' :: l -> SrcSpan--instance HasSrcSpan SrcSpan where-  loc' = id--instance HasSrcSpan RealSrcSpan where-  loc' l = RealSrcSpan l Strict.Nothing--instance HasSrcSpan (SrcSpanAnn' ann) where-  loc' = locA--getLoc' :: (HasSrcSpan l) => GenLocated l a -> SrcSpan-getLoc' = loc' . getLoc  -- | Check whether the given 'AnnKeywordId' or its Unicode variant is in an -- 'AddEpAnn', and return the 'EpaLocation' if so.

@@ -15,12 +15,13 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text qualified as T+import Data.Text.IO.Utf8 qualified as T.Utf8 import Distribution.ModuleName (ModuleName) import Distribution.Types.PackageName (PackageName) import Ormolu.Exception import Ormolu.Fixity import Ormolu.Fixity.Parser-import Ormolu.Utils.IO (findClosestFileSatisfying, readFileUtf8, withIORefCache)+import Ormolu.Utils.IO (findClosestFileSatisfying, withIORefCache) import System.Directory import System.IO.Unsafe (unsafePerformIO) import Text.Megaparsec (errorBundlePretty)@@ -38,7 +39,7 @@   liftIO (findDotOrmoluFile sourceFile) >>= \case     Just dotOrmoluFile -> liftIO $ withIORefCache cacheRef dotOrmoluFile $ do       dotOrmoluRelative <- makeRelativeToCurrentDirectory dotOrmoluFile-      contents <- readFileUtf8 dotOrmoluFile+      contents <- T.Utf8.readFile dotOrmoluFile       case parseDotOrmolu dotOrmoluRelative contents of         Left errorBundle ->           throwIO (OrmoluFixityOverridesParseError errorBundle)

@@ -1,48 +1,20 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} --- | Write 'Text' to files using UTF8 and ignoring native--- line ending conventions. module Ormolu.Utils.IO-  ( writeFileUtf8,-    readFileUtf8,-    getContentsUtf8,-    findClosestFileSatisfying,+  ( findClosestFileSatisfying,     withIORefCache,   ) where  import Control.Exception (catch, throwIO) import Control.Monad.IO.Class-import Data.ByteString (ByteString)-import Data.ByteString qualified as B import Data.IORef import Data.Map.Lazy (Map) import Data.Map.Lazy qualified as M-import Data.Text (Text)-import Data.Text.Encoding qualified as TE import System.Directory import System.FilePath import System.IO.Error (isDoesNotExistError)---- | Write a 'Text' to a file using UTF8 and ignoring native--- line ending conventions.-writeFileUtf8 :: (MonadIO m) => FilePath -> Text -> m ()-writeFileUtf8 p = liftIO . B.writeFile p . TE.encodeUtf8---- | Read an entire file strictly into a 'Text' using UTF8 and--- ignoring native line ending conventions.-readFileUtf8 :: (MonadIO m) => FilePath -> m Text-readFileUtf8 p = liftIO (B.readFile p) >>= decodeUtf8---- | Read stdin as UTF8-encoded 'Text' value.-getContentsUtf8 :: (MonadIO m) => m Text-getContentsUtf8 = liftIO B.getContents >>= decodeUtf8---- | A helper function for decoding a strict 'ByteString' into 'Text'. It is--- strict and fails immediately if decoding encounters a problem.-decodeUtf8 :: (MonadIO m) => ByteString -> m Text-decodeUtf8 = liftIO . either throwIO pure . TE.decodeUtf8'  -- | Find the path to the closest file higher in the file hierarchy that -- satisfies a given predicate.

@@ -36,7 +36,7 @@       mentioned `shouldBe` True       unPackageName ciPackageName `shouldBe` "fourmolu"       ciDynOpts `shouldBe` [DynOption "-XGHC2021"]-      Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "aeson", "ansi-terminal", "array", "base", "binary", "bytestring", "containers", "deepseq", "directory", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "scientific", "syb", "text", "yaml"]+      Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "aeson", "ansi-terminal", "array", "base", "binary", "bytestring", "containers", "deepseq", "directory", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "scientific", "syb", "text"]       ciCabalFilePath `shouldSatisfy` isAbsolute       makeRelativeToCurrentDirectory ciCabalFilePath `shouldReturn` "fourmolu.cabal"     it "extracts correct cabal info from fourmolu.cabal for tests/Ormolu/PrinterSpec.hs" $ do

@@ -17,6 +17,7 @@ import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as T+import Data.Text.IO.Utf8 qualified as T.Utf8 import GHC.Stack (withFrozenCallStack) import Ormolu   ( Config (..),@@ -30,7 +31,6 @@ import Ormolu.Config (ColumnLimit (..), HaddockPrintStyleModule (..)) import Ormolu.Exception (OrmoluException, printOrmoluException) import Ormolu.Terminal (ColorMode (..), runTerm)-import Ormolu.Utils.IO (readFileUtf8, writeFileUtf8) import Path   ( File,     Path,@@ -254,7 +254,7 @@             outputFile = testDir </> toRelFile ("output" ++ testCaseSuffix testCase ++ ".hs")             opts = updateConfig testCase defaultPrinterOpts -        input <- readFileUtf8 inputPath+        input <- T.Utf8.readFile inputPath         actual <-           if isMulti             then overSectionsM (T.pack "{- // -}") (runOrmolu opts checkIdempotence inputPath) input@@ -286,7 +286,7 @@  checkResult :: Path Rel File -> Text -> Expectation checkResult outputFile actual-  | shouldRegenerateOutput = writeFileUtf8 (fromRelFile outputFile) actual+  | shouldRegenerateOutput = T.Utf8.writeFile (fromRelFile outputFile) actual   | otherwise =       getFileContents outputFile >>= \case         Nothing ->@@ -326,7 +326,7 @@ getFileContents path = do   fileExists <- doesFileExist path   if fileExists-    then Just <$> readFileUtf8 (toFilePath path)+    then Just <$> T.Utf8.readFile (toFilePath path)     else pure Nothing  getDiff :: (String, Text) -> (String, Text) -> Text

@@ -2,9 +2,9 @@  module Ormolu.Diff.TextSpec (spec) where +import Data.Text.IO.Utf8 qualified as T.Utf8 import Ormolu.Diff.Text import Ormolu.Terminal-import Ormolu.Utils.IO import Path import System.FilePath qualified as FP import Test.Hspec@@ -36,14 +36,14 @@ stdTest name pathA pathB = it name $ do   inputA <-     parseRelFile (FP.addExtension pathA "hs")-      >>= readFileUtf8 . toFilePath . (diffInputsDir </>)+      >>= T.Utf8.readFile . toFilePath . (diffInputsDir </>)   inputB <-     parseRelFile (FP.addExtension pathB "hs")-      >>= readFileUtf8 . toFilePath . (diffInputsDir </>)+      >>= T.Utf8.readFile . toFilePath . (diffInputsDir </>)   let expectedDiffPath = FP.addExtension name "txt"   expectedDiffText <-     parseRelFile expectedDiffPath-      >>= readFileUtf8 . toFilePath . (diffOutputsDir </>)+      >>= T.Utf8.readFile . toFilePath . (diffOutputsDir </>)   Just actualDiff <- pure $ diffText inputA inputB "TEST"   runTermPure (printTextDiff actualDiff) `shouldBe` expectedDiffText 

@@ -1,7 +1,7 @@ module Ormolu.Integration.CLISpec (spec) where  import Control.Monad (forM_)-import Ormolu.Integration.Utils (getFourmoluExe, readProcess, readProcess')+import Ormolu.Integration.Utils (ProcessSpec (..), getFourmoluExe, proc, readFrom, readProcess) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory, (</>)) import System.IO.Temp (withSystemTempDirectory)@@ -11,17 +11,78 @@ spec =   describe "Fourmolu CLI functionality" . beforeAll getFourmoluExe $ do     it "formats stdin when no files specified" $ \fourmoluExe -> do-      stdout <- readProcess' fourmoluExe ["--no-cabal"] unformattedCode+      stdout <- readFrom $ (proc fourmoluExe ["--no-cabal"]) {procStdin = unformattedCode}       stdout `shouldBe` formattedCode      it "formats stdin when stdin specified" $ \fourmoluExe -> do-      stdout <- readProcess' fourmoluExe ["--no-cabal", "-"] unformattedCode+      stdout <- readFrom $ (proc fourmoluExe ["--no-cabal", "-"]) {procStdin = unformattedCode}       stdout `shouldBe` formattedCode +    it "finds config file in current directory when formatting stdin" $ \fourmoluExe ->+      withTempDir $ \tmpdir -> do+        writeFile' (tmpdir </> "fourmolu.yaml") "single-constraint-parens: never"+        stdout <-+          readFrom $+            (proc fourmoluExe ["--no-cabal", "-"])+              { procStdin = "f :: (Show a) => a -> String",+                procCwd = Just tmpdir+              }+        stdout `shouldBe` "f :: Show a => a -> String\n"++    it "finds config file in ancestor directory when formatting stdin" $ \fourmoluExe ->+      withTempDir $ \tmpdir -> do+        writeFile' (tmpdir </> "fourmolu.yaml") "single-constraint-parens: never"+        let cwd = tmpdir </> "a" </> "b" </> "c"+        createDirectoryIfMissing True cwd+        stdout <-+          readFrom $+            (proc fourmoluExe ["--no-cabal", "-"])+              { procStdin = "f :: (Show a) => a -> String",+                procCwd = Just cwd+              }+        stdout `shouldBe` "f :: Show a => a -> String\n"++    it "finds config file in directory of input file" $ \fourmoluExe ->+      withTempDir $ \tmpdir -> do+        writeFile' (tmpdir </> "fourmolu.yaml") "single-constraint-parens: never"+        writeFile' (tmpdir </> "input.hs") "f :: (Show a) => a -> String"+        stdout <-+          readFrom $+            (proc fourmoluExe ["--no-cabal", "input.hs"])+              { procCwd = Just tmpdir+              }+        stdout `shouldBe` "f :: Show a => a -> String\n"++    it "finds config file in XDG directory" $ \fourmoluExe ->+      withTempDir $ \tmpdir -> do+        let configDir = tmpdir </> "config"+        writeFile' (configDir </> "fourmolu.yaml") "single-constraint-parens: never"+        stdout <-+          readFrom $+            (proc fourmoluExe ["--no-cabal", "-"])+              { procStdin = "f :: (Show a) => a -> String",+                procCwd = Just tmpdir,+                procExtraEnv = [("XDG_CONFIG_HOME", configDir)]+              }+        stdout `shouldBe` "f :: Show a => a -> String\n"++    it "uses specified config file" $ \fourmoluExe ->+      withTempDir $ \tmpdir -> do+        let configFile = tmpdir </> "foo" </> "my-config.yaml"+        let inputFile = tmpdir </> "bar" </> "input.hs"+        writeFile' configFile "single-constraint-parens: never"+        writeFile' inputFile "f :: (Show a) => a -> String"+        stdout <-+          readFrom $+            (proc fourmoluExe ["--no-cabal", "--config", configFile, inputFile])+              { procCwd = Just tmpdir+              }+        stdout `shouldBe` "f :: Show a => a -> String\n"+     it "recursively finds files in directories" $ \fourmoluExe -> do       withTempDir $ \tmpdir -> do         let hsFile = tmpdir </> "test.hs"-        writeFile hsFile unformattedCode+        writeFile' hsFile unformattedCode          output <- readProcess fourmoluExe [tmpdir]         output `shouldBe` formattedCode@@ -37,8 +98,7 @@                 tmpdir </> "dist-newstyle/test.hs"               ]         forM_ (testFiles ++ ignoredFiles) $ \fp -> do-          createDirectoryIfMissing True (takeDirectory fp)-          writeFile fp unformattedCode+          writeFile' fp unformattedCode          _ <- readProcess fourmoluExe ["-i", tmpdir]         forM_ testFiles $ \fp -> do@@ -49,5 +109,8 @@           output `shouldBe` unformattedCode   where     withTempDir = withSystemTempDirectory "fourmolu-cli-test"+    writeFile' fp s = do+      createDirectoryIfMissing True (takeDirectory fp)+      writeFile fp s     unformattedCode = "main=print(1+1)\n"     formattedCode = "main = print (1 + 1)\n"

@@ -1,14 +1,20 @@+{-# LANGUAGE RecordWildCards #-}+ module Ormolu.Integration.Utils   ( getFourmoluExe,     readProcess,-    readProcess',+    ProcessSpec (..),+    proc,+    readFrom,   ) where  import Control.Monad (when) import System.Directory (findExecutable)+import System.Environment (getEnvironment) import System.Exit (ExitCode (..))-import System.Process (readProcessWithExitCode)+import System.Process (CreateProcess (..), readCreateProcessWithExitCode)+import System.Process qualified as Process  -- | Find a `fourmolu` executable on PATH. getFourmoluExe :: IO FilePath@@ -17,15 +23,39 @@ -- | Like 'System.Process.readProcess', except without specifying stdin and -- with better failure messages. readProcess :: FilePath -> [String] -> IO String-readProcess cmd args = readProcess' cmd args ""+readProcess cmd args = readFrom $ proc cmd args --- | Like 'System.Process.readProcess', except with better failure messages.-readProcess' :: FilePath -> [String] -> String -> IO String-readProcess' cmd args stdin = do-  (code, stdout, stderr) <- readProcessWithExitCode cmd args stdin+data ProcessSpec = ProcessSpec+  { procCmd :: FilePath,+    procArgs :: [String],+    procStdin :: String,+    procCwd :: Maybe FilePath,+    procExtraEnv :: [(String, String)]+  } +proc :: FilePath -> [String] -> ProcessSpec+proc cmd args =+  ProcessSpec+    { procCmd = cmd,+      procArgs = args,+      procStdin = "",+      procCwd = Nothing,+      procExtraEnv = []+    }++readFrom :: ProcessSpec -> IO String+readFrom ProcessSpec {..} = do+  currentEnv <- getEnvironment+  (code, stdout, stderr) <-+    readCreateProcessWithExitCode+      (Process.proc procCmd procArgs)+        { cwd = procCwd,+          env = Just $ procExtraEnv <> currentEnv+        }+      procStdin+   when (code /= ExitSuccess) $ do-    putStrLn $ "Command failed: " ++ (unwords . map (\s -> "\"" ++ s ++ "\"")) (cmd : args)+    putStrLn $ "Command failed: " ++ (unwords . map (\s -> "\"" ++ s ++ "\"")) (procCmd : procArgs)     putStrLn "========== stdout =========="     putStrLn stdout     putStrLn "========== stderr =========="

@@ -12,11 +12,11 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T-import Data.Text.IO qualified as T+import Data.Text.IO.Utf8 qualified as T.Utf8+import Data.Yaml qualified as Yaml import Ormolu import Ormolu.Config import Ormolu.Fixity-import Ormolu.Utils.IO import Path import Path.IO import System.Environment (lookupEnv)@@ -26,11 +26,7 @@ spec :: Spec spec = do   -- Config for normal Ormolu output + default Fourmolu output-  ormoluConfig <--    runIO $-      loadConfigFile "fourmolu.yaml" >>= \case-        ConfigLoaded _ cfg -> pure cfg-        result -> error $ "Could not load config file: " ++ show result+  ormoluConfig <- runIO $ Yaml.decodeFileEither "fourmolu.yaml" >>= either (error . show) pure   let ormoluPrinterOpts = resolvePrinterOpts [cfgFilePrinterOpts ormoluConfig]    es <- runIO locateExamples@@ -77,8 +73,8 @@   -- 3. Check the output against expected output. Thus all tests should   -- include two files: input and expected output.   whenShouldRegenerateOutput $-    T.writeFile (fromRelFile expectedOutputPath) formatted0-  expected <- readFileUtf8 $ fromRelFile expectedOutputPath+    T.Utf8.writeFile (fromRelFile expectedOutputPath) formatted0+  expected <- T.Utf8.readFile $ fromRelFile expectedOutputPath   shouldMatch False formatted0 expected   -- 4. Check that running the formatter on the output produces the same   -- output again (the transformation is idempotent).