ormolu 0.7.7.0 → 0.8.1.1

raw patch · 126 files changed

Files

• CHANGELOG.md +86/−0
• CONTRIBUTING.md +8/−2
• DESIGN.md +2/−2
• README.md +7/−1
• app/Main.hs +27/−12
• data/examples/declaration/data/linear-out.hs +11/−0
• data/examples/declaration/data/linear.hs +10/−0
• data/examples/declaration/data/record-out.hs +1/−1
• data/examples/declaration/data/record.hs +1/−1
• data/examples/declaration/data/required-type-arguments-out.hs +27/−0
• data/examples/declaration/data/required-type-arguments.hs +24/−0
• data/examples/declaration/data/wildcard-binders-out.hs +1/−0
• data/examples/declaration/data/wildcard-binders.hs +1/−0
• data/examples/declaration/default/default-out.hs +8/−0
• data/examples/declaration/default/default.hs +7/−0
• data/examples/declaration/foreign/foreign-import-multiline-out.hs +8/−0
• data/examples/declaration/foreign/foreign-import-multiline.hs +6/−0
• data/examples/declaration/rewrite-rule/prelude2-out.hs +1/−1
• data/examples/declaration/rewrite-rule/prelude2.hs +1/−1
• data/examples/declaration/signature/fixity/infix-out.hs +2/−0
• data/examples/declaration/signature/fixity/infix.hs +2/−0
• data/examples/declaration/signature/specialize/specialize-2-out.hs +8/−0
• data/examples/declaration/signature/specialize/specialize-2.hs +9/−0
• data/examples/declaration/signature/specialize/specialize-3-out.hs +10/−0
• data/examples/declaration/signature/specialize/specialize-3.hs +4/−0
• data/examples/declaration/type/promotion-no-puns-out.hs +5/−0
• data/examples/declaration/type/promotion-no-puns.hs +5/−0
• data/examples/declaration/type/wildcard-binders-out.hs +1/−0
• data/examples/declaration/type/wildcard-binders.hs +1/−0
• data/examples/declaration/value/function/arrow/proc-do-complex-out.hs +1/−1
• data/examples/declaration/value/function/arrow/proc-do-complex.hs +1/−1
• data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs +7/−0
• data/examples/declaration/value/function/arrow/proc-form-do-indent.hs +5/−0
• data/examples/declaration/value/function/case-single-line-with-braces-out.hs +2/−0
• data/examples/declaration/value/function/case-single-line-with-braces.hs +2/−0
• data/examples/declaration/value/function/do-multiline-with-case-out.hs +13/−0
• data/examples/declaration/value/function/do-multiline-with-case.hs +13/−0
• data/examples/declaration/value/function/do-single-line-case-guards-out.hs +2/−0
• data/examples/declaration/value/function/do-single-line-case-guards.hs +2/−0
• data/examples/declaration/value/function/do-single-line-lambda-case-out.hs +2/−0
• data/examples/declaration/value/function/do-single-line-lambda-case.hs +2/−0
• data/examples/declaration/value/function/do-single-line-multiple-cases-out.hs +2/−0
• data/examples/declaration/value/function/do-single-line-multiple-cases.hs +2/−0
• data/examples/declaration/value/function/do-single-line-nested-case-out.hs +2/−0
• data/examples/declaration/value/function/do-single-line-nested-case.hs +2/−0
• data/examples/declaration/value/function/do-single-line-with-case-out.hs +2/−0
• data/examples/declaration/value/function/do-single-line-with-case.hs +2/−0
• data/examples/declaration/value/function/guards-out.hs +2/−0
• data/examples/declaration/value/function/guards.hs +2/−0
• data/examples/declaration/value/function/infix/fractional-precedence-out.hs +3/−0
• data/examples/declaration/value/function/infix/fractional-precedence.hs +3/−0
• data/examples/declaration/value/function/linear-bindings-out.hs +9/−0
• data/examples/declaration/value/function/linear-bindings.hs +9/−0
• data/examples/declaration/value/function/multi-way-if-out.hs +2/−0
• data/examples/declaration/value/function/multi-way-if.hs +2/−0
• data/examples/declaration/value/function/multiline-strings-0-out.hs +29/−0
• data/examples/declaration/value/function/multiline-strings-0.hs +31/−0
• data/examples/declaration/value/function/multiline-strings-1-out.hs +12/−0
• data/examples/declaration/value/function/multiline-strings-1.hs +13/−0
• data/examples/declaration/value/function/multiline-strings-2-out.hs +11/−0
• data/examples/declaration/value/function/multiline-strings-2.hs +11/−0
• data/examples/declaration/value/function/multiline-strings-3-out.hs +32/−0
• data/examples/declaration/value/function/multiline-strings-3.hs +32/−0
• data/examples/declaration/value/function/multiline-strings-4-out.hs +25/−0
• data/examples/declaration/value/function/multiline-strings-4.hs +26/−0
• data/examples/declaration/value/function/multiline-strings-5-out.hs +26/−0
• data/examples/declaration/value/function/multiline-strings-5.hs +26/−0
• data/examples/declaration/value/function/multiline-strings-6-out.hs +10/−0
• data/examples/declaration/value/function/multiline-strings-6.hs +10/−0
• data/examples/declaration/value/function/multiline-strings-7-out.hs +30/−0
• data/examples/declaration/value/function/multiline-strings-7.hs +30/−0
• data/examples/declaration/value/function/multiline-strings-8-out.hs +12/−0
• data/examples/declaration/value/function/multiline-strings-8.hs +9/−0
• data/examples/declaration/value/function/multiline-strings-9-out.hs +11/−0
• data/examples/declaration/value/function/multiline-strings-9.hs +11/−0
• data/examples/declaration/value/function/pattern/or-patterns-out.hs +44/−0
• data/examples/declaration/value/function/pattern/or-patterns.hs +39/−0
• data/examples/declaration/value/function/required-type-arguments-2-out.hs +23/−0
• data/examples/declaration/value/function/required-type-arguments-2.hs +14/−0
• data/examples/declaration/value/function/strings-out.hs +5/−1
• data/examples/declaration/value/function/strings.hs +4/−0
• data/examples/declaration/value/function/type-applications-out.hs +2/−0
• data/examples/declaration/value/function/type-applications.hs +2/−0
• data/examples/import/data-out.hs +3/−0
• data/examples/import/data.hs +6/−0
• data/examples/import/explicit-level-imports-out.hs +13/−0
• data/examples/import/explicit-level-imports-qualified-post-out.hs +5/−0
• data/examples/import/explicit-level-imports-qualified-post.hs +5/−0
• data/examples/import/explicit-level-imports.hs +14/−0
• data/examples/other/empty-forall-out.hs +1/−1
• extract-hackage-info/hackage-info.bin binary
• ormolu.cabal +195/−180
• src/GHC/DynFlags.hs +6/−0
• src/Ormolu/Diff/ParseResult.hs +44/−20
• src/Ormolu/Diff/Text.hs +0/−4
• src/Ormolu/Fixity.hs +1/−16
• src/Ormolu/Fixity/Internal.hs +31/−9
• src/Ormolu/Fixity/Parser.hs +3/−1
• src/Ormolu/Fixity/Printer.hs +11/−1
• src/Ormolu/Imports.hs +31/−16
• src/Ormolu/Parser.hs +21/−4
• src/Ormolu/Printer/Combinators.hs +25/−2
• src/Ormolu/Printer/Internal.hs +14/−0
• src/Ormolu/Printer/Meat/Common.hs +21/−5
• src/Ormolu/Printer/Meat/Declaration.hs +8/−1
• src/Ormolu/Printer/Meat/Declaration/Data.hs +63/−65
• src/Ormolu/Printer/Meat/Declaration/Default.hs +6/−1
• src/Ormolu/Printer/Meat/Declaration/Foreign.hs +7/−2
• src/Ormolu/Printer/Meat/Declaration/OpTree.hs +2/−7
• src/Ormolu/Printer/Meat/Declaration/Rule.hs +15/−13
• src/Ormolu/Printer/Meat/Declaration/Signature.hs +67/−14
• src/Ormolu/Printer/Meat/Declaration/Signature.hs-boot +14/−0
• src/Ormolu/Printer/Meat/Declaration/StringLiteral.hs +174/−0
• src/Ormolu/Printer/Meat/Declaration/Value.hs +154/−167
• src/Ormolu/Printer/Meat/Declaration/Value.hs-boot +0/−3
• src/Ormolu/Printer/Meat/ImportExport.hs +13/−0
• src/Ormolu/Printer/Meat/Type.hs +109/−69
• src/Ormolu/Processing/Preprocess.hs +1/−1
• src/Ormolu/Utils.hs +0/−8
• src/Ormolu/Utils/Cabal.hs +7/−8
• src/Ormolu/Utils/Fixity.hs +4/−7
• src/Ormolu/Utils/IO.hs +15/−6
• tests/Ormolu/CabalInfoSpec.hs +1/−1
• tests/Ormolu/Fixity/ParserSpec.hs +23/−1
• tests/Ormolu/Fixity/PrinterSpec.hs +6/−1
• tests/Ormolu/PrinterSpec.hs +4/−1

@@ -1,3 +1,89 @@+## Ormolu 0.8.1.1++* Add missing braces for case expressions in single‑line do blocks. [Issue+  1180](https://github.com/tweag/ormolu/issues/1180).++* Fix the import grouping logic in the presence of imports with explicit+  levels. [Issue 1192](https://github.com/tweag/ormolu/issues/1192).++## Ormolu 0.8.1.0++* Fixed printing of guards on pattern binds. [Issue+  1178](https://github.com/tweag/ormolu/issues/1178).++* Switched to `ghc-lib-parser-9.14`, with the following new syntactic features:+   * GHC proposal [#493](https://github.com/ghc-proposals/ghc-proposals/blob/e2c683698323cec3e33625369ae2b5f585387c70/proposals/0493-specialise-expressions.rst): expressions in SPECIALISE pragmas+   * Multiline strings in foreign import declarations.+   * `ExplicitNamespaces` supports the `data` namespace specifier in import and export lists, replacing `pattern`.+   * `LinearTypes` adds new syntax to support non-linear record fields.+   * `RequiredTypeArguments` allows visible forall in GADT syntax.++* Updated to `Cabal-syntax-3.16`.++* Correctly format string literals containing the `\^\` escape sequence. [Issue+  1165](https://github.com/tweag/ormolu/issues/1165).++* Correctly preserve consecutive blank lines in multiline strings. [Issue+  1194](https://github.com/tweag/ormolu/issues/1194).++* Fixed printing of multi-line or-patterns inside as-patterns. [Issue+  1183](https://github.com/tweag/ormolu/issues/1183).++* Fixed an issue where or-patterns would be indented twice. [Issue+  1188](https://github.com/tweag/ormolu/issues/1188).++* Add support for `ExplicitLevelImports`. [Issue+  1192](https://github.com/tweag/ormolu/issues/1192).++## Ormolu 0.8.0.2++* Fixed a performance regression introduced in 0.8.0.0. [Issue+  1176](https://github.com/tweag/ormolu/issues/1176).++## Ormolu 0.8.0.1++* Correctly format edge cases where fully collapsing string gaps changes the+  string represented by a string literal. [Issue+  1160](https://github.com/tweag/ormolu/issues/1160).++* Fix false positives in AST diffing in fixity declarations with implicit+  fixity, such as `infix +`. [Issue+  1166](https://github.com/tweag/ormolu/issues/1166).++* Make multiline function signatures in RequiredTypeArguments consistent with+  types [PR 1170](https://github.com/tweag/ormolu/pull/1170).++* Correctly format single-line `MultiWayIf`s. [Issue+  1171](https://github.com/tweag/ormolu/issues/1171).++## Ormolu 0.8.0.0++* Format multiple files in parallel. [Issue+  1128](https://github.com/tweag/ormolu/issues/1128).++* Fractional precedences are now allowed in `.ormolu` files for more precise+  control over formatting of complex operator chains. [Issue+  1106](https://github.com/tweag/ormolu/issues/1106).++* Correctly format type applications of `QuasiQuotes`. [Issue+  1134](https://github.com/tweag/ormolu/issues/1134).++* Correctly format multi-line parentheses in arrow `do` blocks. [Issue+  1144](https://github.com/tweag/ormolu/issues/1144).++* Switched to `ghc-lib-parser-9.12`, with the following new syntactic features:+   * GHC proposal [#522](https://github.com/ghc-proposals/ghc-proposals/blob/c9401f037cb22d1661931b2ec621925101052997/proposals/0522-or-patterns.rst): `OrPatterns` (enabled by default)+   * GHC proposal [#569](https://github.com/ghc-proposals/ghc-proposals/blob/c9401f037cb22d1661931b2ec621925101052997/proposals/0569-multiline-strings.rst): `MultilineStrings` (disabled by default)+   * GHC proposal [#409](https://github.com/ghc-proposals/ghc-proposals/blob/f79438cf8dbfcd90187f7af3a380515ffe45dbdc/proposals/0409-exportable-named-default.rst): `NamedDefaults` (enabled by default)+   * GHC proposal [#281](https://github.com/ghc-proposals/ghc-proposals/blob/c9401f037cb22d1661931b2ec621925101052997/proposals/0281-visible-forall.rst): accept more types in terms: `forall` quantifications, constraint arrows `=>`, type arrows `->` (enabled by default)+   * Part of GHC proposal [#425](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0425-decl-invis-binders.rst): wildcard binders (enabled by default)++* Correctly format non-promoted type-level tuples with `NoListTuplePuns`. [Issue+  1146](https://github.com/tweag/ormolu/issues/1146).++* Updated to `Cabal-syntax-3.14`. [Issue+  1152](https://github.com/tweag/ormolu/issues/1152).+ ## Ormolu 0.7.7.0  * Use single-line layout for parens around single-line content. [Issue

@@ -40,7 +40,13 @@  ## Formatting -Use `nix run .#format` script to format Ormolu with the current version of-Ormolu. If Ormolu is not formatted like this, the CI will fail.+ - Use `nix run .#format` script to format Ormolu with the current version of+   Ormolu.++ - Additional formatters are configured via a pre-commit hook which is+   automatically installed when entering the Nix shell. You can also run it via+   `pre-commit run`/`pre-commit run -a`.++If Ormolu is not formatted like this, the CI will fail.  [issues]: https://github.com/tweag/ormolu/issues

@@ -65,7 +65,7 @@ of which fit in linear space. So care is necessary to keep memory bounded. -The compexities of the `BriDoc` structure, together with the lack of+The complexities of the `BriDoc` structure, together with the lack of documentation, make Brittany at least challenging to maintain.  ### Hindent@@ -386,7 +386,7 @@ Forking or contributing to Hindent is not an option because if we replace `haskell-src-exts` with `ghc` (or `ghc-exact-print`) then we'll have to work with a different AST type and all the code in Hindent will become-incompatible and there won't be much code to be re-used in that case. It is+incompatible and there won't be much code to be reused in that case. It is also possible that we'll find a nicer way to write pretty-printer.  ## Examples

