fourmolu 0.19.0.1 → 0.20.0.0

raw patch · 137 files changed

+2283/−953 lines, 137 filesdep ~Cabal-syntaxdep ~containersdep ~ghc-lib-parser

Dependency ranges changed: Cabal-syntax, containers, ghc-lib-parser

Files

• CHANGELOG.md +57/−0
• README.md +15/−4
• app/Main.hs +1/−2
• data/examples/declaration/data/linear-four-out.hs +11/−0
• data/examples/declaration/data/linear-out.hs +11/−0
• data/examples/declaration/data/linear.hs +10/−0
• data/examples/declaration/data/record-four-out.hs +1/−1
• data/examples/declaration/data/record-out.hs +1/−1
• data/examples/declaration/data/record.hs +1/−1
• data/examples/declaration/data/required-type-arguments-four-out.hs +25/−0
• data/examples/declaration/data/required-type-arguments-out.hs +27/−0
• data/examples/declaration/data/required-type-arguments.hs +24/−0
• data/examples/declaration/foreign/foreign-import-multiline-four-out.hs +8/−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-four-out.hs +1/−1
• data/examples/declaration/rewrite-rule/prelude2-out.hs +1/−1
• data/examples/declaration/rewrite-rule/prelude2.hs +1/−1
• data/examples/declaration/signature/specialize/specialize-2-four-out.hs +8/−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-four-out.hs +10/−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/value/function/arrow/proc-do-complex-four-out.hs +1/−1
• 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/case-single-line-with-braces-four-out.hs +2/−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-four-out.hs +13/−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-four-out.hs +2/−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-four-out.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-four-out.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-four-out.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-four-out.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-four-out.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/linear-bindings-four-out.hs +9/−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/multiline-strings-9-four-out.hs +11/−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-four-out.hs +9/−1
• data/examples/declaration/value/function/pattern/or-patterns-out.hs +9/−1
• data/examples/declaration/value/function/pattern/or-patterns.hs +7/−1
• data/examples/declaration/value/function/strings-four-out.hs +2/−0
• data/examples/declaration/value/function/strings-out.hs +2/−0
• data/examples/declaration/value/function/strings.hs +2/−0
• data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-four-out.hs +8/−8
• data/examples/import/data-four-out.hs +3/−0
• data/examples/import/data-out.hs +3/−0
• data/examples/import/data.hs +6/−0
• data/examples/import/explicit-level-imports-four-out.hs +13/−0
• data/examples/import/explicit-level-imports-out.hs +13/−0
• data/examples/import/explicit-level-imports-qualified-post-four-out.hs +5/−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-four-out.hs +1/−1
• data/examples/other/empty-forall-out.hs +1/−1
• data/fourmolu/haddock-style/output-multi_line-module=multi_line.hs +1/−1
• data/fourmolu/haddock-style/output-multi_line-module=multi_line_compact.hs +1/−1
• data/fourmolu/haddock-style/output-multi_line-module=single_line.hs +1/−1
• data/fourmolu/haddock-style/output-multi_line.hs +1/−1
• data/fourmolu/haddock-style/output-multi_line_compact-module=multi_line.hs +1/−1
• data/fourmolu/haddock-style/output-multi_line_compact-module=multi_line_compact.hs +1/−1
• data/fourmolu/haddock-style/output-multi_line_compact-module=single_line.hs +1/−1
• data/fourmolu/haddock-style/output-multi_line_compact.hs +1/−1
• data/fourmolu/import-grouping/input.hs +3/−0
• data/fourmolu/import-grouping/output-by_qualified.hs +3/−0
• data/fourmolu/import-grouping/output-by_scope.hs +3/−0
• data/fourmolu/import-grouping/output-by_scope_then_qualified.hs +3/−0
• data/fourmolu/import-grouping/output-custom.hs +4/−0
• data/fourmolu/import-grouping/output-preserve.hs +3/−0
• data/fourmolu/import-grouping/output-single.hs +3/−0
• data/fourmolu/indentation/input.hs +6/−0
• data/fourmolu/indentation/output-2-indent_wheres.hs +6/−0
• data/fourmolu/indentation/output-2.hs +6/−0
• data/fourmolu/indentation/output-3-indent_wheres.hs +6/−0
• data/fourmolu/indentation/output-3.hs +6/−0
• data/fourmolu/indentation/output-4-indent_wheres.hs +6/−0
• data/fourmolu/indentation/output-4.hs +6/−0
• data/fourmolu/record-style/input.hs +24/−0
• data/fourmolu/record-style/output-aligned-leading.hs +35/−0
• data/fourmolu/record-style/output-aligned-trailing.hs +35/−0
• data/fourmolu/record-style/output-knr-leading.hs +35/−0
• data/fourmolu/record-style/output-knr-trailing.hs +35/−0
• data/fourmolu/unicode-syntax/output-always.hs +2/−2
• data/fourmolu/unicode-syntax/output-detect.hs +2/−2
• data/fourmolu/unicode-syntax/output-never.hs +2/−2
• fourmolu.cabal +15/−14
• fourmolu.yaml +1/−0
• src/GHC/DynFlags.hs +6/−0
• src/Ormolu/Config.hs +3/−1
• src/Ormolu/Config/Gen.hs +41/−0
• src/Ormolu/Config/Types.hs +47/−40
• src/Ormolu/Diff/ParseResult.hs +5/−2
• src/Ormolu/Diff/Text.hs +0/−4
• src/Ormolu/Imports.hs +31/−8
• src/Ormolu/Imports/Grouping.hs +35/−10
• src/Ormolu/Parser.hs +7/−2
• src/Ormolu/Printer/Combinators.hs +51/−2
• src/Ormolu/Printer/Internal.hs +14/−0
• src/Ormolu/Printer/Meat/Common.hs +20/−12
• src/Ormolu/Printer/Meat/Declaration.hs +7/−1
• src/Ormolu/Printer/Meat/Declaration/Data.hs +129/−56
• src/Ormolu/Printer/Meat/Declaration/Foreign.hs +7/−2
• src/Ormolu/Printer/Meat/Declaration/OpTree.hs +1/−6
• src/Ormolu/Printer/Meat/Declaration/Rule.hs +15/−13
• src/Ormolu/Printer/Meat/Declaration/Signature.hs +67/−13
• src/Ormolu/Printer/Meat/Declaration/Signature.hs-boot +14/−0
• src/Ormolu/Printer/Meat/Declaration/StringLiteral.hs +18/−5
• src/Ormolu/Printer/Meat/Declaration/Value.hs +126/−95
• src/Ormolu/Printer/Meat/ImportExport.hs +13/−0
• src/Ormolu/Printer/Meat/Type.hs +186/−359
• src/Ormolu/Printer/Meat/Type/Function.hs +493/−0
• src/Ormolu/Utils.hs +3/−7
• src/Ormolu/Utils/Glob.hs +4/−0
• tests/Ormolu/Config/PrinterOptsSpec.hs +76/−57
• tests/Ormolu/ConfigSpec.hs +92/−199
• tests/Ormolu/Fixity/ParserSpec.hs +1/−1
• tests/Ormolu/Integration/Utils.hs +3/−2

@@ -1,4 +1,61 @@+## Fourmolu 0.20.0.0++Now installable with GHCup! See README for details.++* Improve `import-grouping` configuration++    * Add the `scope` option for import grouping ([#525](https://github.com/fourmolu/fourmolu/pull/525)).++    * Deprecate the `match` option for import grouping in favor of `glob` and `scope` ([#525](https://github.com/fourmolu/fourmolu/pull/525)).++    * Add the `import-list` option for import grouping ([#522](https://github.com/fourmolu/fourmolu/pull/522)).++* Add a `record-style` to configure the placement of record braces. ([#467](https://github.com/fourmolu/fourmolu/issues/467))++* Fix applying `indent-wheres` configuration to pattern synonyms with explicit bidirectional `where` clauses ([#486](https://github.com/fourmolu/fourmolu/issues/486))++### Upstream changed:++#### 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).+ ## Fourmolu 0.19.0.1++### Upstream changed:++#### Ormolu 0.8.0.2  * Fixed a performance regression introduced in 0.8.0.0. [Issue   1176](https://github.com/tweag/ormolu/issues/1176).

@@ -49,12 +49,23 @@  ## Installation -To install the latest release from Hackage, simply install with Cabal or Stack:+### (Recommended) Install with GHCup -```console-$ cabal install fourmolu-$ stack install fourmolu+```bash+ghcup config add-release-channel 3rdparty+ghcup install fourmolu latest ```++### Install with Cabal/Stack++```bash+cabal install fourmolu+stack install fourmolu+```++### Install with [dotslash](https://dotslash-cli.com/docs/)++Copy the configuration in the GitHub release notes.  ## Building from source 

@@ -468,7 +468,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)@@ -492,7 +492,6 @@     <*> pure defaultPrinterOpts -- unused; overwritten in resolveConfig     <*> (fmap Set.fromList . many . strOption . mconcat)       [ long "local-modules",-        short 'm',         metavar "LOCAL_MODULES",         help "Modules Fourmolu should consider as local by the current Cabal package"       ]

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