@@ -184,10 +184,16 @@ infixr 1  =<< infixr 0  $, $! infixl 4 <*>, <*, *>, <**>++infixr 3 >~<+infixr 3.3 |~|+infixr 3.7 <~> ```  It uses exactly the same syntax as usual Haskell fixity declarations to make-it easier for Haskellers to edit and maintain.+it easier for Haskellers to edit and maintain. Since Ormolu 0.7.8.0+fractional precedences are supported for more precise control over+formatting of complex operator chains.  As of Ormolu 0.7.0.0, `.ormolu` files can also contain instructions about module re-exports that Ormolu should be aware of. This might be desirable

@@ -7,6 +7,7 @@  module Main (main) where +import Control.Concurrent (MVar, newMVar, withMVar) import Control.Exception (throwIO) import Control.Monad import Data.Bool (bool)@@ -33,17 +34,22 @@ import System.Exit (ExitCode (..), exitWith) import System.FilePath qualified as FP import System.IO (hPutStrLn, stderr)+import UnliftIO.Async (pooledMapConcurrently)  -- | Entry point of the program. main :: IO () main = do   Opts {..} <- execParser optsParserInfo+  -- We use this to guard writes to stdout in order to avoid+  -- garbled output from concurrent formatting processes.+  outputLock <- newMVar ()   let formatOne' =         formatOne           optConfigFileOpts           optMode           optSourceType           optConfig+          outputLock   exitCode <- case optInputFiles of     [] -> formatOne' Nothing     ["-"] -> formatOne' Nothing@@ -53,7 +59,8 @@             ExitSuccess -> Nothing             ExitFailure n -> Just n       errorCodes <--        mapMaybe selectFailure <$> mapM (formatOne' . Just) (sort xs)+        mapMaybe selectFailure+          <$> pooledMapConcurrently (formatOne' . Just) (sort xs)       return $         if null errorCodes           then ExitSuccess@@ -74,10 +81,12 @@   Maybe SourceType ->   -- | Configuration   Config RegionIndices ->+  -- | Lock for writing to output handles+  MVar () ->   -- | File to format or stdin as 'Nothing'   Maybe FilePath ->   IO ExitCode-formatOne ConfigFileOpts {..} mode reqSourceType rawConfig mpath =+formatOne ConfigFileOpts {..} mode reqSourceType rawConfig outputLock mpath =   withPrettyOrmoluExceptions (cfgColorMode rawConfig) $ do     let getCabalInfoForSourceFile' sourceFile = do           cabalSearchResult <- getCabalInfoForSourceFile sourceFile@@ -85,18 +94,20 @@           case cabalSearchResult of             CabalNotFound -> do               when debugEnabled $-                hPutStrLn stderr $-                  "Could not find a .cabal file for " <> sourceFile+                withMVar outputLock $ \_ ->+                  hPutStrLn stderr $+                    "Could not find a .cabal file for " <> sourceFile               return Nothing             CabalDidNotMention cabalInfo -> do               when debugEnabled $ do                 relativeCabalFile <-                   makeRelativeToCurrentDirectory (ciCabalFilePath cabalInfo)-                hPutStrLn stderr $-                  "Found .cabal file "-                    <> relativeCabalFile-                    <> ", but it did not mention "-                    <> sourceFile+                withMVar outputLock $ \_ ->+                  hPutStrLn stderr $+                    "Found .cabal file "+                      <> relativeCabalFile+                      <> ", but it did not mention "+                      <> sourceFile               return (Just cabalInfo)             CabalFound cabalInfo -> return (Just cabalInfo)         getDotOrmoluForSourceFile' sourceFile = do@@ -116,7 +127,9 @@         config <- patchConfig Nothing mcabalInfo mdotOrmolu         case mode of           Stdout -> do-            ormoluStdin config >>= T.Utf8.putStr+            output <- ormoluStdin config+            withMVar outputLock $ \_ ->+              T.Utf8.putStr output             return ExitSuccess           InPlace -> do             hPutStrLn@@ -145,7 +158,9 @@             mdotOrmolu         case mode of           Stdout -> do-            ormoluFile config inputFile >>= T.Utf8.putStr+            output <- ormoluFile config inputFile+            withMVar outputLock $ \_ ->+              T.Utf8.putStr output             return ExitSuccess           InPlace -> do             -- ormoluFile is not used because we need originalInput@@ -346,7 +361,7 @@         help "Fail if formatting is not idempotent"       ]     -- We cannot parse the source type here, because we might need to do-    -- autodection based on the input file extension (not available here)+    -- autodetection based on the input file extension (not available here)     -- before storing the resolved value in the config struct.     <*> pure ModuleSource     <*> (option parseColorMode . mconcat)

@@ -0,0 +1,11 @@+{-# LANGUAGE LinearTypes #-}++data Record = Rec {x %'Many :: Int, y :: Char}++data T2 a b c where+  MkT2 :: a -> b %1 -> c %1 -> T2 a b c++data T2 a b c = MkT2 {x %Many :: a, y :: b, z :: c}++data T3 a m where+  MkT3 :: a %m -> T3 a m

@@ -0,0 +1,10 @@+{-# LANGUAGE LinearTypes #-}+data Record = Rec { x %'Many :: Int, y :: Char }++data T2 a b c where+    MkT2 :: a -> b %1 -> c %1 -> T2 a b c++data T2 a b c = MkT2 { x %Many :: a, y :: b, z :: c }++data T3 a m where+    MkT3 :: a %m -> T3 a m

@@ -12,7 +12,7 @@     fooGag,     fooGog ::       NonEmpty-        ( Indentity+        ( Identity             Bool         ),     -- | Huh!

@@ -6,7 +6,7 @@   { fooX :: Int -- ^ X   , fooY :: Int -- ^ Y   , fooBar, fooBaz :: NonEmpty (Identity Bool) -- ^ BarBaz-  , fooGag, fooGog :: NonEmpty (Indentity+  , fooGag, fooGog :: NonEmpty (Identity                                   Bool)     -- ^ GagGog   , fooFoo

@@ -0,0 +1,27 @@+data T a where+  Typed :: forall a -> a -> T a++f1 (Typed a x) = x :: a++f2 (Typed Int n) = n * 2++f3 (Typed ((->) w Bool) g) = not . g++data D x where+  MkD1 ::+    forall a b ->+    a ->+    b ->+    D (a, b)+  MkD2 ::+    forall a.+    forall b ->+    a ->+    b ->+    D (a, b)+  MkD3 ::+    forall a ->+    a ->+    forall b ->+    b ->+    D (a, b)

@@ -0,0 +1,24 @@+data T a where+  Typed :: forall a -> a -> T a++f1 (Typed a x) = x :: a+f2 (Typed Int n) = n*2+f3 (Typed ((->) w Bool) g) = not . g++data D x where+  MkD1 :: forall a b ->+          a ->+          b ->+          D (a, b)++  MkD2 :: forall a.+          forall b ->+          a ->+          b ->+          D (a, b)++  MkD3 :: forall a ->+          a ->+          forall b ->+          b ->+          D (a, b)

@@ -0,0 +1,1 @@+data Proxy _ = Proxy

@@ -0,0 +1,1 @@+data Proxy _ = Proxy

@@ -1,3 +1,5 @@+module MyModule (default Monoid) where+ default (Int, Foo, Bar)  default@@ -5,3 +7,9 @@     Foo,     Bar   )++default Num (Int, Float)++default IsList ([], Vector)++default IsString (Text.Text, Foundation.String, String)

@@ -1,6 +1,13 @@+module MyModule (default Monoid) where+ default        (  Int , Foo     , Bar      )  default ( Int                , Foo,   Bar            )++default Num (Int, Float)+default IsList ([], Vector)++default IsString (Text.Text, Foundation.String, String)

@@ -0,0 +1,8 @@+{-# LANGUAGE MultilineStrings #-}++foreign import capi+  """+  foo+     bar+  """+  foo :: Int -> Int

@@ -0,0 +1,6 @@+{-# language MultilineStrings #-}++foreign import capi """+         foo+            bar+     """ foo :: Int -> Int

@@ -11,7 +11,7 @@ -- when we disable the rule that expands (++) into foldr  -- The foldr/cons rule looks nice, but it can give disastrously--- bloated code when commpiling+-- bloated code when compiling --      array (a,b) [(1,2), (2,2), (3,2), ...very long list... ] -- i.e. when there are very very long literal lists -- So I've disabled it for now. We could have special cases

@@ -11,7 +11,7 @@         -- when we disable the rule that expands (++) into foldr  -- The foldr/cons rule looks nice, but it can give disastrously--- bloated code when commpiling+-- bloated code when compiling --      array (a,b) [(1,2), (2,2), (3,2), ...very long list... ] -- i.e. when there are very very long literal lists -- So I've disabled it for now. We could have special cases

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

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

@@ -0,0 +1,8 @@+{-# SPECIALIZE addMult @Double #-}+{-# SPECIALIZE addMult (5 :: Int) #-}+{-# SPECIALIZE addMult 5 :: Int -> Int #-}++{-# SPECIALIZE [1] forall x y. f @Int True (x, y) #-}++{-# SPECIALIZE forall x xs. loop (x : xs)+  #-}

@@ -0,0 +1,9 @@+{-# SPECIALISE addMult @Double #-}+{-# SPECIALISE addMult (5 :: Int) #-}+{-# SPECIALISE addMult 5 :: Int -> Int #-}++{-# SPECIALISE [1] forall x y. f @Int True (x,y) #-}++{-# SPECIALISE+  forall x xs .+  loop (x:xs) #-}

@@ -0,0 +1,10 @@+sep, fsep, hsep :: (Applicative m, Foldable t) => t (m Doc) -> m Doc+sep = fmap P.sep . sequenceAFoldable+{-# SPECIALIZE NOINLINE sep :: [TCM Doc] -> TCM Doc #-}+{-# SPECIALIZE NOINLINE sep :: List1 (TCM Doc) -> TCM Doc #-}+fsep = fmap P.fsep . sequenceAFoldable+{-# SPECIALIZE NOINLINE [2] fsep :: [TCM Doc] -> TCM Doc #-}+{-# SPECIALIZE NOINLINE [2] fsep :: List1 (TCM Doc) -> TCM Doc #-}+hsep = fmap P.hsep . sequenceAFoldable+{-# SPECIALIZE NOINLINE [~2] hsep :: [TCM Doc] -> TCM Doc #-}+{-# SPECIALIZE NOINLINE [~2] hsep :: List1 (TCM Doc) -> TCM Doc #-}

@@ -0,0 +1,4 @@+sep, fsep, hsep :: (Applicative m, Foldable t) => t (m Doc) -> m Doc+sep  = fmap P.sep  . sequenceAFoldable  ; {-# SPECIALIZE NOINLINE sep  :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE sep  :: List1 (TCM Doc) -> TCM Doc #-}+fsep = fmap P.fsep . sequenceAFoldable  ; {-# SPECIALIZE NOINLINE [2] fsep :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE [2] fsep :: List1 (TCM Doc) -> TCM Doc #-}+hsep = fmap P.hsep . sequenceAFoldable  ; {-# SPECIALIZE NOINLINE [~2] hsep :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE [~2] hsep :: List1 (TCM Doc) -> TCM Doc #-}

@@ -0,0 +1,5 @@+{-# LANGUAGE NoListTuplePuns #-}++type X = (Int, String)++type Y = [String, Int]

@@ -0,0 +1,5 @@+{-# Language NoListTuplePuns #-}++type X = (Int, String)++type Y = [String, Int]

@@ -0,0 +1,1 @@+type Const a _ = a

@@ -0,0 +1,1 @@+type Const a _ = a

@@ -12,7 +12,7 @@         )     -> do       -- Begin do-      (x, y) <- -- GHC parser fails if layed out over multiple lines+      (x, y) <- -- GHC parser fails if laid out over multiple lines         f -- Call into f           ( a,             c -- Tuple together arguments

@@ -9,7 +9,7 @@         (e, f)       ) ->     do -- Begin do-        (x,y) -- GHC parser fails if layed out over multiple lines+        (x,y) -- GHC parser fails if laid out over multiple lines          <- f -- Call into f               (a,                c) -- Tuple together arguments

@@ -12,3 +12,10 @@       (bindA -< y)     |)     z++foo2 = proc () -> do+  ( proc () ->+      returnA -< ()+    )+    -<+      ()

@@ -11,3 +11,8 @@     bar       (bindA -< y)     |) z++foo2 = proc () -> do+  (proc () ->+    returnA -< ()+    ) -< ()

@@ -0,0 +1,2 @@+getValue :: Maybe Int -> Int+getValue x = case x of Just n -> n; Nothing -> 0

@@ -0,0 +1,2 @@+getValue :: Maybe Int -> Int+getValue x = case x of {Just n -> n; Nothing -> 0}

@@ -0,0 +1,13 @@+handleInput :: IO ()+handleInput = do+  putStrLn "Enter command:"+  cmd <- getLine+  case cmd of+    "quit" -> putStrLn "Goodbye"+    "help" -> do+      putStrLn "Available commands:"+      putStrLn "  quit - exit the program"+      putStrLn "  help - show this message"+    _ -> do+      putStrLn $ "Unknown command: " ++ cmd+      handleInput

@@ -0,0 +1,13 @@+handleInput :: IO ()+handleInput = do+  putStrLn "Enter command:"+  cmd <- getLine+  case cmd of+    "quit" -> putStrLn "Goodbye"+    "help" -> do+      putStrLn "Available commands:"+      putStrLn "  quit - exit the program"+      putStrLn "  help - show this message"+    _ -> do+      putStrLn $ "Unknown command: " ++ cmd+      handleInput

@@ -0,0 +1,2 @@+checkValue :: Int -> IO ()+checkValue n = do putStr "Value is: "; case () of { _ | n < 0 -> putStrLn "negative" | n == 0 -> putStrLn "zero" | otherwise -> putStrLn "positive" }

@@ -0,0 +1,2 @@+checkValue :: Int -> IO ()+checkValue n = do {putStr "Value is: "; case () of {_ | n < 0 -> putStrLn "negative" | n == 0 -> putStrLn "zero" | otherwise -> putStrLn "positive"}}

@@ -0,0 +1,2 @@+processValue :: Maybe Int -> IO ()+processValue x = do putStrLn "Processing:"; \case { Just n -> print n; Nothing -> putStrLn "Empty" } x; putStrLn "Done"

@@ -0,0 +1,2 @@+processValue :: Maybe Int -> IO ()+processValue x = do {putStrLn "Processing:"; \case {Just n -> print n; Nothing -> putStrLn "Empty"} x; putStrLn "Done"}

@@ -0,0 +1,2 @@+processPair :: Maybe Int -> Maybe String -> IO ()+processPair x y = do case x of { Just n -> print n; Nothing -> putStrLn "No number" }; case y of { Just s -> putStrLn s; Nothing -> putStrLn "No string" }

@@ -0,0 +1,2 @@+processPair :: Maybe Int -> Maybe String -> IO ()+processPair x y = do {case x of {Just n -> print n; Nothing -> putStrLn "No number"}; case y of {Just s -> putStrLn s; Nothing -> putStrLn "No string"}}

@@ -0,0 +1,2 @@+nestedDo :: Either String Int -> IO ()+nestedDo e = do putStr "Start: "; case e of { Left s -> do { putStr "Error: "; putStrLn s }; Right n -> do { putStr "Value: "; print n } }; putStrLn "End"

@@ -0,0 +1,2 @@+nestedDo :: Either String Int -> IO ()+nestedDo e = do {putStr "Start: "; case e of {Left s -> do {putStr "Error: "; putStrLn s}; Right n -> do {putStr "Value: "; print n}}; putStrLn "End"}

@@ -0,0 +1,2 @@+doGuessing :: (Ord t, Read t) => t -> IO ()+doGuessing num = do putStrLn "Enter your guess:"; guess <- getLine; case compare (read guess) num of { LT -> do { putStrLn "Too low!"; doGuessing num }; GT -> do { putStrLn "Too high!"; doGuessing num }; EQ -> putStrLn "You win!" }

@@ -0,0 +1,2 @@+doGuessing :: (Ord t, Read t) => t -> IO ()+doGuessing num = do {putStrLn "Enter your guess:"; guess <- getLine; case compare (read guess) num of {LT -> do {putStrLn "Too low!"; doGuessing num}; GT -> do { putStrLn "Too high!"; doGuessing num}; EQ -> putStrLn "You win!"}}

@@ -10,3 +10,5 @@ quux :: Int -> Int quux x | x < 0 = x quux x = x++(a, b) | c = d

@@ -10,3 +10,5 @@ quux :: Int -> Int quux x | x < 0 = x quux x = x++(a, b) | c = d

@@ -0,0 +1,3 @@+startFormTok |~| messageTag+  >~< startMessageTok |~| name+  >~< p' |~| endMessageTok |~| endFormTok

@@ -0,0 +1,3 @@+startFormTok |~| messageTag+  >~< startMessageTok |~| name+  >~< p' |~| endMessageTok |~| endFormTok

@@ -0,0 +1,9 @@+{-# LANGUAGE LinearTypes #-}++h x = g y+  where+    %1 y = f x++let %1 x = u in ()+let %Many (x, y) = u in ()+let %1 ~(x, y) = u in ()

@@ -0,0 +1,9 @@+{-# Language LinearTypes #-}++h x = g y+  where+    %1 y = f x++let %1 x = u in ()+let %Many (x, y) = u in ()+let %1 ~(x, y) = u in ()

@@ -14,3 +14,5 @@       | p -> f       | otherwise -> g     x++x y = if | foo -> False | otherwise -> True

@@ -12,3 +12,5 @@   if | p -> f      | otherwise -> g     x++x y = if | foo -> False | otherwise -> True

@@ -0,0 +1,29 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """Line 1+     Line 2+  Line 3+  """++s_2 =+  """\ \Line 1+     Line 2+  Line 3+  """++-- equivalent to+s' = "Line 1\n   Line 2\nLine 3"++-- the following are equivalent+s = """hello world"""++s' = "hello world"++s =+  """    hello+  world+  """++-- equivalent to+s' = "    hello\nworld"

@@ -0,0 +1,31 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """Line 1+     Line 2+  Line 3+  """++s_2 =+  """\+ \Line 1+     Line 2+  Line 3+  """++-- equivalent to+s' = "Line 1\n   Line 2\nLine 3"+++-- the following are equivalent+s = """hello world"""+s' = "hello world"+++s =+  """    hello+  world+  """++-- equivalent to+s' = "    hello\nworld"

@@ -0,0 +1,12 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """+  a b\ \ c d e+  f g+  """++-- equivalent to+s' = "a b c d e\nf g"++weirdGap = """\65\ \0"""

@@ -0,0 +1,13 @@+{-# LANGUAGE MultilineStrings #-}++s =+    """+      a b\+  \ c d e+      f g+    """++-- equivalent to+s' = "a b c d e\nf g"++weirdGap = """\65\ \0"""

@@ -0,0 +1,11 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """+  a+  b+  c+  """++-- equivalent to+s' = "a\nb\nc"

@@ -0,0 +1,11 @@+{-# LANGUAGE MultilineStrings #-}++s =+	"""+	        a+	 	b+	    	c+	"""++-- equivalent to+s' = "a\nb\nc"

@@ -0,0 +1,32 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """++  a+  b+  c+  """++-- equivalent to+s' = "\na\nb\nc"++s1 =+  """    a+  b+  c+  """++s2 =+  """+  a+  b+  c+  """++-- In the current proposal, these are equivalent to+-- the below. If leading newline were removed at the+-- beginning, both would result in s1'.+s1' = "    a\nb\nc"++s2' = "a\nb\nc"

@@ -0,0 +1,32 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """++  a+  b+  c+  """++-- equivalent to+s' = "\na\nb\nc"+++s1 =+  """    a+  b+  c+  """++s2 =+  """+  a+  b+  c+  """++-- In the current proposal, these are equivalent to+-- the below. If leading newline were removed at the+-- beginning, both would result in s1'.+s1' = "    a\nb\nc"+s2' = "a\nb\nc"

@@ -0,0 +1,25 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """+  a+  b++  """++-- equivalent to+s' = "a\nb\n"++s1 =+  """+  line 1+  line 2+  """++s2 = "line 3"++s3 =+  """+  line 4+  line 5+  """

@@ -0,0 +1,26 @@+{-# LANGUAGE MultilineStrings #-}++s =+  """+  a+  b++  """++-- equivalent to+s' = "a\nb\n"+++s1 =+  """+  line 1+  line 2+  """++s2 = "line 3"++s3 =+  """+  line 4+  line 5+  """

@@ -0,0 +1,26 @@+{-# LANGUAGE MultilineStrings #-}++s1 =+  """+  a+  b+  c+  """++s1' = "a\nb\nc"++s2 =+  """+  \&  a+    b+    c+  """++s2_2 =+  """+  \&  a+  \&  b+  \&  c+  """++s2' = "  a\n  b\n  c"

@@ -0,0 +1,26 @@+{-# LANGUAGE MultilineStrings #-}++s1 =+  """+    a+    b+    c+  """++s1' = "a\nb\nc"++s2 =+  """+  \&  a+    b+    c+  """++s2_2 =+  """+  \&  a+  \&  b+  \&  c+  """++s2' = "  a\n  b\n  c"

@@ -0,0 +1,10 @@+{-# LANGUAGE MultilineStrings #-}++x =+  """+  This is a literal multiline string:+  \"\"\"+  Hello+    world!+  \"""+  """

@@ -0,0 +1,10 @@+{-# LANGUAGE MultilineStrings #-}++x =+  """+  This is a literal multiline string:+  \"\"\"+  Hello+    world!+  \"""+  """

@@ -0,0 +1,30 @@+{-# LANGUAGE MultilineStrings #-}++printf+  """+  instance Aeson.FromJSON %s where+    parseJSON =+      Aeson.withText "%s" $ \\s ->+        either Aeson.parseFail pure $+          parsePrinterOptType (Text.unpack s)++  instance PrinterOptsFieldType %s where+    parsePrinterOptType s =+      case s of+  %s+        _ ->+          Left . unlines $+            [ "unknown value: " <> show s+            , "Valid values are: %s"+            ]++  """+  fieldTypeName+  fieldTypeName+  fieldTypeName+  ( unlines_+      [ printf "      \"%s\" -> Right %s" val con+      | (con, val) <- enumOptions+      ]+  )+  (renderEnumOptions enumOptions)

@@ -0,0 +1,30 @@+{-# LANGUAGE MultilineStrings #-}++printf+  """+  instance Aeson.FromJSON %s where+    parseJSON =+      Aeson.withText "%s" $ \\s ->+        either Aeson.parseFail pure $+          parsePrinterOptType (Text.unpack s)++  instance PrinterOptsFieldType %s where+    parsePrinterOptType s =+      case s of+  %s+        _ ->+          Left . unlines $+            [ "unknown value: " <> show s+            , "Valid values are: %s"+            ]++  """+  fieldTypeName+  fieldTypeName+  fieldTypeName+  ( unlines_+      [ printf "      \"%s\" -> Right %s" val con+      | (con, val) <- enumOptions+      ]+  )+  (renderEnumOptions enumOptions)

@@ -0,0 +1,12 @@+{-# LANGUAGE MultilineStrings #-}++type Foo =+  """+  yeah+    yeah"""++foo =+  foo+    @"""yeah+     yeah+     """

@@ -0,0 +1,9 @@+{-# LANGUAGE MultilineStrings #-}++type Foo = """+  yeah+    yeah"""++foo = foo @"""yeah+           yeah+           """

@@ -0,0 +1,11 @@+{-# LANGUAGE MultilineStrings #-}++multilineBlank =+  """+  1+++++  6+  """

@@ -0,0 +1,11 @@+{-# LANGUAGE MultilineStrings #-}++multilineBlank =+  """+  1+++++  6+  """

@@ -0,0 +1,44 @@+{-# LANGUAGE PatternSynonyms #-}++tasty (Cupcake; Cookie) = True+tasty (Liquorice; Raisins) = False++f :: (Eq a, Show a) => a -> a -> Bool+f a ((== a) -> True; show -> "yes") = True+f _ _ = False++small (abs -> (0; 1; 2); 3) = True -- -3 is not small+small _ = False++type Coll a = Either [a] (Set a)++pattern None <- (Left []; Right (toList -> []))++case e of+  1; 2; 3 -> x+  4; (5; 6) -> y++sane e = case e of+  1+  2+  3 ->+    a+  4+  5+  6 -> b+  7; 8 -> c++insane e = case e of+  A _ _+  B _+  C -> 3+  (D; E (Just _) Nothing) ->+    4+  F -> 5++food+  foo@( A;+        B;+        C+        ) = Just foo+food _ = Nothing

@@ -0,0 +1,39 @@+{-# LANGUAGE PatternSynonyms #-}++tasty (Cupcake; Cookie) = True+tasty (Liquorice; Raisins) = False++f :: (Eq a, Show a) => a -> a -> Bool+f a ((== a) -> True; show -> "yes") = True+f _ _ = False++small (abs -> (0; 1; 2); 3) = True -- -3 is not small+small _ = False++type Coll a = Either [a] (Set a)+pattern None <- (Left []; Right (toList -> []))++case e of+  1; 2; 3 -> x+  4; (5; 6) -> y++sane e = case e of+  1+  2+  3 ->+    a+  4+  5;6 -> b+  7;8 -> c++insane e = case e of+  A _ _; B _+  C -> 3+  (D; E (Just _) Nothing)+   -> 4+  F -> 5++food foo@(A;+          B;+          C) = Just foo+food _ = Nothing

@@ -0,0 +1,23 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE UnicodeSyntax #-}++ex1 = f (forall a. Proxy a)++ex2 = f ((ctx) => Int)++ex2' = f ((ctx, ctx') => Int)++ex3 = f (String -> Bool)++long =+  f+    ( forall m a.+      (A a, M m) =>+      String ->+      Bool %1 ->+      Maybe Int ->+      Maybe+        (String, Int) %1 ->+      Word %m ->+      Text+    )

@@ -0,0 +1,14 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE LinearTypes #-}++ex1  = f (forall a. Proxy a)+ex2  = f (ctx => Int)+ex2' = f ((ctx,ctx') => Int)+ex3  = f (String -> Bool)++long = f (forall m a. (A a, M m) => String+       -> Bool %1 ->+          Maybe Int+       -> Maybe+             (String,Int)+        ⊸ Word %m -> Text )

@@ -2,9 +2,13 @@  foo = "foobar" -bar = "foo\&barbaz"+bar = "foo\&bar\ \baz"  baz =   "foo\   \bar\   \baz"++weirdGap = "\65\ \0"++weirdEscape = "\^\ "

@@ -5,3 +5,7 @@ baz = "foo\       \bar\     \baz"++weirdGap = "\65\ \0"++weirdEscape = "\^\ "

@@ -22,3 +22,5 @@     @u     v ->       ""++foo = foo @[k|bar|]

@@ -17,3 +17,5 @@   Bar    @t @u v     -> ""++foo = foo @[k|bar|]

@@ -0,0 +1,3 @@+module Bar (data P, T (data P), data f) where++import N (T (data P), data P, data f)

@@ -0,0 +1,6 @@++module Bar (data P, T(data P), data f) where++import N (data P)+import N (T(data P))+import N (data f)

@@ -0,0 +1,13 @@+{-# LANGUAGE ExplicitLevelImports #-}++import A splice+import {-# SOURCE #-} safe qualified A splice as QA hiding (a, b, c, d, e, f)+import quote qualified B as QB+import qualified C splice as SC+import qualified D splice+import Data.ByteString (e)+import Data.ByteString.Lazy quote (d)+import splice Data.Text (a, b, c)+import PyF ()+import splice PyF (fmt, tmf)+import quote PyF (abc)

@@ -0,0 +1,5 @@+{-# LANGUAGE ExplicitLevelImports #-}+{-# LANGUAGE ImportQualifiedPost #-}++import quote A qualified as QA+import B quote qualified as QB

@@ -0,0 +1,5 @@+{-# LANGUAGE ExplicitLevelImports #-}+{-# LANGUAGE ImportQualifiedPost #-}++import qualified B quote as QB+import quote qualified A as QA

@@ -0,0 +1,14 @@+{-# LANGUAGE ExplicitLevelImports #-}++import splice Data.Text (a, b, c)+import Data.ByteString.Lazy quote (d)+import Data.ByteString (e)+import {-# SOURCE #-} safe qualified A splice as QA hiding (a, b, c, d, e, f)+import quote qualified B as QB+import qualified C splice as SC+import A splice+import qualified D splice+import quote PyF (abc)+import splice PyF (fmt)+import splice PyF (tmf)+import PyF ()

@@ -12,7 +12,7 @@   forall. T x = x  {-# RULES-"r"+"r" forall.   r a =     ()   #-}

binary file changed (989821 → 1002933 bytes)

@@ -1,199 +1,214 @@-cabal-version:      2.4-name:               ormolu-version:            0.7.7.0-license:            BSD-3-Clause-license-file:       LICENSE.md-maintainer:         Mark Karpov <mark.karpov@tweag.io>-tested-with:        ghc ==9.6.5 ghc ==9.8.2 ghc ==9.10.1-homepage:           https://github.com/tweag/ormolu-bug-reports:        https://github.com/tweag/ormolu/issues-synopsis:           A formatter for Haskell source code-description:        A formatter for Haskell source code.-category:           Development, Formatting-build-type:         Simple+cabal-version: 2.4+name: ormolu+version: 0.8.1.1+license: BSD-3-Clause+license-file: LICENSE.md+maintainer: Mark Karpov <mark.karpov@tweag.io>+tested-with:+  ghc ==9.10.2+  ghc ==9.12.2+  ghc ==9.14.1++homepage: https://github.com/tweag/ormolu+bug-reports: https://github.com/tweag/ormolu/issues+synopsis: A formatter for Haskell source code+description: A formatter for Haskell source code.+category: Development, Formatting+build-type: Simple extra-source-files:-    data/**/*.hs-    data/**/*.txt-    data/**/*.cabal-    extract-hackage-info/hackage-info.bin+  data/**/*.cabal+  data/**/*.hs+  data/**/*.txt+  extract-hackage-info/hackage-info.bin  extra-doc-files:-    CONTRIBUTING.md-    CHANGELOG.md-    DESIGN.md-    README.md+  CHANGELOG.md+  CONTRIBUTING.md+  DESIGN.md+  README.md  source-repository head-    type:     git-    location: https://github.com/tweag/ormolu.git+  type: git+  location: https://github.com/tweag/ormolu.git  flag dev-    description: Turn on development settings.-    default:     False-    manual:      True--flag internal-bundle-fixities-    description:-        An internal ad-hoc flag that is enabled by default, Ormolu Live disables-        it due to missing WASM TH support.--    manual:      True+  description: Turn on development settings.+  default: False+  manual: True  library-    exposed-modules:-        Ormolu-        Ormolu.Config-        Ormolu.Diff.ParseResult-        Ormolu.Diff.Text-        Ormolu.Exception-        Ormolu.Imports-        Ormolu.Parser-        Ormolu.Parser.CommentStream-        Ormolu.Parser.Pragma-        Ormolu.Parser.Result-        Ormolu.Printer-        Ormolu.Printer.Combinators-        Ormolu.Printer.Comments-        Ormolu.Printer.Internal-        Ormolu.Printer.Meat.Common-        Ormolu.Printer.Meat.Declaration-        Ormolu.Printer.Meat.Declaration.Annotation-        Ormolu.Printer.Meat.Declaration.Class-        Ormolu.Printer.Meat.Declaration.Data-        Ormolu.Printer.Meat.Declaration.Default-        Ormolu.Printer.Meat.Declaration.Foreign-        Ormolu.Printer.Meat.Declaration.Instance-        Ormolu.Printer.Meat.Declaration.RoleAnnotation-        Ormolu.Printer.Meat.Declaration.Rule-        Ormolu.Printer.Meat.Declaration.Signature-        Ormolu.Printer.Meat.Declaration.Splice-        Ormolu.Printer.Meat.Declaration.Type-        Ormolu.Printer.Meat.Declaration.TypeFamily-        Ormolu.Printer.Meat.Declaration.Value-        Ormolu.Printer.Meat.Declaration.OpTree-        Ormolu.Printer.Meat.Declaration.Warning-        Ormolu.Printer.Meat.ImportExport-        Ormolu.Printer.Meat.Module-        Ormolu.Printer.Meat.Pragma-        Ormolu.Printer.Meat.Type-        Ormolu.Printer.Operators-        Ormolu.Fixity-        Ormolu.Fixity.Imports-        Ormolu.Fixity.Internal-        Ormolu.Fixity.Parser-        Ormolu.Fixity.Printer-        Ormolu.Printer.SpanStream-        Ormolu.Processing.Common-        Ormolu.Processing.Cpp-        Ormolu.Processing.Preprocess-        Ormolu.Terminal-        Ormolu.Terminal.QualifiedDo-        Ormolu.Utils-        Ormolu.Utils.Cabal-        Ormolu.Utils.Fixity-        Ormolu.Utils.IO--    hs-source-dirs:   src-    other-modules:    GHC.DynFlags-    default-language: GHC2021-    build-depends:-        Cabal-syntax >=3.12 && <3.13,-        Diff >=0.4 && <1,-        MemoTrie >=0.6 && <0.7,-        ansi-terminal >=0.10 && <1.2,-        array >=0.5 && <0.6,-        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,-        file-embed >=0.0.15 && <0.1,-        filepath >=1.2 && <1.6,-        ghc-lib-parser >=9.10 && <9.11,-        megaparsec >=9,-        mtl >=2 && <3,-        syb >=0.7 && <0.8,-        text >=2.1 && <3--    if flag(dev)-        ghc-options:-            -Wall -Werror -Wredundant-constraints -Wpartial-fields-            -Wunused-packages+  exposed-modules:+    Ormolu+    Ormolu.Config+    Ormolu.Diff.ParseResult+    Ormolu.Diff.Text+    Ormolu.Exception+    Ormolu.Fixity+    Ormolu.Fixity.Imports+    Ormolu.Fixity.Internal+    Ormolu.Fixity.Parser+    Ormolu.Fixity.Printer+    Ormolu.Imports+    Ormolu.Parser+    Ormolu.Parser.CommentStream+    Ormolu.Parser.Pragma+    Ormolu.Parser.Result+    Ormolu.Printer+    Ormolu.Printer.Combinators+    Ormolu.Printer.Comments+    Ormolu.Printer.Internal+    Ormolu.Printer.Meat.Common+    Ormolu.Printer.Meat.Declaration+    Ormolu.Printer.Meat.Declaration.Annotation+    Ormolu.Printer.Meat.Declaration.Class+    Ormolu.Printer.Meat.Declaration.Data+    Ormolu.Printer.Meat.Declaration.Default+    Ormolu.Printer.Meat.Declaration.Foreign+    Ormolu.Printer.Meat.Declaration.Instance+    Ormolu.Printer.Meat.Declaration.OpTree+    Ormolu.Printer.Meat.Declaration.RoleAnnotation+    Ormolu.Printer.Meat.Declaration.Rule+    Ormolu.Printer.Meat.Declaration.Signature+    Ormolu.Printer.Meat.Declaration.Splice+    Ormolu.Printer.Meat.Declaration.StringLiteral+    Ormolu.Printer.Meat.Declaration.Type+    Ormolu.Printer.Meat.Declaration.TypeFamily+    Ormolu.Printer.Meat.Declaration.Value+    Ormolu.Printer.Meat.Declaration.Warning+    Ormolu.Printer.Meat.ImportExport+    Ormolu.Printer.Meat.Module+    Ormolu.Printer.Meat.Pragma+    Ormolu.Printer.Meat.Type+    Ormolu.Printer.Operators+    Ormolu.Printer.SpanStream+    Ormolu.Processing.Common+    Ormolu.Processing.Cpp+    Ormolu.Processing.Preprocess+    Ormolu.Terminal+    Ormolu.Terminal.QualifiedDo+    Ormolu.Utils+    Ormolu.Utils.Cabal+    Ormolu.Utils.Fixity+    Ormolu.Utils.IO -    else-        ghc-options: -O2 -Wall+  hs-source-dirs: src+  other-modules: GHC.DynFlags+  default-language: GHC2021+  build-depends:+    Cabal-syntax >=3.16 && <3.17,+    Diff >=0.4 && <2,+    MemoTrie >=0.6 && <0.7,+    ansi-terminal >=0.10 && <1.2,+    array >=0.5 && <0.6,+    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.9,+    directory ^>=1.3,+    file-embed >=0.0.15 && <0.1,+    filepath >=1.2 && <1.6,+    ghc-lib-parser >=9.14 && <9.15,+    megaparsec >=9,+    mtl >=2 && <3,+    syb >=0.7 && <0.8,+    text >=2.1 && <3, -    if flag(internal-bundle-fixities)-        cpp-options: -DBUNDLE_FIXITIES+  if flag(dev)+    ghc-options:+      -Wall+      -Werror+      -Wredundant-constraints+      -Wpartial-fields+      -Wunused-packages+  else+    ghc-options:+      -O2+      -Wall  executable ormolu-    main-is:          Main.hs-    hs-source-dirs:   app-    other-modules:    Paths_ormolu-    autogen-modules:  Paths_ormolu-    default-language: GHC2021-    build-depends:-        Cabal-syntax >=3.12 && <3.13,-        base >=4.12 && <5,-        containers >=0.5 && <0.8,-        directory ^>=1.3,-        filepath >=1.2 && <1.6,-        ghc-lib-parser >=9.10 && <9.11,-        optparse-applicative >=0.14 && <0.19,-        ormolu,-        text >=2.1 && <3,-        th-env >=0.1.1 && <0.2+  main-is: Main.hs+  hs-source-dirs: app+  other-modules: Paths_ormolu+  autogen-modules: Paths_ormolu+  default-language: GHC2021+  build-depends:+    Cabal-syntax >=3.16 && <3.17,+    base >=4.12 && <5,+    containers >=0.5 && <0.9,+    directory ^>=1.3,+    filepath >=1.2 && <1.6,+    ghc-lib-parser >=9.14 && <9.15,+    optparse-applicative >=0.14 && <0.20,+    ormolu,+    text >=2.1 && <3,+    th-env >=0.1.1 && <0.2,+    unliftio >=0.2.10 && <0.3, -    if flag(dev)-        ghc-options:-            -Wall -Werror -Wredundant-constraints -Wpartial-fields-            -Wunused-packages -Wwarn=unused-packages+  -- We use parallelism so we need a threaded runtime to get any+  -- benefit.+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-N -    else-        ghc-options: -O2 -Wall -rtsopts+  if flag(dev)+    ghc-options:+      -Wall+      -Werror+      -Wredundant-constraints+      -Wpartial-fields+      -Wunused-packages+      -Wwarn=unused-packages+  else+    ghc-options:+      -O2+      -Wall  test-suite tests-    type:               exitcode-stdio-1.0-    main-is:            Spec.hs-    build-tool-depends: hspec-discover:hspec-discover >=2 && <3-    hs-source-dirs:     tests-    other-modules:-        Ormolu.CabalInfoSpec-        Ormolu.Diff.TextSpec-        Ormolu.Fixity.ParserSpec-        Ormolu.Fixity.PrinterSpec-        Ormolu.FixitySpec-        Ormolu.OpTreeSpec-        Ormolu.Parser.OptionsSpec-        Ormolu.Parser.ParseFailureSpec-        Ormolu.Parser.PragmaSpec-        Ormolu.PrinterSpec--    default-language:   GHC2021-    build-depends:-        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,-        ghc-lib-parser >=9.10 && <9.11,-        hspec >=2 && <3,-        hspec-megaparsec >=2.2,-        megaparsec >=9,-        ormolu,-        path >=0.6 && <0.10,-        path-io >=1.4.2 && <2,-        temporary ^>=1.3,-        text >=2.1 && <3+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  build-tool-depends: hspec-discover:hspec-discover >=2 && <3+  hs-source-dirs: tests+  other-modules:+    Ormolu.CabalInfoSpec+    Ormolu.Diff.TextSpec+    Ormolu.Fixity.ParserSpec+    Ormolu.Fixity.PrinterSpec+    Ormolu.FixitySpec+    Ormolu.OpTreeSpec+    Ormolu.Parser.OptionsSpec+    Ormolu.Parser.ParseFailureSpec+    Ormolu.Parser.PragmaSpec+    Ormolu.PrinterSpec -    if flag(dev)-        ghc-options:-            -Wall -Werror -Wredundant-constraints -Wpartial-fields-            -Wunused-packages+  default-language: GHC2021+  build-depends:+    Cabal-syntax >=3.16 && <3.17,+    QuickCheck >=2.14,+    base >=4.14 && <5,+    choice >=0.2.4.1 && <0.3,+    containers >=0.5 && <0.9,+    directory ^>=1.3,+    filepath >=1.2 && <1.6,+    ghc-lib-parser >=9.14 && <9.15,+    hspec >=2 && <3,+    hspec-megaparsec >=2.2,+    megaparsec >=9,+    ormolu,+    path >=0.6 && <0.10,+    path-io >=1.4.2 && <2,+    temporary ^>=1.3,+    text >=2.1 && <3, -    else-        ghc-options: -O2 -Wall+  if flag(dev)+    ghc-options:+      -Wall+      -Werror+      -Wredundant-constraints+      -Wpartial-fields+      -Wunused-packages+  else+    ghc-options:+      -O2+      -Wall

@@ -7,10 +7,12 @@   ) where +import GHC.Data.FastString import GHC.Driver.Session import GHC.Platform import GHC.Settings import GHC.Settings.Config+import GHC.Unit.Types import GHC.Utils.Fingerprint  fakeSettings :: Settings@@ -43,6 +45,10 @@             platform_constants = Nothing           },       sPlatformMisc = PlatformMisc {},+      sUnitSettings =+        UnitSettings+          { unitSettings_baseUnitId = UnitId $ fsLit "ormolu"+          },       sToolSettings =         ToolSettings           { toolSettings_opt_P_fingerprint = fingerprint0,

@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeepSubsumption #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} @@ -14,12 +15,14 @@ import Data.Foldable import Data.Function import Data.Generics+import GHC.Data.FastString (FastString) import GHC.Hs import GHC.Types.SourceText import GHC.Types.SrcLoc import Ormolu.Parser.CommentStream import Ormolu.Parser.Result import Ormolu.Utils+import Type.Reflection qualified as TR  -- | Result of comparing two 'ParseResult's. data ParseResultDiff@@ -61,16 +64,8 @@   where     commentLines = concatMap (toList . unComment . unLoc) --- | Compare two modules for equality disregarding the following aspects:------     * 'SrcSpan's---     * ordering of import lists---     * style (ASCII vs Unicode) of arrows, colons---     * LayoutInfo (brace style) in extension fields---     * Empty contexts in type classes---     * Parens around derived type classes---     * 'TokenLocation' (in 'LHsToken'/'LHsUniToken')---     * 'EpaLocation'+-- | Compare two modules for equality disregarding certain semantically+-- irrelevant features like exact print annotations. diffHsModule :: HsModule GhcPs -> HsModule GhcPs -> ParseResultDiff diffHsModule = genericQuery   where@@ -83,35 +78,63 @@           if x' == (y' :: ByteString)             then Same             else Different []+      | Just rep <- isEpTokenish x,+        Just rep' <- isEpTokenish y =+          -- Only check whether the Ep(Uni)Tokens are of the same type; don't+          -- look at the actual payload (e.g. the location).+          if rep == rep' then Same else Different []       | typeOf x == typeOf y,         toConstr x == toConstr y =           mconcat $             gzipWithQ               ( genericQuery+                  -- EPA-related                   `extQ` considerEqual @SrcSpan                   `ext1Q` epAnnEq                   `extQ` considerEqual @SourceText-                  `extQ` hsDocStringEq-                  `extQ` importDeclQualifiedStyleEq-                  `extQ` classDeclCtxEq-                  `extQ` derivedTyClsParensEq                   `extQ` considerEqual @EpAnnComments -- ~ XCGRHSs GhcPs-                  `extQ` considerEqual @TokenLocation -- in LHs(Uni)Token                   `extQ` considerEqual @EpaLocation+                  `extQ` considerEqual @(Maybe EpaLocation)                   `extQ` considerEqual @EpLayout-                  `extQ` considerEqual @[AddEpAnn]                   `extQ` considerEqual @AnnSig                   `extQ` considerEqual @HsRuleAnn+                  `extQ` considerEqual @EpLinear+                  `extQ` considerEqual @AnnSynDecl+                  -- FastString (for example for string literals)+                  `extQ` considerEqualVia' ((==) @FastString)+                  -- ModuleName is a newtype of FastString+                  `extQ` considerEqualVia' ((==) @ModuleName)+                  -- Haddock strings+                  `extQ` hsDocStringEq+                  -- Whether imports are pre- or post-qualified+                  `extQ` importDeclQualifiedStyleEq+                  -- Whether a class has an empty context+                  `extQ` classDeclCtxEq+                  -- Whether there are parens around a derived type class+                  `extQ` derivedTyClsParensEq+                  -- For better error messages                   `ext2Q` forLocated-                  -- unicode-related-                  `extQ` considerEqual @(EpUniToken "->" "→")-                  `extQ` considerEqual @(EpUniToken "::" "∷")-                  `extQ` considerEqual @EpLinearArrow               )               x               y       | otherwise = Different [] +    -- Return the 'TR.SomeTypeRep' of the type of the given value if it is an+    -- 'EpToken', an 'EpUniToken', or a list of these.+    isEpTokenish :: (Typeable a) => a -> Maybe TR.SomeTypeRep+    isEpTokenish = fmap TR.SomeTypeRep . go . TR.typeOf+      where+        go :: TR.TypeRep a -> Maybe (TR.TypeRep a)+        go rep = case rep of+          TR.App t t'+            | Just HRefl <- TR.eqTypeRep t (TR.typeRep @[]) ->+                TR.App t <$> go t'+          TR.App (TR.App t _) _ ->+            rep <$ TR.eqTypeRep t (TR.typeRep @EpUniToken)+          TR.App t _ ->+            rep <$ TR.eqTypeRep t (TR.typeRep @EpToken)+          _ -> Nothing+     considerEqualVia ::       forall a.       (Typeable a) =>@@ -130,6 +153,7 @@     epAnnEq :: EpAnn a -> b -> ParseResultDiff     epAnnEq _ _ = Same +    importDeclQualifiedStyleEq :: forall a. (Data a) => ImportDeclQualifiedStyle -> a -> ParseResultDiff     importDeclQualifiedStyleEq = considerEqualVia' f       where         f QualifiedPre QualifiedPost = True

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QualifiedDo #-}@@ -24,9 +23,6 @@ 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

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-}@@ -35,6 +34,7 @@ import Data.Binary qualified as Binary import Data.Binary.Get qualified as Binary import Data.ByteString.Lazy qualified as BL+import Data.FileEmbed (embedFile) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map@@ -46,27 +46,12 @@ import Language.Haskell.Syntax.ImpExp (ImportListInterpretation (..)) import Ormolu.Fixity.Imports (FixityImport (..)) import Ormolu.Fixity.Internal-#if BUNDLE_FIXITIES-import Data.FileEmbed (embedFile)-#else-import qualified Data.ByteString as B-import System.IO.Unsafe (unsafePerformIO)-#endif  -- | The built-in 'HackageInfo' used by Ormolu. hackageInfo :: HackageInfo-#if BUNDLE_FIXITIES hackageInfo =   Binary.runGet Binary.get $     BL.fromStrict $(embedFile "extract-hackage-info/hackage-info.bin")-#else--- The GHC WASM backend does not yet support Template Haskell, so we instead--- pass in the encoded fixity DB via pre-initialization with Wizer.-hackageInfo =-  unsafePerformIO $-    Binary.runGet Binary.get . BL.fromStrict <$> B.readFile "hackage-info.bin"-{-# NOINLINE hackageInfo #-}-#endif  -- | Default set of packages to assume as dependencies e.g. when no Cabal -- file is found or taken into consideration.

@@ -30,8 +30,10 @@   ) where -import Control.DeepSeq (NFData) import Data.Binary (Binary)+import Data.Binary qualified as Binary+import Data.Binary.Get qualified as Binary+import Data.Binary.Put qualified as Binary import Data.ByteString.Short (ShortByteString) import Data.ByteString.Short qualified as SBS import Data.Choice (Choice)@@ -59,7 +61,7 @@   { -- | Invariant: UTF-8 encoded     getOpName :: ShortByteString   }-  deriving newtype (Eq, Ord, Binary, NFData)+  deriving newtype (Eq, Ord, Binary)  -- | Convert an 'OpName' to 'Text'. unOpName :: OpName -> Text@@ -88,7 +90,7 @@   | InfixR   | InfixN   deriving stock (Eq, Ord, Show, Generic)-  deriving anyclass (Binary, NFData)+  deriving anyclass (Binary)  -- | Fixity information about an infix operator. This type provides precise -- information as opposed to 'FixityApproximation'.@@ -96,11 +98,20 @@   { -- | Fixity direction     fiDirection :: FixityDirection,     -- | Precedence-    fiPrecedence :: Int+    fiPrecedence :: Double   }   deriving stock (Eq, Ord, Show, Generic)-  deriving anyclass (Binary, NFData) +instance Binary FixityInfo where+  put FixityInfo {..} = do+    Binary.put fiDirection+    Binary.putDoublele fiPrecedence++  get = do+    fiDirection <- Binary.get+    fiPrecedence <- Binary.getDoublele+    pure FixityInfo {..}+ -- | Fixity info of the built-in colon data constructor. colonFixityInfo :: FixityInfo colonFixityInfo = FixityInfo InfixR 5@@ -116,14 +127,25 @@     faDirection :: Maybe FixityDirection,     -- | Minimum precedence level found in the (maybe conflicting)     -- definitions for the operator (inclusive)-    faMinPrecedence :: Int,+    faMinPrecedence :: Double,     -- | Maximum precedence level found in the (maybe conflicting)     -- definitions for the operator (inclusive)-    faMaxPrecedence :: Int+    faMaxPrecedence :: Double   }   deriving stock (Eq, Ord, Show, Generic)-  deriving anyclass (Binary, NFData) +instance Binary FixityApproximation where+  put FixityApproximation {..} = do+    Binary.put faDirection+    Binary.putDoublele faMinPrecedence+    Binary.putDoublele faMaxPrecedence++  get = do+    faDirection <- Binary.get+    faMinPrecedence <- Binary.getDoublele+    faMaxPrecedence <- Binary.getDoublele+    pure FixityApproximation {..}+ -- | Gives the ability to merge two (maybe conflicting) definitions for an -- operator, keeping the higher level of compatible information from both. instance Semigroup FixityApproximation where@@ -156,7 +178,7 @@ newtype HackageInfo   = HackageInfo (Map PackageName (Map ModuleName (Map OpName FixityInfo)))   deriving stock (Generic)-  deriving anyclass (Binary, NFData)+  deriving anyclass (Binary)  -- | Map from the operator name to its 'FixityInfo'. newtype FixityOverrides = FixityOverrides

@@ -103,7 +103,9 @@   fiDirection <- pFixityDirection   hidden hspace1   offsetAtPrecedence <- getOffset-  fiPrecedence <- L.decimal+  fiPrecedence <-+    try L.float+      <|> (fromIntegral <$> (L.decimal :: Parser Integer))   when (fiPrecedence > 9) $     region       (setErrorOffset offsetAtPrecedence)

@@ -19,6 +19,7 @@ import Data.Text.Lazy.Builder (Builder) import Data.Text.Lazy.Builder qualified as B import Data.Text.Lazy.Builder.Int qualified as B+import Data.Text.Lazy.Builder.RealFloat qualified as B import Distribution.ModuleName (ModuleName) import Distribution.ModuleName qualified as ModuleName import Distribution.Types.PackageName@@ -44,7 +45,7 @@         InfixR -> "infixr"         InfixN -> "infix",       " ",-      B.decimal fiPrecedence,+      renderPrecedence fiPrecedence,       " ",       if isTickedOperator operator         then "`" <> B.fromText operator <> "`"@@ -75,3 +76,12 @@  renderModuleName :: ModuleName -> Builder renderModuleName = B.fromString . intercalate "." . ModuleName.components++-- | Render precedence using integer representation for whole numbers.+renderPrecedence :: Double -> Builder+renderPrecedence x =+  let (n :: Int, fraction :: Double) = properFraction x+      isWholeEnough = fraction < 0.0001+   in if isWholeEnough+        then B.decimal n+        else B.realFloat x

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}@@ -17,6 +16,7 @@ import Data.List (nubBy, sortBy, sortOn) import Data.Map.Strict (Map) import Data.Map.Strict qualified as M+import Data.Ord (comparing) import GHC.Data.FastString import GHC.Hs import GHC.Hs.ImpExp as GHC@@ -25,9 +25,6 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc import Ormolu.Utils (notImplemented, showOutputable)-#if !MIN_VERSION_base(4,20,0)-import Data.List (foldl')-#endif  -- | Sort and normalize imports. normalizeImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs]@@ -74,10 +71,23 @@     importSafe :: Bool,     importQualified :: Bool,     importAs :: Maybe ModuleName,-    importHiding :: Maybe ImportListInterpretationOrd+    importHiding :: Maybe ImportListInterpretationOrd,+    importLevel :: Maybe ImportDeclLevelOrd   }   deriving (Eq, Ord) +-- | A wrapper for 'ImportDeclLevel' that provides an 'Ord' instance.+newtype ImportDeclLevelOrd = ImportDeclLevelOrd+  { unImportDeclLevelOrd :: ImportDeclLevel+  }+  deriving stock (Eq)++instance Ord ImportDeclLevelOrd where+  compare = compare `on` toBool . unImportDeclLevelOrd+    where+      toBool ImportDeclSplice = False+      toBool ImportDeclQuote = True+ data ImportPkgQual   = -- | The import is not qualified by a package name.     NoImportPkgQual@@ -121,11 +131,16 @@         QualifiedPost -> True         NotQualified -> False,       importAs = unLoc <$> ideclAs,-      importHiding = ImportListInterpretationOrd . fst <$> ideclImportList+      importHiding = ImportListInterpretationOrd . fst <$> ideclImportList,+      importLevel = importLevelOf ideclLevelSpec     }   where     isPrelude = moduleNameString moduleName == "Prelude"     moduleName = unLoc ideclName+    importLevelOf = \case+      LevelStylePre l -> Just (ImportDeclLevelOrd l)+      LevelStylePost l -> Just (ImportDeclLevelOrd l)+      NotLevelled -> Nothing  -- | Normalize a collection of import items. normalizeLies :: [LIE GhcPs] -> [LIE GhcPs]@@ -155,7 +170,7 @@                         IEVar _ _ _ ->                           error "Ormolu.Imports broken presupposition"                         IEThingAbs x _ _ ->-                          IEThingWith x n wildcard g Nothing+                          IEThingWith (x, noAnn) n wildcard g Nothing                         IEThingAll x n' _ ->                           IEThingAll x n' Nothing                         IEThingWith x n' wildcard' g' _ ->@@ -207,15 +222,15 @@  -- | Compare two @'IEWrapppedName' 'GhcPs'@ things. compareIewn :: IEWrappedName GhcPs -> IEWrappedName GhcPs -> Ordering-compareIewn (IEName _ x) (IEName _ y) = unLoc x `compareRdrName` unLoc y-compareIewn (IEName _ _) (IEPattern _ _) = LT-compareIewn (IEName _ _) (IEType _ _) = LT-compareIewn (IEPattern _ _) (IEName _ _) = GT-compareIewn (IEPattern _ x) (IEPattern _ y) = unLoc x `compareRdrName` unLoc y-compareIewn (IEPattern _ _) (IEType _ _) = LT-compareIewn (IEType _ _) (IEName _ _) = GT-compareIewn (IEType _ _) (IEPattern _ _) = GT-compareIewn (IEType _ x) (IEType _ y) = unLoc x `compareRdrName` unLoc y+compareIewn = (comparing fst <> (compareRdrName `on` unLoc . snd)) `on` classify+  where+    classify :: IEWrappedName GhcPs -> (Int, LocatedN RdrName)+    classify = \case+      IEName _ x -> (0, x)+      IEDefault _ x -> (1, x)+      IEPattern _ x -> (2, x)+      IEType _ x -> (3, x)+      IEData _ x -> (4, x)  compareRdrName :: RdrName -> RdrName -> Ordering compareRdrName x y =

@@ -28,7 +28,7 @@ import GHC.Data.FastString qualified as GHC import GHC.Data.Maybe (orElse) import GHC.Data.StringBuffer (StringBuffer)-import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Config.Parser (initParserOpts, supportedLanguagePragmas) import GHC.Driver.Errors.Types qualified as GHC import GHC.Driver.Session as GHC import GHC.DynFlags (baseDynFlags)@@ -43,6 +43,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Error import GHC.Utils.Exception (ExceptionMonad)+import GHC.Utils.Logger (initLogger) import GHC.Utils.Panic qualified as GHC import Ormolu.Config import Ormolu.Exception@@ -175,7 +176,11 @@ normalizeModule :: HsModule GhcPs -> HsModule GhcPs normalizeModule hsmod =   everywhere-    (mkT dropBlankTypeHaddocks `extT` dropBlankDataDeclHaddocks `extT` patchContext)+    ( mkT dropBlankTypeHaddocks+        `extT` dropBlankDataDeclHaddocks+        `extT` patchContext+        `extT` patchExprContext+    )     hsmod       { hsmodImports =           normalizeImports (hsmodImports hsmod),@@ -209,11 +214,18 @@         | isBlankDocString s -> ConDeclH98 {con_doc = Nothing, ..}       a -> a +    -- For constraint contexts (both in types and in expressions), normalize+    -- parenthesis as decided in https://github.com/tweag/ormolu/issues/264.     patchContext :: LHsContext GhcPs -> LHsContext GhcPs     patchContext = fmap $ \case       [x@(L _ (HsParTy _ _))] -> [x]       [x@(L lx _)] -> [L lx (HsParTy noAnn x)]       xs -> xs+    patchExprContext :: LHsExpr GhcPs -> LHsExpr GhcPs+    patchExprContext = fmap $ \case+      x@(HsQual _ (L _ [L _ HsPar {}]) _) -> x+      HsQual l0 (L l1 [x@(L lx _)]) e -> HsQual l0 (L l1 [L lx (HsPar noAnn x)]) e+      x -> x  -- | Enable all language extensions that we think should be enabled by -- default for ease of use.@@ -253,7 +265,8 @@     OverloadedRecordDot, -- f.g parses differently     OverloadedRecordUpdate, -- qualified fields are not supported     OverloadedLabels, -- a#b is parsed differently-    ExtendedLiterals -- 1#Word32 is parsed differently+    ExtendedLiterals, -- 1#Word32 is parsed differently+    MultilineStrings -- """""" is parsed differently   ]  -- | Run a 'GHC.P' computation.@@ -294,10 +307,14 @@     let (_warnings, fileOpts) =           GHC.getOptions             (initParserOpts flags)+            (supportedLanguagePragmas flags)             input             filepath+    -- 'initLogger' does not have any hooks installed, so we don't get any+    -- (unwanted) output.+    logger <- initLogger     (flags', leftovers, warnings) <--      parseDynamicFilePragma flags (extraOpts <> fileOpts)+      parseDynamicFilePragma logger flags (extraOpts <> fileOpts)     case NE.nonEmpty leftovers of       Nothing -> return ()       Just unrecognizedOpts ->

@@ -21,6 +21,7 @@     atom,     space,     newline,+    newlineLiteral,     inci,     inciIf,     askSourceType,@@ -39,6 +40,7 @@     -- ** Formatting lists     sep,     sepSemi,+    sepSemi',     canUseBraces,     useBraces,     dontUseBraces,@@ -207,7 +209,25 @@   -- | Elements to render   [a] ->   R ()-sepSemi f xs = vlayout singleLine multiLine+sepSemi = sepSemi' False++-- | A version of 'sepSemi' that allows to control whether semicolons should+-- be inserted in multi-line layout.+--+-- > useBraces $ sepSemi' False txt ["foo", "bar"]+-- >   == vlayout (txt "{ foo; bar }") (txt "foo\nbar")+--+-- > dontUseBraces $ sepSemi' True txt ["foo", "bar"]+-- >   == vlayout (txt "foo; bar") (txt "foo;\nbar")+sepSemi' ::+  -- | Whether to insert semicolons in multi-line layout+  Bool ->+  -- | How to render an element+  (a -> R ()) ->+  -- | Elements to render+  [a] ->+  R ()+sepSemi' addMultiColSemi f xs = vlayout singleLine multiLine   where     singleLine = do       ub <- canUseBraces@@ -223,7 +243,10 @@               txt "}"             else sep (txt ";" >> space) f xs'     multiLine =-      sep newline (dontUseBraces . f) xs+      sep+        (if addMultiColSemi then txt ";" >> newline else newline)+        (dontUseBraces . f)+        xs  ---------------------------------------------------------------------------- -- Wrapping

@@ -17,6 +17,7 @@     atom,     space,     newline,+    newlineLiteral,     askSourceType,     askModuleFixityMap,     askDebug,@@ -385,6 +386,19 @@             VeryBeginning -> VeryBeginning             _ -> AfterNewline         }++-- | Insert a newline literal without modifying the internal state of the+-- parser. This is to be used exceptionally, e.g. for printing multiline+-- string literals.+newlineLiteral :: R ()+newlineLiteral = R . modify $ \sc ->+  sc+    { scBuilder = scBuilder sc <> "\n",+      scColumn = 0,+      scIndent = 0,+      scThisLineSpans = [],+      scRequestedDelimiter = AfterNewline+    }  -- | Return the source type. askSourceType :: R SourceType

@@ -15,6 +15,7 @@     p_hsDocName,     p_sourceText,     p_namespaceSpec,+    p_hsMultAnn,   ) where @@ -27,6 +28,7 @@ import GHC.Hs.Doc import GHC.Hs.Extension (GhcPs) import GHC.Hs.ImpExp+import GHC.Hs.Type import GHC.LanguageExtensions.Type (Extension (..)) import GHC.Parser.Annotation import GHC.Types.Name.Occurrence (OccName (..), occNameString)@@ -45,7 +47,7 @@   | -- | Top-level declarations     Free --- | Outputs the name of the module-like entity, preceeded by the correct prefix ("module" or "signature").+-- | Outputs the name of the module-like entity, preceded by the correct prefix ("module" or "signature"). p_hsmodName :: ModuleName -> R () p_hsmodName mname = do   sourceType <- askSourceType@@ -58,6 +60,10 @@ p_ieWrappedName :: IEWrappedName GhcPs -> R () p_ieWrappedName = \case   IEName _ x -> p_rdrName x+  IEDefault _ x -> do+    txt "default"+    space+    p_rdrName x   IEPattern _ x -> do     txt "pattern"     space@@ -66,6 +72,10 @@     txt "type"     space     p_rdrName x+  IEData _ x -> do+    txt "data"+    space+    p_rdrName x  -- | Render a @'LocatedN' 'RdrName'@. p_rdrName :: LocatedN RdrName -> R ()@@ -73,20 +83,20 @@   unboxedSums <- isExtensionEnabled UnboxedSums   let wrapper EpAnn {anns} = case anns of         NameAnnQuote {nann_quoted} -> tickPrefix . wrapper nann_quoted-        NameAnn {nann_adornment = NameParens} ->+        NameAnn {nann_adornment = NameParens {}} ->           parens N . handleUnboxedSumsAndHashInteraction-        NameAnn {nann_adornment = NameBackquotes} -> backticks+        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 "(# #)"+        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 `#`.       handleUnboxedSumsAndHashInteraction         | unboxedSums,-          -- Qualified names do not start wth a `#`.+          -- Qualified names do not start with a `#`.           Unqual (occNameString -> '#' : _) <- x =             \y -> space *> y <* space         | otherwise = id@@ -201,3 +211,9 @@   NoNamespaceSpecifier -> pure ()   TypeNamespaceSpecifier _ -> txt "type" *> space   DataNamespaceSpecifier _ -> txt "data" *> space++p_hsMultAnn :: (mult -> R ()) -> HsMultAnnOf mult GhcPs -> R ()+p_hsMultAnn p_mult = \case+  HsUnannotated _ -> pure ()+  HsLinearAnn _ -> txt "%1"+  HsExplicitMult _ mult -> txt "%" *> p_mult mult

@@ -256,7 +256,7 @@   TypeSynonym ::     RdrName -> HsDecl GhcPs pattern InlinePragma n <- SigD _ (InlineSig _ (L _ n) _)-pattern SpecializePragma n <- SigD _ (SpecSig _ (L _ n) _ _)+pattern SpecializePragma n <- SigD _ (isSpecSig -> Just n) pattern SCCPragma n <- SigD _ (SCCFunSig _ (L _ n) _) pattern AnnTypePragma n <- AnnD _ (HsAnnotation _ (TypeAnnProvenance (L _ n)) _) pattern AnnValuePragma n <- AnnD _ (HsAnnotation _ (ValueAnnProvenance (L _ n)) _)@@ -267,6 +267,12 @@ pattern FamilyDeclaration n <- TyClD _ (FamDecl _ (FamilyDecl _ _ _ (L _ n) _ _ _ _)) pattern TypeSynonym n <- TyClD _ (SynDecl _ (L _ n) _ _ _) +isSpecSig :: Sig GhcPs -> Maybe RdrName+isSpecSig = \case+  SpecSig _ (L _ n) _ _ -> Just n+  SpecSigE _ _ (deconstructExprFromSpecSigE -> (L _ n, _, _)) _ -> Just n+  _ -> Nothing+ -- Declarations which can refer to multiple names  pattern@@ -313,6 +319,7 @@  patBindNames :: Pat GhcPs -> [RdrName] patBindNames (TuplePat _ ps _) = concatMap (patBindNames . unLoc) ps+patBindNames (OrPat _ ps) = foldMap (patBindNames . unLoc) ps patBindNames (VarPat _ (L _ n)) = [n] patBindNames (WildPat _) = [] patBindNames (LazyPat _ (L _ p)) = patBindNames p