@@ -11,7 +11,7 @@     , fooGag       , fooGog ::         NonEmpty-            ( Indentity+            ( Identity                 Bool             )     -- ^ GagGog

@@ -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,25 @@+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,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,8 @@+{-# LANGUAGE MultilineStrings #-}++foreign import capi+    """+    foo+       bar+    """+    foo :: Int -> Int

@@ -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

@@ -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

@@ -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,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,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 #-}

@@ -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

@@ -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

@@ -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,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,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 @@+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 @@+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 @@+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 @@+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!" }

@@ -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

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

@@ -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 ()

@@ -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,11 @@+{-# LANGUAGE MultilineStrings #-}++multilineBlank =+    """+    1+++++    6+    """

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

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

@@ -20,7 +20,8 @@ sane e = case e of     1     2-    3 -> a+    3 ->+        a     4     5     6 -> b@@ -33,3 +34,10 @@     (D; E (Just _) Nothing) ->         4     F -> 5++food+    foo@( A;+            B;+            C+            ) = Just foo+food _ = Nothing

@@ -21,7 +21,8 @@ sane e = case e of   1   2-  3 -> a+  3 ->+    a   4   5   6 -> b@@ -34,3 +35,10 @@   (D; E (Just _) Nothing) ->     4   F -> 5++food+  foo@( A;+        B;+        C+        ) = Just foo+food _ = Nothing

@@ -20,7 +20,8 @@ sane e = case e of   1   2-  3 -> a+  3 ->+    a   4   5;6 -> b   7;8 -> c@@ -31,3 +32,8 @@   (D; E (Just _) Nothing)    -> 4   F -> 5++food foo@(A;+          B;+          C) = Just foo+food _ = Nothing

@@ -8,3 +8,5 @@     \baz"  weirdGap = "\65\ \0"++weirdEscape = "\^\ "

@@ -10,3 +10,5 @@   \baz"  weirdGap = "\65\ \0"++weirdEscape = "\^\ "

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

@@ -3,19 +3,19 @@ pattern P a <- C a where P a = C a  pattern HeadC x <- x : xs-    where-        HeadC x = [x]+  where+    HeadC x = [x]  pattern HeadC' x <-     x : xs-    where-        HeadC' x = [x]+  where+    HeadC' x = [x]  pattern Simple <- "Simple"-    where-        Simple = "Complicated"+  where+    Simple = "Complicated"  pattern a :< b <-     (a, b)-    where-        a :< b = (a, b)+  where+    a :< b = (a, b)

@@ -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,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,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 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 =         ()     #-}

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

@@ -37,6 +37,6 @@  {- | This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\}+> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int

@@ -37,6 +37,6 @@  {- | This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\}+> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int

@@ -36,6 +36,6 @@  {- | This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\}+> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int

@@ -37,6 +37,6 @@  {- | This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\}+> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int

@@ -37,6 +37,6 @@  {-| This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\}+> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int

@@ -37,6 +37,6 @@  {-| This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\}+> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int

@@ -36,6 +36,6 @@  {-| This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\}+> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int

@@ -37,6 +37,6 @@  {-| This is a haddock containing another haddock -> {\-# LANGUAGE ScopedTypeVariables #-\}+> {-# LANGUAGE ScopedTypeVariables #-} -} haddock_in_haddock :: Int

@@ -1,13 +1,16 @@ module Main where +import Data.Either import Data.Text (Text) import Data.Maybe (maybe)  import qualified Data.Text import Control.Monad (Monad (..))+import Data.Functor  import qualified System.IO as SIO import SomeInternal.Module1 (anotherDefinition, someDefinition) import qualified SomeInternal.Module2 as Mod2 import Text.Printf (printf) import qualified SomeModule+import SomeInternal.Module2

@@ -1,9 +1,12 @@ module Main where  import Control.Monad (Monad (..))+import Data.Either+import Data.Functor import Data.Maybe (maybe) import Data.Text (Text) import SomeInternal.Module1 (anotherDefinition, someDefinition)+import SomeInternal.Module2 import Text.Printf (printf)  import qualified Data.Text

@@ -1,6 +1,8 @@ module Main where  import Control.Monad (Monad (..))+import Data.Either+import Data.Functor import Data.Maybe (maybe) import Data.Text (Text) import qualified Data.Text@@ -9,4 +11,5 @@ import Text.Printf (printf)  import SomeInternal.Module1 (anotherDefinition, someDefinition)+import SomeInternal.Module2 import qualified SomeInternal.Module2 as Mod2

@@ -1,6 +1,8 @@ module Main where  import Control.Monad (Monad (..))+import Data.Either+import Data.Functor import Data.Maybe (maybe) import Data.Text (Text) import Text.Printf (printf)@@ -10,5 +12,6 @@ import qualified System.IO as SIO  import SomeInternal.Module1 (anotherDefinition, someDefinition)+import SomeInternal.Module2  import qualified SomeInternal.Module2 as Mod2

@@ -1,5 +1,9 @@ module Main where +import Data.Either+import Data.Functor+import SomeInternal.Module2+ import Data.Text (Text) import qualified Data.Text 

@@ -1,12 +1,15 @@ module Main where +import Data.Either import Data.Maybe (maybe) import Data.Text (Text)  import Control.Monad (Monad (..))+import Data.Functor import qualified Data.Text  import SomeInternal.Module1 (anotherDefinition, someDefinition)+import SomeInternal.Module2 import qualified SomeInternal.Module2 as Mod2 import qualified SomeModule import qualified System.IO as SIO

@@ -1,10 +1,13 @@ module Main where  import Control.Monad (Monad (..))+import Data.Either+import Data.Functor import Data.Maybe (maybe) import Data.Text (Text) import qualified Data.Text import SomeInternal.Module1 (anotherDefinition, someDefinition)+import SomeInternal.Module2 import qualified SomeInternal.Module2 as Mod2 import qualified SomeModule import qualified System.IO as SIO

@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+ module Foo (   asdf,   bar,@@ -21,3 +23,7 @@  class Foo a where   foo :: a -> Int++pattern HeadC x <- x : xs+  where+    HeadC x = [x]

@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+ module Foo (   asdf,   bar,@@ -21,3 +23,7 @@  class Foo a where   foo :: a -> Int++pattern HeadC x <- x : xs+  where+    HeadC x = [x]

@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+ module Foo (   asdf,   bar,@@ -21,3 +23,7 @@  class Foo a where   foo :: a -> Int++pattern HeadC x <- x : xs+ where+  HeadC x = [x]

@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+ module Foo (    asdf,    bar,@@ -21,3 +23,7 @@  class Foo a where    foo :: a -> Int++pattern HeadC x <- x : xs+   where+      HeadC x = [x]

@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+ module Foo (    asdf,    bar,@@ -21,3 +23,7 @@  class Foo a where    foo :: a -> Int++pattern HeadC x <- x : xs+  where+   HeadC x = [x]

@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+ module Foo (     asdf,     bar,@@ -21,3 +23,7 @@  class Foo a where     foo :: a -> Int++pattern HeadC x <- x : xs+    where+        HeadC x = [x]

@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+ module Foo (     asdf,     bar,@@ -21,3 +23,7 @@  class Foo a where     foo :: a -> Int++pattern HeadC x <- x : xs+  where+    HeadC x = [x]

@@ -0,0 +1,24 @@+data Foo = Foo+  { a :: Int+  , b :: Int+  , c :: Int+  }++-- Test nesting+data Client = PremiumClient { name :: String,+    address :: String, aFieldWithAnUnneccessarilyLongFieldName :: String }+  -- And some comment here as well+  | NotSoPremiumClient { name :: String,+    address :: String, aFieldWithAnUnneccessarilyLongFieldName :: String }++x :: Foo -> [Int]+x Foo{ a = possiblyLongName,+    b = anotherLongName,+    c = longNameAsWell+    } = [possiblyLongName, anotherLongName, longNameAsWell]++y :: Int -> Int -> Int -> Foo+y possiblyLongName anotherLongName longNameAsWell = Foo{ a = possiblyLongName,+    b = anotherLongName,+    c = longNameAsWell+  }

@@ -0,0 +1,35 @@+data Foo = Foo+    { a :: Int+    , b :: Int+    , c :: Int+    }++-- Test nesting+data Client+    = PremiumClient+        { name :: String+        , address :: String+        , aFieldWithAnUnneccessarilyLongFieldName :: String+        }+    | -- And some comment here as well+      NotSoPremiumClient+        { name :: String+        , address :: String+        , aFieldWithAnUnneccessarilyLongFieldName :: String+        }++x :: Foo -> [Int]+x+    Foo+        { a = possiblyLongName+        , b = anotherLongName+        , c = longNameAsWell+        } = [possiblyLongName, anotherLongName, longNameAsWell]++y :: Int -> Int -> Int -> Foo+y possiblyLongName anotherLongName longNameAsWell =+    Foo+        { a = possiblyLongName+        , b = anotherLongName+        , c = longNameAsWell+        }

@@ -0,0 +1,35 @@+data Foo = Foo+    { a :: Int,+      b :: Int,+      c :: Int+    }++-- Test nesting+data Client+    = PremiumClient+        { name :: String,+          address :: String,+          aFieldWithAnUnneccessarilyLongFieldName :: String+        }+    | -- And some comment here as well+      NotSoPremiumClient+        { name :: String,+          address :: String,+          aFieldWithAnUnneccessarilyLongFieldName :: String+        }++x :: Foo -> [Int]+x+    Foo+        { a = possiblyLongName,+          b = anotherLongName,+          c = longNameAsWell+        } = [possiblyLongName, anotherLongName, longNameAsWell]++y :: Int -> Int -> Int -> Foo+y possiblyLongName anotherLongName longNameAsWell =+    Foo+        { a = possiblyLongName,+          b = anotherLongName,+          c = longNameAsWell+        }

@@ -0,0 +1,35 @@+data Foo = Foo {+    a :: Int+    , b :: Int+    , c :: Int+    }++-- Test nesting+data Client+    = PremiumClient {+        name :: String+        , address :: String+        , aFieldWithAnUnneccessarilyLongFieldName :: String+        }+    | -- And some comment here as well+      NotSoPremiumClient {+        name :: String+        , address :: String+        , aFieldWithAnUnneccessarilyLongFieldName :: String+        }++x :: Foo -> [Int]+x+    Foo {+        a = possiblyLongName+        , b = anotherLongName+        , c = longNameAsWell+        } = [possiblyLongName, anotherLongName, longNameAsWell]++y :: Int -> Int -> Int -> Foo+y possiblyLongName anotherLongName longNameAsWell =+    Foo {+        a = possiblyLongName+        , b = anotherLongName+        , c = longNameAsWell+        }

@@ -0,0 +1,35 @@+data Foo = Foo {+    a :: Int,+    b :: Int,+    c :: Int+}++-- Test nesting+data Client+    = PremiumClient {+        name :: String,+        address :: String,+        aFieldWithAnUnneccessarilyLongFieldName :: String+    }+    | -- And some comment here as well+      NotSoPremiumClient {+        name :: String,+        address :: String,+        aFieldWithAnUnneccessarilyLongFieldName :: String+    }++x :: Foo -> [Int]+x+    Foo {+        a = possiblyLongName,+        b = anotherLongName,+        c = longNameAsWell+    } = [possiblyLongName, anotherLongName, longNameAsWell]++y :: Int -> Int -> Int -> Foo+y possiblyLongName anotherLongName longNameAsWell =+    Foo {+        a = possiblyLongName,+        b = anotherLongName,+        c = longNameAsWell+    }

@@ -55,8 +55,8 @@ deconstruct (MkT1 x) = x  pattern HeadC x ← x : xs-    where-        HeadC x = [x]+  where+    HeadC x = [x]  pattern Point ∷ Int → Int → (Int, Int) pattern Point{x, y} = (x, y)

@@ -55,8 +55,8 @@ deconstruct (MkT1 x) = x  pattern HeadC x ← x : xs-    where-        HeadC x = [x]+  where+    HeadC x = [x]  pattern Point ∷ Int → Int → (Int, Int) pattern Point{x, y} = (x, y)

@@ -55,8 +55,8 @@ deconstruct (MkT1 x) = x  pattern HeadC x <- x : xs-    where-        HeadC x = [x]+  where+    HeadC x = [x]  pattern Point :: Int -> Int -> (Int, Int) pattern Point{x, y} = (x, y)

@@ -1,6 +1,6 @@ cabal-version: 2.4 name: fourmolu-version: 0.19.0.1+version: 0.20.0.0 license: BSD-3-Clause license-file: LICENSE.md maintainer:@@ -8,9 +8,9 @@     George Thomas <georgefsthomas@gmail.com>     Brandon Chinn <brandonchinn178@gmail.com> tested-with:-  ghc ==9.8.4-  ghc ==9.10.1-  ghc ==9.12.1+  ghc ==9.10.2+  ghc ==9.12.2+  ghc ==9.14.1  homepage: https://github.com/fourmolu/fourmolu bug-reports: https://github.com/fourmolu/fourmolu/issues@@ -84,6 +84,7 @@     Ormolu.Printer.Meat.Module     Ormolu.Printer.Meat.Pragma     Ormolu.Printer.Meat.Type+    Ormolu.Printer.Meat.Type.Function     Ormolu.Printer.Operators     Ormolu.Printer.SpanStream     Ormolu.Processing.Common@@ -100,7 +101,7 @@   other-modules: GHC.DynFlags   default-language: GHC2021   build-depends:-    Cabal-syntax >=3.14 && <3.15,+    Cabal-syntax >=3.16 && <3.17,     Diff >=0.4 && <2,     MemoTrie >=0.6 && <0.7,     ansi-terminal >=0.10 && <1.2,@@ -109,11 +110,11 @@     binary >=0.8 && <0.9,     bytestring >=0.2 && <0.13,     choice >=0.2.4.1 && <0.3,-    containers >=0.5 && <0.8,+    containers >=0.5 && <0.9,     directory ^>=1.3,     file-embed >=0.0.15 && <0.1,     filepath >=1.2 && <1.6,-    ghc-lib-parser >=9.12 && <9.13,+    ghc-lib-parser >=9.14 && <9.15,     megaparsec >=9,     mtl >=2 && <3,     syb >=0.7 && <0.8,@@ -152,13 +153,13 @@   autogen-modules: Paths_fourmolu   default-language: GHC2021   build-depends:-    Cabal-syntax >=3.14 && <3.15,+    Cabal-syntax >=3.16 && <3.17,     base >=4.12 && <5,-    containers >=0.5 && <0.8,+    containers >=0.5 && <0.9,     directory ^>=1.3,     filepath >=1.2 && <1.6,-    ghc-lib-parser >=9.12 && <9.13,-    optparse-applicative >=0.14 && <0.19,+    ghc-lib-parser >=9.14 && <9.15,+    optparse-applicative >=0.14 && <0.20,     text >=2.1 && <3,     th-env >=0.1.1 && <0.2,     unliftio >=0.2.10 && <0.3,@@ -210,14 +211,14 @@    default-language: GHC2021   build-depends:-    Cabal-syntax >=3.14 && <3.15,+    Cabal-syntax >=3.16 && <3.17,     QuickCheck >=2.14,     base >=4.14 && <5,     choice >=0.2.4.1 && <0.3,-    containers >=0.5 && <0.8,+    containers >=0.5 && <0.9,     directory ^>=1.3,     filepath >=1.2 && <1.6,-    ghc-lib-parser >=9.12 && <9.13,+    ghc-lib-parser >=9.14 && <9.15,     hspec >=2 && <3,     hspec-megaparsec >=2.2,     megaparsec >=9,

@@ -5,6 +5,7 @@ column-limit: none function-arrows: trailing comma-style: trailing+record-style: aligned import-export-style: trailing import-grouping: legacy indent-wheres: true

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

@@ -35,6 +35,7 @@     fillMissingPrinterOpts,     resolvePrinterOpts,     CommaStyle (..),+    RecordStyle (..),     FunctionArrowsStyle (..),     HaddockPrintStyle (..),     HaddockPrintStyleModule (..),@@ -43,12 +44,13 @@     ImportGrouping (..),     ImportGroup (..),     ImportGroupRule (..),-    ImportModuleMatcher (..),     ImportRulePriority (..),     matchAllRulePriority,     matchLocalRulePriority,     defaultImportRulePriority,+    ImportListMatcher (..),     QualifiedImportMatcher (..),+    ImportScopeMatcher (..),     LetStyle (..),     InStyle (..),     IfStyle (..),

@@ -9,6 +9,7 @@ module Ormolu.Config.Gen   ( PrinterOpts (..)   , CommaStyle (..)+  , RecordStyle (..)   , FunctionArrowsStyle (..)   , HaddockPrintStyle (..)   , HaddockPrintStyleModule (..)@@ -54,6 +55,8 @@       poFunctionArrows :: f FunctionArrowsStyle     , -- | How to place commas in multi-line lists, records, etc.       poCommaStyle :: f CommaStyle+    , -- | How to place braces in records+      poRecordStyle :: f RecordStyle     , -- | Styling of import/export lists       poImportExportStyle :: f ImportExportStyle     , -- | Rules for grouping import declarations@@ -102,6 +105,7 @@     , poColumnLimit = Nothing     , poFunctionArrows = Nothing     , poCommaStyle = Nothing+    , poRecordStyle = Nothing     , poImportExportStyle = Nothing     , poImportGrouping = Nothing     , poIndentWheres = Nothing@@ -130,6 +134,7 @@     , poColumnLimit = pure NoLimit     , poFunctionArrows = pure TrailingArrows     , poCommaStyle = pure Leading+    , poRecordStyle = pure RecordStyleAligned     , poImportExportStyle = pure ImportExportDiffFriendly     , poImportGrouping = pure ImportGroupLegacy     , poIndentWheres = pure False@@ -165,6 +170,7 @@     , poColumnLimit = maybe (poColumnLimit p2) pure (poColumnLimit p1)     , poFunctionArrows = maybe (poFunctionArrows p2) pure (poFunctionArrows p1)     , poCommaStyle = maybe (poCommaStyle p2) pure (poCommaStyle p1)+    , poRecordStyle = maybe (poRecordStyle p2) pure (poRecordStyle p1)     , poImportExportStyle = maybe (poImportExportStyle p2) pure (poImportExportStyle p1)     , poImportGrouping = maybe (poImportGrouping p2) pure (poImportGrouping p1)     , poIndentWheres = maybe (poIndentWheres p2) pure (poIndentWheres p1)@@ -209,6 +215,10 @@       "How to place commas in multi-line lists, records, etc. (choices: \"leading\" or \"trailing\") (default: leading)"       "OPTION"     <*> f+      "record-style"+      "How to place braces in records (choices: \"aligned\" or \"knr\") (default: aligned)"+      "OPTION"+    <*> f       "import-export-style"       "Styling of import/export lists (choices: \"leading\", \"trailing\", or \"diff-friendly\") (default: diff-friendly)"       "OPTION"@@ -295,6 +305,7 @@     <*> f "column-limit"     <*> f "function-arrows"     <*> f "comma-style"+    <*> f "record-style"     <*> f "import-export-style"     <*> f "import-grouping"     <*> f "indent-wheres"@@ -348,6 +359,11 @@   | Trailing   deriving (Eq, Show, Enum, Bounded) +data RecordStyle+  = RecordStyleAligned+  | RecordStyleKnr+  deriving (Eq, Show, Enum, Bounded)+ data FunctionArrowsStyle   = TrailingArrows   | LeadingArrows@@ -450,6 +466,28 @@     Leading -> "leading"     Trailing -> "trailing" +instance Aeson.FromJSON RecordStyle where+  parseJSON =+    Aeson.withText "RecordStyle" $ \s ->+      either Aeson.parseFail pure $+        parsePrinterOptType (Text.unpack s)++instance PrinterOptsFieldType RecordStyle where+  parsePrinterOptType s =+    case s of+      "aligned" -> Right RecordStyleAligned+      "knr" -> Right RecordStyleKnr+      _ ->+        Left . unlines $+          [ "unknown value: " <> show s+          , "Valid values are: \"aligned\" or \"knr\""+          ]++instance RenderPrinterOpt RecordStyle where+  renderPrinterOpt = \case+    RecordStyleAligned -> "aligned"+    RecordStyleKnr -> "knr"+ instance Aeson.FromJSON FunctionArrowsStyle where   parseJSON =     Aeson.withText "FunctionArrowsStyle" $ \s ->@@ -776,6 +814,9 @@     , ""     , "# How to place commas in multi-line lists, records, etc. (choices: leading or trailing)"     , "comma-style: leading"+    , ""+    , "# How to place braces in records (choices: aligned or knr)"+    , "record-style: aligned"     , ""     , "# Styling of import/export lists (choices: leading, trailing, or diff-friendly)"     , "import-export-style: diff-friendly"

@@ -1,20 +1,22 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  module Ormolu.Config.Types   ( ImportGroup (..),     ImportGroupRule (..),-    ImportModuleMatcher (..),     ImportRulePriority (..),     matchAllRulePriority,     matchLocalRulePriority,     defaultImportRulePriority,+    ImportListMatcher (..),     QualifiedImportMatcher (..),+    ImportScopeMatcher (..),   ) where -import Control.Applicative (Alternative (..), asum)-import Data.Aeson ((.!=), (.:), (.:?))+import Control.Applicative (Alternative (..))+import Data.Aeson ((.!=), (.:?)) import Data.Aeson qualified as Aeson import Data.Aeson.Types qualified as Aeson import Data.List.NonEmpty (NonEmpty)@@ -34,28 +36,47 @@       <*> Aeson.parseField o "rules"  data ImportGroupRule = ImportGroupRule-  { igrModuleMatcher :: !ImportModuleMatcher,+  { igrGlob :: !Glob,+    igrImportListMatcher :: !ImportListMatcher,     igrQualifiedMatcher :: !QualifiedImportMatcher,+    igrScopeMatcher :: !ImportScopeMatcher,     igrPriority :: !ImportRulePriority   }   deriving (Eq, Show)  instance Aeson.FromJSON ImportGroupRule where   parseJSON = Aeson.withObject "rule" $ \o -> do-    let parseModuleMatcher = Aeson.parseJSON (Aeson.Object o)-        failUnknownModuleMatcher = Aeson.parseFail "Unknown or invalid module matcher"-        attemptParseModuleMatcher = parseModuleMatcher <|> failUnknownModuleMatcher-    igrModuleMatcher <- attemptParseModuleMatcher+    legacyMatch <- o .:? "match"+    (defaultPriority, defaultScope) <- case legacyMatch of+      Just "all" -> pure (matchAllRulePriority, pure MatchAllModules)+      Just "local-modules" -> pure (matchLocalRulePriority, pure MatchLocalModules)+      Just other -> Aeson.parseFail $ "Unknown legacy match value: " <> other+      Nothing -> pure (defaultImportRulePriority, empty) -    qualified <- o .:? "qualified"-    igrQualifiedMatcher <- case qualified of-      Just True -> pure MatchQualifiedOnly-      Just False -> pure MatchUnqualifiedOnly-      Nothing -> pure MatchBothQualifiedAndUnqualified+    igrGlob <- mkGlob <$> o .:? "glob" .!= "**" -    let defaultPriority-          | MatchAllModules <- igrModuleMatcher = matchAllRulePriority-          | otherwise = defaultImportRulePriority+    igrImportListMatcher <-+      o .:? "import-list" .!= "any" >>= \case+        "any" -> pure MatchAnyImportDeclaration+        "explicit" -> pure MatchExplicitImportList+        "hiding" -> pure MatchHidingImportClause+        "none" -> pure MatchWholeModuleImport+        other -> Aeson.parseFail $ "Unknown import list matcher: " <> other++    igrQualifiedMatcher <-+      o .:? "qualified" >>= \case+        Just True -> pure MatchQualifiedOnly+        Just False -> pure MatchUnqualifiedOnly+        Nothing -> pure MatchBothQualifiedAndUnqualified++    igrScopeMatcher <-+      o .:? "scope" >>= \case+        Just "any" -> pure MatchAllModules+        Just "local" -> pure MatchLocalModules+        Just "external" -> pure MatchExternalModules+        Nothing -> defaultScope <|> pure MatchAllModules+        Just other -> Aeson.parseFail ("Unknown scope matcher: " <> other)+     igrPriority <- o .:? "priority" .!= defaultPriority      pure ImportGroupRule {..}@@ -75,35 +96,21 @@ defaultImportRulePriority :: ImportRulePriority defaultImportRulePriority = ImportRulePriority 50 +data ImportListMatcher+  = MatchExplicitImportList+  | MatchHidingImportClause+  | MatchWholeModuleImport+  | MatchAnyImportDeclaration+  deriving (Eq, Show)+ data QualifiedImportMatcher   = MatchQualifiedOnly   | MatchUnqualifiedOnly   | MatchBothQualifiedAndUnqualified   deriving (Eq, Show) -data ImportModuleMatcher-  = MatchAllModules+data ImportScopeMatcher+  = MatchExternalModules   | MatchLocalModules-  | MatchGlob !Glob+  | MatchAllModules   deriving (Eq, Show)--instance Aeson.FromJSON ImportModuleMatcher where-  parseJSON v =-    asum-      [ parseMatchModuleMatcher v,-        parseGlobModuleMatcher v-      ]-    where-      parseMatchModuleMatcher :: Aeson.Value -> Aeson.Parser ImportModuleMatcher-      parseMatchModuleMatcher = Aeson.withObject "ImportModuleMatcher" $ \o -> do-        c <- Aeson.parseField @String o "match"-        case c of-          "all" -> pure MatchAllModules-          "local-modules" -> pure MatchLocalModules-          other -> Aeson.parseFail $ "Unknown matcher: " <> other--      parseGlobModuleMatcher :: Aeson.Value -> Aeson.Parser ImportModuleMatcher-      parseGlobModuleMatcher = Aeson.withObject "ImportModuleMatcher" $ \o -> do-        rawGlob <- o .: "glob"-        let glob = mkGlob rawGlob-        pure (MatchGlob glob)

@@ -106,11 +106,13 @@                   `extQ` considerEqual @EpLayout                   `extQ` considerEqual @AnnSig                   `extQ` considerEqual @HsRuleAnn-                  `extQ` considerEqual @EpLinearArrow+                  `extQ` considerEqual @EpLinear                   `extQ` considerEqual @AnnSynDecl                   `extQ` considerEqual @IsUnicodeSyntax                   -- 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@@ -170,6 +172,7 @@     epAnnEq :: EpAnn a -> b -> ParseResultDiff     epAnnEq _ _ = Same +    importDeclQualifiedStyleEq :: forall a. (Data a) => ImportDeclQualifiedStyle -> a -> ParseResultDiff     importDeclQualifiedStyleEq = considerEqualVia' f       where         f QualifiedPre QualifiedPost = True@@ -177,7 +180,7 @@         f x x' = x == x'      hsDocStringEq :: HsDocString -> GenericQ ParseResultDiff-    hsDocStringEq = considerEqualVia' ((==) `on` (map (T.dropWhile isSpace) . splitDocString True))+    hsDocStringEq = considerEqualVia' ((==) `on` (map (T.dropWhile isSpace) . splitDocString))      forLocated ::       (Data e0, Data e1) =>

@@ -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 DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}@@ -28,11 +27,8 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc import Ormolu.Config (ImportGrouping)-import Ormolu.Imports.Grouping (Import (..), groupImports, prepareExistingGroups)+import Ormolu.Imports.Grouping (Import (..), ImportList (..), groupImports, prepareExistingGroups) import Ormolu.Utils (notImplemented, showOutputable)-#if !MIN_VERSION_base(4,20,0)-import Data.List (foldl')-#endif  -- | Sort, group and normalize imports. --@@ -51,7 +47,15 @@     . prepareExistingGroups importGrouping respectful   where     toImport :: (ImportId, x) -> Import-    toImport (ImportId {..}, _) = Import {importName = importIdName, importQualified}+    toImport (ImportId {..}, _) =+      Import+        { importName = importIdName,+          importList = case importHiding of+            Just (ImportListInterpretationOrd Exactly) -> Just ImportList+            Just (ImportListInterpretationOrd EverythingBut) -> Just HidingList+            Nothing -> Nothing,+          importQualified+        }      g :: LImportDecl GhcPs -> LImportDecl GhcPs     g (L l ImportDecl {..}) =@@ -90,10 +94,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@@ -137,11 +154,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]@@ -231,6 +253,7 @@       IEDefault _ x -> (1, x)       IEPattern _ x -> (2, x)       IEType _ x -> (3, x)+      IEData _ x -> (4, x)  compareRdrName :: RdrName -> RdrName -> Ordering compareRdrName x y =

@@ -3,6 +3,7 @@  module Ormolu.Imports.Grouping   ( Import (..),+    ImportList (..),     prepareExistingGroups,     groupImports,   )@@ -19,18 +20,24 @@ import Distribution.ModuleName qualified as Cabal import GHC.Hs (GhcPs, getLocA) import Language.Haskell.Syntax (LImportDecl, ModuleName, moduleNameString)-import Ormolu.Config (ImportGroup (..), ImportGroupRule (..), ImportGrouping (..), ImportModuleMatcher (..))+import Ormolu.Config (ImportGroup (..), ImportGroupRule (..), ImportGrouping (..)) import Ormolu.Config qualified as Config import Ormolu.Utils (ghcModuleNameToCabal, groupBy', separatedByBlank)-import Ormolu.Utils.Glob (matchesGlob)+import Ormolu.Utils.Glob (matchAllGlob, matchesGlob)  newtype ImportGroups = ImportGroups (NonEmpty ImportGroup)  data Import = Import   { importName :: ModuleName,+    importList :: Maybe ImportList,     importQualified :: Bool   } +data ImportList+  = ImportList+  | HidingList+  deriving (Eq)+ importGroupSingleStrategy :: ImportGroups importGroupSingleStrategy =   ImportGroups $@@ -94,16 +101,20 @@ matchAllImportRule :: ImportGroupRule matchAllImportRule =   ImportGroupRule-    { igrModuleMatcher = MatchAllModules,+    { igrGlob = matchAllGlob,+      igrImportListMatcher = Config.MatchAnyImportDeclaration,       igrQualifiedMatcher = Config.MatchBothQualifiedAndUnqualified,+      igrScopeMatcher = Config.MatchAllModules,       igrPriority = Config.matchAllRulePriority     }  matchLocalModulesRule :: ImportGroupRule matchLocalModulesRule =   ImportGroupRule-    { igrModuleMatcher = MatchLocalModules,+    { igrGlob = matchAllGlob,+      igrImportListMatcher = Config.MatchAnyImportDeclaration,       igrQualifiedMatcher = Config.MatchBothQualifiedAndUnqualified,+      igrScopeMatcher = Config.MatchLocalModules,       igrPriority = Config.matchLocalRulePriority     } @@ -122,16 +133,30 @@     }  matchesRule :: Set Cabal.ModuleName -> Import -> ImportGroupRule -> Bool-matchesRule localMods Import {..} ImportGroupRule {..} = matchesModules && matchesQualified+matchesRule localMods Import {..} ImportGroupRule {..} =+  and+    [ matchingGlob,+      matchingImportList,+      matchingQualified,+      matchingScope+    ]   where-    matchesModules = case igrModuleMatcher of-      MatchAllModules -> True-      MatchLocalModules -> ghcModuleNameToCabal importName `Set.member` localMods-      MatchGlob gl -> moduleNameString importName `matchesGlob` gl-    matchesQualified = case igrQualifiedMatcher of+    matchingGlob = moduleNameString importName `matchesGlob` igrGlob+    matchingImportList = case igrImportListMatcher of+      Config.MatchExplicitImportList -> importList == Just ImportList+      Config.MatchHidingImportClause -> importList == Just HidingList+      Config.MatchWholeModuleImport -> importList == Nothing+      Config.MatchAnyImportDeclaration -> True+    matchingQualified = case igrQualifiedMatcher of       Config.MatchQualifiedOnly -> importQualified       Config.MatchUnqualifiedOnly -> not importQualified       Config.MatchBothQualifiedAndUnqualified -> True+    matchingScope =+      let isLocalModule = ghcModuleNameToCabal importName `Set.member` localMods+       in case igrScopeMatcher of+            Config.MatchAllModules -> True+            Config.MatchExternalModules -> not isLocalModule+            Config.MatchLocalModules -> isLocalModule  prepareExistingGroups :: ImportGrouping -> Bool -> [LImportDecl GhcPs] -> [[LImportDecl GhcPs]] prepareExistingGroups ig respectful =

@@ -30,7 +30,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)@@ -45,6 +45,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.Config.Gen (SingleConstraintParens (..))@@ -317,10 +318,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 ->

@@ -24,6 +24,7 @@     newline,     declNewline,     multilineCommentNewline,+    newlineLiteral,     inci,     inciBy,     inciIf,@@ -48,6 +49,7 @@     -- ** Formatting lists     sep,     sepSemi,+    sepSemi',     canUseBraces,     useBraces,     dontUseBraces,@@ -58,6 +60,7 @@     backticks,     banana,     braces,+    recordBraces,     brackets,     parens,     parensHash,@@ -256,7 +259,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@@ -272,7 +293,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@@ -368,6 +392,31 @@             else space >> sitcc m       newline       inciIf (style == S) close++-- With leading commas align the close brace with commas+-- otherwise move the close brace back to the left+recordBraces :: R () -> R ()+recordBraces m = do+  commaStyle <- getPrinterOpt poCommaStyle+  recordBraces_ (commaStyle == Trailing) m++recordBraces_ :: Bool -> R () -> R ()+recordBraces_ moveBraceBack m = do+  style <- getPrinterOpt poRecordStyle+  case style of+    RecordStyleAligned -> braces N m+    RecordStyleKnr ->+      vlayout+        (txt "{" >> m >> txt "}")+        ( do+            txt "{"+            newline+            sitcc m+            newline+            if moveBraceBack+              then inciByFrac (-1) (txt "}")+              else txt "}"+        )  ---------------------------------------------------------------------------- -- Literals

@@ -20,6 +20,7 @@     newline,     declNewline,     multilineCommentNewline,+    newlineLiteral,     askSourceType,     askModuleFixityMap,     askDebug,@@ -437,6 +438,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_hsDoc',     p_sourceText,     p_namespaceSpec,+    p_hsMultAnn,     p_arrow,   ) where@@ -29,13 +30,13 @@ 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) import GHC.Types.Name.Reader import GHC.Types.SourceText import GHC.Types.SrcLoc-import Language.Haskell.Syntax (HsArrowOf (..)) import Language.Haskell.Syntax.Module.Name import Ormolu.Config import Ormolu.Printer.Combinators@@ -48,7 +49,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@@ -73,6 +74,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 ()@@ -93,7 +98,7 @@       -- 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@@ -190,12 +195,7 @@   -- Make sure the Haddock is separated by a newline from other comments.   when goesAfterComment newline -  let shouldEscapeCommentBraces =-        case poHStyle of-          HaddockSingleLine -> False-          HaddockMultiLine -> True-          HaddockMultiLineCompact -> True-  let docStringLines = splitDocString shouldEscapeCommentBraces $ hsDocString str+  let docStringLines = splitDocString $ hsDocString str    if poHStyle == HaddockSingleLine || length docStringLines <= 1     then do@@ -242,10 +242,18 @@   TypeNamespaceSpecifier _ -> txt "type" *> space   DataNamespaceSpecifier _ -> txt "data" *> space -p_arrow :: (mult -> R ()) -> HsArrowOf mult GhcPs -> R ()+p_hsMultAnn :: (mult -> R ()) -> HsMultAnnOf mult GhcPs -> R ()+p_hsMultAnn p_mult = \case+  HsUnannotated _ -> pure ()+  HsLinearAnn _ -> txt "%1"+  HsExplicitMult _ mult -> txt "%" *> p_mult mult++-- | Like 'p_hsMultAnn', except specifically for arrows, taking -XUnicodeSyntax+--   into account.+p_arrow :: (mult -> R ()) -> HsMultAnnOf mult GhcPs -> R () p_arrow p_mult = \case-  HsUnrestrictedArrow _ -> token'rarrow-  HsLinearArrow _ -> token'lolly+  HsUnannotated _ -> token'rarrow+  HsLinearAnn _ -> token'lolly   HsExplicitMult _ mult -> do     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)) _)@@ -266,6 +266,12 @@ pattern KindSignature n <- KindSigD _ (StandaloneKindSig _ (L _ n) _) 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 

@@ -3,9 +3,12 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}  -- | Renedring of data type declarations. module Ormolu.Printer.Meat.Declaration.Data@@ -21,7 +24,6 @@ import Data.List.NonEmpty qualified as NE import Data.Maybe (isJust, isNothing, maybeToList) import Data.Text qualified as Text-import Data.Void import GHC.Hs import GHC.Types.Fixity import GHC.Types.ForeignCall@@ -154,7 +156,7 @@   deriving (Eq, Ord)  p_conDecl :: Choice "singleRecCon" -> ConDecl GhcPs -> R ()-p_conDecl _ ConDeclGADT {..} = do+p_conDecl _ decl@ConDeclGADT {..} = do   mapM_ (p_hsDoc Pipe (With #endNewline)) con_doc   switchLayout conDeclSpn $ do     let c :| cs = con_names@@ -162,61 +164,42 @@     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-      p_hsTypeAnnotation quantifiedTy+    inci $ p_hsFun decl   where     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+        recordStyle <- getPrinterOpt poRecordStyle+        if recordStyle == RecordStyleKnr then space else breakpoint+        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@@ -229,10 +212,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@@ -242,7 +225,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 =@@ -262,13 +245,9 @@     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 ->@@ -337,6 +316,105 @@           located sigTy p_hsSigType  ----------------------------------------------------------------------------+-- FunRepr ConDeclGADT++-- | ConDecl, except should only be called with the ConDeclGADT constructor.+type ConDeclGADT = ConDecl++-- | FunRepr ConDeclGADT renders a GADT constructor type annotation, which looks+-- similar to a function type, except the arguments of the function have two+-- additional capabilities:+--   * They can specify UNPACK/strictness+--   * It can be a single argument with a record fields syntax+instance FunRepr (ConDeclGADT GhcPs) where+  parseFunRepr = \case+    L _ ConDeclGADT {..} ->+      fst+        . addSig+        . addOuter con_outer_bndrs+        . addInner con_inner_bndrs+        . addCtx con_mb_cxt+        . addArgs con_g_args+        $ mkRet con_res_ty+    _ -> error "parseFunRepr @ConDeclGADT unexpectedly called on non-GADT constructor"+    where+      addSig (next, loc) = (ParsedFunSig {sig = (), next}, loc)+      addOuter (L ann bndrs) =+        case bndrs :: HsOuterSigTyVarBndrs GhcPs of+          HsOuterImplicit {} -> id+          HsOuterExplicit _ bndrs' -> \(next, loc) ->+            let loc' = combineSrcSpans loc (getHasLoc ann)+                fun =+                  ParsedFunForall+                    { tele = L (l2l loc') $ mkHsForAllInvisTele noAnn bndrs',+                      next+                    }+             in (fun, loc')+      addInner =+        let go tele (next, loc) =+              let loc' =+                    combineSrcSpans loc $+                      case tele of+                        HsForAllVis x _ -> getHasLoc x+                        HsForAllInvis x _ -> getHasLoc x+                  fun = ParsedFunForall {tele = L (l2l loc') tele, next}+               in (fun, loc')+         in foldr (\tele acc -> go tele . acc) id+      addCtx = \case+        Nothing -> id+        Just ctxs -> \(next, loc) ->+          let loc' = combineSrcSpans loc (getHasLoc ctxs)+              fun = ParsedFunQuals {ctxs = [L (l2l loc') ctxs], next}+           in (fun, loc')+      addArgs details =+        case details :: HsConDeclGADTDetails GhcPs of+          PrefixConGADT _ fields ->+            let go field (next, loc) =+                  let loc' = combineSrcSpans loc (getHasLoc field.cdf_type)+                      fun =+                        ParsedFunArg+                          { span = l2l loc',+                            arg = L noAnn (Left field),+                            doc = field.cdf_doc,+                            multAnn = field.cdf_multiplicity,+                            next+                          }+                   in (fun, loc')+             in foldr (\field acc -> go field . acc) id fields+          RecConGADT _ fields -> \(next, loc) ->+            let loc' = combineSrcSpans (getHasLoc fields) loc+                fun =+                  ParsedFunArg+                    { span = l2l loc',+                      arg = la2la $ Right <$> fields,+                      doc = Nothing,+                      multAnn = HsUnannotated (EpArrow noAnn),+                      next+                    }+             in (fun, loc')+      mkRet ty =+        let fun =+              case ty of+                L _ (HsDocTy _ ret doc) -> ParsedFunReturn {ret, doc = Just doc}+                ret -> ParsedFunReturn {ret, doc = Nothing}+         in (fun, getHasLoc ty)++  type FunReprCtx (ConDeclGADT GhcPs) = HsType GhcPs+  renderFunReprCtx = p_hsType++  -- Invariant: Exactly one of the following must be true:+  --   * There's exactly one 'Right' arg+  --   * There are zero or more 'Left' args+  type FunReprArg (ConDeclGADT GhcPs) = Either (HsConDeclField GhcPs) [LocatedA (HsConDeclRecField GhcPs)]+  renderFunReprArg = either p_hsConDeclField p_hsConDeclRecFields++  type FunReprMult (ConDeclGADT GhcPs) = HsType GhcPs+  renderFunReprMult = p_hsType++  type FunReprRet (ConDeclGADT GhcPs) = HsType GhcPs+  renderFunReprRet = p_hsType++---------------------------------------------------------------------------- -- Helpers  isInfix :: LexicalFixity -> Bool@@ -349,14 +427,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)

@@ -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

@@ -138,12 +138,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

@@ -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,18 +9,24 @@     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 import GHC.Types.SourceText+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 @@ -30,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@@ -116,26 +125,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-  token'dcolon-  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+        token'dcolon+        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"@@ -165,7 +219,7 @@  p_minimalSig ::   -- | Boolean formula-  LBooleanFormula (LocatedN RdrName) ->+  LBooleanFormula GhcPs ->   R () p_minimalSig =   located' $ \booleanFormula ->@@ -173,7 +227,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 ()

@@ -40,7 +40,7 @@                   LastPos -> txt "\\" *> txt s         vlayout singleLine multiLine       MultilineStringLiteral ->-        sep breakpoint' txt segments+        sep newlineLiteral txt segments     txt endMarker  -- | The start/end marker of the literal, whether it is a regular or a multiline@@ -91,12 +91,25 @@       where         go [] = [s]         go ((pre, suf) : bs) = case T.uncons suf of-          Just ('\\', T.uncons -> Just (c, s'))-            | is_space c,-              let rest = T.drop 1 $ T.dropWhile (/= '\\') s' ->+          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 -> go $ (if c == '\\' then drop 1 else id) bs+            | 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.

@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}@@ -31,7 +32,6 @@ import Data.Maybe import Data.Text (Text) import Data.Text qualified as Text-import Data.Void import GHC.Data.Strict qualified as Strict import GHC.Hs import GHC.LanguageExtensions.Type (Extension (NegativeLiterals))@@ -47,7 +47,7 @@ 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@@ -100,15 +100,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,7 +117,7 @@         render         (adjustMatchGroupStyle m style)         (isInfixMatch m)-        (HsNoMultAnn NoExtField)+        (HsUnannotated EpPatBind)         (matchStrictness m)         -- We use the spans of the individual patterns.         (unLoc m_pats)@@ -126,7 +126,7 @@ -- | 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 ::@@ -134,14 +134,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@@ -186,17 +185,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@@ -207,7 +208,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)       switchLayoutNoLimit [combinedSpans] $ do         let stdCase = sep breakpoint (located' p_pat) m_pats         case style of@@ -244,14 +250,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@@ -277,7 +279,7 @@         sep           breakpoint           (located' (p_grhs' placement placer render groupStyle))-          grhssGRHSs+          (NE.toList grhssGRHSs)       p_where = do         unless (eqEmptyLocalBinds grhssLocalBinds) $ do           breakpoint@@ -290,6 +292,7 @@       case style of         Function _ | hasGuards -> return ()         Function _ -> space >> inci equals+        PatternBind | hasGuards -> return ()         PatternBind -> space >> inci equals         s | isCase s && hasGuards -> return ()         _ -> space >> token'rarrow@@ -375,10 +378,10 @@     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 $ sitcc $ 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 (letToken, _) localBinds c ->@@ -565,8 +568,8 @@ p_dotFieldOcc =   p_rdrName . fmap (mkVarUnqual . field_label) . dfoLabel -p_dotFieldOccs :: [DotFieldOcc GhcPs] -> R ()-p_dotFieldOccs = sep (txt ".") p_dotFieldOcc+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@@ -591,7 +594,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@@ -604,10 +607,18 @@   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   HsOverLabel sourceText _ -> do     txt "#"     p_sourceText sourceText@@ -622,7 +633,7 @@       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@@ -743,13 +754,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 breakpoint (located' (p_grhs RightArrow)) guards+    inciApplicand isApp $+      sep breakpoint (located' (p_grhs RightArrow)) (NE.toList guards)   HsLet (letToken, _) localBinds e ->     p_let (s == S) p_hsExpr letToken localBinds e   HsDo _ doFlavor es -> do@@ -775,7 +787,7 @@         dotdot = case rec_dotdot of           Just {} -> [txt ".."]           Nothing -> []-    inci . braces N $+    inci . recordBraces $       sep commaDel sitcc (fields <> dotdot)   RecordUpd {..} -> do     located rupd_expr p_hsExpr@@ -784,7 +796,7 @@           sep commaDel (sitcc . located' (p_hsFieldBind p_lbl))         p_fieldLabelStrings (FieldLabelStrings flss) =           p_dotFieldOccs $ unLoc <$> flss-    inci . braces N $ case rupd_flds of+    inci . recordBraces $ case rupd_flds of       RegularRecUpdFields {..} ->         p_recFields (located' p_fieldOcc) recUpdFields       OverloadedRecUpdFields {..} ->@@ -795,7 +807,7 @@     located gf_field p_dotFieldOcc   HsProjection {..} -> parens N $ do     txt "."-    p_dotFieldOccs (NE.toList proj_flds)+    p_dotFieldOccs proj_flds   ExprWithTySig _ x HsWC {hswc_body} -> sitcc $ do     located x p_hsExpr     inci $ p_hsTypeAnnotation (hsSigTypeToType <$> hswc_body)@@ -828,7 +840,7 @@     breakpoint'     txt "||]"   HsUntypedBracket _ x -> p_hsQuote x-  HsTypedSplice _ expr -> p_hsSpliceTH True expr DollarSplice+  HsTypedSplice _ (HsTypedSpliceExpr _ expr) -> p_hsSpliceTH True expr DollarSplice   HsUntypedSplice _ untySplice -> p_hsUntypedSplice DollarSplice untySplice   HsProc _ p e -> do     txt "proc"@@ -855,6 +867,9 @@     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   expr@HsForAll {} ->     p_hsFun expr@@ -962,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 ->@@ -998,12 +1013,17 @@               breakpoint               located psb_def p_pat             breakpoint-            txt "where"+            indentWhere <- getPrinterOpt poIndentWheres+            let (inciWhere, inciBody) =+                  if indentWhere+                    then (id, inci)+                    else (inciByFrac (-1 / 2), id)+            inciWhere $ txt "where"             breakpoint-            inci (p_matchGroup (Function psb_id) mgroup)+            inciBody $ 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@@ -1012,7 +1032,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@@ -1020,7 +1039,7 @@         let conSpans = getLocA . recordPatSynPatVar <$> xs         switchLayout conSpans $ do           unless (null xs) breakpointPreRecordBrace-          braces N $+          recordBraces $             sep commaDel (p_rdrName . recordPatSynPatVar) xs         rhs conSpans     InfixCon l r -> do@@ -1040,6 +1059,7 @@     Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA   ) =>   IsApplicand ->+  BracketStyle ->   -- | Placer   (body -> Placement) ->   -- | Render@@ -1049,20 +1069,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@@ -1072,7 +1095,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"@@ -1084,7 +1107,7 @@     Just caseTxt -> do       txt caseTxt       breakpoint-      inciApplicand isApp pMatchGroup+      adjustBracing isApp s (inciApplicand isApp pMatchGroup)  p_if ::   -- | Placer@@ -1243,65 +1266,66 @@         _ -> Nothing  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 . sitcc . p_pat)+    located pat (parens S . sitcc . 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-  OrPat _ pats ->-    sepSemi (located' p_pat) (NE.toList 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)+        unless (null xs) breakpoint+        inci . sitcc $ sep breakpoint (sitcc . located' (p_pat' inAsPat)) xs       RecCon (HsRecFields _ fields dotdot) -> do         p_rdrName pat         breakpointPreRecordBrace         let f = \case               Nothing -> txt ".."               Just x -> located x p_pat_hsFieldBind-        inci . braces N . sep commaDel f $+        inci . recordBraces . sep commaDel f $           case dotdot of             Nothing -> Just <$> fields             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     token'rarrow     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@@ -1318,7 +1342,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"@@ -1329,9 +1353,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@@ -1361,7 +1382,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.@@ -1428,21 +1449,31 @@  -- | Function types in expressions, e.g. with -XRequiredTypeArguments instance FunRepr (HsExpr GhcPs) where-  renderFunItem = p_hsExpr   parseFunRepr = \case     -- `forall a. _`     L ann (HsForAll _ tele expr) ->-      ParsedFunForall (L ann tele) (parseFunRepr expr)+      ParsedFunForall+        { tele = L ann tele,+          next = parseFunRepr expr+        }     -- `HasCallStack => _`     expr@(L _ HsQual {}) ->       let (ctxs, rest) = getContexts expr-       in ParsedFunQuals ctxs (parseFunRepr rest)+       in ParsedFunQuals+            { ctxs,+              next = parseFunRepr rest+            }     -- `Int -> _`-    expr@(L _ HsFunArr {}) ->-      let (args, ret) = getArgsAndReturn expr-       in ParsedFunArgs args (parseFunRepr ret)+    L ann (HsFunArr _ multAnn arg r) ->+      ParsedFunArg+        { span = ann,+          arg,+          doc = Nothing,+          multAnn,+          next = parseFunRepr r+        }     -- `_ -> Int`-    expr -> ParsedFunReturn (expr, Nothing)+    ret -> ParsedFunReturn {ret, doc = Nothing}     where       getContexts =         let go ctxs = \case@@ -1451,14 +1482,12 @@               expr ->                 (reverse ctxs, expr)          in go []-      getArgsAndReturn =-        let go args = \case-              L ann (HsFunArr _ arrow l r) ->-                go (L ann (l, Nothing, arrow) : args) r-              expr ->-                (reverse args, expr)-         in go [] +  renderFunReprArg = p_hsExpr+  renderFunReprCtx = p_hsExpr+  renderFunReprMult = p_hsExpr+  renderFunReprRet = p_hsExpr+ ---------------------------------------------------------------------------- -- Helpers @@ -1476,9 +1505,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.@@ -1522,7 +1551,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@@ -1531,10 +1560,12 @@ -- | For use before record braces. Collapse to empty if not 'poRecordBraceSpace'. breakpointPreRecordBrace :: R () breakpointPreRecordBrace = do+  recordStyle <- getPrinterOpt poRecordStyle   useSpace <- getPrinterOpt poRecordBraceSpace-  if useSpace-    then breakpoint-    else breakpoint'+  if+    | recordStyle == RecordStyleKnr -> space+    | useSpace -> breakpoint+    | otherwise -> breakpoint'  -- | For nested lists/tuples, pad with whitespace so that we always indent correctly, -- rather than sometimes indenting by 2 regardless of 'poIndentation'.

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

@@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}  -- | Rendering of types. module Ormolu.Printer.Meat.Type@@ -16,42 +18,40 @@     p_hsTyVarBndr,     ForAllVisibility (..),     p_forallBndrs,-    p_conDeclFields,+    p_hsConDeclRecFields,+    p_hsConDeclField,+    p_hsConDeclFieldWithDoc,     p_lhsTypeArg,     p_hsSigType,-    FunRepr (..),-    ParsedFunRepr (..),-    p_hsFun,-    hsOuterTyVarBndrsToHsType,     hsSigTypeToType,     lhsTypeToSigType,++    -- * Re-exports from Ormolu.Printer.Meat.Type.Function+    FunRepr (..),+    ParsedFunRepr,+    ParsedFunRepr' (..),+    p_hsFun,   ) where  import Control.Monad-import Control.Monad.Cont qualified as Cont-import Control.Monad.State qualified as State-import Control.Monad.Trans qualified as Trans-import Data.Choice (Choice, pattern Is, pattern Isn't, pattern With, pattern Without)-import Data.Choice qualified as Choice-import Data.Foldable (traverse_)-import Data.Functor ((<&>))-import Data.List (sortOn)-import Data.Maybe (isJust)+import Data.Choice (pattern Is, pattern With, pattern Without)+import Data.Maybe (fromMaybe) import GHC.Data.Strict qualified as Strict import GHC.Hs hiding (isPromoted) import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Types.Var-import GHC.Utils.Outputable (Outputable) import Ormolu.Config import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.OpTree (p_tyOpTree, tyOpTree) import Ormolu.Printer.Meat.Declaration.StringLiteral import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsUntypedSplice)+import Ormolu.Printer.Meat.Type.Function import Ormolu.Printer.Operators import Ormolu.Utils+import Prelude hiding (span)  p_hsType :: HsType GhcPs -> R () p_hsType = \case@@ -137,31 +137,8 @@     --       String     --       -- | Age     --       Int-    usePipe <--      getPrinterOpt poFunctionArrows <&> \case-        TrailingArrows -> True-        LeadingArrows -> False-        LeadingArgsArrows -> False-    if usePipe-      then do-        p_hsDoc Pipe (With #endNewline) str-        located t p_hsType-      else do-        located t p_hsType-        newline-        p_hsDoc Caret (Without #endNewline) str-  HsBangTy _ (HsBang 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+    withHaddocks (Is #end) (Just str) $ do+      located t p_hsType   HsExplicitListTy _ p xs -> do     case p of       IsPromoted -> txt "'"@@ -189,7 +166,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@@ -200,7 +190,12 @@       _ -> False  p_hsTypeAnnotation :: LHsType GhcPs -> R ()-p_hsTypeAnnotation = p_hsFunParsed . ParsedFunSig . parseFunRepr+p_hsTypeAnnotation ty =+  p_hsFunParsed @(HsType GhcPs) $+    ParsedFunSig+      { sig = (),+        next = parseFunRepr ty+      }  -- | Return 'True' if at least one argument in 'HsType' has a doc string -- attached to it.@@ -215,101 +210,47 @@ p_hsContext :: HsContext GhcPs -> R () p_hsContext = p_hsContext' p_hsType -p_hsContext' ::-  (Outputable (GenLocated (Anno a) a), HasLoc (Anno a)) =>-  (a -> R ()) ->-  [XRec GhcPs a] ->-  R ()-p_hsContext' f = \case-  [] -> txt "()"-  [x] -> located x f-  xs -> do-    shouldSort <- getPrinterOpt poSortConstraints-    let sort = if shouldSort then sortOn showOutputable else id-    parens N $ sep commaDel (sitcc . located' f) (sort xs)--class IsTyVarBndrFlag flag where-  isInferred :: flag -> Bool-  p_tyVarBndrFlag :: flag -> R ()-  p_tyVarBndrFlag _ = pure ()--instance IsTyVarBndrFlag () where-  isInferred () = False--instance IsTyVarBndrFlag Specificity where-  isInferred = \case-    InferredSpec -> True-    SpecifiedSpec -> False--instance IsTyVarBndrFlag (HsBndrVis GhcPs) where-  isInferred _ = False-  p_tyVarBndrFlag = \case-    HsBndrRequired NoExtField -> pure ()-    HsBndrInvisible _ -> txt "@"--p_hsTyVarBndr :: (IsTyVarBndrFlag flag) => HsTyVarBndr flag GhcPs -> R ()-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 -> inci $ p_hsTypeAnnotation k-      HsBndrNoKind _ -> pure ()--data ForAllVisibility = ForAllInvis | ForAllVis---- | Render several @forall@-ed variables.-p_forallBndrs ::-  (HasLoc l) =>-  ForAllVisibility ->-  (a -> R ()) ->-  [GenLocated l a] ->-  R ()-p_forallBndrs vis p tyvars = do-  p_forallBndrsStart p tyvars-  p_forallBndrsEnd (Without #extraSpace) vis--p_forallBndrsStart :: (HasLoc l) => (a -> R ()) -> [GenLocated l a] -> R ()-p_forallBndrsStart _ [] = token'forall-p_forallBndrsStart p tyvars = do-  switchLayout (locA <$> tyvars) $ do-    token'forall-    breakpoint-    inci $ do-      sitcc $ sep breakpoint (sitcc . located' p) tyvars--p_forallBndrsEnd :: Choice "extraSpace" -> ForAllVisibility -> R ()-p_forallBndrsEnd extraSpace = \case-  ForAllInvis -> txt dot >> space-  ForAllVis -> space >> token'rarrow-  where-    dot = if Choice.isTrue extraSpace then " ." else "."--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 =+  recordBraces $ sep commaDel (sitcc . located' p_hsConDeclRecField) xs -p_conDeclField :: ConDeclField GhcPs -> R ()-p_conDeclField ConDeclField {..} = do-  commaStyle <- getPrinterOpt poCommaStyle-  when (commaStyle == Trailing) $-    mapM_ (p_hsDoc Pipe (With #endNewline)) cd_fld_doc+p_hsConDeclRecField :: HsConDeclRecField GhcPs -> R ()+p_hsConDeclRecField field@HsConDeclRecField {..} = withFieldHaddocks $ do   sitcc $     sep       commaDel       (located' (p_rdrName . foLabel))-      cd_fld_names-  inci $ p_hsTypeAnnotation cd_fld_type-  when (commaStyle == Leading) $-    mapM_ (inciByFrac (-1) . (newline >>) . p_hsDoc Caret (Without #endNewline)) cd_fld_doc+      cdrf_names+  inci $ p_hsFun field+  where+    withFieldHaddocks action = do+      commaStyle <- getPrinterOpt poCommaStyle+      let doc = cdf_doc cdrf_spec+      when (commaStyle == Trailing) $+        mapM_ (p_hsDoc Pipe (With #endNewline)) doc+      action+      when (commaStyle == Leading) $+        mapM_ (inciByFrac (-1) . (newline >>) . p_hsDoc Caret (Without #endNewline)) doc +-- | 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 = withHaddocks (Is #end) cdf.cdf_doc $ do+  p_hsConDeclField cdf+ p_lhsTypeArg :: LHsTypeArg GhcPs -> R () p_lhsTypeArg = \case   HsValArg NoExtField ty -> located ty p_hsType@@ -322,54 +263,37 @@ p_hsSigType :: HsSigType GhcPs -> R () p_hsSigType = p_hsType . hsSigTypeToType -------------------------------------------------------------------------------- Rendering function types---- | The parsed representation of a function-data ParsedFunRepr a-  = ParsedFunSig (ParsedFunRepr a)-  | ParsedFunForall-      (LocatedA (HsForAllTelescope GhcPs))-      (ParsedFunRepr a)-  | ParsedFunQuals-      [LocatedA (LocatedC [LocatedA a])]-      (ParsedFunRepr a)-  | -- | The argument, its optional docstring, and the arrow going to the next arg/return-    ParsedFunArgs-      [ LocatedA-          ( LocatedA a,-            Maybe (LHsDoc GhcPs),-            HsArrowOf (LocatedA a) GhcPs-          )-      ]-      (ParsedFunRepr a)-  | ParsedFunReturn-      ( LocatedA a,-        Maybe (LHsDoc GhcPs)-      )--class (Anno a ~ SrcSpanAnnA, Outputable a) => FunRepr a where-  renderFunItem :: a -> R ()--  parseFunRepr :: LocatedA a -> ParsedFunRepr a- instance FunRepr (HsType GhcPs) where-  renderFunItem = p_hsType   parseFunRepr = \case     -- `forall a. _`     L ann (HsForAllTy _ tele ty) ->-      ParsedFunForall (L ann tele) (parseFunRepr ty)+      ParsedFunForall+        { tele = L ann tele,+          next = parseFunRepr ty+        }     -- `HasCallStack => _`     ty@(L _ HsQualTy {}) ->       let (ctxs, rest) = getContexts ty-       in ParsedFunQuals ctxs (parseFunRepr rest)+       in ParsedFunQuals+            { ctxs,+              next = parseFunRepr rest+            }     -- `Int -> _`-    ty@(L _ HsFunTy {}) ->-      let (args, ret) = getArgsAndReturn ty-       in ParsedFunArgs args (parseFunRepr ret)+    L ann (HsFunTy _ multAnn l r) ->+      let (arg, doc) =+            case l of+              L _ (HsDocTy _ x doc_) -> (x, Just doc_)+              _ -> (l, Nothing)+       in ParsedFunArg+            { span = ann,+              arg,+              doc,+              multAnn,+              next = parseFunRepr r+            }     -- `_ -> Int`-    L _ (HsDocTy _ ty doc) -> ParsedFunReturn (ty, Just doc)-    ty -> ParsedFunReturn (ty, Nothing)+    L _ (HsDocTy _ ret doc) -> ParsedFunReturn {ret, doc = Just doc}+    ret -> ParsedFunReturn {ret, doc = Nothing}     where       getContexts =         let go ctxs = \case@@ -378,203 +302,106 @@               ty ->                 (reverse ctxs, ty)          in go []-      getArgsAndReturn =-        let go args = \case-              L ann (HsFunTy _ arrow (L _ (HsDocTy _ l doc)) r) ->-                go (L ann (l, Just doc, arrow) : args) r-              L ann (HsFunTy _ arrow l r) ->-                go (L ann (l, Nothing, arrow) : args) r-              ty ->-                (reverse args, ty)-         in go [] --- | For implementing function-arrows and related configuration, we'll collect--- all the components of the function type first, then render as a block instead--- of rendering each part independently, which will let us track local state--- within a function type.------ This function should be passed the first function-related construct we find;--- see FunRepr for more details.-p_hsFun :: (FunRepr a) => a -> R ()-p_hsFun = p_hsFunParsed . parseFunRepr . L (noAnn @SrcSpanAnnA)--p_hsFunParsed :: (FunRepr a) => ParsedFunRepr a -> R ()-p_hsFunParsed fun = do-  arrowsStyle <- getPrinterOpt poFunctionArrows-  p_hsFunParsed' arrowsStyle fun--type PrintHsFun x = State.StateT PrintHsFunState (Cont.ContT () R) x--type PrintHsFunState =-  ( Maybe (R ()), -- The leading delimiter to output at the next line-    Choice "forceMultiline"-  )--p_hsFunParsed' ::-  (FunRepr a) =>-  FunctionArrowsStyle ->-  ParsedFunRepr a ->-  R ()-p_hsFunParsed' arrowsStyle fun0 = Cont.evalContT . (`State.evalStateT` initialState) . go $ fun0-  where-    go = \case-      ParsedFunSig fun' -> do-        -- Should only happen at the very beginning, if at all-        p_parsedFunSig-        setMultilineContext fun'-        go fun'-      ParsedFunForall tele fun' -> do-        p_parsedFunForall tele-        setMultilineContext fun'-        go fun'-      ParsedFunQuals ctxs fun' -> do-        p_parsedFunQuals ctxs-        setMultilineContext fun'-        go fun'-      ParsedFunArgs args fun' -> do-        p_parsedFunArgs args-        go fun'-      ParsedFunReturn ret -> do-        p_parsedFunReturn ret--    liftR = Trans.lift . Trans.lift-    initialState = (Nothing, Without #forceMultiline)--    withApplyLeadingDelim f = do-      (leadingDelim, _) <- State.get-      a <- f leadingDelim-      State.modify $ \(_, x) -> (Nothing, x)-      pure a-    applyLeadingDelim = withApplyLeadingDelim (traverse_ liftR)--    setLeadingDelim delim =-      State.modify $ \(_, x) -> (Just delim, x)--    getIsMultiline = do-      (_, forceMultiline) <- State.get-      layout <- liftR getLayout-      pure $ Choice.toBool forceMultiline || layout == MultiLine--    setMultilineContext fun =-      State.modify $ \(x, _) -> (x, Choice.fromBool $ hasDocs fun)--    -- Make everything afterwards occur within a located block, with the-    -- magic of ContT. `item <- setLocated litem; ...` is equivalent to-    -- `located litem $ \item -> ...`.-    setLocated :: (HasLoc ann) => GenLocated ann x -> PrintHsFun x-    setLocated litem = Trans.lift $ Cont.ContT (located litem)--    p_parsedFunSig = do-      if isTrailing (Isn't #argDelim)-        then liftR $ do-          space >> token'dcolon-          if hasDocs fun0 then newline else breakpoint-        else do-          liftR breakpoint-          setLeadingDelim (token'dcolon >> space)--    p_parsedFunForall x@(L _ tele) = do-      void $ setLocated x-      applyLeadingDelim-      vis <--        case tele of-          HsForAllInvis _ bndrs -> do-            liftR $ p_forallBndrsStart p_hsTyVarBndr bndrs-            pure ForAllInvis-          HsForAllVis _ bndrs -> do-            liftR $ p_forallBndrsStart p_hsTyVarBndr bndrs-            pure ForAllVis-      isMultiline <- getIsMultiline-      if isTrailing (Isn't #argDelim) || not isMultiline-        then do-          liftR $ p_forallBndrsEnd (Without #extraSpace) vis-          interArgBreak-        else do-          interArgBreak-          let extraSpace = if isMultiline then With #extraSpace else Without #extraSpace-          setLeadingDelim (p_forallBndrsEnd extraSpace vis)--    p_parsedFunQuals ctxs = do-      -- we only want to set located on the first context-      case ctxs of-        ctx : _ -> void $ setLocated ctx-        _ -> pure ()--      forM_ ctxs $ \(L _ lctx) -> do-        applyLeadingDelim-        liftR $ located lctx (p_hsContext' renderFunItem)-        if isTrailing (Isn't #argDelim)-          then do-            liftR $ space >> token'darrow-            interArgBreak-          else do-            interArgBreak-            setLeadingDelim (token'darrow >> space)--    p_parsedFunArgs args = do-      -- we only want to set located on the first arg-      case args of-        arg : _ -> void $ setLocated arg-        _ -> pure ()+  renderFunReprCtx = p_hsType+  renderFunReprArg = p_hsType+  renderFunReprMult = p_hsType+  renderFunReprRet = p_hsType -      forM_ args $ \(L _ (larg, doc, arrow)) -> do-        let renderArrow = p_arrow (located' renderFunItem) arrow-        withHaddocks (Isn't #end) doc $ do-          withApplyLeadingDelim $ \applyLeadingDelim' ->-            liftR . located larg $ \arg -> do-              traverse_ id applyLeadingDelim'-              renderFunItem arg-          if isTrailing (Is #argDelim)-            then do-              liftR $ space >> renderArrow-              interArgBreak-            else do-              interArgBreak-              setLeadingDelim (renderArrow >> space)+----------------------------------------------------------------------------+-- FunRepr HsConDeclRecField -    p_parsedFunReturn (ret, doc) = do-      void $ setLocated ret-      withHaddocks (Is #end) doc $ do-        applyLeadingDelim-        liftR $ located ret renderFunItem+-- | FunRepr HsConDeclRecField renders a record field type annotation. If the+-- record field has a function type, we want to render it as a function+-- respecting `function-arrows`. For the most part, it behaves like HsTypeSig;+-- however, record fields can have additional syntax not in normal function+-- types, like specifying the multiplicity for the `::` or specifying+-- UNPACK/strictness, so we need to handle this specially.+instance FunRepr (HsConDeclRecField GhcPs) where+  parseFunRepr (L _ HsConDeclRecField {..}) =+    ParsedFunSig+      { sig = cdrf_spec.cdf_multiplicity,+        next = toRecFieldRepr False $ parseFunRepr cdrf_spec.cdf_type+      }+    where+      toRecFieldRepr :: Bool -> ParsedFunRepr (HsType GhcPs) -> ParsedFunRepr (HsConDeclRecField GhcPs)+      toRecFieldRepr seenArg = \case+        ParsedFunSig {} -> error "parseFunRepr @HsType unexpectedly returned ParsedFunSig"+        ParsedFunForall {..} ->+          ParsedFunForall+            { tele,+              next = toRecFieldRepr seenArg next+            }+        ParsedFunQuals {..} ->+          ParsedFunQuals+            { ctxs,+              next = toRecFieldRepr seenArg next+            }+        ParsedFunArg {..} ->+          ParsedFunArg+            { span,+              arg =+                let mUnpack =+                      if not seenArg+                        then Just cdrf_spec.cdf_unpack+                        else Nothing+                 in L (getLoc arg) (mUnpack, arg),+              doc,+              multAnn,+              next = toRecFieldRepr True next+            }+        ParsedFunReturn {..} ->+          ParsedFunReturn+            { ret =+                let mAnn =+                      if not seenArg+                        then Just (cdrf_spec.cdf_unpack, cdrf_spec.cdf_bang)+                        else Nothing+                 in L (getLoc ret) (mAnn, ret),+              doc+            } -    withHaddocks isEnd doc m = do-      isLeadingHaddock <--        liftR $-          getPrinterOpt poHaddockLocSignature <&> \case-            HaddockLocSigAuto ->-              if isTrailing (Is #argDelim) then With #pipe else Without #pipe-            HaddockLocSigLeading ->-              With #pipe-            HaddockLocSigTrailing ->-              Without #pipe+  type FunReprSig (HsConDeclRecField GhcPs) = HsMultAnnOf (LocatedA (HsType GhcPs)) GhcPs+  renderFunReprSig multAnn = do+    space+    p_hsMultAnn (located' p_hsType) multAnn+    space+    token'dcolon -      if Choice.isTrue isLeadingHaddock-        then do-          traverse (liftR . p_hsDoc Pipe (With #endNewline)) doc *> m-        else do-          let (pre, endNewline) =-                if Choice.isTrue isEnd-                  then (when (isJust doc) (liftR newline), Without #endNewline)-                  else (pure (), With #endNewline)-          m <* pre <* traverse (liftR . p_hsDoc Caret endNewline) doc+  type FunReprCtx (HsConDeclRecField GhcPs) = HsType GhcPs+  renderFunReprCtx = p_hsType -    interArgBreak = do-      isMultiline <- getIsMultiline-      liftR $ if isMultiline then newline else breakpoint+  -- Invariant: SrcUnpackedness should only be set for the first arg+  type FunReprArg (HsConDeclRecField GhcPs) = (Maybe SrcUnpackedness, LocatedA (HsType GhcPs))+  renderFunReprArg (mUnpacked, ty) =+    p_hsConDeclField+      CDF+        { cdf_ext = error "unused",+          cdf_unpack = fromMaybe NoSrcUnpack mUnpacked,+          cdf_bang = NoSrcStrict,+          cdf_multiplicity = error "unused",+          cdf_type = ty,+          cdf_doc = error "unused"+        } -    hasDocs = \case-      ParsedFunSig fun -> hasDocs fun-      ParsedFunForall _ fun -> hasDocs fun-      ParsedFunQuals _ fun -> hasDocs fun-      ParsedFunArgs args fun -> or [isJust doc | L _ (_, doc, _) <- args] || hasDocs fun-      ParsedFunReturn (_, doc) -> isJust doc+  type FunReprMult (HsConDeclRecField GhcPs) = HsType GhcPs+  renderFunReprMult = p_hsType -    isTrailing isArgDelim =-      case arrowsStyle of-        TrailingArrows -> True-        LeadingArgsArrows -> not $ Choice.isTrue isArgDelim-        LeadingArrows -> False+  -- Invariant: SrcUnpackedness/SrcStrictness should only be set if there are+  -- no args+  type FunReprRet (HsConDeclRecField GhcPs) = (Maybe (SrcUnpackedness, SrcStrictness), LocatedA (HsType GhcPs))+  renderFunReprRet (mAnn, ty) =+    p_hsConDeclField+      CDF+        { cdf_ext = error "unused",+          cdf_unpack = unpack,+          cdf_bang = strictness,+          cdf_multiplicity = error "unused",+          cdf_type = ty,+          cdf_doc = error "unused"+        }+    where+      (unpack, strictness) = fromMaybe (NoSrcUnpack, NoSrcStrict) mAnn  ---------------------------------------------------------------------------- -- Conversion functions

@@ -0,0 +1,493 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-partial-fields #-}++-- | A Fourmolu-specific module for rendering function-like type signatures.+module Ormolu.Printer.Meat.Type.Function+  ( -- * PrintHsFun+    PrintHsFun,+    MonadR,++    -- * ParsedFunRepr+    ParsedFunRepr,+    ParsedFunRepr' (..),+    FunRepr (..),+    p_hsFun,+    p_hsFunParsed,++    -- * forall+    ForAllVisibility (..),+    p_forallBndrs,++    -- * TyVarBndr+    p_hsTyVarBndr,++    -- * Contexts+    p_hsContext',++    -- * Haddocks+    withHaddocks,+  )+where++import Control.Monad (forM_, void, when)+import Control.Monad.Cont qualified as Cont+import Control.Monad.State qualified as State+import Control.Monad.Trans qualified as Trans+import Data.Choice (Choice, pattern Is, pattern Isn't, pattern With, pattern Without)+import Data.Choice qualified as Choice+import Data.Foldable (traverse_)+import Data.Functor ((<&>))+import Data.List (sortOn)+import Data.Maybe (isJust)+import GHC.Hs+import GHC.Types.SrcLoc (GenLocated (..))+import GHC.Types.Var (Specificity (..))+import GHC.Utils.Outputable (Outputable)+import Ormolu.Config+import Ormolu.Printer.Combinators+import Ormolu.Printer.Meat.Common (p_arrow, p_hsDoc, p_rdrName)+import Ormolu.Utils (showOutputable)+import Prelude hiding (span)++{----- PrintHsFun -----}++newtype PrintHsFun a = PrintHsFun (State.StateT PrintHsFunState (Cont.ContT () R) a)+  deriving newtype (Functor, Applicative, Monad)++data PrintHsFunState = PrintHsFunState+  { -- | The leading delimiter to output at the next line+    leadingDelim :: Maybe (R ()),+    forceMultiline :: Bool,+    -- | Whether we're currently printing args+    inArgList :: Bool+  }++runPrintHsFun :: PrintHsFun () -> R ()+runPrintHsFun (PrintHsFun m) = Cont.evalContT . (`State.evalStateT` initialState) $ m+  where+    initialState =+      PrintHsFunState+        { leadingDelim = Nothing,+          forceMultiline = False,+          inArgList = False+        }++class (Monad m) => MonadR m where+  liftR :: R a -> m a++instance MonadR R where+  liftR = id++instance MonadR PrintHsFun where+  liftR = PrintHsFun . Trans.lift . Trans.lift++withApplyLeadingDelim :: (Maybe (R ()) -> PrintHsFun a) -> PrintHsFun a+withApplyLeadingDelim f = do+  state <- PrintHsFun State.get+  a <- f state.leadingDelim+  PrintHsFun . State.put $ state {leadingDelim = Nothing}+  pure a++applyLeadingDelim :: PrintHsFun ()+applyLeadingDelim = withApplyLeadingDelim (traverse_ liftR)++setLeadingDelim :: R () -> PrintHsFun ()+setLeadingDelim delim =+  PrintHsFun . State.modify $ \state -> state {leadingDelim = Just delim}++getIsMultiline :: PrintHsFun Bool+getIsMultiline = do+  state <- PrintHsFun State.get+  layout <- liftR getLayout+  pure $ state.forceMultiline || layout == MultiLine++setMultilineContext :: ParsedFunRepr' sig ctx arg mult ret -> PrintHsFun ()+setMultilineContext fun =+  PrintHsFun . State.modify $ \state -> state {forceMultiline = hasDocs fun}++getIsTrailing :: (MonadR m) => m (Choice "argDelim" -> Bool)+getIsTrailing = do+  arrowsStyle <- liftR $ getPrinterOpt poFunctionArrows+  pure $ \isArgDelim ->+    case arrowsStyle of+      TrailingArrows -> True+      LeadingArgsArrows -> not $ Choice.isTrue isArgDelim+      LeadingArrows -> False++getInArgList :: PrintHsFun Bool+getInArgList = PrintHsFun . State.gets $ (.inArgList)++setInArgList :: Bool -> PrintHsFun ()+setInArgList x = PrintHsFun . State.modify $ \state -> state {inArgList = x}++-- Make everything afterwards occur within a located block, with the+-- magic of ContT. `item <- setLocated litem; ...` is equivalent to+-- `located litem $ \item -> ...`.+setLocated :: (HasLoc ann) => GenLocated ann x -> PrintHsFun x+setLocated litem = PrintHsFun . Trans.lift $ Cont.ContT (located litem)++setLocated_ :: (HasLoc ann) => GenLocated ann x -> PrintHsFun ()+setLocated_ = void . setLocated++{----- ParsedFunRepr -----}++type ParsedFunRepr a =+  ParsedFunRepr'+    (FunReprSig a)+    (FunReprCtx a)+    (FunReprArg a)+    (FunReprMult a)+    (FunReprRet a)++-- | The parsed representation of a function+data ParsedFunRepr' sig ctx arg mult ret+  = -- | The "::" delimiter. Invariant: must be first.+    ParsedFunSig+      { sig :: sig,+        next :: ParsedFunRepr' sig ctx arg mult ret+      }+  | -- | The "forall a b." or "forall a b ->" construct.+    ParsedFunForall+      { tele :: LocatedA (HsForAllTelescope GhcPs),+        next :: ParsedFunRepr' sig ctx arg mult ret+      }+  | -- | The "(A, B) =>" construct.+    ParsedFunQuals+      { ctxs :: [LocatedA (LocatedC [LocatedA ctx])],+        next :: ParsedFunRepr' sig ctx arg mult ret+      }+  | ParsedFunArg+      { span :: SrcSpanAnnA,+        arg :: LocatedA arg,+        doc :: Maybe (LHsDoc GhcPs),+        multAnn :: HsMultAnnOf (LocatedA mult) GhcPs,+        next :: ParsedFunRepr' sig ctx arg mult ret+      }+  | ParsedFunReturn+      { ret :: LocatedA ret,+        doc :: Maybe (LHsDoc GhcPs)+      }++class+  ( Anno (FunReprCtx a) ~ SrcSpanAnnA,+    Outputable (FunReprCtx a)+  ) =>+  FunRepr a+  where+  parseFunRepr :: LocatedA a -> ParsedFunRepr a++  type FunReprSig a+  type FunReprSig a = ()+  renderFunReprSig :: FunReprSig a -> R ()+  default renderFunReprSig :: (FunReprSig a ~ ()) => FunReprSig a -> R ()+  renderFunReprSig () = space *> token'dcolon++  type FunReprCtx a+  type FunReprCtx a = a+  renderFunReprCtx :: FunReprCtx a -> R ()++  type FunReprArg a+  type FunReprArg a = a+  renderFunReprArg :: FunReprArg a -> R ()++  type FunReprMult a+  type FunReprMult a = a+  renderFunReprMult :: FunReprMult a -> R ()++  type FunReprRet a+  type FunReprRet a = a+  renderFunReprRet :: FunReprRet a -> R ()++-- | Some functions rely on HsType having a FunRepr instance, but the instance+-- can't be implemented here, since p_hsType is implemented in Type.hs, which+-- would cause a circular dependency. So we'll add it as an explicit constraint+-- and the call-site should bring the FunRepr instance for HsType in scope.+type FunReprHsType =+  ( FunRepr (HsType GhcPs),+    FunReprSig (HsType GhcPs) ~ (),+    FunReprCtx (HsType GhcPs) ~ HsType GhcPs,+    FunReprArg (HsType GhcPs) ~ HsType GhcPs,+    FunReprMult (HsType GhcPs) ~ HsType GhcPs,+    FunReprRet (HsType GhcPs) ~ HsType GhcPs+  )++hasDocs :: ParsedFunRepr' ig ctx arg mult ret -> Bool+hasDocs = \case+  ParsedFunSig {next} -> hasDocs next+  ParsedFunForall {next} -> hasDocs next+  ParsedFunQuals {next} -> hasDocs next+  ParsedFunArg {doc, next} -> isJust doc || hasDocs next+  ParsedFunReturn {doc} -> isJust doc++{----- Rendering ParsedFunRepr -----}++-- | For implementing function-arrows and related configuration, we'll collect+-- all the components of the function type first, then render as a block instead+-- of rendering each part independently, which will let us track local state+-- within a function type.+--+-- This function should be passed the first function-related construct we find;+-- see FunRepr for more details.+p_hsFun :: forall a. (FunRepr a, FunReprHsType) => a -> R ()+p_hsFun = p_hsFunParsed @a . parseFunRepr . L (noAnn @SrcSpanAnnA)++p_hsFunParsed :: forall a. (FunRepr a, FunReprHsType) => ParsedFunRepr a -> R ()+p_hsFunParsed = runPrintHsFun . p_hsFunParsed' @a++p_hsFunParsed' :: forall a. (FunRepr a, FunReprHsType) => ParsedFunRepr a -> PrintHsFun ()+p_hsFunParsed' = \case+  ParsedFunSig {sig, next} -> do+    -- Should only happen at the very beginning, if at all+    p_parsedFunSig @a sig next+    setMultilineContext next+    p_hsFunParsed' @a next+  ParsedFunForall {tele, next} -> do+    p_parsedFunForall tele+    setMultilineContext next+    p_hsFunParsed' @a next+  ParsedFunQuals {ctxs, next} -> do+    p_parsedFunQuals @a ctxs+    setMultilineContext next+    p_hsFunParsed' @a next+  ParsedFunArg {span, arg, doc, multAnn, next} -> do+    p_parsedFunArg @a span arg doc multAnn+    case next of+      ParsedFunArg {} -> pure ()+      _ -> do+        -- Don't reset multiline context within args; all args should be on+        -- one line together, or all on separate lines+        setMultilineContext next+        -- Reset inArgList, needed if there are multiple arg lists in one+        -- function type (e.g. `a -> Show a => b -> c`)+        setInArgList False+    p_hsFunParsed' @a next+  ParsedFunReturn {ret, doc} -> do+    p_parsedFunReturn @a ret doc++p_parsedFunSig :: forall a. (FunRepr a) => FunReprSig a -> ParsedFunRepr a -> PrintHsFun ()+p_parsedFunSig sig fun = do+  isTrailing <- getIsTrailing+  if isTrailing (Isn't #argDelim)+    then liftR $ do+      renderFunReprSig @a sig+      if hasDocs fun then newline else breakpoint+    else do+      liftR breakpoint+      setLeadingDelim (token'dcolon >> space)++p_parsedFunForall :: (FunReprHsType) => LocatedA (HsForAllTelescope GhcPs) -> PrintHsFun ()+p_parsedFunForall x@(L _ tele) = do+  setLocated_ x+  applyLeadingDelim+  vis <-+    case tele of+      HsForAllInvis _ bndrs -> do+        liftR $ p_forallBndrsStart p_hsTyVarBndr bndrs+        pure ForAllInvis+      HsForAllVis _ bndrs -> do+        liftR $ p_forallBndrsStart p_hsTyVarBndr bndrs+        pure ForAllVis++  isTrailing <- getIsTrailing+  isMultiline <- getIsMultiline+  if isTrailing (Isn't #argDelim) || not isMultiline+    then do+      liftR $ p_forallBndrsEnd (Without #extraSpace) vis+      interArgBreak+    else do+      interArgBreak+      let extraSpace = if isMultiline then With #extraSpace else Without #extraSpace+      setLeadingDelim (p_forallBndrsEnd extraSpace vis)++p_parsedFunQuals :: forall a. (FunRepr a) => [LocatedA (LocatedC [LocatedA (FunReprCtx a)])] -> PrintHsFun ()+p_parsedFunQuals ctxs = do+  isTrailing <- getIsTrailing+  -- we only want to set located on the first context+  case ctxs of+    ctx : _ -> setLocated_ ctx+    _ -> pure ()++  forM_ ctxs $ \(L _ lctx) -> do+    applyLeadingDelim+    liftR $ located lctx (p_hsContext' (renderFunReprCtx @a))+    if isTrailing (Isn't #argDelim)+      then do+        liftR $ space >> token'darrow+        interArgBreak+      else do+        interArgBreak+        setLeadingDelim (token'darrow >> space)++p_parsedFunArg ::+  forall a.+  (FunRepr a) =>+  SrcSpanAnnA ->+  LocatedA (FunReprArg a) ->+  Maybe (LHsDoc GhcPs) ->+  HsMultAnnOf (LocatedA (FunReprMult a)) GhcPs ->+  PrintHsFun ()+p_parsedFunArg span item doc multAnn = do+  isTrailing <- getIsTrailing++  -- We only want to set located on the first arg+  inArgList <- getInArgList+  when (not inArgList) $ do+    setLocated_ (L span item)+    setInArgList True++  let renderArrow = p_arrow (located' (renderFunReprMult @a)) multAnn+  withHaddocks (Isn't #end) doc $ do+    withApplyLeadingDelim $ \applyLeadingDelim' ->+      liftR . located item $ \arg -> do+        traverse_ id applyLeadingDelim'+        renderFunReprArg @a arg+    if isTrailing (Is #argDelim)+      then do+        liftR $ space >> renderArrow+        interArgBreak+      else do+        interArgBreak+        setLeadingDelim (renderArrow >> space)++p_parsedFunReturn ::+  forall a.+  (FunRepr a) =>+  LocatedA (FunReprRet a) ->+  Maybe (LHsDoc GhcPs) ->+  PrintHsFun ()+p_parsedFunReturn item doc = do+  setLocated_ item+  withHaddocks (Is #end) doc $ do+    applyLeadingDelim+    liftR $ located item (renderFunReprRet @a)++{----- forall -----}++data ForAllVisibility = ForAllInvis | ForAllVis++-- | Render several @forall@-ed variables.+p_forallBndrs ::+  (HasLoc l) =>+  ForAllVisibility ->+  (a -> R ()) ->+  [GenLocated l a] ->+  R ()+p_forallBndrs vis p tyvars = do+  p_forallBndrsStart p tyvars+  p_forallBndrsEnd (Without #extraSpace) vis++p_forallBndrsStart :: (HasLoc l) => (a -> R ()) -> [GenLocated l a] -> R ()+p_forallBndrsStart _ [] = token'forall+p_forallBndrsStart p tyvars = do+  switchLayout (locA <$> tyvars) $ do+    token'forall+    breakpoint+    inci $ do+      sitcc $ sep breakpoint (sitcc . located' p) tyvars++p_forallBndrsEnd :: Choice "extraSpace" -> ForAllVisibility -> R ()+p_forallBndrsEnd extraSpace = \case+  ForAllInvis -> txt dot >> space+  ForAllVis -> space >> token'rarrow+  where+    dot = if Choice.isTrue extraSpace then " ." else "."++{----- HsTyVarBndr -----}++class IsTyVarBndrFlag flag where+  isInferred :: flag -> Bool+  p_tyVarBndrFlag :: flag -> R ()+  p_tyVarBndrFlag _ = pure ()++instance IsTyVarBndrFlag () where+  isInferred () = False++instance IsTyVarBndrFlag Specificity where+  isInferred = \case+    InferredSpec -> True+    SpecifiedSpec -> False++instance IsTyVarBndrFlag (HsBndrVis GhcPs) where+  isInferred _ = False+  p_tyVarBndrFlag = \case+    HsBndrRequired NoExtField -> pure ()+    HsBndrInvisible _ -> txt "@"++p_hsTyVarBndr ::+  (IsTyVarBndrFlag flag, FunReprHsType) =>+  HsTyVarBndr flag GhcPs -> R ()+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 -> inci $ do+        p_hsFunParsed @(HsType GhcPs) $+          ParsedFunSig+            { sig = (),+              next = parseFunRepr k+            }+      HsBndrNoKind _ -> pure ()++{----- Contexts -----}++p_hsContext' ::+  (Outputable (GenLocated (Anno a) a), HasLoc (Anno a)) =>+  (a -> R ()) ->+  [XRec GhcPs a] ->+  R ()+p_hsContext' f = \case+  [] -> txt "()"+  [x] -> located x f+  xs -> do+    shouldSort <- getPrinterOpt poSortConstraints+    let sort = if shouldSort then sortOn showOutputable else id+    parens N $ sep commaDel (sitcc . located' f) (sort xs)++{----- Helpers -----}++withHaddocks :: (MonadR m) => Choice "end" -> Maybe (LHsDoc GhcPs) -> m a -> m a+withHaddocks isEnd doc m = do+  isTrailing <- getIsTrailing+  isLeadingHaddock <-+    liftR $+      getPrinterOpt poHaddockLocSignature <&> \case+        HaddockLocSigAuto ->+          if isTrailing (Is #argDelim) then With #pipe else Without #pipe+        HaddockLocSigLeading ->+          With #pipe+        HaddockLocSigTrailing ->+          Without #pipe++  if Choice.isTrue isLeadingHaddock+    then do+      traverse (liftR . p_hsDoc Pipe (With #endNewline)) doc *> m+    else do+      let (pre, endNewline) =+            if Choice.isTrue isEnd+              then (when (isJust doc) (liftR newline), Without #endNewline)+              else (pure (), With #endNewline)+      m <* pre <* traverse (liftR . p_hsDoc Caret endNewline) doc++interArgBreak :: PrintHsFun ()+interArgBreak = do+  isMultiline <- getIsMultiline+  liftR $ if isMultiline then newline else breakpoint

@@ -73,14 +73,14 @@  -- | Split and normalize a doc string. The result is a list of lines that -- make up the comment.-splitDocString :: Bool -> HsDocString -> [Text]-splitDocString shouldEscapeCommentBraces docStr =+splitDocString :: HsDocString -> [Text]+splitDocString docStr =   case r of     [] -> [""]     _ -> r   where     r =-      fmap (escapeLeadingDollar . escapeCommentBraces)+      fmap escapeLeadingDollar         . dropPaddingSpace'         . dropWhileEnd T.null         . fmap (T.stripEnd . T.pack)@@ -117,10 +117,6 @@            in if leadingSpace x                 then dropSpace <$> xs                 else xs-    escapeCommentBraces =-      if shouldEscapeCommentBraces-        then T.replace "{-" "{\\-" . T.replace "-}" "-\\}"-        else id  -- | Increment line number in a 'SrcSpan'. incSpanLine :: Int -> SrcSpan -> SrcSpan

@@ -1,6 +1,7 @@ module Ormolu.Utils.Glob   ( Glob,     mkGlob,+    matchAllGlob,     matchesGlob,   ) where@@ -31,6 +32,9 @@       t ->         let (m, t') = break (== '*') t          in MatchExactly m : parsePart t'++matchAllGlob :: Glob+matchAllGlob = Glob [DoubleWildcard]  matchesGlob :: String -> Glob -> Bool matchesGlob s (Glob ps) = s `matchesGlobParts` ps

@@ -13,6 +13,7 @@ import Control.Monad (forM_, when) import Data.Algorithm.DiffContext qualified as Diff import Data.Char (isSpace)+import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (isJust) import Data.Set qualified as S@@ -26,7 +27,7 @@ import Ormolu.Config import Ormolu.Exception (OrmoluException, printOrmoluException) import Ormolu.Terminal (runTerm)-import Ormolu.Utils.Glob (mkGlob)+import Ormolu.Utils.Glob (matchAllGlob, mkGlob) import Path   ( File,     Path,@@ -111,6 +112,24 @@           checkIdempotence = True         },       TestGroup+        { label = "record-style",+          isMulti = False,+          testCases = liftA2 (,) allOptions allOptions,+          updateConfig = \(recordStyle, commaStyle) opts ->+            opts+              { poRecordStyle = pure recordStyle,+                -- Test record style in combination with comma style+                poCommaStyle = pure commaStyle,+                -- Makes the indentation more visible+                poIndentation = pure 4+              },+          showTestCase = \(recordStyle, commaStyle) ->+            [ renderPrinterOpt recordStyle,+              renderPrinterOpt commaStyle+            ],+          checkIdempotence = True+        },+      TestGroup         { label = "import-export",           isMulti = True,           testCases = allOptions,@@ -130,62 +149,7 @@               ImportGroupByQualified,               ImportGroupByScope,               ImportGroupByScopeThenQualified,-              ImportGroupCustom . NonEmpty.fromList $-                [ ImportGroup-                    { igName = Nothing,-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchGlob (mkGlob "Data.Text"),-                                igrQualifiedMatcher = MatchBothQualifiedAndUnqualified,-                                igrPriority = defaultImportRulePriority-                              }-                          ]-                    },-                  ImportGroup-                    { igName = Nothing,-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchAllModules,-                                igrQualifiedMatcher = MatchBothQualifiedAndUnqualified,-                                igrPriority = ImportRulePriority 100-                              }-                          ]-                    },-                  ImportGroup-                    { igName = Nothing,-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchGlob (mkGlob "SomeInternal.**"),-                                igrQualifiedMatcher = MatchQualifiedOnly,-                                igrPriority = defaultImportRulePriority-                              },-                            ImportGroupRule-                              { igrModuleMatcher = MatchGlob (mkGlob "Unknown.**"),-                                igrQualifiedMatcher = MatchUnqualifiedOnly,-                                igrPriority = defaultImportRulePriority-                              }-                          ]-                    },-                  ImportGroup-                    { igName = Nothing,-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchLocalModules,-                                igrQualifiedMatcher = MatchUnqualifiedOnly,-                                igrPriority = defaultImportRulePriority-                              },-                            ImportGroupRule-                              { igrModuleMatcher = MatchAllModules,-                                igrQualifiedMatcher = MatchQualifiedOnly,-                                igrPriority = defaultImportRulePriority-                              }-                          ]-                    }-                ]+              ImportGroupCustom importGroupCustomRules             ],           updateConfig = \igs opts ->             opts@@ -525,3 +489,58 @@ spanEnd f xs =   let xs' = reverse xs    in (reverse $ dropWhile f xs', reverse $ takeWhile f xs')++importGroupCustomRules :: NonEmpty ImportGroup+importGroupCustomRules =+  NonEmpty.fromList+    [ defaultImportGroup . NonEmpty.fromList $+        [ defaultImportGroupRule+            { igrImportListMatcher = MatchWholeModuleImport,+              igrQualifiedMatcher = MatchUnqualifiedOnly+            }+        ],+      defaultImportGroup . NonEmpty.fromList $+        [ defaultImportGroupRule {igrGlob = mkGlob "Data.Text"}+        ],+      defaultImportGroup . NonEmpty.fromList $+        [ defaultImportGroupRule+            { igrPriority = ImportRulePriority 100+            }+        ],+      defaultImportGroup . NonEmpty.fromList $+        [ defaultImportGroupRule+            { igrGlob = mkGlob "SomeInternal.**",+              igrQualifiedMatcher = MatchQualifiedOnly+            },+          defaultImportGroupRule+            { igrGlob = mkGlob "Unknown.**",+              igrQualifiedMatcher = MatchUnqualifiedOnly+            }+        ],+      defaultImportGroup . NonEmpty.fromList $+        [ defaultImportGroupRule+            { igrQualifiedMatcher = MatchUnqualifiedOnly,+              igrScopeMatcher = MatchLocalModules+            },+          defaultImportGroupRule+            { igrQualifiedMatcher = MatchQualifiedOnly+            }+        ]+    ]+  where+    defaultImportGroup :: NonEmpty ImportGroupRule -> ImportGroup+    defaultImportGroup rules =+      ImportGroup+        { igName = Nothing,+          igRules = rules+        }++    defaultImportGroupRule :: ImportGroupRule+    defaultImportGroupRule =+      ImportGroupRule+        { igrGlob = matchAllGlob,+          igrImportListMatcher = MatchAnyImportDeclaration,+          igrQualifiedMatcher = MatchBothQualifiedAndUnqualified,+          igrScopeMatcher = MatchAllModules,+          igrPriority = defaultImportRulePriority+        }

@@ -3,14 +3,16 @@ -- | Tests for Fourmolu file configuration. module Ormolu.ConfigSpec (spec) where +import Control.Monad ((>=>)) import Data.ByteString.Char8 qualified as Char8 import Data.List (isInfixOf)+import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map import Data.Yaml qualified as Yaml-import Ormolu.Config (FourmoluConfig (..), ImportGroup (..), ImportGroupRule (..), ImportGrouping (..), ImportModuleMatcher (..), ImportRulePriority (ImportRulePriority), PrinterOpts (..), QualifiedImportMatcher (MatchBothQualifiedAndUnqualified, MatchQualifiedOnly, MatchUnqualifiedOnly), defaultImportRulePriority, matchAllRulePriority, resolvePrinterOpts)+import Ormolu.Config import Ormolu.Fixity (ModuleReexports (..))-import Ormolu.Utils.Glob (mkGlob)+import Ormolu.Utils.Glob (matchAllGlob, mkGlob) import Test.Hspec  spec :: Spec@@ -71,165 +73,84 @@             [ "import-grouping:",               "  - name: Some name",               "    rules:",-              "      - match: all"+              "      - {}"             ]         let actualStrategy = poImportGrouping (cfgFilePrinterOpts config)             expectedRules =               NonEmpty.fromList                 [ ImportGroup                     { igName = Just "Some name",-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchAllModules,-                                igrQualifiedMatcher = MatchBothQualifiedAndUnqualified,-                                igrPriority = matchAllRulePriority-                              }-                          ]-                    }-                ]-        actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules)-      it "enables the 'qualified' rule option" $ do-        config <--          Yaml.decodeThrow . Char8.pack . unlines $-            [ "import-grouping:",-              "  - rules:",-              "      - glob: \"**\"",-              "        qualified: yes"-            ]-        let actualStrategy = poImportGrouping (cfgFilePrinterOpts config)-            expectedRules =-              NonEmpty.fromList-                [ ImportGroup-                    { igName = Nothing,-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchGlob (mkGlob "**"),-                                igrQualifiedMatcher = MatchQualifiedOnly,-                                igrPriority = defaultImportRulePriority-                              }-                          ]-                    }-                ]-        actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules)-      it "disables the 'qualified' rule option" $ do-        config <--          Yaml.decodeThrow . Char8.pack . unlines $-            [ "import-grouping:",-              "  - rules:",-              "      - glob: \"**\"",-              "        qualified: no"-            ]-        let actualStrategy = poImportGrouping (cfgFilePrinterOpts config)-            expectedRules =-              NonEmpty.fromList-                [ ImportGroup-                    { igName = Nothing,-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchGlob (mkGlob "**"),-                                igrQualifiedMatcher = MatchUnqualifiedOnly,-                                igrPriority = defaultImportRulePriority-                              }-                          ]-                    }-                ]-        actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules)-      it "decodes the 'priority' rule option" $ do-        config <--          Yaml.decodeThrow . Char8.pack . unlines $-            [ "import-grouping:",-              "  - rules:",-              "      - match: all",-              "        priority: 55"-            ]-        let actualStrategy = poImportGrouping (cfgFilePrinterOpts config)-            expectedRules =-              NonEmpty.fromList-                [ ImportGroup-                    { igName = Nothing,-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchAllModules,-                                igrQualifiedMatcher = MatchBothQualifiedAndUnqualified,-                                igrPriority = ImportRulePriority 55-                              }-                          ]-                    }-                ]-        actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules)-      it "parses a 'glob' rule" $ do-        config <--          Yaml.decodeThrow . Char8.pack . unlines $-            [ "import-grouping:",-              "  - rules:",-              "      - glob: Data.Text.**"-            ]-        let actualStrategy = poImportGrouping (cfgFilePrinterOpts config)-            expectedRules =-              NonEmpty.fromList-                [ ImportGroup-                    { igName = Nothing,-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchGlob (mkGlob "Data.Text.**"),-                                igrQualifiedMatcher = MatchBothQualifiedAndUnqualified,-                                igrPriority = defaultImportRulePriority-                              }-                          ]-                    }-                ]-        actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules)-      it "parses a 'match' rule for local modules" $ do-        config <--          Yaml.decodeThrow . Char8.pack . unlines $-            [ "import-grouping:",-              "  - rules:",-              "      - match: local-modules"-            ]-        let actualStrategy = poImportGrouping (cfgFilePrinterOpts config)-            expectedRules =-              NonEmpty.fromList-                [ ImportGroup-                    { igName = Nothing,-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchLocalModules,-                                igrQualifiedMatcher = MatchBothQualifiedAndUnqualified,-                                igrPriority = defaultImportRulePriority-                              }-                          ]-                    }-                ]-        actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules)-      it "parses a 'match' rule for all modules" $ do-        config <--          Yaml.decodeThrow . Char8.pack . unlines $-            [ "import-grouping:",-              "  - rules:",-              "      - match: all"-            ]-        let actualStrategy = poImportGrouping (cfgFilePrinterOpts config)-            expectedRules =-              NonEmpty.fromList-                [ ImportGroup-                    { igName = Nothing,-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchAllModules,-                                igrQualifiedMatcher = MatchBothQualifiedAndUnqualified,-                                igrPriority = matchAllRulePriority-                              }-                          ]+                      igRules = NonEmpty.fromList [defaultImportGroupRule]                     }                 ]         actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules)++      let checkRule :: (HasCallStack) => String -> String -> ImportGroupRule -> SpecWith ()+          checkRule desc yamlRuleConfig expectedRuleConfig =+            it ("parses " ++ desc) $ do+              let yamlConfig =+                    unlines+                      [ "import-grouping:",+                        "  - rules:",+                        "      - " ++ yamlRuleConfig+                      ]++                  downCustomRules (ImportGroupCustom customRules) = Just customRules+                  downCustomRules _ = Nothing+                  downSingleton (a :| []) = Just a+                  downSingleton _ = Nothing+                  accessTestedRule = downCustomRules >=> downSingleton >=> downSingleton . igRules++              config <- Yaml.decodeThrow (Char8.pack yamlConfig)++              let actualStrategy = poImportGrouping (cfgFilePrinterOpts config)+              case actualStrategy >>= accessTestedRule of+                Nothing -> expectationFailure "A single tested rule change was expected"+                Just actualRule -> actualRule `shouldBe` expectedRuleConfig++          checkRuleAttribute :: (HasCallStack) => String -> String -> (ImportGroupRule -> ImportGroupRule) -> SpecWith ()+          checkRuleAttribute desc yamlRuleConfig applyExpectedChange = do+            let baseArbitraryYamlConfig = "glob: \"**\""+                yamlConfig = "{ " ++ baseArbitraryYamlConfig ++ ", " ++ yamlRuleConfig ++ "}"++                baseArbitraryConfig = defaultImportGroupRule {igrGlob = matchAllGlob}+                expectedRuleConfig = applyExpectedChange baseArbitraryConfig+            checkRule+              ("rules with the " ++ desc ++ " rule option")+              yamlConfig+              expectedRuleConfig++      checkRule "the 'glob' rule" "glob: Data.Text.**" defaultImportGroupRule {igrGlob = mkGlob "Data.Text.**"}+      checkRule "the default 'glob' rule (match all modules)" "{}" defaultImportGroupRule {igrGlob = mkGlob "**"}++      checkRuleAttribute "'any' import list" "import-list: any" $ \config -> config {igrImportListMatcher = MatchAnyImportDeclaration}+      checkRuleAttribute "'explicit' import list" "import-list: explicit" $ \config -> config {igrImportListMatcher = MatchExplicitImportList}+      checkRuleAttribute "'hiding' import list" "import-list: hiding" $ \config -> config {igrImportListMatcher = MatchHidingImportClause}+      checkRuleAttribute "'none' import list" "import-list: none" $ \config -> config {igrImportListMatcher = MatchWholeModuleImport}+      checkRuleAttribute "default import list" "" $ \config -> config {igrImportListMatcher = MatchAnyImportDeclaration}++      checkRuleAttribute "'qualified: yes'" "qualified: yes" $ \config -> config {igrQualifiedMatcher = MatchQualifiedOnly}+      checkRuleAttribute "'qualified: no'" "qualified: no" $ \config -> config {igrQualifiedMatcher = MatchUnqualifiedOnly}+      checkRuleAttribute "default 'qualified' (match any)" "" $ \config -> config {igrQualifiedMatcher = MatchBothQualifiedAndUnqualified}++      checkRuleAttribute "'scope: any'" "scope: any" $ \config -> config {igrScopeMatcher = MatchAllModules}+      checkRuleAttribute "'scope: local'" "scope: local" $ \config -> config {igrScopeMatcher = MatchLocalModules}+      checkRuleAttribute "'scope: external'" "scope: external" $ \config -> config {igrScopeMatcher = MatchExternalModules}+      checkRuleAttribute "default 'scope' (match all)" "" $ \config -> config {igrScopeMatcher = MatchAllModules}++      checkRuleAttribute "'priority' (55 priority example)" "priority: 55" $ \config -> config {igrPriority = ImportRulePriority 55}+      checkRuleAttribute "'priority' (80 priority example)" "priority: 80" $ \config -> config {igrPriority = ImportRulePriority 80}+      checkRuleAttribute "default 'priority' (50)" "" $ \config -> config {igrPriority = ImportRulePriority 50}++      checkRule+        "the legacy 'match' rule for all modules (with a 100 priority)"+        "match: all"+        defaultImportGroupRule {igrGlob = mkGlob "**", igrScopeMatcher = MatchAllModules, igrPriority = ImportRulePriority 100}+      checkRule+        "the legacy 'match' rule for local modules"+        "match: local-modules"+        defaultImportGroupRule {igrGlob = mkGlob "**", igrScopeMatcher = MatchLocalModules, igrPriority = ImportRulePriority 60}+       it "parses multiple group configurations and rules in their order of appearance in the configuration" $ do         config <-           Yaml.decodeThrow . Char8.pack . unlines $@@ -240,7 +161,6 @@               "  - name: The rest",               "    rules:",               "      - match: all",-              "        priority: 100",               "  - name: My internals and monads unqualified",               "    rules:",               "      - match: local-modules",@@ -262,68 +182,31 @@               NonEmpty.fromList                 [ ImportGroup                     { igName = Just "Text modules",-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchGlob (mkGlob "Data.Text"),-                                igrQualifiedMatcher = MatchBothQualifiedAndUnqualified,-                                igrPriority = defaultImportRulePriority-                              }-                          ]+                      igRules = NonEmpty.fromList [defaultImportGroupRule {igrGlob = mkGlob "Data.Text"}]                     },                   ImportGroup                     { igName = Just "The rest",-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchAllModules,-                                igrQualifiedMatcher = MatchBothQualifiedAndUnqualified,-                                igrPriority = ImportRulePriority 100-                              }-                          ]+                      igRules = NonEmpty.fromList [defaultImportGroupRule {igrGlob = matchAllGlob, igrPriority = ImportRulePriority 100}]                     },                   ImportGroup                     { igName = Just "My internals and monads unqualified",                       igRules =                         NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchLocalModules,-                                igrQualifiedMatcher = MatchUnqualifiedOnly,-                                igrPriority = defaultImportRulePriority-                              },-                            ImportGroupRule-                              { igrModuleMatcher = MatchGlob (mkGlob "Control.Monad"),-                                igrQualifiedMatcher = MatchUnqualifiedOnly,-                                igrPriority = defaultImportRulePriority-                              }+                          [ defaultImportGroupRule {igrQualifiedMatcher = MatchUnqualifiedOnly, igrScopeMatcher = MatchLocalModules, igrPriority = ImportRulePriority 60},+                            defaultImportGroupRule {igrGlob = mkGlob "Control.Monad", igrQualifiedMatcher = MatchUnqualifiedOnly}                           ]                     },                   ImportGroup                     { igName = Just "My internals and monads qualified",                       igRules =                         NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchLocalModules,-                                igrQualifiedMatcher = MatchQualifiedOnly,-                                igrPriority = defaultImportRulePriority-                              },-                            ImportGroupRule-                              { igrModuleMatcher = MatchGlob (mkGlob "Control.Monad"),-                                igrQualifiedMatcher = MatchQualifiedOnly,-                                igrPriority = defaultImportRulePriority-                              }+                          [ defaultImportGroupRule {igrQualifiedMatcher = MatchQualifiedOnly, igrScopeMatcher = MatchLocalModules, igrPriority = ImportRulePriority 60},+                            defaultImportGroupRule {igrGlob = mkGlob "Control.Monad", igrQualifiedMatcher = MatchQualifiedOnly}                           ]                     },                   ImportGroup                     { igName = Just "Specific monads",-                      igRules =-                        NonEmpty.fromList-                          [ ImportGroupRule-                              { igrModuleMatcher = MatchGlob (mkGlob "Control.Monad.**"),-                                igrQualifiedMatcher = MatchBothQualifiedAndUnqualified,-                                igrPriority = defaultImportRulePriority-                              }-                          ]+                      igRules = NonEmpty.fromList [defaultImportGroupRule {igrGlob = mkGlob "Control.Monad.**"}]                     }                 ]         actualStrategy `shouldBe` Just (ImportGroupCustom expectedRules)@@ -332,9 +215,19 @@               Yaml.decodeEither' @FourmoluConfig . Char8.pack . unlines $                 [ "import-grouping:",                   "  - rules:",-                  "      - some-unknown-rule-type: whatever"+                  "      - match: whatever"                 ]             isAnUnknownModuleMatcher e = case e of-              Left (Yaml.AesonException msg) -> "Unknown or invalid module matcher" `isInfixOf` msg+              Left (Yaml.AesonException msg) -> "Unknown legacy match value" `isInfixOf` msg               _ -> False         decodeResult `shouldSatisfy` isAnUnknownModuleMatcher++defaultImportGroupRule :: ImportGroupRule+defaultImportGroupRule =+  ImportGroupRule+    { igrGlob = matchAllGlob,+      igrImportListMatcher = MatchAnyImportDeclaration,+      igrQualifiedMatcher = MatchBothQualifiedAndUnqualified,+      igrScopeMatcher = MatchAllModules,+      igrPriority = defaultImportRulePriority+    }

@@ -214,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

@@ -10,15 +10,16 @@ where  import Control.Monad (when)-import System.Directory (findExecutable)+import System.Directory (findExecutable, makeAbsolute) import System.Environment (getEnvironment) import System.Exit (ExitCode (..)) import System.Process (CreateProcess (..), readCreateProcessWithExitCode) import System.Process qualified as Process  -- | Find a `fourmolu` executable on PATH.+-- Needs to be absolute to work around https://github.com/haskell/cabal/issues/11598 getFourmoluExe :: IO FilePath-getFourmoluExe = findExecutable "fourmolu" >>= maybe (fail "Could not find fourmolu executable") return+getFourmoluExe = findExecutable "fourmolu" >>= maybe (fail "Could not find fourmolu executable") makeAbsolute  -- | Like 'System.Process.readProcess', except without specifying stdin and -- with better failure messages.