@@ -18,9 +18,7 @@ import Data.Choice qualified as Choice import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE-import Data.Maybe (isJust, isNothing, mapMaybe, maybeToList)-import Data.Void-import GHC.Data.Strict qualified as Strict+import Data.Maybe (isJust, isNothing, maybeToList) import GHC.Hs import GHC.Types.Fixity import GHC.Types.ForeignCall@@ -142,66 +140,78 @@     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+    space+    txt "::"+    delimiter+    inci . switchLayout conSigSpans $ do+      located con_outer_bndrs p_hsOuterTyVarBndrs+      case unLoc con_outer_bndrs of+        HsOuterImplicit {} -> pure ()+        HsOuterExplicit {} -> delimiter+      forM_ con_inner_bndrs $ \tele -> do+        p_hsForAllTelescope tele+        delimiter+      forM_ con_mb_cxt $ \qs -> do+        located qs p_hsContext+        space+        txt "=>"+        delimiter+      switchLayout conArgResSpans $ do+        case con_g_args of+          PrefixConGADT NoExtField xs ->+            forM_ xs $ \x -> do+              p_hsConDeclFieldWithDoc x+              space+              p_hsMultAnn (located' p_hsType) (cdf_multiplicity x)+              space+              txt "->"+              delimiter+          RecConGADT _ x -> do+            located x p_hsConDeclRecFields+            space+            txt "->"+            delimiter+        located con_res_ty p_hsType   where+    delimiter = if anyDocStrings then newline else breakpoint+    anyDocStrings =+      hasDocStrings (unLoc con_res_ty) || case con_g_args of+        PrefixConGADT _ xs -> conArgsHaveHaddocks xs+        RecConGADT _ (L _ xs) -> conArgsHaveHaddocks $ cdrf_spec . unLoc <$> xs+     conDeclSpn =-      fmap getLocA (NE.toList con_names)-        <> [getLocA con_bndrs]+      fmap getLocA (NE.toList con_names) <> conSigSpans+    conSigSpans =+      [getLocA con_outer_bndrs]         <> maybeToList (fmap getLocA con_mb_cxt)-        <> conArgsSpans-    conArgsSpans = case con_g_args of-      PrefixConGADT NoExtField xs -> getLocA . hsScaledThing <$> xs-      RecConGADT _ x -> [getLocA x]+        <> conArgResSpans+    conArgResSpans =+      getLocA con_res_ty : case con_g_args of+        PrefixConGADT NoExtField xs -> getLocA . cdf_type <$> xs+        RecConGADT _ x -> [getLocA x] p_conDecl singleRecCon ConDeclH98 {..} =   case con_args of-    PrefixCon (_ :: [Void]) xs -> do+    PrefixCon xs -> do       renderConDoc       renderContext       switchLayout conDeclSpn $ do         p_rdrName con_name-        let args = hsScaledThing <$> xs-            argsHaveDocs = conArgsHaveHaddocks args+        let argsHaveDocs = conArgsHaveHaddocks xs             delimiter = if argsHaveDocs then newline else breakpoint         unless (null xs) delimiter         inci . sitcc $-          sep delimiter (sitcc . located' p_hsType) args+          sep delimiter (sitcc . p_hsConDeclFieldWithDoc) xs     RecCon l -> do       renderConDoc       renderContext       switchLayout conDeclSpn $ do         p_rdrName con_name         breakpoint-        inciIf (Choice.isFalse singleRecCon) (located l p_conDeclFields)-    InfixCon (HsScaled _ l) (HsScaled _ r) -> do+        inciIf (Choice.isFalse singleRecCon) (located l p_hsConDeclRecFields)+    InfixCon l r -> do       -- manually render these-      let (lType, larg_doc) = splitDocTy l-      let (rType, rarg_doc) = splitDocTy r+      let larg_doc = cdf_doc l+          rarg_doc = cdf_doc r        -- the constructor haddock can go on top of the entire constructor       -- only if neither argument has haddocks@@ -214,10 +224,10 @@         if isJust con_doc           then do             mapM_ (p_hsDoc Pipe (With #endNewline)) larg_doc-            located lType p_hsType+            p_hsConDeclField l             breakpoint           else do-            located lType p_hsType+            p_hsConDeclField l             case larg_doc of               Just doc -> space >> p_hsDoc Caret (With #endNewline) doc               Nothing -> breakpoint@@ -227,7 +237,7 @@           case rarg_doc of             Just doc -> newline >> p_hsDoc Pipe (With #endNewline) doc             Nothing -> breakpoint-          located rType p_hsType+          p_hsConDeclField r   where     renderConDoc = mapM_ (p_hsDoc Pipe (With #endNewline)) con_doc     renderContext =@@ -238,23 +248,16 @@         forM_ con_mb_cxt p_lhsContext      conNameWithContextSpn =-      [ RealSrcSpan real Strict.Nothing-      | EpaSpan (RealSrcSpan real _) <--          mapMaybe (matchAddEpAnn AnnForall) con_ext-      ]+      [getHasLoc $ acdh_forall 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+      PrefixCon xs -> getLocA . cdf_type <$> xs       RecCon l -> [getLocA l]-      InfixCon x y -> getLocA . hsScaledThing <$> [x, y]--    splitDocTy = \case-      L _ (HsDocTy _ ty doc) -> (ty, Just doc)-      ty -> (ty, Nothing)+      InfixCon x y -> getLocA . cdf_type <$> [x, y]  p_lhsContext ::   LHsContext GhcPs ->@@ -325,14 +328,9 @@   where     f ConDeclH98 {..} =       isJust con_doc || case con_args of-        PrefixCon [] xs ->-          conArgsHaveHaddocks (hsScaledThing <$> xs)+        PrefixCon xs -> conArgsHaveHaddocks xs         _ -> False     f _ = False -conArgsHaveHaddocks :: [LBangType GhcPs] -> Bool-conArgsHaveHaddocks xs =-  let hasDocs = \case-        HsDocTy {} -> True-        _ -> False-   in any (hasDocs . unLoc) xs+conArgsHaveHaddocks :: [HsConDeclField GhcPs] -> Bool+conArgsHaveHaddocks = any (isJust . cdf_doc)

@@ -5,13 +5,18 @@   ) where +import GHC.Data.Maybe (whenIsJust) import GHC.Hs import Ormolu.Printer.Combinators+import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type  p_defaultDecl :: DefaultDecl GhcPs -> R ()-p_defaultDecl (DefaultDecl _ ts) = do+p_defaultDecl (DefaultDecl _ mclass ts) = do   txt "default"+  whenIsJust mclass $ \c -> do+    breakpoint+    p_rdrName c   breakpoint   inci . parens N $     sep commaDel (sitcc . located' p_hsType) ts

@@ -9,10 +9,12 @@ import Control.Monad import GHC.Hs import GHC.Types.ForeignCall+import GHC.Types.SourceText import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Declaration.Signature+import Ormolu.Printer.Meat.Declaration.StringLiteral  p_foreignDecl :: ForeignDecl GhcPs -> R () p_foreignDecl = \case@@ -56,8 +58,11 @@   located cCallConv atom   -- Need to check for 'noLoc' for the 'safe' annotation   when (isGoodSrcSpan $ getLocA safety) (space >> atom safety)-  space-  located sourceText p_sourceText+  inci $ located sourceText $ \case+    NoSourceText -> pure ()+    SourceText lit -> do+      breakpoint+      p_stringLit lit  p_foreignExport :: ForeignExport GhcPs -> R () p_foreignExport (CExport sourceText (L loc (CExportStatic _ _ cCallConv))) = do

@@ -132,12 +132,7 @@       putOpsExprs prevExpr (opi : ops') (expr : exprs') = do         let isLast = null exprs'             ub' = if not isLast then ub else id-            -- Distinguish holes used in infix notation.-            -- eg. '1 _foo 2' and '1 `_foo` 2'-            opWrapper = case unLoc (opiOp opi) of-              HsUnboundVar _ _ -> backticks-              _ -> id-            p_op = located (opiOp opi) (opWrapper . p_hsExpr)+            p_op = located (opiOp opi) p_hsExpr             p_y = ub' $ p_exprOpTree N expr         if isTrailing           then do@@ -169,7 +164,7 @@ -- intermediate representation. cmdOpTree :: LHsCmdTop GhcPs -> OpTree (LHsCmdTop GhcPs) (LHsExpr GhcPs) cmdOpTree = \case-  (L _ (HsCmdTop _ (L _ (HsCmdArrForm _ op Infix _ [x, y])))) ->+  (L _ (HsCmdTop _ (L _ (HsCmdArrForm _ op Infix [x, y])))) ->     BinaryOpBranches (cmdOpTree x) op (cmdOpTree y)   n -> OpNode n 

@@ -4,16 +4,16 @@  module Ormolu.Printer.Meat.Declaration.Rule   ( p_ruleDecls,+    p_ruleBndrs,   ) where -import Control.Monad (unless) import GHC.Hs import GHC.Types.Basic import GHC.Types.SourceText import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common-import Ormolu.Printer.Meat.Declaration.Signature+import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Signature import Ormolu.Printer.Meat.Declaration.Value import Ormolu.Printer.Meat.Type @@ -22,21 +22,12 @@   pragma "RULES" $ sep breakpoint (sitcc . located' p_ruleDecl) xs  p_ruleDecl :: RuleDecl GhcPs -> R ()-p_ruleDecl (HsRule _ ruleName activation tyvars ruleBndrs lhs rhs) = do+p_ruleDecl (HsRule _ ruleName activation ruleBndrs lhs rhs) = do   located ruleName p_ruleName   space   p_activation activation   space-  case tyvars of-    Nothing -> return ()-    Just xs -> do-      p_forallBndrs ForAllInvis p_hsTyVarBndr xs-      space-  -- It appears that there is no way to tell if there was an empty forall-  -- in the input or no forall at all. We do not want to add redundant-  -- foralls, so let's just skip the empty ones.-  unless (null ruleBndrs) $-    p_forallBndrs ForAllInvis p_ruleBndr ruleBndrs+  p_ruleBndrs ruleBndrs   breakpoint   inci $ do     located lhs p_hsExpr@@ -48,6 +39,17 @@  p_ruleName :: RuleName -> R () p_ruleName name = atom (HsString NoSourceText name :: HsLit GhcPs)++p_ruleBndrs :: RuleBndrs GhcPs -> R ()+p_ruleBndrs (RuleBndrs HsRuleBndrsAnn {..} tyvars ruleBndrs) = do+  case tyvars of+    Nothing -> return ()+    Just xs -> do+      p_forallBndrs ForAllInvis p_hsTyVarBndr xs+      space+  case rb_tmanns of+    Nothing -> pure ()+    Just _ -> p_forallBndrs ForAllInvis p_ruleBndr ruleBndrs  p_ruleBndr :: RuleBndr GhcPs -> R () p_ruleBndr = \case

@@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}  -- | Type signature declarations. module Ormolu.Printer.Meat.Declaration.Signature@@ -8,12 +9,15 @@     p_typeAscription,     p_activation,     p_standaloneKindSig,+    deconstructExprFromSpecSigE,   ) where  import Control.Monad+import Data.Maybe (maybeToList) import GHC.Data.BooleanFormula import GHC.Hs+import GHC.Stack (HasCallStack) import GHC.Types.Basic import GHC.Types.Fixity import GHC.Types.Name.Reader@@ -21,6 +25,8 @@ import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common+import Ormolu.Printer.Meat.Declaration.Rule+import Ormolu.Printer.Meat.Declaration.Value (p_hsExpr) import Ormolu.Printer.Meat.Type import Ormolu.Utils @@ -31,7 +37,9 @@   ClassOpSig _ def names sigType -> p_classOpSig def names sigType   FixSig _ sig -> p_fixSig sig   InlineSig _ name inlinePragma -> p_inlineSig name inlinePragma-  SpecSig _ name ts inlinePragma -> p_specSig name ts inlinePragma+  SpecSig _ name ts inlinePragma ->+    p_specSig Nothing (noLocA $ HsVar NoExtField name) ts inlinePragma+  SpecSigE _ ruleBndrs expr inlinePragma -> p_specSigE ruleBndrs expr inlinePragma   SpecInstSig _ sigType -> p_specInstSig sigType   MinimalSig _ booleanFormula -> p_minimalSig booleanFormula   CompleteMatchSig _ cs ty -> p_completeSig cs ty@@ -93,7 +101,7 @@   FixitySig GhcPs ->   R () p_fixSig = \case-  FixitySig namespace names (Fixity _ n dir) -> do+  FixitySig namespace names (Fixity n dir) -> do     txt $ case dir of       InfixL -> "infixl"       InfixR -> "infixr"@@ -122,26 +130,71 @@   p_rdrName name  p_specSig ::-  -- | Name-  LocatedN RdrName ->+  -- | Rule binders+  Maybe (RuleBndrs GhcPs) ->+  -- | Expression to specialize+  LHsExpr GhcPs ->   -- | The types to specialize to   [LHsSigType GhcPs] ->   -- | For specialize inline   InlinePragma ->   R ()-p_specSig name ts InlinePragma {..} = pragmaBraces $ do+p_specSig mRuleBndrs specExpr ts InlinePragma {..} = pragmaBraces $ do   txt "SPECIALIZE"   space   p_inlineSpec inl_inline   space-  p_activation inl_act-  space-  p_rdrName name-  space-  txt "::"-  breakpoint-  inci $ sep commaDel (located' p_hsSigType) ts+  case (inl_inline, inl_act) of+    (NoInline _, NeverActive) -> return ()+    _ -> p_activation inl_act+  inci $ do+    space+    forM_ mRuleBndrs $ \ruleBndrs -> do+      p_ruleBndrs ruleBndrs+      space+    located specExpr p_hsExpr+    case ts of+      [] -> pure ()+      _ -> do+        space+        txt "::"+        breakpoint+        sep commaDel (located' p_hsSigType) ts +p_specSigE ::+  -- | Rule binders+  RuleBndrs GhcPs ->+  -- | Expression to specialize+  LHsExpr GhcPs ->+  -- | For specialize inline+  InlinePragma ->+  R ()+p_specSigE ruleBndrs expr =+  p_specSig (Just ruleBndrs) specExpr (maybeToList sigTy)+  where+    (_, specExpr, sigTy) = deconstructExprFromSpecSigE expr++-- | The 'LHsExpr' in a 'SpecSigE' can only be of a very specific form, namely a+-- variable applied to value/type-level arguments, optionally with a type+-- signature.+--+-- https://github.com/ghc-proposals/ghc-proposals/blob/e2c683698323cec3e33625369ae2b5f585387c70/proposals/0493-specialise-expressions.rst#2proposed-change-specification+deconstructExprFromSpecSigE ::+  (HasCallStack) =>+  LHsExpr GhcPs ->+  (LocatedN RdrName, LHsExpr GhcPs, Maybe (LHsSigType GhcPs))+deconstructExprFromSpecSigE = \case+  L _ (ExprWithTySig _ e HsWC {hswc_body}) ->+    (findVar e, e, Just hswc_body)+  e -> (findVar e, e, Nothing)+  where+    findVar :: LHsExpr GhcPs -> LocatedN RdrName+    findVar = \case+      L _ (HsVar _ name) -> name+      L _ (HsApp _ e _) -> findVar e+      L _ (HsAppType _ e _) -> findVar e+      _ -> error "unreachble"+ p_inlineSpec :: InlineSpec -> R () p_inlineSpec = \case   Inline _ -> txt "INLINE"@@ -171,7 +224,7 @@  p_minimalSig ::   -- | Boolean formula-  LBooleanFormula (LocatedN RdrName) ->+  LBooleanFormula GhcPs ->   R () p_minimalSig =   located' $ \booleanFormula ->@@ -179,7 +232,7 @@  p_booleanFormula ::   -- | Boolean formula-  BooleanFormula (LocatedN RdrName) ->+  BooleanFormula GhcPs ->   R () p_booleanFormula = \case   Var name -> p_rdrName name

@@ -0,0 +1,14 @@+module Ormolu.Printer.Meat.Declaration.Signature+  ( p_sigDecl,+    p_typeAscription,+    p_activation,+  )+where++import GHC.Hs+import GHC.Types.Basic+import Ormolu.Printer.Combinators++p_sigDecl :: Sig GhcPs -> R ()+p_typeAscription :: LHsSigType GhcPs -> R ()+p_activation :: Activation -> R ()

@@ -0,0 +1,174 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Ormolu.Printer.Meat.Declaration.StringLiteral (p_stringLit) where++import Control.Applicative (Alternative (..))+import Control.Category ((>>>))+import Control.Monad ((>=>))+import Data.Semigroup (Min (..))+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Data.FastString+import GHC.Parser.CharClass (is_space)+import Ormolu.Printer.Combinators+import Ormolu.Utils++-- | Print the source text of a string literal while indenting gaps and newlines+-- correctly.+p_stringLit :: FastString -> R ()+p_stringLit src = case parseStringLiteral $ T.pack $ unpackFS src of+  Nothing -> error $ "Internal Ormolu error: couldn't parse string literal: " <> show src+  Just ParsedStringLiteral {..} -> sitcc do+    txt startMarker+    case stringLiteralKind of+      RegularStringLiteral -> do+        let singleLine =+              txt $ intercalateMinimalStringGaps segments+            multiLine =+              sep breakpoint f (attachRelativePos segments)+              where+                f :: (RelativePos, Text) -> R ()+                f (pos, s) = case pos of+                  SinglePos -> txt s+                  FirstPos -> txt s *> txt "\\"+                  MiddlePos -> txt "\\" *> txt s *> txt "\\"+                  LastPos -> txt "\\" *> txt s+        vlayout singleLine multiLine+      MultilineStringLiteral ->+        sep newlineLiteral txt segments+    txt endMarker++-- | The start/end marker of the literal, whether it is a regular or a multiline+-- literal, and the segments of the literals (separated by gaps for a regular+-- literal, and separated by newlines for a multiline literal).+data ParsedStringLiteral = ParsedStringLiteral+  { startMarker, endMarker :: Text,+    stringLiteralKind :: StringLiteralKind,+    segments :: [Text]+  }+  deriving stock (Show, Eq)++-- | A regular or a multiline string literal.+data StringLiteralKind = RegularStringLiteral | MultilineStringLiteral+  deriving stock (Show, Eq)++-- | Turn a string literal (as it exists in the source) into a more structured+-- form for printing. This should never return 'Nothing' for literals that the+-- GHC parser accepted.+parseStringLiteral :: Text -> Maybe ParsedStringLiteral+parseStringLiteral = \s -> do+  psl <-+    (stripStartEndMarker MultilineStringLiteral "\"\"\"" s)+      <|> (stripStartEndMarker RegularStringLiteral "\"" s)+  let splitSegments = case stringLiteralKind psl of+        RegularStringLiteral -> splitGaps+        MultilineStringLiteral -> splitMultilineString+  pure psl {segments = concatMap splitSegments $ segments psl}+  where+    -- Remove the given marker from the start and the end (at the end,+    -- optionally also remove a #).+    stripStartEndMarker ::+      StringLiteralKind -> Text -> Text -> Maybe ParsedStringLiteral+    stripStartEndMarker stringLiteralKind marker s = do+      let startMarker = marker+      suffix <- T.stripPrefix startMarker s+      let markerWithHash = marker <> "#"+      (endMarker, infix_) <-+        ((markerWithHash,) <$> T.stripSuffix markerWithHash suffix)+          <|> ((marker,) <$> T.stripSuffix marker suffix)+      pure ParsedStringLiteral {segments = [infix_], ..}++    -- Split a string on gaps (backslash delimited whitespaces).+    --+    -- > splitGaps "bar\\  \\fo\\&o" == ["bar", "fo\\&o"]+    splitGaps :: Text -> [Text]+    splitGaps s = go $ T.breakOnAll "\\" s+      where+        go [] = [s]+        go ((pre, suf) : bs) = case T.uncons suf of+          Just ('\\', suf')+            | (gap, T.uncons -> Just ('\\', rest)) <- T.span is_space suf',+              -- If there is a space after the backslash, this definitely is a+              -- string gap. Continue parsing gaps after the next backslash.+              not $ T.null gap ->+                pre : splitGaps rest+            | otherwise ->+                -- Check whether @suf@ starts with an escape sequence involving+                -- another backslash. If so, it can not be the start of a string+                -- gap, so we skip it.+                let skipNextBackslash =+                      any (`T.isPrefixOf` suf') escapesWithAnotherBackslash+                 in go $ (if skipNextBackslash then drop 1 else id) bs+          _ -> go bs++        -- All escape sequences (without the initial backslash) with another+        -- backslash. See+        -- https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6+        escapesWithAnotherBackslash = ["\\", "^\\"]++    -- See the the MultilineStrings GHC proposal and 'lexMultilineString' from+    -- "GHC.Parser.String" for reference.+    --+    -- https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0569-multiline-strings.rst#proposed-change-specification+    splitMultilineString :: Text -> [Text]+    splitMultilineString =+      splitGaps+        -- There is no reason to use gaps with multiline string literals just to+        -- emulate multi-line strings, so we replace them with "\\ \\".+        >>> intercalateMinimalStringGaps+        >>> splitNewlines+        >>> fmap expandLeadingTabs+        >>> rmCommonWhitespacePrefixAndBlank++    -- See the definition of newlines on+    -- <https://www.haskell.org/onlinereport/haskell2010/haskellch10.html#x17-17800010.3>.+    splitNewlines :: Text -> [Text]+    splitNewlines = T.splitOn "\r\n" >=> T.split isNewlineish+      where+        isNewlineish c = c == '\n' || c == '\r' || c == '\f'++    -- See GHC's 'lexMultilineString'.+    expandLeadingTabs :: Text -> Text+    expandLeadingTabs = T.concat . go 0+      where+        go :: Int -> Text -> [Text]+        go col s = case T.breakOn "\t" s of+          (pre, T.uncons -> Just (_, suf)) ->+            let col' = col + T.length pre+                fill = 8 - (col' `mod` 8)+             in pre : T.replicate fill " " : go (col' + fill) suf+          _ -> [s]++    -- Don't touch the first line, and remove common whitespace from all+    -- remaining lines as well as convert those consisting only of whitespace to+    -- empty lines.+    rmCommonWhitespacePrefixAndBlank :: [Text] -> [Text]+    rmCommonWhitespacePrefixAndBlank = \case+      [] -> []+      hd : tl -> hd : tl'+        where+          (leadingSpaces, tl') = unzip $ countLeadingAndBlank <$> tl++          commonWs :: Int+          commonWs = maybe 0 getMin $ mconcat leadingSpaces++          countLeadingAndBlank :: Text -> (Maybe (Min Int), Text)+          countLeadingAndBlank l+            | T.all is_space l = (Nothing, "")+            | otherwise = (Just $ Min leadingSpace, T.drop commonWs l)+            where+              leadingSpace = T.length $ T.takeWhile is_space l++-- | Add minimal string gaps between string literal chunks. Such string gaps+-- /can/ be semantically meaningful (so we preserve them for simplicity); for+-- example:+--+-- >>> "\65\ \0" == "\650"+-- False+intercalateMinimalStringGaps :: [Text] -> Text+intercalateMinimalStringGaps = T.intercalate "\\ \\"

@@ -9,7 +9,6 @@     p_pat,     p_hsExpr,     p_hsUntypedSplice,-    p_stringLit,     IsApplicand (..),     p_hsExpr',     p_hsCmdTop,@@ -20,24 +19,18 @@  import Control.Monad import Data.Bool (bool)-import Data.Coerce (coerce) import Data.Data hiding (Infix, Prefix) import Data.Function (on) import Data.Functor ((<&>)) import Data.Generics.Schemes (everything)-import Data.List (intersperse, sortBy)+import Data.List (intersperse, sortBy, unsnoc) import Data.List.NonEmpty (NonEmpty (..), (<|)) import Data.List.NonEmpty qualified as NE import Data.Maybe import Data.Text (Text)-import Data.Text qualified as Text-import Data.Void-import GHC.Data.Bag (bagToList)-import GHC.Data.FastString import GHC.Data.Strict qualified as Strict import GHC.Hs import GHC.LanguageExtensions.Type (Extension (NegativeLiterals))-import GHC.Parser.CharClass (is_space) import GHC.Types.Basic import GHC.Types.Fixity import GHC.Types.Name.Reader@@ -48,7 +41,8 @@ import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.OpTree-import Ormolu.Printer.Meat.Declaration.Signature+import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Signature+import Ormolu.Printer.Meat.Declaration.StringLiteral import Ormolu.Printer.Meat.Type import Ormolu.Printer.Operators import Ormolu.Utils@@ -100,15 +94,15 @@   MatchGroup GhcPs (LocatedA body) ->   R () p_matchGroup' placer render style mg@MG {..} = do-  let ob = case style of-        Case -> bracesIfEmpty-        LambdaCase -> bracesIfEmpty-        _ -> dontUseBraces-        where-          bracesIfEmpty = if isEmptyMatchGroup mg then useBraces else id   -- Since we are forcing braces on 'sepSemi' based on 'ob', we have to   -- restore the brace state inside the sepsemi.   ub <- bool dontUseBraces useBraces <$> canUseBraces+  let ob = case style of+        Case -> bracesIfNecessary+        LambdaCase -> bracesIfNecessary+        _ -> dontUseBraces+        where+          bracesIfNecessary = if isEmptyMatchGroup mg then useBraces else ub   ob $ sepSemi (located' (ub . p_Match)) (unLoc mg_alts)   where     p_Match m@Match {..} =@@ -117,15 +111,16 @@         render         (adjustMatchGroupStyle m style)         (isInfixMatch m)-        (HsNoMultAnn NoExtField)+        (HsUnannotated EpPatBind)         (matchStrictness m)-        m_pats+        -- We use the spans of the individual patterns.+        (unLoc m_pats)         m_grhss  -- | Function id obtained through pattern matching on 'FunBind' should not -- be used to print the actual equations because the different ‘RdrNames’ -- used in the equations may have different “decorations” (such as backticks--- and paretheses) associated with them. It is necessary to use per-equation+-- and parentheses) associated with them. It is necessary to use per-equation -- names obtained from 'm_ctxt' of 'Match'. This function replaces function -- name inside of 'Function' accordingly. adjustMatchGroupStyle ::@@ -133,14 +128,13 @@   MatchGroupStyle ->   MatchGroupStyle adjustMatchGroupStyle m = \case-  Function _ -> (Function . mc_fun . m_ctxt) m+  Function _ | FunRhs {mc_fun = f} <- m_ctxt m -> Function f   style -> style  matchStrictness :: Match id body -> SrcStrictness-matchStrictness match =-  case m_ctxt match of-    FunRhs {mc_strictness = s} -> s-    _ -> NoSrcStrict+matchStrictness = \case+  Match {m_ctxt = FunRhs {mc_strictness = s}} -> s+  _ -> NoSrcStrict  p_match ::   -- | Style of the group@@ -185,17 +179,19 @@   -- 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.+  p_hsMultAnn (located' p_hsType) multAnn   case multAnn of-    HsNoMultAnn NoExtField -> pure ()-    HsPct1Ann _ -> txt "%1" *> space-    HsMultAnn _ ty -> do-      txt "%"-      located ty p_hsType-      space+    HsUnannotated {} -> pure ()+    HsLinearAnn {} -> space+    HsExplicitMult {} -> space   case strictness of     NoSrcStrict -> return ()     SrcStrict -> txt "!"     SrcLazy -> txt "~"+  let isCase = \case+        Case -> True+        LambdaCase -> True+        _ -> False   indentBody <- case NE.nonEmpty m_pats of     Nothing ->       False <$ case style of@@ -206,7 +202,12 @@             Function name -> combineSrcSpans (getLocA name) patSpans             _ -> patSpans           patSpans = combineSrcSpans' (getLocA <$> ne_pats)-          indentBody = not (isOneLineSpan combinedSpans)+          containsOrPat = everything (||) $ \b -> case cast @_ @(Pat GhcPs) b of+            Just OrPat {} -> True+            _ -> False+          indentBody =+            not (isOneLineSpan combinedSpans)+              && not (isCase style && containsOrPat ne_pats)       switchLayout [combinedSpans] $ do         let stdCase = sep breakpoint (located' p_pat) m_pats         case style of@@ -243,14 +244,10 @@           Function name -> Just (getLocA name)           _ -> Nothing         Just pats -> (Just . getLocA . NE.last) pats-      isCase = \case-        Case -> True-        LambdaCase -> True-        _ -> False       hasGuards = withGuards grhssGRHSs       grhssSpan =         combineSrcSpans' $-          getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs+          getGRHSSpan . unLoc <$> grhssGRHSs       patGrhssSpan =         maybe           grhssSpan@@ -276,7 +273,7 @@         sep           breakpoint           (located' (p_grhs' placement placer render groupStyle))-          grhssGRHSs+          (NE.toList grhssGRHSs)       p_where = do         unless (eqEmptyLocalBinds grhssLocalBinds) $ do           breakpoint@@ -288,6 +285,7 @@       case style of         Function _ | hasGuards -> return ()         Function _ -> space >> inci equals+        PatternBind | hasGuards -> return ()         PatternBind -> space >> inci equals         s | isCase s && hasGuards -> return ()         _ -> space >> txt "->"@@ -345,7 +343,7 @@ p_hsCmd' isApp s = \case   HsCmdArrApp _ body input arrType rightToLeft -> do     let (l, r) = if rightToLeft then (body, input) else (input, body)-    located l p_hsExpr+    located l $ p_hsExpr' NotApplicand s     breakpoint     inci $ do       case (arrType, rightToLeft) of@@ -355,27 +353,27 @@         (HsHigherOrderApp, False) -> txt ">>-"       placeHanging (exprPlacement (unLoc input)) $         located r p_hsExpr-  HsCmdArrForm _ form Prefix _ cmds -> banana s $ do+  HsCmdArrForm _ form Prefix cmds -> banana s $ do     located form p_hsExpr     unless (null cmds) $ do       breakpoint       inci (sequence_ (intersperse breakpoint (located' (p_hsCmdTop N) <$> cmds)))-  HsCmdArrForm _ form Infix _ [left, right] -> do+  HsCmdArrForm _ form Infix [left, right] -> do     modFixityMap <- askModuleFixityMap     debug <- askDebug     let opTree = BinaryOpBranches (cmdOpTree left) form (cmdOpTree right)     p_cmdOpTree       s       (reassociateOpTree debug (getOpName . unLoc) modFixityMap opTree)-  HsCmdArrForm _ _ Infix _ _ -> notImplemented "HsCmdArrForm"+  HsCmdArrForm _ _ Infix _ -> notImplemented "HsCmdArrForm"   HsCmdApp _ cmd expr -> do     located cmd (p_hsCmd' Applicand s)     breakpoint     inci $ located expr p_hsExpr-  HsCmdLam _ variant mgroup -> p_lam isApp variant cmdPlacement p_hsCmd mgroup+  HsCmdLam _ variant mgroup -> p_lam isApp s variant cmdPlacement p_hsCmd mgroup   HsCmdPar _ c -> parens N (located c p_hsCmd)   HsCmdCase _ e mgroup ->-    p_case isApp cmdPlacement p_hsCmd e mgroup+    p_case isApp s cmdPlacement p_hsCmd e mgroup   HsCmdIf anns _ if' then' else' ->     p_if cmdPlacement p_hsCmd anns if' then' else'   HsCmdLet _ localBinds c ->@@ -421,8 +419,9 @@ p_stmt = p_stmt' N exprPlacement (p_hsExpr' NotApplicand)  p_stmt' ::-  ( Anno (Stmt GhcPs (LocatedA body)) ~ SrcSpanAnnA,-    Anno [LocatedA (Stmt GhcPs (LocatedA body))] ~ SrcSpanAnnL+  ( Anno [LStmt GhcPs (XRec GhcPs body)] ~ SrcSpanAnnLW,+    Anno (Stmt GhcPs (XRec GhcPs body)) ~ SrcSpanAnnA,+    Anno body ~ SrcSpanAnnA   ) =>   BracketStyle ->   -- | Placer@@ -430,7 +429,7 @@   -- | Render   (BracketStyle -> body -> R ()) ->   -- | Statement to render-  Stmt GhcPs (LocatedA body) ->+  Stmt GhcPs (XRec GhcPs body) ->   R () p_stmt' s placer render = \case   LastStmt _ body _ _ -> located body (render s)@@ -444,7 +443,6 @@           | otherwise = Normal     switchLayout [loc, l] $       placeHanging placement (located f (render N))-  ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer   BodyStmt _ body _ _ -> located body (render s)   LetStmt _ binds -> do     txt "let"@@ -490,8 +488,9 @@     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+  ( Anno [LStmt GhcPs (XRec GhcPs body)] ~ SrcSpanAnnLW,+    Anno (Stmt GhcPs (XRec GhcPs body)) ~ SrcSpanAnnA,+    Anno body ~ SrcSpanAnnA   ) =>   BracketStyle ->   IsApplicand ->@@ -500,7 +499,7 @@   -- | Render   (BracketStyle -> body -> R ()) ->   -- | Statements to render-  LocatedL [LocatedA (Stmt GhcPs (LocatedA body))] ->+  XRec GhcPs [LStmt GhcPs (XRec GhcPs body)] ->   R () p_stmts s isApp placer render es = do   breakpoint@@ -520,7 +519,7 @@  p_hsLocalBinds :: HsLocalBinds GhcPs -> R () p_hsLocalBinds = \case-  HsValBinds epAnn (ValBinds _ bag lsigs) -> pseudoLocated epAnn $ do+  HsValBinds epAnn (ValBinds _ binds lsigs) -> pseudoLocated epAnn $ do     -- When in a single-line layout, there is a chance that the inner     -- elements will also contain semicolons and they will confuse the     -- parser. so we request braces around every element except the last.@@ -528,7 +527,7 @@     let items =           let injectLeft (L l x) = L l (Left x)               injectRight (L l x) = L l (Right x)-           in (injectLeft <$> bagToList bag) ++ (injectRight <$> lsigs)+           in (injectLeft <$> binds) ++ (injectRight <$> lsigs)         positionToBracing = \case           SinglePos -> id           FirstPos -> br@@ -537,8 +536,8 @@         p_item' (p, item) =           positionToBracing p $             withSpacing (either p_valDecl p_sigDecl) item-        binds = sortBy (leftmost_smallest `on` getLocA) items-    sitcc $ sepSemi p_item' (attachRelativePos binds)+        items' = sortBy (leftmost_smallest `on` getLocA) items+    sitcc $ sepSemi p_item' (attachRelativePos items')   HsValBinds _ _ -> notImplemented "HsValBinds"   HsIPBinds epAnn (IPBinds _ xs) -> pseudoLocated epAnn $ do     let p_ipBind (IPBind _ (L _ name) expr) = do@@ -560,12 +559,12 @@             located (L al_anchor ()) . const       _ -> id -p_ldotFieldOcc :: XRec GhcPs (DotFieldOcc GhcPs) -> R ()-p_ldotFieldOcc =-  located' $ p_rdrName . fmap (mkVarUnqual . field_label) . dfoLabel+p_dotFieldOcc :: DotFieldOcc GhcPs -> R ()+p_dotFieldOcc =+  p_rdrName . fmap (mkVarUnqual . field_label) . dfoLabel -p_ldotFieldOccs :: [XRec GhcPs (DotFieldOcc GhcPs)] -> R ()-p_ldotFieldOccs = sep (txt ".") p_ldotFieldOcc+p_dotFieldOccs :: NonEmpty (DotFieldOcc GhcPs) -> R ()+p_dotFieldOccs = sep (txt ".") p_dotFieldOcc . NE.toList  p_fieldOcc :: FieldOcc GhcPs -> R () p_fieldOcc FieldOcc {..} = p_rdrName foLabel@@ -590,7 +589,7 @@ p_hsExpr = p_hsExpr' NotApplicand N  -- | An applicand is the left-hand side in a function application, i.e. @f@ in--- @f a@. We need to track this in order to add extra identation in cases like+-- @f a@. We need to track this in order to add extra indentation in cases like -- -- > foo = -- >   do@@ -603,12 +602,19 @@   Applicand -> inci . inci   NotApplicand -> inci +-- | Adjust bracing as needed for certain cases e.g. involving case+-- expressions and lambdas.+adjustBracing :: IsApplicand -> BracketStyle -> R () -> R ()+adjustBracing isApp s p = do+  layout <- getLayout+  case (s, layout, isApp) of+    (S, SingleLine, NotApplicand) -> useBraces p+    _ -> p+ p_hsExpr' :: IsApplicand -> BracketStyle -> HsExpr GhcPs -> R () p_hsExpr' isApp s = \case   HsVar _ name -> p_rdrName name-  HsUnboundVar _ occ -> atom occ-  HsRecSel _ fldOcc -> p_fieldOcc fldOcc-  HsOverLabel _ sourceText _ -> do+  HsOverLabel sourceText _ -> do     txt "#"     p_sourceText sourceText   HsIPVar _ (HsIPName name) -> do@@ -619,9 +625,10 @@     case lit of       HsString (SourceText stxt) _ -> p_stringLit stxt       HsStringPrim (SourceText stxt) _ -> p_stringLit stxt+      HsMultilineString (SourceText stxt) _ -> p_stringLit stxt       r -> atom r   HsLam _ variant mgroup ->-    p_lam isApp variant exprPlacement p_hsExpr mgroup+    p_lam isApp s 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@@ -672,11 +679,6 @@     breakpoint     inci $ do       txt "@"-      -- Insert a space when the type is represented as a TH splice to avoid-      -- gluing @ and $ together.-      case unLoc (hswc_body a) of-        HsSpliceTy {} -> space-        _ -> return ()       located (hswc_body a) p_hsType   OpApp _ x op y -> do     modFixityMap <- askModuleFixityMap@@ -735,13 +737,14 @@   ExplicitSum _ tag arity e ->     p_unboxedSum N tag arity (located e p_hsExpr)   HsCase _ e mgroup ->-    p_case isApp exprPlacement p_hsExpr e mgroup+    p_case isApp s exprPlacement p_hsExpr e mgroup   HsIf anns if' then' else' ->     p_if exprPlacement p_hsExpr anns if' then' else'   HsMultiIf _ guards -> do     txt "if"     breakpoint-    inciApplicand isApp $ sep newline (located' (p_grhs RightArrow)) guards+    inciApplicand isApp $+      sep breakpoint (located' (p_grhs RightArrow)) (NE.toList guards)   HsLet _ localBinds e ->     p_let p_hsExpr localBinds e   HsDo _ doFlavor es -> do@@ -772,25 +775,22 @@   RecordUpd {..} -> do     located rupd_expr p_hsExpr     breakpoint-    let p_updLbl =-          located' $-            p_rdrName . \case-              (Unambiguous NoExtField n :: AmbiguousFieldOcc GhcPs) -> n-              Ambiguous NoExtField n -> n-        p_recFields p_lbl =+    let p_recFields p_lbl =           sep commaDel (sitcc . located' (p_hsFieldBind p_lbl))+        p_fieldLabelStrings (FieldLabelStrings flss) =+          p_dotFieldOccs $ unLoc <$> flss     inci . braces N $ case rupd_flds of       RegularRecUpdFields {..} ->-        p_recFields p_updLbl recUpdFields+        p_recFields (located' p_fieldOcc) recUpdFields       OverloadedRecUpdFields {..} ->-        p_recFields (located' (coerce p_ldotFieldOccs)) olRecUpdFields+        p_recFields (located' p_fieldLabelStrings) olRecUpdFields   HsGetField {..} -> do     located gf_expr p_hsExpr     txt "."-    p_ldotFieldOcc gf_field+    located gf_field p_dotFieldOcc   HsProjection {..} -> parens N $ do     txt "."-    p_ldotFieldOccs (NE.toList proj_flds)+    p_dotFieldOccs proj_flds   ExprWithTySig _ x HsWC {hswc_body} -> sitcc $ do     located x p_hsExpr     space@@ -825,8 +825,8 @@     located expr p_hsExpr     breakpoint'     txt "||]"-  HsUntypedBracket anns x -> p_hsQuote anns x-  HsTypedSplice _ expr -> p_hsSpliceTH True expr DollarSplice+  HsUntypedBracket _ x -> p_hsQuote x+  HsTypedSplice _ (HsTypedSpliceExpr _ expr) -> p_hsSpliceTH True expr DollarSplice   HsUntypedSplice _ untySplice -> p_hsUntypedSplice DollarSplice untySplice   HsProc _ p e -> do     txt "proc"@@ -853,11 +853,37 @@     txt "type"     space     located hswc_body p_hsType+  HsHole holeKind -> case holeKind of+    HoleVar name -> p_rdrName name+    HoleError -> error "parse error"+  -- similar to HsForAllTy+  HsForAll _ tele e -> do+    p_hsForAllTelescope tele+    breakpoint+    located e p_hsExpr+  -- similar to HsQualTy+  HsQual _ qs e -> do+    located qs $ p_hsContext' p_hsExpr+    space+    txt "=>"+    breakpoint+    located e p_hsExpr+  -- similar to HsFunTy+  HsFunArr _ multAnn x y -> do+    located x p_hsExpr+    space+    p_hsMultAnn (located' p_hsExpr) multAnn+    space+    txt "->"+    breakpoint+    case unLoc y of+      HsFunArr {} -> p_hsExpr (unLoc y)+      _ -> located y p_hsExpr  -- | 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 :: BracketStyle -> XRec GhcPs [ExprLStmt GhcPs] -> R () p_listComp s es = sitcc (vlayout singleLine multiLine)   where     singleLine = do@@ -874,10 +900,9 @@     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)+            case unsnoc xs of+              Nothing -> error $ "list comprehension unexpectedly had no expressions"+              Just (ys, y) -> (ys, y)       sitcc $ located yield p_stmt       breakpoint       txt "|"@@ -952,7 +977,7 @@   -- will be ParStmt.   [L _ (ParStmt _ blocks _ _)] ->     [ concatMap collectNonParStmts stmts-    | ParStmtBlock _ stmts _ _ <- blocks+    | ParStmtBlock _ stmts _ _ <- NE.toList blocks     ]   -- Otherwise, list will not contain any ParStmt   stmts ->@@ -993,7 +1018,7 @@             inci (p_matchGroup (Function psb_id) mgroup)   txt "pattern"   case psb_args of-    PrefixCon [] xs -> do+    PrefixCon xs -> do       space       p_rdrName psb_id       inci $ do@@ -1002,7 +1027,6 @@           unless (null xs) breakpoint           sitcc (sep breakpoint p_rdrName xs)         rhs conSpans-    PrefixCon (v : _) _ -> absurd v     RecCon xs -> do       space       p_rdrName psb_id@@ -1030,6 +1054,7 @@     Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA   ) =>   IsApplicand ->+  BracketStyle ->   -- | Placer   (body -> Placement) ->   -- | Render@@ -1039,20 +1064,23 @@   -- | Match group   MatchGroup GhcPs (LocatedA body) ->   R ()-p_case isApp placer render e mgroup = do+p_case isApp s placer render e mgroup = do   txt "case"   space   located e p_hsExpr   space   txt "of"   breakpoint-  inciApplicand isApp (p_matchGroup' placer render Case mgroup)+  adjustBracing isApp s $+    inciApplicand isApp (p_matchGroup' placer render Case mgroup)  p_lam ::   ( Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO,     Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA   ) =>   IsApplicand ->+  -- | BracketStyle (S when inside a do block)+  BracketStyle ->   -- | Variant (@\\@ or @\\case@ or @\\cases@)   HsLamVariant ->   -- | Placer@@ -1062,7 +1090,7 @@   -- | Expression   MatchGroup GhcPs (LocatedA body) ->   R ()-p_lam isApp variant placer render mgroup = do+p_lam isApp s variant placer render mgroup = do   let mCaseTxt = case variant of         LamSingle -> Nothing         LamCase -> Just "\\case"@@ -1074,7 +1102,7 @@     Just caseTxt -> do       txt caseTxt       breakpoint-      inciApplicand isApp pMatchGroup+      adjustBracing isApp s (inciApplicand isApp pMatchGroup)  p_if ::   -- | Placer@@ -1139,40 +1167,43 @@   sitcc (located e render)  p_pat :: Pat GhcPs -> R ()-p_pat = \case+p_pat = p_pat' False++p_pat' :: Bool -> Pat GhcPs -> R ()+p_pat' inAsPat = \case   WildPat _ -> txt "_"   VarPat _ name -> p_rdrName name   LazyPat _ pat -> do     txt "~"-    located pat p_pat+    located pat (p_pat' inAsPat)   AsPat _ name pat -> do     p_rdrName name     txt "@"-    located pat p_pat+    located pat (p_pat' True)   ParPat _ pat ->-    located pat (parens S . p_pat)+    located pat (parens S . p_pat' inAsPat)   BangPat _ pat -> do     txt "!"-    located pat p_pat+    located pat (p_pat' inAsPat)   ListPat _ pats ->-    brackets S $ sep commaDel (located' p_pat) pats+    brackets S $ sep commaDel (located' (p_pat' inAsPat)) pats   TuplePat _ pats boxing -> do     let parens' =           case boxing of             Boxed -> parens S             Unboxed -> parensHash S-    parens' $ sep commaDel (sitcc . located' p_pat) pats+    parens' $ sep commaDel (sitcc . located' (p_pat' inAsPat)) pats+  OrPat _ pats -> do+    sepSemi' inAsPat (located' (p_pat' inAsPat)) (NE.toList pats)   SumPat _ pat tag arity ->-    p_unboxedSum S tag arity (located pat p_pat)+    p_unboxedSum S tag arity (located pat (p_pat' inAsPat))   ConPat _ pat details ->     case details of-      PrefixCon tys xs -> sitcc $ do+      PrefixCon xs -> sitcc $ do         p_rdrName pat-        unless (null tys && null xs) breakpoint-        inci . sitcc $-          sep breakpoint (sitcc . either p_hsConPatTyArg (located' p_pat)) $-            (Left <$> tys) <> (Right <$> xs)-      RecCon (HsRecFields fields dotdot) -> do+        unless (null xs) breakpoint+        inci . sitcc $ sep breakpoint (sitcc . located' (p_pat' inAsPat)) xs+      RecCon (HsRecFields _ fields dotdot) -> do         p_rdrName pat         breakpoint         let f = \case@@ -1184,18 +1215,18 @@             Just (L _ (RecFieldsDotDot n)) -> (Just <$> take n fields) ++ [Nothing]       InfixCon l r -> do         switchLayout [getLocA l, getLocA r] $ do-          located l p_pat+          located l (p_pat' inAsPat)           breakpoint           inci $ do             p_rdrName pat             space-            located r p_pat+            located r (p_pat' inAsPat)   ViewPat _ expr pat -> sitcc $ do     located expr p_hsExpr     space     txt "->"     breakpoint-    inci (located pat p_pat)+    inci (located pat (p_pat' inAsPat))   SplicePat _ splice -> p_hsUntypedSplice DollarSplice splice   LitPat _ p -> atom p   NPat _ v (isJust -> isNegated) _ -> do@@ -1212,7 +1243,7 @@       space       located k (atom . ol_val)   SigPat _ pat HsPS {..} -> do-    located pat p_pat+    located pat (p_pat' inAsPat)     p_typeAscription (lhsTypeToSigType hsps_body)   EmbTyPat _ (HsTP _ ty) -> do     txt "type"@@ -1223,9 +1254,6 @@ p_tyPat :: HsTyPat GhcPs -> R () p_tyPat (HsTP _ ty) = txt "@" *> located ty p_hsType -p_hsConPatTyArg :: HsConPatTyArg GhcPs -> R ()-p_hsConPatTyArg (HsConPatTyArg _ patSigTy) = p_tyPat patSigTy- p_pat_hsFieldBind :: HsRecField GhcPs (LPat GhcPs) -> R () p_pat_hsFieldBind HsFieldBind {..} = do   located hfbLHS p_fieldOcc@@ -1255,7 +1283,7 @@   HsUntypedSpliceExpr _ expr -> p_hsSpliceTH False expr deco   HsQuasiQuote _ quoterName str -> do     txt "["-    p_rdrName (noLocA quoterName)+    p_rdrName quoterName     txt "|"     -- QuasiQuoters often rely on precise custom strings. We cannot do any     -- formatting here without potentially breaking someone's code.@@ -1279,12 +1307,12 @@   where     decoSymbol = if isTyped then "$$" else "$" -p_hsQuote :: [AddEpAnn] -> HsQuote GhcPs -> R ()-p_hsQuote anns = \case-  ExpBr _ expr -> do-    let name-          | any (isJust . matchAddEpAnn AnnOpenEQ) anns = ""-          | otherwise = "e"+p_hsQuote :: HsQuote GhcPs -> R ()+p_hsQuote = \case+  ExpBr (bracketAnn, _) expr -> do+    let name = case bracketAnn of+          BracketNoE {} -> ""+          BracketHasE {} -> "e"     quote name (located expr p_hsExpr)   PatBr _ pat -> located pat (quote "p" . p_pat)   DecBrL _ decls -> quote "d" (handleStarIsType decls (p_hsDecls Free decls))@@ -1318,47 +1346,6 @@           Just HsStarTy {} -> True           _ -> False --- | Print the source text of a string literal while indenting gaps correctly.-p_stringLit :: FastString -> R ()-p_stringLit src =-  let s = splitGaps (unpackFS src)-      singleLine =-        txt $ Text.pack (mconcat s)-      multiLine =-        sitcc $ sep breakpoint (txt . Text.pack) (backslashes s)-   in vlayout singleLine multiLine-  where-    -- Split a string on gaps (backslash delimited whitespaces)-    ---    -- > splitGaps "bar\\  \\fo\\&o" == ["bar", "fo\\&o"]-    splitGaps :: String -> [String]-    splitGaps "" = []-    splitGaps s =-      let -- A backslash and a whitespace starts a "gap"-          p (Just '\\', _, _) = True-          p (_, '\\', Just c) | ghcSpace c = False-          p _ = True-       in case span p (zipPrevNext s) of-            (l, r) ->-              let -- drop the initial '\', any amount of 'ghcSpace', and another '\'-                  r' = drop 1 . dropWhile ghcSpace . drop 1 $ map orig r-               in map orig l : splitGaps r'-    -- GHC's definition of whitespaces in strings-    -- See: https://gitlab.haskell.org/ghc/ghc/blob/86753475/compiler/parser/Lexer.x#L1653-    ghcSpace :: Char -> Bool-    ghcSpace c = c <= '\x7f' && is_space c-    -- Add backslashes to the inner side of the strings-    ---    -- > backslashes ["a", "b", "c"] == ["a\\", "\\b\\", "\\c"]-    backslashes :: [String] -> [String]-    backslashes (x : y : xs) = (x ++ "\\") : backslashes (('\\' : y) : xs)-    backslashes xs = xs-    -- Attaches previous and next items to each list element-    zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)]-    zipPrevNext xs =-      zip3 (Nothing : map Just xs) xs (map Just (drop 1 xs) ++ [Nothing])-    orig (_, x, _) = x- ---------------------------------------------------------------------------- -- Helpers @@ -1376,9 +1363,9 @@ -- | Determine placement of a given block. blockPlacement ::   (body -> Placement) ->-  [LGRHS GhcPs (LocatedA body)] ->+  NonEmpty (LGRHS GhcPs (LocatedA body)) ->   Placement-blockPlacement placer [L _ (GRHS _ _ (L _ x))] = placer x+blockPlacement placer (L _ (GRHS _ _ (L _ x)) :| []) = placer x blockPlacement _ _ = Normal  -- | Determine placement of a given command.@@ -1399,7 +1386,7 @@   -- Only hang lambdas with single line parameter lists   HsLam _ variant mg -> case variant of     LamSingle -> case mg of-      MG _ (L _ [L _ (Match _ _ (x : xs) _)])+      MG _ (L _ [L _ (Match _ _ (L _ (x : xs)) _)])         | isOneLineSpan (combineSrcSpans' $ fmap getLocA (x :| xs)) ->             Hanging       _ -> Normal@@ -1422,7 +1409,7 @@   _ -> Normal  -- | Return 'True' if any of the RHS expressions has guards.-withGuards :: [LGRHS GhcPs body] -> Bool+withGuards :: NonEmpty (LGRHS GhcPs body) -> Bool withGuards = any (checkOne . unLoc)   where     checkOne (GRHS _ [] _) = False

@@ -3,7 +3,6 @@     p_pat,     p_hsExpr,     p_hsUntypedSplice,-    p_stringLit,     p_hsExpr',     p_hsCmdTop,     exprPlacement,@@ -11,7 +10,6 @@   ) where -import GHC.Data.FastString import GHC.Hs import Ormolu.Printer.Combinators @@ -19,7 +17,6 @@ p_pat :: Pat GhcPs -> R () p_hsExpr :: HsExpr GhcPs -> R () p_hsUntypedSplice :: SpliceDecoration -> HsUntypedSplice GhcPs -> R ()-p_stringLit :: FastString -> R ()  data IsApplicand 

@@ -46,6 +46,10 @@   space   when ideclSafe (txt "safe")   space+  case ideclLevelSpec of+    LevelStylePre l -> p_declLevel l+    _ -> return ()+  space   when     (isImportDeclQualified ideclQualified && not useQualifiedPost)     (txt "qualified")@@ -56,6 +60,10 @@   space   inci $ do     located ideclName atom+    space+    case ideclLevelSpec of+      LevelStylePost l -> p_declLevel l+      _ -> return ()     when       (isImportDeclQualified ideclQualified && useQualifiedPost)       (space >> txt "qualified")@@ -81,6 +89,11 @@             (\(p, l) -> sitcc (located l (p_lie layout p)))             (attachRelativePos xs)     newline++p_declLevel :: ImportDeclLevel -> R ()+p_declLevel = \case+  ImportDeclSplice -> txt "splice"+  ImportDeclQuote -> txt "quote"  p_lie :: Layout -> RelativePos -> IE GhcPs -> R () p_lie encLayout relativePos = \case

@@ -10,13 +10,17 @@   ( p_hsType,     hasDocStrings,     p_hsContext,+    p_hsContext',     p_hsTyVarBndr,     ForAllVisibility (..),     p_forallBndrs,-    p_conDeclFields,+    p_hsConDeclRecFields,+    p_hsConDeclField,+    p_hsConDeclFieldWithDoc,     p_lhsTypeArg,     p_hsSigType,-    hsOuterTyVarBndrsToHsType,+    p_hsForAllTelescope,+    p_hsOuterTyVarBndrs,     lhsTypeToSigType,   ) where@@ -30,7 +34,8 @@ import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.OpTree (p_tyOpTree, tyOpTree)-import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsUntypedSplice, p_stringLit)+import Ormolu.Printer.Meat.Declaration.StringLiteral+import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsUntypedSplice) import Ormolu.Printer.Operators import Ormolu.Utils @@ -40,9 +45,7 @@ p_hsType' :: Bool -> HsType GhcPs -> R () p_hsType' multilineArgs = \case   HsForAllTy _ tele t -> do-    case tele of-      HsForAllInvis _ bndrs -> p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs-      HsForAllVis _ bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs+    p_hsForAllTelescope tele     interArgBreak     located t p_hsType   HsQualTy _ qs t -> do@@ -86,20 +89,15 @@     inci $ do       txt "@"       located kd p_hsType-  HsFunTy _ arrow x y@(L _ y') -> do+  HsFunTy _ multAnn x y -> do     located x p_hsType     space-    case arrow of-      HsUnrestrictedArrow _ -> txt "->"-      HsLinearArrow _ -> txt "%1 ->"-      HsExplicitMult _ mult -> do-        txt "%"-        p_hsTypeR (unLoc mult)-        space-        txt "->"+    p_hsMultAnn (located' p_hsTypeR) multAnn+    space+    txt "->"     interArgBreak-    case y' of-      HsFunTy {} -> p_hsTypeR y'+    case unLoc y of+      HsFunTy {} -> p_hsTypeR (unLoc y)       _ -> located y p_hsTypeR   HsListTy _ t ->     located t (brackets N . p_hsType)@@ -140,18 +138,6 @@   HsDocTy _ t str -> do     p_hsDoc Pipe (With #endNewline) str     located t p_hsType-  HsBangTy _ (HsSrcBang _ u s) t -> do-    case u of-      SrcUnpack -> txt "{-# UNPACK #-}" >> space-      SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space-      NoSrcUnpack -> return ()-    case s of-      SrcLazy -> txt "~"-      SrcStrict -> txt "!"-      NoSrcStrict -> return ()-    located t p_hsType-  HsRecTy _ fields ->-    p_conDeclFields fields   HsExplicitListTy _ p xs -> do     case p of       IsPromoted -> txt "'"@@ -163,11 +149,15 @@         (IsPromoted, L _ t : _) | startsWithSingleQuote t -> space         _ -> return ()       sep commaDel (sitcc . located' p_hsType) xs-  HsExplicitTupleTy _ xs -> do-    txt "'"+  HsExplicitTupleTy _ p xs -> do+    case p of+      IsPromoted -> txt "'"+      NotPromoted -> return ()     parens N $ do-      case xs of-        L _ t : _ | startsWithSingleQuote t -> space+      -- If this tuple is promoted and the first element starts with a single+      -- quote, we need to put a space in between or it fails to parse.+      case (p, xs) of+        (IsPromoted, L _ t : _) | startsWithSingleQuote t -> space         _ -> return ()       sep commaDel (located' p_hsType) xs   HsTyLit _ t ->@@ -175,7 +165,20 @@       HsStrTy (SourceText s) _ -> p_stringLit s       a -> atom a   HsWildCardTy _ -> txt "_"-  XHsType t -> atom t+  XHsType ext -> case ext of+    HsCoreTy t -> atom @HsCoreTy t+    HsBangTy _ (HsSrcBang _ u s) t -> do+      case u of+        SrcUnpack -> txt "{-# UNPACK #-}" >> space+        SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space+        NoSrcUnpack -> return ()+      case s of+        SrcLazy -> txt "~"+        SrcStrict -> txt "!"+        NoSrcStrict -> return ()+      located t p_hsType+    HsRecTy _ fields ->+      p_hsConDeclRecFields fields   where     startsWithSingleQuote = \case       HsAppTy _ (L _ f) _ -> startsWithSingleQuote f@@ -201,10 +204,13 @@   _ -> False  p_hsContext :: HsContext GhcPs -> R ()-p_hsContext = \case+p_hsContext = p_hsContext' p_hsType++p_hsContext' :: (HasLoc (Anno a)) => (a -> R ()) -> [XRec GhcPs a] -> R ()+p_hsContext' f = \case   [] -> txt "()"-  [x] -> located x p_hsType-  xs -> parens N $ sep commaDel (sitcc . located' p_hsType) xs+  [x] -> located x f+  xs -> parens N $ sep commaDel (sitcc . located' f) xs  class IsTyVarBndrFlag flag where   isInferred :: flag -> Bool@@ -226,18 +232,24 @@     HsBndrInvisible _ -> txt "@"  p_hsTyVarBndr :: (IsTyVarBndrFlag flag) => HsTyVarBndr flag GhcPs -> R ()-p_hsTyVarBndr = \case-  UserTyVar _ flag x -> do-    p_tyVarBndrFlag flag-    (if isInferred flag then braces N else id) $ p_rdrName x-  KindedTyVar _ flag l k -> do-    p_tyVarBndrFlag flag-    (if isInferred flag then braces else parens) N $ do-      located l atom-      space-      txt "::"-      breakpoint-      inci (located k p_hsType)+p_hsTyVarBndr HsTvb {..} = do+  p_tyVarBndrFlag tvb_flag+  let wrap+        | isInferred tvb_flag = braces N+        | otherwise = case tvb_kind of+            HsBndrKind {} -> parens N+            HsBndrNoKind {} -> id+  wrap $ do+    case tvb_var of+      HsBndrVar _ x -> p_rdrName x+      HsBndrWildCard _ -> txt "_"+    case tvb_kind of+      HsBndrKind _ k -> do+        space+        txt "::"+        breakpoint+        inci (located k p_hsType)+      HsBndrNoKind _ -> pure ()  data ForAllVisibility = ForAllInvis | ForAllVis @@ -260,23 +272,45 @@         ForAllInvis -> txt "."         ForAllVis -> space >> txt "->" -p_conDeclFields :: [LConDeclField GhcPs] -> R ()-p_conDeclFields xs =-  braces N $ sep commaDel (sitcc . located' p_conDeclField) xs+p_hsConDeclRecFields :: [LHsConDeclRecField GhcPs] -> R ()+p_hsConDeclRecFields xs =+  braces N $ sep commaDel (sitcc . located' p_hsConDeclRecField) xs -p_conDeclField :: ConDeclField GhcPs -> R ()-p_conDeclField ConDeclField {..} = do-  mapM_ (p_hsDoc Pipe (With #endNewline)) cd_fld_doc+p_hsConDeclRecField :: HsConDeclRecField GhcPs -> R ()+p_hsConDeclRecField HsConDeclRecField {..} = do+  mapM_ (p_hsDoc Pipe (With #endNewline)) (cdf_doc cdrf_spec)   sitcc $     sep       commaDel       (located' (p_rdrName . foLabel))-      cd_fld_names+      cdrf_names   space+  p_hsMultAnn (located' p_hsType) (cdf_multiplicity cdrf_spec)+  space   txt "::"   breakpoint-  sitcc . inci $ p_hsType (unLoc cd_fld_type)+  sitcc . inci $ p_hsConDeclField cdrf_spec +-- | This does not print 'cdf_doc' and 'cdf_multiplicity' as there is no single+-- strategy for where to print them (see call sites).+p_hsConDeclField :: HsConDeclField GhcPs -> R ()+p_hsConDeclField CDF {..} = do+  case cdf_unpack of+    SrcUnpack -> txt "{-# UNPACK #-}" *> space+    SrcNoUnpack -> txt "{-# NOUNPACK #-}" *> space+    NoSrcUnpack -> pure ()+  located cdf_type $ \ty -> do+    case cdf_bang of+      SrcLazy -> txt "~"+      SrcStrict -> txt "!"+      NoSrcStrict -> pure ()+    p_hsType ty++p_hsConDeclFieldWithDoc :: HsConDeclField GhcPs -> R ()+p_hsConDeclFieldWithDoc cdf = do+  mapM_ (p_hsDoc Pipe (With #endNewline)) (cdf_doc cdf)+  p_hsConDeclField cdf+ p_lhsTypeArg :: LHsTypeArg GhcPs -> R () p_lhsTypeArg = \case   HsValArg NoExtField ty -> located ty p_hsType@@ -287,21 +321,27 @@   HsArgPar _ -> notImplemented "HsArgPar"  p_hsSigType :: HsSigType GhcPs -> R ()-p_hsSigType HsSig {..} =-  p_hsType $ hsOuterTyVarBndrsToHsType sig_bndrs sig_body+p_hsSigType HsSig {..} = do+  p_hsOuterTyVarBndrs sig_bndrs+  case sig_bndrs of+    HsOuterImplicit {} -> pure ()+    HsOuterExplicit {} -> breakpoint+  located sig_body p_hsType -------------------------------------------------------------------------------- Conversion functions+p_hsForAllTelescope :: HsForAllTelescope GhcPs -> R ()+p_hsForAllTelescope = \case+  HsForAllInvis _ bndrs -> p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs+  HsForAllVis _ bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs --- could be generalized to also handle () instead of Specificity-hsOuterTyVarBndrsToHsType ::+p_hsOuterTyVarBndrs ::   HsOuterTyVarBndrs Specificity GhcPs ->-  LHsType GhcPs ->-  HsType GhcPs-hsOuterTyVarBndrsToHsType obndrs ty = case obndrs of-  HsOuterImplicit NoExtField -> unLoc ty-  HsOuterExplicit _ bndrs ->-    HsForAllTy NoExtField (mkHsForAllInvisTele noAnn bndrs) ty+  R ()+p_hsOuterTyVarBndrs = \case+  HsOuterImplicit _ -> pure ()+  HsOuterExplicit _ bndrs -> p_hsForAllTelescope $ mkHsForAllInvisTele noAnn bndrs++----------------------------------------------------------------------------+-- Conversion functions  lhsTypeToSigType :: LHsType GhcPs -> LHsSigType GhcPs lhsTypeToSigType ty =

@@ -85,7 +85,7 @@     interleave [] bs = bs     interleave (a : as) bs = a : interleave bs as -    xs !!? i = if A.bounds rawLines `A.inRange` i then Just $ xs A.! i else Nothing+    xs !!? i = if A.bounds xs `A.inRange` i then Just $ xs A.! i else Nothing  -- | All lines we are not supposed to format, and a set of replacements -- for specific lines.

@@ -13,7 +13,6 @@     separatedByBlank,     separatedByBlankNE,     onTheSameLine,-    matchAddEpAnn,     textToStringBuffer,     ghcModuleNameToCabal,   )@@ -138,13 +137,6 @@ onTheSameLine :: SrcSpan -> SrcSpan -> Bool onTheSameLine a b =   isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b))---- | Check whether the given 'AnnKeywordId' or its Unicode variant is in an--- 'AddEpAnn', and return the 'EpaLocation' if so.-matchAddEpAnn :: AnnKeywordId -> AddEpAnn -> Maybe EpaLocation-matchAddEpAnn annId (AddEpAnn annId' loc)-  | annId == annId' || unicodeAnn annId == annId' = Just loc-  | otherwise = Nothing  -- | Convert 'Text' to a 'StringBuffer' by making a copy. textToStringBuffer :: Text -> StringBuffer

@@ -14,7 +14,6 @@ import Control.Exception import Control.Monad.IO.Class import Data.ByteString qualified as B-import Data.IORef import Data.Map.Lazy (Map) import Data.Map.Lazy qualified as M import Data.Maybe (maybeToList)@@ -29,7 +28,7 @@ import Ormolu.Config import Ormolu.Exception import Ormolu.Fixity-import Ormolu.Utils.IO (findClosestFileSatisfying, withIORefCache)+import Ormolu.Utils.IO (Cache, findClosestFileSatisfying, newCache, withCache) import System.Directory import System.FilePath import System.IO.Unsafe (unsafePerformIO)@@ -101,8 +100,8 @@   deriving (Show)  -- | Cache ref that stores 'CachedCabalFile' per Cabal file.-cacheRef :: IORef (Map FilePath CachedCabalFile)-cacheRef = unsafePerformIO $ newIORef M.empty+cacheRef :: Cache FilePath CachedCabalFile+cacheRef = unsafePerformIO newCache {-# NOINLINE cacheRef #-}  -- | Parse 'CabalInfo' from a @.cabal@ file at the given 'FilePath'.@@ -118,7 +117,7 @@ parseCabalInfo cabalFileAsGiven sourceFileAsGiven = liftIO $ do   cabalFile <- makeAbsolute cabalFileAsGiven   sourceFileAbs <- makeAbsolute sourceFileAsGiven-  CachedCabalFile {..} <- withIORefCache cacheRef cabalFile $ do+  CachedCabalFile {..} <- withCache cacheRef cabalFile $ do     cabalFileBs <- B.readFile cabalFile     genericPackageDescription <-       whenLeft (snd . runParseResult $ parseGenericPackageDescription cabalFileBs) $@@ -190,17 +189,17 @@     extractFromLibrary Library {..} =       extractFromBuildInfo (ModuleName.toFilePath <$> exposedModules) libBuildInfo     extractFromExecutable Executable {..} =-      extractFromBuildInfo [modulePath] buildInfo+      extractFromBuildInfo [getSymbolicPath modulePath] buildInfo     extractFromTestSuite TestSuite {..} =       extractFromBuildInfo mainPath testBuildInfo       where         mainPath = case testInterface of-          TestSuiteExeV10 _ p -> [p]+          TestSuiteExeV10 _ p -> [getSymbolicPath p]           TestSuiteLibV09 _ p -> [ModuleName.toFilePath p]           TestSuiteUnsupported {} -> []     extractFromBenchmark Benchmark {..} =       extractFromBuildInfo mainPath benchmarkBuildInfo       where         mainPath = case benchmarkInterface of-          BenchmarkExeV10 _ p -> [p]+          BenchmarkExeV10 _ p -> [getSymbolicPath p]           BenchmarkUnsupported {} -> []

@@ -10,10 +10,7 @@ import Control.Exception (throwIO) import Control.Monad.IO.Class import Data.Bifunctor (first)-import Data.IORef import Data.List.NonEmpty (NonEmpty)-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)@@ -21,7 +18,7 @@ import Ormolu.Exception import Ormolu.Fixity import Ormolu.Fixity.Parser-import Ormolu.Utils.IO (findClosestFileSatisfying, withIORefCache)+import Ormolu.Utils.IO (Cache, findClosestFileSatisfying, newCache, withCache) import System.Directory import System.IO.Unsafe (unsafePerformIO) import Text.Megaparsec (errorBundlePretty)@@ -37,7 +34,7 @@   m (FixityOverrides, ModuleReexports) getDotOrmoluForSourceFile sourceFile =   liftIO (findDotOrmoluFile sourceFile) >>= \case-    Just dotOrmoluFile -> liftIO $ withIORefCache cacheRef dotOrmoluFile $ do+    Just dotOrmoluFile -> liftIO $ withCache cacheRef dotOrmoluFile $ do       dotOrmoluRelative <- makeRelativeToCurrentDirectory dotOrmoluFile       contents <- T.Utf8.readFile dotOrmoluFile       case parseDotOrmolu dotOrmoluRelative contents of@@ -58,8 +55,8 @@   x == ".ormolu"  -- | Cache ref that maps names of @.ormolu@ files to their contents.-cacheRef :: IORef (Map FilePath (FixityOverrides, ModuleReexports))-cacheRef = unsafePerformIO (newIORef Map.empty)+cacheRef :: Cache FilePath (FixityOverrides, ModuleReexports)+cacheRef = unsafePerformIO newCache {-# NOINLINE cacheRef #-}  -- | A wrapper around 'parseFixityDeclaration' for parsing individual fixity

@@ -3,7 +3,9 @@  module Ormolu.Utils.IO   ( findClosestFileSatisfying,-    withIORefCache,+    Cache,+    newCache,+    withCache,   ) where @@ -48,14 +50,21 @@         then pure Nothing         else findClosestFileSatisfying isRightFile parentDir +newtype Cache k v = Cache (IORef (Map k v))++newCache :: (Ord k) => IO (Cache k v)+newCache = do+  var <- newIORef mempty+  pure (Cache var)+ -- | Execute an 'IO' action but only if the given key is not found in the--- 'IORef' cache.-withIORefCache :: (Ord k) => IORef (Map k v) -> k -> IO v -> IO v-withIORefCache cacheRef k action = do-  cache <- readIORef cacheRef+-- cache.+withCache :: (Ord k) => Cache k v -> k -> IO v -> IO v+withCache (Cache cacheVar) k action = do+  cache <- readIORef cacheVar   case M.lookup k cache of     Just v -> pure v     Nothing -> do       v <- action-      modifyIORef' cacheRef (M.insert k v)+      atomicModifyIORef cacheVar ((,()) . M.insert k v)       pure v

@@ -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", "choice", "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", "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

@@ -35,6 +35,18 @@         `shouldParse` ( exampleFixityOverrides,                         ModuleReexports Map.empty                       )+    it "accepts fractional operator precedences" $+      parseDotOrmolu+        ""+        ( T.unlines+            [ "infixr 3 >~<",+              "infixr 3.3 |~|",+              "infixr 3.7 <~>"+            ]+        )+        `shouldParse` ( fractionalFixityOverrides,+                        ModuleReexports Map.empty+                      )     it "combines conflicting fixity declarations correctly" $       parseDotOrmolu         ""@@ -202,7 +214,7 @@                 elabel "module name"               ]           )-    it "fails with correct parse error (typo: export intead exports)" $+    it "fails with correct parse error (typo: export instead exports)" $       parseModuleReexportDeclaration "module Control.Lens export Control.Lens.Lens"         `shouldFailWith` err           20@@ -228,6 +240,16 @@           ("=<<", FixityInfo InfixR 1),           (">>", FixityInfo InfixL 1),           (">>=", FixityInfo InfixL 1)+        ]+    )++fractionalFixityOverrides :: FixityOverrides+fractionalFixityOverrides =+  FixityOverrides+    ( Map.fromList+        [ (">~<", FixityInfo InfixR 3),+          ("|~|", FixityInfo InfixR 3.3),+          ("<~>", FixityInfo InfixR 3.7)         ]     ) 

@@ -37,7 +37,12 @@               InfixR,               InfixN             ]-        fiPrecedence <- chooseInt (0, 9)+        precedenceWholePart <- fromIntegral <$> chooseInt (0, 9)+        precedenceFractionalPart <-+          if precedenceWholePart < 9.0+            then (* 0.1) . fromIntegral <$> chooseInt (0, 1)+            else return 0+        let fiPrecedence = precedenceWholePart + precedenceFractionalPart         return FixityInfo {..}  instance Arbitrary ModuleReexports where

@@ -31,7 +31,10 @@   FixityOverrides     ( Map.fromList         [ (".=", FixityInfo InfixR 8),-          ("#", FixityInfo InfixR 5)+          ("#", FixityInfo InfixR 5),+          (">~<", FixityInfo InfixR 3),+          ("|~|", FixityInfo InfixR 3.3),+          ("<~>", FixityInfo InfixR 3.7)         ]     )