diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,46 @@ +## Fourmolu 0.20.1.0 + +### Upstream changes: + +#### Ormolu 0.8.2.0 + +* Overhaul how operator fixity information is collected. In addition to the + Hoogle database, Ormolu now parses the sources of a curated set of important + packages directly, which yields more accurate and complete fixity data than + before. In particular it recovers fixities for operators re-exported through + umbrella modules (e.g. `Servant.API`, `Control.Lens`) that recent Hoogle + databases no longer record. As a result, formatting of operator chains is + improved out of the box, and users should expect some operator-heavy code to + be laid out differently (and more correctly) than in previous releases. + +* Improve the layout of chains of `infixr 0` operators (`$`, `seq`, `?:`, and + the like). Such operators are only laid out in the trailing "staircase" style + when it is warranted: either the chain consists of a single operator, or its + final operand is a hanging construct (a `do` block, lambda, `case`, etc.). A + chain of several such operators that ends in an ordinary expression is now + laid out with the operators in the leading position instead of an + ever-deepening pyramid. [Issue + 1151](https://github.com/tweag/ormolu/issues/1151). + +* Do not crash when a parent directory cannot be read due to insufficient + permissions while searching for configuration files; the search for + configuration files is stopped at that point instead. [Issue + 1212](https://github.com/tweag/ormolu/issues/1212). + +* Preserve blank lines between blocks in layout contexts (`where`, `do`, + `let`) when the preceding block ends with a trailing comment. [Issue + 1132](https://github.com/tweag/ormolu/issues/1132). + +* Fix printing of single line export lists with inlined Haddock comments. + [Issue 1051](https://github.com/tweag/ormolu/issues/1051). + +* Fix preservation of the position of comments around the `where` keyword. + [Issue 784](https://github.com/tweag/ormolu/issues/784). + +* Do not sort `Prelude` to the end of the import list when the + `NoImplicitPrelude` extension is enabled; instead sort it like any other + import. [Issue 1189](https://github.com/tweag/ormolu/issues/1189). + ## Fourmolu 0.20.0.0 Now installable with GHCup! See README for details. @@ -14,7 +57,7 @@ * Fix applying `indent-wheres` configuration to pattern synonyms with explicit bidirectional `where` clauses ([#486](https://github.com/fourmolu/fourmolu/issues/486)) -### Upstream changed: +### Upstream changes: #### Ormolu 0.8.1.1 @@ -24,7 +67,7 @@ #### Ormolu 0.8.1.0 -* Fixed printing of guards on pattern binds. [Issue +* Fix 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: @@ -42,10 +85,10 @@ * 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 +* Fix 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 +* Fix an issue where or-patterns would be indented twice. [Issue 1188](https://github.com/tweag/ormolu/issues/1188). * Add support for `ExplicitLevelImports`. [Issue @@ -53,11 +96,11 @@ ## Fourmolu 0.19.0.1 -### Upstream changed: +### Upstream changes: #### Ormolu 0.8.0.2 -* Fixed a performance regression introduced in 0.8.0.0. [Issue +* Fix a performance regression introduced in 0.8.0.0. [Issue 1176](https://github.com/tweag/ormolu/issues/1176). ## Fourmolu 0.19.0.0 @@ -486,7 +529,7 @@ #### Ormolu 0.5.0.1 -* Fixed a bug in the diff printing functionality. [Issue +* Fix a bug in the diff printing functionality. [Issue 886](https://github.com/tweag/ormolu/issues/886). * Indent closing bracket for list comprehensions in `do` blocks. @@ -779,7 +822,7 @@ * Now `--mode check` fails on missing trailing blank lines. [Issue 743](https://github.com/tweag/ormolu/issues/743). -* Fixed indentation of arrow forms in do blocks. [Issue +* Fix indentation of arrow forms in do blocks. [Issue 739](https://github.com/tweag/ormolu/issues/739). #### Ormolu 0.1.4.1 @@ -792,7 +835,7 @@ * Added support for monad comprehensions. [Issue 665](https://github.com/tweag/ormolu/issues/665). -* Fixed a bug when a space was inserted in front of promoted types even when +* Fix a bug when a space was inserted in front of promoted types even when it wasn't strictly necessary. [Issue 668](https://github.com/tweag/ormolu/issues/668). @@ -802,7 +845,7 @@ #### Ormolu 0.1.3.1 -* Fixed a problem with multiline record updates using the record dot +* Fix a problem with multiline record updates using the record dot preprocessor. [Issue 658](https://github.com/tweag/ormolu/issues/658). ## Fourmolu 0.3.0.0 @@ -837,7 +880,7 @@ #### Ormolu 0.1.2.0: -* Fixed the bug when comments in different styles got glued together after +* Fix the bug when comments in different styles got glued together after formatting. [Issue 589](https://github.com/tweag/ormolu/issues/589). * Added `-i` as a shortcut for `--mode inplace`. [Issue @@ -866,26 +909,26 @@ * Improved sorting of operators in imports. [Issue 602](https://github.com/tweag/ormolu/issues/602). -* Fixed a bug related to trailing space in multiline comments in certain +* Fix a bug related to trailing space in multiline comments in certain cases. [Issue 603](https://github.com/tweag/ormolu/issues/602). * Added support for formatting linked lists with `(:)` as line terminator. [Issue 478](https://github.com/tweag/ormolu/issues/478). -* Fixed rendering of function arguments in multiline layout. [Issue +* Fix rendering of function arguments in multiline layout. [Issue 609](https://github.com/tweag/ormolu/issues/609). * Blank lines between definitions in `let` and `while` bindings are now preserved. [Issue 554](https://github.com/tweag/ormolu/issues/554). -* Fixed the bug when type applications stuck to the `$` of TH splices that +* Fix the bug when type applications stuck to the `$` of TH splices that followed them. [Issue 613](https://github.com/tweag/ormolu/issues/613). * Improved region formatting so that indented fragments—such as definitions inside of `where` clauses—can be formatted. [Issue 572](https://github.com/tweag/ormolu/issues/572). -* Fixed the bug related to the de-association of pragma comments. [Issue +* Fix the bug related to the de-association of pragma comments. [Issue 619](https://github.com/tweag/ormolu/issues/619). ## Fourmolu 0.1.0.0 @@ -898,24 +941,24 @@ #### Ormolu 0.1.0.0: -* Fixed rendering of type signatures concerning several identifiers. [Issue +* Fix rendering of type signatures concerning several identifiers. [Issue 566](https://github.com/tweag/ormolu/issues/566). -* Fixed an idempotence issue with inline comments in tuples and parentheses. +* Fix an idempotence issue with inline comments in tuples and parentheses. [Issue 450](https://github.com/tweag/ormolu/issues/450). -* Fixed an idempotence issue when certain comments were picked up as +* Fix an idempotence issue when certain comments were picked up as “continuation” of a series of comments [Issue 449](https://github.com/tweag/ormolu/issues/449). -* Fixed an idempotence issue related to different indentation levels in a +* Fix an idempotence issue related to different indentation levels in a comment series. [Issue 512](https://github.com/tweag/ormolu/issues/512). -* Fixed an idempotence issue related to comments which may happen to be +* Fix an idempotence issue related to comments which may happen to be separated from the elements they are attached to by the equality sign. [Issue 340](https://github.com/tweag/ormolu/issues/340). -* Fixed an idempotence issue with type synonym and data declarations where +* Fix an idempotence issue with type synonym and data declarations where the type has a Haddock. [Issue 578](https://github.com/tweag/ormolu/issues/578). @@ -923,17 +966,17 @@ multiple blank lines in a row. [Issue 518](https://github.com/tweag/ormolu/issues/518). -* Fixed rendering of comments around if expressions. [Issue +* Fix rendering of comments around if expressions. [Issue 458](https://github.com/tweag/ormolu/issues/458). * Unnamed fields of data constructors are now documented using the `-- ^` syntax. [Issue 445](https://github.com/tweag/ormolu/issues/445) and [Issue 428](https://github.com/tweag/ormolu/issues/428). -* Fixed non-idempotent transformation of partly documented data definition. +* Fix non-idempotent transformation of partly documented data definition. [Issue 590](https://github.com/tweag/ormolu/issues/590). -* Fixed an idempotence issue related to operators. [Issue +* Fix an idempotence issue related to operators. [Issue 522](https://github.com/tweag/ormolu/issues/522). * Renamed the `--check-idempotency` flag to `--check-idempotence`. @@ -964,7 +1007,7 @@ select a region to format. [Issue 516](https://github.com/tweag/ormolu/issues/516). -* Fixed rendering of module headers in the presence of preceding comments or +* Fix rendering of module headers in the presence of preceding comments or Haddocks. [Issue 561](https://github.com/tweag/ormolu/issues/561). ## Ormolu 0.0.4.0 @@ -985,7 +1028,7 @@ now put on its own line. [Issue 509](https://github.com/tweag/ormolu/issues/509). -* Fixed the bug pertaining to rendering of arrow notation with multiline +* Fix the bug pertaining to rendering of arrow notation with multiline expressions. [Issue 513](https://github.com/tweag/ormolu/issues/513). * Made rendering of data type definitions, value-level applications, and @@ -1003,15 +1046,15 @@ ## Ormolu 0.0.3.1 -* Fixed rendering of record updates with the record dot preprocessor syntax +* Fix rendering of record updates with the record dot preprocessor syntax [Issue 498](https://github.com/tweag/ormolu/issues/498). ## Ormolu 0.0.3.0 -* Fixed an issue related to unnecessary use of curly braces. [Issue +* Fix an issue related to unnecessary use of curly braces. [Issue 473](https://github.com/tweag/ormolu/issues/473). -* Fixed the issue with formatting multi-way if when it happens to be a +* Fix the issue with formatting multi-way if when it happens to be a function applied to arguments [Issue 488](https://github.com/tweag/ormolu/issues/488). This changed the way multi-line if is formatted in general. @@ -1023,7 +1066,7 @@ potentially-hanging consturctions in the presence of comments. [Issue 447](https://github.com/tweag/ormolu/issues/447). -* Fixed indentation in presence of type applications. [Issue +* Fix indentation in presence of type applications. [Issue 493](https://github.com/tweag/ormolu/issues/493). * Class and instance declarations now do not have a blank line after @@ -1041,20 +1084,20 @@ * Now unrecognized GHC options passed with `--ghc-opt` cause Ormolu to fail (exit code 7). -* Fixed formatting of result type in closed type families. See [issue +* Fix formatting of result type in closed type families. See [issue 420](https://github.com/tweag/ormolu/issues/420). -* Fixed a minor inconsistency between formatting of normal and foreign type +* Fix a minor inconsistency between formatting of normal and foreign type signatures. See [issue 408](https://github.com/tweag/ormolu/issues/408). -* Fixed a bug when comment before module header with Haddock was moved +* Fix a bug when comment before module header with Haddock was moved inside the export list. See [issue 430](https://github.com/tweag/ormolu/issues/430). * Empty `forall`s are now correctly preserved. See [issue 429](https://github.com/tweag/ormolu/issues/429). -* Fixed [issue 446](https://github.com/tweag/ormolu/issues/446), which +* Fix [issue 446](https://github.com/tweag/ormolu/issues/446), which involved braces and operators. * When there are comments between preceding Haddock (pipe-style) and its @@ -1074,7 +1117,7 @@ * Sorting language pragmas cannot not change meaning of the input program anymore. [Issue 404](https://github.com/tweag/ormolu/issues/404). -* Fixed formatting of applications where function is a complex expression. +* Fix formatting of applications where function is a complex expression. [Issue 444](https://github.com/tweag/ormolu/issues/444). ## Ormolu 0.0.1.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -22,7 +22,7 @@ * [Contributing](#contributing) * [License](#license) -Fourmolu is a formatter for Haskell source code. It is a fork of [Ormolu](https://github.com/tweag/ormolu), with upstream improvements continually merged. +Fourmolu is a formatter for Haskell source code. It is a fork of [Ormolu](https://github.com/mrkkrp/ormolu), with upstream improvements continually merged. We share all bar one of Ormolu's goals: @@ -282,7 +282,7 @@ * CPP support is experimental. CPP is virtually impossible to handle correctly, so we process them as a sort of unchangeable snippets. This works only in simple cases when CPP conditionals surround top-level - declarations. See the [CPP](https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp) section in the design notes for a + declarations. See the [CPP](https://github.com/mrkkrp/ormolu/blob/master/DESIGN.md#cpp) section in the design notes for a discussion of the dangers. * Various minor idempotence issues, most of them are related to comments or column limits. diff --git a/data/examples/declaration/value/function/case-with-comment-before-where-four-out.hs b/data/examples/declaration/value/function/case-with-comment-before-where-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-with-comment-before-where-four-out.hs @@ -0,0 +1,14 @@ +foo = + case x of + _ -> 1 + -- comment + where + -- comment 2 + x = 1 + +foo = case x of + _ -> 1 + -- comment + where + -- comment 2 + x = 1 diff --git a/data/examples/declaration/value/function/case-with-comment-before-where-out.hs b/data/examples/declaration/value/function/case-with-comment-before-where-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-with-comment-before-where-out.hs @@ -0,0 +1,14 @@ +foo = + case x of + _ -> 1 + -- comment + where + -- comment 2 + x = 1 + +foo = case x of + _ -> 1 + -- comment + where + -- comment 2 + x = 1 diff --git a/data/examples/declaration/value/function/case-with-comment-before-where.hs b/data/examples/declaration/value/function/case-with-comment-before-where.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-with-comment-before-where.hs @@ -0,0 +1,14 @@ +foo = + case x of + _ -> 1 + -- comment + where + -- comment 2 + x = 1 + +foo = case x of + _ -> 1 + -- comment + where + -- comment 2 + x = 1 diff --git a/data/examples/declaration/value/function/infix/dollar-chains-1-four-out.hs b/data/examples/declaration/value/function/infix/dollar-chains-1-four-out.hs --- a/data/examples/declaration/value/function/infix/dollar-chains-1-four-out.hs +++ b/data/examples/declaration/value/function/infix/dollar-chains-1-four-out.hs @@ -13,9 +13,9 @@ throwIO (OrmoluCppEnabled path) foo = - bar $ - baz $ - quux + bar + $ baz + $ quux x = case l of { A -> B } $ diff --git a/data/examples/declaration/value/function/infix/dollar-chains-1-out.hs b/data/examples/declaration/value/function/infix/dollar-chains-1-out.hs --- a/data/examples/declaration/value/function/infix/dollar-chains-1-out.hs +++ b/data/examples/declaration/value/function/infix/dollar-chains-1-out.hs @@ -13,9 +13,9 @@ throwIO (OrmoluCppEnabled path) foo = - bar $ - baz $ - quux + bar + $ baz + $ quux x = case l of { A -> B } $ diff --git a/data/examples/declaration/value/function/infix/dollar-chains-3-four-out.hs b/data/examples/declaration/value/function/infix/dollar-chains-3-four-out.hs --- a/data/examples/declaration/value/function/infix/dollar-chains-3-four-out.hs +++ b/data/examples/declaration/value/function/infix/dollar-chains-3-four-out.hs @@ -1,11 +1,11 @@ ex1 = - f1 $ - arg1 $ - arg2 $ - arg3 + f1 + $ arg1 + $ arg2 + $ arg3 ex3 = - f1 $ - arg1 $ - arg2 $ - 1 + 3 + f1 + $ arg1 + $ arg2 + $ 1 + 3 diff --git a/data/examples/declaration/value/function/infix/dollar-chains-3-out.hs b/data/examples/declaration/value/function/infix/dollar-chains-3-out.hs --- a/data/examples/declaration/value/function/infix/dollar-chains-3-out.hs +++ b/data/examples/declaration/value/function/infix/dollar-chains-3-out.hs @@ -1,11 +1,11 @@ ex1 = - f1 $ - arg1 $ - arg2 $ - arg3 + f1 + $ arg1 + $ arg2 + $ arg3 ex3 = - f1 $ - arg1 $ - arg2 $ - 1 + 3 + f1 + $ arg1 + $ arg2 + $ 1 + 3 diff --git a/data/examples/declaration/value/function/infix/dollar-chains-4-four-out.hs b/data/examples/declaration/value/function/infix/dollar-chains-4-four-out.hs --- a/data/examples/declaration/value/function/infix/dollar-chains-4-four-out.hs +++ b/data/examples/declaration/value/function/infix/dollar-chains-4-four-out.hs @@ -1,5 +1,5 @@ ex2 = - f1 $ - arg1 $ - arg2 $ - f2 arg3 + f1 + $ arg1 + $ arg2 + $ f2 arg3 diff --git a/data/examples/declaration/value/function/infix/dollar-chains-4-out.hs b/data/examples/declaration/value/function/infix/dollar-chains-4-out.hs --- a/data/examples/declaration/value/function/infix/dollar-chains-4-out.hs +++ b/data/examples/declaration/value/function/infix/dollar-chains-4-out.hs @@ -1,5 +1,5 @@ ex2 = - f1 $ - arg1 $ - arg2 $ - f2 arg3 + f1 + $ arg1 + $ arg2 + $ f2 arg3 diff --git a/data/examples/declaration/value/function/infix/lenses-four-out.hs b/data/examples/declaration/value/function/infix/lenses-four-out.hs --- a/data/examples/declaration/value/function/infix/lenses-four-out.hs +++ b/data/examples/declaration/value/function/infix/lenses-four-out.hs @@ -1,14 +1,14 @@ import Control.Lens lenses = - Just $ - M.fromList $ - "type" .= ("user.connection" :: Text) - # "connection" .= uc - # "user" .= case name of - Just n -> Just $ object ["name" .= n] - Nothing -> Nothing - # [] + Just + $ M.fromList + $ "type" .= ("user.connection" :: Text) + # "connection" .= uc + # "user" .= case name of + Just n -> Just $ object ["name" .= n] + Nothing -> Nothing + # [] foo = a diff --git a/data/examples/declaration/value/function/infix/lenses-out.hs b/data/examples/declaration/value/function/infix/lenses-out.hs --- a/data/examples/declaration/value/function/infix/lenses-out.hs +++ b/data/examples/declaration/value/function/infix/lenses-out.hs @@ -1,14 +1,14 @@ import Control.Lens lenses = - Just $ - M.fromList $ - "type" .= ("user.connection" :: Text) - # "connection" .= uc - # "user" .= case name of - Just n -> Just $ object ["name" .= n] - Nothing -> Nothing - # [] + Just + $ M.fromList + $ "type" .= ("user.connection" :: Text) + # "connection" .= uc + # "user" .= case name of + Just n -> Just $ object ["name" .= n] + Nothing -> Nothing + # [] foo = a diff --git a/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-1-four-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-1-four-out.hs --- a/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-1-four-out.hs +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-1-four-out.hs @@ -1,11 +1,11 @@ -- Right chain, $ case, 2 operators with p($) == p(b) n :: Int n = - 1 $ - 2 $ - 3 $ - 4 `seq` - 5 $ - 6 $ - 7 $ - 8 + 1 + $ 2 + $ 3 + $ 4 + `seq` 5 + $ 6 + $ 7 + $ 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-1-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-1-out.hs --- a/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-1-out.hs +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-1-out.hs @@ -1,11 +1,11 @@ -- Right chain, $ case, 2 operators with p($) == p(b) n :: Int n = - 1 $ - 2 $ - 3 $ - 4 `seq` - 5 $ - 6 $ - 7 $ - 8 + 1 + $ 2 + $ 3 + $ 4 + `seq` 5 + $ 6 + $ 7 + $ 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-2-four-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-2-four-out.hs --- a/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-2-four-out.hs +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-2-four-out.hs @@ -1,11 +1,11 @@ -- Right chain, $ case, 2 operators with p(a) == p($) p :: Int p = - 1 `seq` - 2 `seq` - 3 `seq` - 4 $ - 5 `seq` - 6 `seq` - 7 `seq` - 8 + 1 + `seq` 2 + `seq` 3 + `seq` 4 + $ 5 + `seq` 6 + `seq` 7 + `seq` 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-2-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-2-out.hs --- a/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-2-out.hs +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-2-out.hs @@ -1,11 +1,11 @@ -- Right chain, $ case, 2 operators with p(a) == p($) p :: Int p = - 1 `seq` - 2 `seq` - 3 `seq` - 4 $ - 5 `seq` - 6 `seq` - 7 `seq` - 8 + 1 + `seq` 2 + `seq` 3 + `seq` 4 + $ 5 + `seq` 6 + `seq` 7 + `seq` 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-s-dollar-four-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-s-dollar-four-out.hs --- a/data/examples/declaration/value/function/infix/op-chain-r-s-dollar-four-out.hs +++ b/data/examples/declaration/value/function/infix/op-chain-r-s-dollar-four-out.hs @@ -1,7 +1,7 @@ -- Right chain, $ case, 1 operator type c :: Int c = - 1 $ - 2 $ - 3 $ - 4 + 1 + $ 2 + $ 3 + $ 4 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-s-dollar-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-s-dollar-out.hs --- a/data/examples/declaration/value/function/infix/op-chain-r-s-dollar-out.hs +++ b/data/examples/declaration/value/function/infix/op-chain-r-s-dollar-out.hs @@ -1,7 +1,7 @@ -- Right chain, $ case, 1 operator type c :: Int c = - 1 $ - 2 $ - 3 $ - 4 + 1 + $ 2 + $ 3 + $ 4 diff --git a/data/examples/declaration/value/function/infix/qualified-ops-four-out.hs b/data/examples/declaration/value/function/infix/qualified-ops-four-out.hs --- a/data/examples/declaration/value/function/infix/qualified-ops-four-out.hs +++ b/data/examples/declaration/value/function/infix/qualified-ops-four-out.hs @@ -1,9 +1,9 @@ lenses = - Just $ - M.fromList $ - "type" Foo..= ("user.connection" :: Text) - Bar.# "connection" Foo..= uc - Bar.# "user" Foo..= case name of - Just n -> Just $ object ["name" .= n] - Nothing -> Nothing - Bar.# [] + Just + $ M.fromList + $ "type" Foo..= ("user.connection" :: Text) + Bar.# "connection" Foo..= uc + Bar.# "user" Foo..= case name of + Just n -> Just $ object ["name" .= n] + Nothing -> Nothing + Bar.# [] diff --git a/data/examples/declaration/value/function/infix/qualified-ops-out.hs b/data/examples/declaration/value/function/infix/qualified-ops-out.hs --- a/data/examples/declaration/value/function/infix/qualified-ops-out.hs +++ b/data/examples/declaration/value/function/infix/qualified-ops-out.hs @@ -1,9 +1,9 @@ lenses = - Just $ - M.fromList $ - "type" Foo..= ("user.connection" :: Text) - Bar.# "connection" Foo..= uc - Bar.# "user" Foo..= case name of - Just n -> Just $ object ["name" .= n] - Nothing -> Nothing - Bar.# [] + Just + $ M.fromList + $ "type" Foo..= ("user.connection" :: Text) + Bar.# "connection" Foo..= uc + Bar.# "user" Foo..= case name of + Just n -> Just $ object ["name" .= n] + Nothing -> Nothing + Bar.# [] diff --git a/data/examples/fixity/megaparsec-alternative-four-out.hs b/data/examples/fixity/megaparsec-alternative-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/megaparsec-alternative-four-out.hs @@ -0,0 +1,8 @@ +module MegaparsecExample where + +import Text.Megaparsec + +pValue = + Object <$> parseObjectBody + <|> Array <$> parseArrayBody + <|> String <$> parseStringBody diff --git a/data/examples/fixity/megaparsec-alternative-out.hs b/data/examples/fixity/megaparsec-alternative-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/megaparsec-alternative-out.hs @@ -0,0 +1,8 @@ +module MegaparsecExample where + +import Text.Megaparsec + +pValue = + Object <$> parseObjectBody + <|> Array <$> parseArrayBody + <|> String <$> parseStringBody diff --git a/data/examples/fixity/megaparsec-alternative.hs b/data/examples/fixity/megaparsec-alternative.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/megaparsec-alternative.hs @@ -0,0 +1,8 @@ +module MegaparsecExample where + +import Text.Megaparsec + +pValue = + Object <$> parseObjectBody + <|> Array <$> parseArrayBody + <|> String <$> parseStringBody diff --git a/data/examples/fixity/optics-mixed-four-out.hs b/data/examples/fixity/optics-mixed-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/optics-mixed-four-out.hs @@ -0,0 +1,8 @@ +module OpticsExample where + +import Optics + +updated = + record + & fieldLens % subFieldLens .~ someValue + & otherLens %~ someTransformationFunctionApplied diff --git a/data/examples/fixity/optics-mixed-out.hs b/data/examples/fixity/optics-mixed-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/optics-mixed-out.hs @@ -0,0 +1,8 @@ +module OpticsExample where + +import Optics + +updated = + record + & fieldLens % subFieldLens .~ someValue + & otherLens %~ someTransformationFunctionApplied diff --git a/data/examples/fixity/optics-mixed.hs b/data/examples/fixity/optics-mixed.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/optics-mixed.hs @@ -0,0 +1,8 @@ +module OpticsExample where + +import Optics + +updated = + record + & fieldLens % subFieldLens .~ someValue + & otherLens %~ someTransformationFunctionApplied diff --git a/data/examples/fixity/relude-default-operator-chain-four-out.hs b/data/examples/fixity/relude-default-operator-chain-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/relude-default-operator-chain-four-out.hs @@ -0,0 +1,10 @@ +module ReludeChainExample where + +import Relude + +resolveValue = + primarySource + ?: secondarySource + ?: tertiarySource + ?: quaternarySource + ?: finalFallbackValue diff --git a/data/examples/fixity/relude-default-operator-chain-out.hs b/data/examples/fixity/relude-default-operator-chain-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/relude-default-operator-chain-out.hs @@ -0,0 +1,10 @@ +module ReludeChainExample where + +import Relude + +resolveValue = + primarySource + ?: secondarySource + ?: tertiarySource + ?: quaternarySource + ?: finalFallbackValue diff --git a/data/examples/fixity/relude-default-operator-chain.hs b/data/examples/fixity/relude-default-operator-chain.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/relude-default-operator-chain.hs @@ -0,0 +1,10 @@ +module ReludeChainExample where + +import Relude + +resolveValue = + primarySource + ?: secondarySource + ?: tertiarySource + ?: quaternarySource + ?: finalFallbackValue diff --git a/data/examples/fixity/relude-default-operator-four-out.hs b/data/examples/fixity/relude-default-operator-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/relude-default-operator-four-out.hs @@ -0,0 +1,7 @@ +module ReludeExample where + +import Relude + +config = + lookupOptionalSetting environment ?: + defaultConfigurationValue diff --git a/data/examples/fixity/relude-default-operator-out.hs b/data/examples/fixity/relude-default-operator-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/relude-default-operator-out.hs @@ -0,0 +1,7 @@ +module ReludeExample where + +import Relude + +config = + lookupOptionalSetting environment ?: + defaultConfigurationValue diff --git a/data/examples/fixity/relude-default-operator.hs b/data/examples/fixity/relude-default-operator.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/relude-default-operator.hs @@ -0,0 +1,7 @@ +module ReludeExample where + +import Relude + +config = + lookupOptionalSetting environment + ?: defaultConfigurationValue diff --git a/data/examples/fixity/rio-ampersand-four-out.hs b/data/examples/fixity/rio-ampersand-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/rio-ampersand-four-out.hs @@ -0,0 +1,7 @@ +module RioExample where + +import RIO + +message = + greetingText <> userNameText + & Text.strip diff --git a/data/examples/fixity/rio-ampersand-out.hs b/data/examples/fixity/rio-ampersand-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/rio-ampersand-out.hs @@ -0,0 +1,7 @@ +module RioExample where + +import RIO + +message = + greetingText <> userNameText + & Text.strip diff --git a/data/examples/fixity/rio-ampersand.hs b/data/examples/fixity/rio-ampersand.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/rio-ampersand.hs @@ -0,0 +1,7 @@ +module RioExample where + +import RIO + +message = + greetingText <> userNameText + & Text.strip diff --git a/data/examples/fixity/rio-deepseq-four-out.hs b/data/examples/fixity/rio-deepseq-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/rio-deepseq-four-out.hs @@ -0,0 +1,7 @@ +module RioDeepseqExample where + +import RIO + +result = + forceEvaluationOfBigStructure `deepseq` + continueWithNextStep diff --git a/data/examples/fixity/rio-deepseq-out.hs b/data/examples/fixity/rio-deepseq-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/rio-deepseq-out.hs @@ -0,0 +1,7 @@ +module RioDeepseqExample where + +import RIO + +result = + forceEvaluationOfBigStructure `deepseq` + continueWithNextStep diff --git a/data/examples/fixity/rio-deepseq.hs b/data/examples/fixity/rio-deepseq.hs new file mode 100644 --- /dev/null +++ b/data/examples/fixity/rio-deepseq.hs @@ -0,0 +1,7 @@ +module RioDeepseqExample where + +import RIO + +result = + forceEvaluationOfBigStructure + `deepseq` continueWithNextStep diff --git a/data/examples/import/implicit-prelude-package-four-out.hs b/data/examples/import/implicit-prelude-package-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/implicit-prelude-package-four-out.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} + +import "base" Control.Applicative (Alternative, (<|>)) +import "base" Data.Maybe (Maybe (Nothing), maybe) +import "base" System.IO (IO) +import "yaya" Yaya.Fold (ana, cata) +import "base" Prelude ((+)) diff --git a/data/examples/import/implicit-prelude-package-out.hs b/data/examples/import/implicit-prelude-package-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/implicit-prelude-package-out.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} + +import "base" Control.Applicative (Alternative, (<|>)) +import "base" Data.Maybe (Maybe (Nothing), maybe) +import "base" System.IO (IO) +import "yaya" Yaya.Fold (ana, cata) +import "base" Prelude ((+)) diff --git a/data/examples/import/implicit-prelude-package.hs b/data/examples/import/implicit-prelude-package.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/implicit-prelude-package.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PackageImports #-} + +import "base" System.IO (IO) +import "base" Prelude ((+)) +import "yaya" Yaya.Fold (ana, cata) +import "base" Control.Applicative (Alternative, (<|>)) +import "base" Data.Maybe (Maybe (Nothing), maybe) diff --git a/data/examples/import/no-implicit-prelude-four-out.hs b/data/examples/import/no-implicit-prelude-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/no-implicit-prelude-four-out.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +import Control.Applicative (Alternative, (<|>)) +import Data.Maybe (Maybe (Nothing), maybe) +import Prelude ((+)) +import System.IO (IO) diff --git a/data/examples/import/no-implicit-prelude-out.hs b/data/examples/import/no-implicit-prelude-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/no-implicit-prelude-out.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +import Control.Applicative (Alternative, (<|>)) +import Data.Maybe (Maybe (Nothing), maybe) +import Prelude ((+)) +import System.IO (IO) diff --git a/data/examples/import/no-implicit-prelude-package-four-out.hs b/data/examples/import/no-implicit-prelude-package-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/no-implicit-prelude-package-four-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE NoImplicitPrelude #-} + +import "base" Control.Applicative (Alternative, (<|>)) +import "base" Data.Maybe (Maybe (Nothing), maybe) +import "base" Prelude ((+)) +import "base" System.IO (IO) +import "yaya" Yaya.Fold (ana, cata) diff --git a/data/examples/import/no-implicit-prelude-package-out.hs b/data/examples/import/no-implicit-prelude-package-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/no-implicit-prelude-package-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE NoImplicitPrelude #-} + +import "base" Control.Applicative (Alternative, (<|>)) +import "base" Data.Maybe (Maybe (Nothing), maybe) +import "base" Prelude ((+)) +import "base" System.IO (IO) +import "yaya" Yaya.Fold (ana, cata) diff --git a/data/examples/import/no-implicit-prelude-package.hs b/data/examples/import/no-implicit-prelude-package.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/no-implicit-prelude-package.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PackageImports #-} + +import "base" System.IO (IO) +import "base" Prelude ((+)) +import "yaya" Yaya.Fold (ana, cata) +import "base" Control.Applicative (Alternative, (<|>)) +import "base" Data.Maybe (Maybe (Nothing), maybe) diff --git a/data/examples/import/no-implicit-prelude.hs b/data/examples/import/no-implicit-prelude.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/no-implicit-prelude.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +import System.IO (IO) +import Prelude ((+)) +import Control.Applicative (Alternative, (<|>)) +import Data.Maybe (Maybe (Nothing), maybe) diff --git a/data/examples/module-header/block-haddock-in-export-list-four-out.hs b/data/examples/module-header/block-haddock-in-export-list-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/block-haddock-in-export-list-four-out.hs @@ -0,0 +1,4 @@ +module Foo ( + -- | asdf + foo, +) where diff --git a/data/examples/module-header/block-haddock-in-export-list-out.hs b/data/examples/module-header/block-haddock-in-export-list-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/block-haddock-in-export-list-out.hs @@ -0,0 +1,5 @@ +module Foo + ( -- | asdf + foo, + ) +where diff --git a/data/examples/module-header/block-haddock-in-export-list.hs b/data/examples/module-header/block-haddock-in-export-list.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/block-haddock-in-export-list.hs @@ -0,0 +1,1 @@ +module Foo ({- | asdf -} foo) where diff --git a/data/examples/other/comment-trailing-blank-line-do-four-out.hs b/data/examples/other/comment-trailing-blank-line-do-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-blank-line-do-four-out.hs @@ -0,0 +1,4 @@ +doBlock = do + a -- + + b diff --git a/data/examples/other/comment-trailing-blank-line-do-out.hs b/data/examples/other/comment-trailing-blank-line-do-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-blank-line-do-out.hs @@ -0,0 +1,4 @@ +doBlock = do + a -- + + b diff --git a/data/examples/other/comment-trailing-blank-line-do.hs b/data/examples/other/comment-trailing-blank-line-do.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-blank-line-do.hs @@ -0,0 +1,4 @@ +doBlock = do + a -- + + b diff --git a/data/examples/other/comment-trailing-blank-line-let-four-out.hs b/data/examples/other/comment-trailing-blank-line-let-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-blank-line-let-four-out.hs @@ -0,0 +1,5 @@ +letBlock = + let a = a -- + + b = b + in c diff --git a/data/examples/other/comment-trailing-blank-line-let-out.hs b/data/examples/other/comment-trailing-blank-line-let-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-blank-line-let-out.hs @@ -0,0 +1,5 @@ +letBlock = + let a = a -- + + b = b + in c diff --git a/data/examples/other/comment-trailing-blank-line-let.hs b/data/examples/other/comment-trailing-blank-line-let.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-blank-line-let.hs @@ -0,0 +1,5 @@ +letBlock = + let a = a -- + + b = b + in c diff --git a/data/examples/other/comment-trailing-blank-line-variants-four-out.hs b/data/examples/other/comment-trailing-blank-line-variants-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-blank-line-variants-four-out.hs @@ -0,0 +1,22 @@ +textComment = do + a -- some text + + b + +blockComment = do + a {- foo -} + + b + +twoComments = do + a -- + + -- + + bar + +adjacentThenBlank = do + a -- + -- + + bar diff --git a/data/examples/other/comment-trailing-blank-line-variants-out.hs b/data/examples/other/comment-trailing-blank-line-variants-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-blank-line-variants-out.hs @@ -0,0 +1,22 @@ +textComment = do + a -- some text + + b + +blockComment = do + a {- foo -} + + b + +twoComments = do + a -- + + -- + + bar + +adjacentThenBlank = do + a -- + -- + + bar diff --git a/data/examples/other/comment-trailing-blank-line-variants.hs b/data/examples/other/comment-trailing-blank-line-variants.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-blank-line-variants.hs @@ -0,0 +1,22 @@ +textComment = do + a -- some text + + b + +blockComment = do + a {- foo -} + + b + +twoComments = do + a -- + + -- + + bar + +adjacentThenBlank = do + a -- + -- + + bar diff --git a/data/examples/other/comment-trailing-blank-line-where-four-out.hs b/data/examples/other/comment-trailing-blank-line-where-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-blank-line-where-four-out.hs @@ -0,0 +1,5 @@ +whereBlock = foo + where + a = a -- + + b = b diff --git a/data/examples/other/comment-trailing-blank-line-where-out.hs b/data/examples/other/comment-trailing-blank-line-where-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-blank-line-where-out.hs @@ -0,0 +1,5 @@ +whereBlock = foo + where + a = a -- + + b = b diff --git a/data/examples/other/comment-trailing-blank-line-where.hs b/data/examples/other/comment-trailing-blank-line-where.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-blank-line-where.hs @@ -0,0 +1,5 @@ +whereBlock = foo + where + a = a -- + + b = b diff --git a/data/examples/other/comment-trailing-no-blank-line-four-out.hs b/data/examples/other/comment-trailing-no-blank-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-no-blank-line-four-out.hs @@ -0,0 +1,25 @@ +noBlankAfterComment = do + a -- + b + +noBlankTextComment = do + a -- some text + b + +noBlankBlockComment = do + a {- foo -} + b + +blockCommentFollowedByExpr = do + a {- foo -} 1 + b + +whereNoBlank = foo + where + a = a -- + b = b + +letNoBlank = + let a = a -- + b = b + in c diff --git a/data/examples/other/comment-trailing-no-blank-line-out.hs b/data/examples/other/comment-trailing-no-blank-line-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-no-blank-line-out.hs @@ -0,0 +1,25 @@ +noBlankAfterComment = do + a -- + b + +noBlankTextComment = do + a -- some text + b + +noBlankBlockComment = do + a {- foo -} + b + +blockCommentFollowedByExpr = do + a {- foo -} 1 + b + +whereNoBlank = foo + where + a = a -- + b = b + +letNoBlank = + let a = a -- + b = b + in c diff --git a/data/examples/other/comment-trailing-no-blank-line.hs b/data/examples/other/comment-trailing-no-blank-line.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-no-blank-line.hs @@ -0,0 +1,25 @@ +noBlankAfterComment = do + a -- + b + +noBlankTextComment = do + a -- some text + b + +noBlankBlockComment = do + a {- foo -} + b + +blockCommentFollowedByExpr = do + a {- foo -} 1 + b + +whereNoBlank = foo + where + a = a -- + b = b + +letNoBlank = + let a = a -- + b = b + in c diff --git a/data/fourmolu/trailing-section-operators/output-True.hs b/data/fourmolu/trailing-section-operators/output-True.hs --- a/data/fourmolu/trailing-section-operators/output-True.hs +++ b/data/fourmolu/trailing-section-operators/output-True.hs @@ -3,11 +3,11 @@ someShortFunction $ someShortFunction $ \x -> do putStrLn x -someLongFunction $ - someLongFunction $ - someLongFunction $ - someLongFunction $ - someLongFunction x +someLongFunction + $ someLongFunction + $ someLongFunction + $ someLongFunction + $ someLongFunction x someLongFunction $ someLongFunction $ diff --git a/extract-hackage-info/hackage-info.bin b/extract-hackage-info/hackage-info.bin Binary files a/extract-hackage-info/hackage-info.bin and b/extract-hackage-info/hackage-info.bin differ diff --git a/fixity-tests/test-1-no-extra-info-expected.hs b/fixity-tests/test-1-no-extra-info-expected.hs --- a/fixity-tests/test-1-no-extra-info-expected.hs +++ b/fixity-tests/test-1-no-extra-info-expected.hs @@ -1,12 +1,12 @@ lenses = - Just $ - M.fromList $ - "type" - .= ("user.connection" :: Text) - # "connection" - .= uc - # "user" - .= case name of - Just n -> Just $ object ["name" .= n] - Nothing -> Nothing - # [] + Just + $ M.fromList + $ "type" + .= ("user.connection" :: Text) + # "connection" + .= uc + # "user" + .= case name of + Just n -> Just $ object ["name" .= n] + Nothing -> Nothing + # [] diff --git a/fixity-tests/test-1-with-fixity-info-expected.hs b/fixity-tests/test-1-with-fixity-info-expected.hs --- a/fixity-tests/test-1-with-fixity-info-expected.hs +++ b/fixity-tests/test-1-with-fixity-info-expected.hs @@ -1,9 +1,9 @@ lenses = - Just $ - M.fromList $ - "type" .= ("user.connection" :: Text) - # "connection" .= uc - # "user" .= case name of - Just n -> Just $ object ["name" .= n] - Nothing -> Nothing - # [] + Just + $ M.fromList + $ "type" .= ("user.connection" :: Text) + # "connection" .= uc + # "user" .= case name of + Just n -> Just $ object ["name" .= n] + Nothing -> Nothing + # [] diff --git a/fourmolu.cabal b/fourmolu.cabal --- a/fourmolu.cabal +++ b/fourmolu.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: fourmolu -version: 0.20.0.0 +version: 0.20.1.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: diff --git a/src/Ormolu.hs b/src/Ormolu.hs --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -47,6 +47,7 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class (MonadIO (..)) +import Data.Choice qualified as Choice import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Set qualified as Set @@ -118,7 +119,7 @@ -- when we try to parse the rendered code back, inside of GHC monad -- wrapper which will lead to error messages presenting the exceptions as -- GHC bugs. - let !formattedText = printSnippets (cfgDebug cfg) result0 $ cfgPrinterOpts cfgWithIndices + let !formattedText = printSnippets (Choice.fromBool (cfgDebug cfg)) result0 $ cfgPrinterOpts cfgWithIndices when (not (cfgUnsafe cfg) || cfgCheckIdempotence cfg) $ do -- Parse the result of pretty-printing again and make sure that AST -- is the same as AST of original snippet module span positions. @@ -144,7 +145,7 @@ -- Try re-formatting the formatted result to check if we get exactly -- the same output. when (cfgCheckIdempotence cfg) . liftIO $ - let reformattedText = printSnippets (cfgDebug cfg) result1 $ cfgPrinterOpts cfgWithIndices + let reformattedText = printSnippets (Choice.fromBool (cfgDebug cfg)) result1 $ cfgPrinterOpts cfgWithIndices in case diffText formattedText reformattedText path of Nothing -> return () Just diff -> throwIO (OrmoluNonIdempotentOutput diff) diff --git a/src/Ormolu/Diff/ParseResult.hs b/src/Ormolu/Diff/ParseResult.hs --- a/src/Ormolu/Diff/ParseResult.hs +++ b/src/Ormolu/Diff/ParseResult.hs @@ -2,6 +2,8 @@ {-# LANGUAGE DeepSubsumption #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} @@ -14,6 +16,7 @@ import Data.ByteString (ByteString) import Data.Char (isSpace) +import Data.Choice (pattern Without) import Data.Foldable import Data.Function import Data.Generics @@ -62,8 +65,16 @@ } = diffCommentStream cstream0 cstream1 <> diffHsModule - hs0 {hsmodImports = concat . normalizeImports False mempty ImportGroupSingle $ hsmodImports hs0} - hs1 {hsmodImports = concat . normalizeImports False mempty ImportGroupSingle $ hsmodImports hs1} + hs0 {hsmodImports = concat . normalizeImports' $ hsmodImports hs0} + hs1 {hsmodImports = concat . normalizeImports' $ hsmodImports hs1} + where + -- The exact parameters here don't matter, it just needs to be consistent + normalizeImports' = + normalizeImports + (Without #implicitPrelude) + False + mempty + ImportGroupSingle diffCommentStream :: CommentStream -> CommentStream -> ParseResultDiff diffCommentStream (CommentStream cs) (CommentStream cs') diff --git a/src/Ormolu/Fixity/Internal.hs b/src/Ormolu/Fixity/Internal.hs --- a/src/Ormolu/Fixity/Internal.hs +++ b/src/Ormolu/Fixity/Internal.hs @@ -190,7 +190,7 @@ defaultFixityOverrides :: FixityOverrides defaultFixityOverrides = FixityOverrides Map.empty --- | Module re-exports +-- | Module re-exports. newtype ModuleReexports = ModuleReexports { unModuleReexports :: Map ModuleName (NonEmpty (Maybe PackageName, ModuleName)) } @@ -198,61 +198,7 @@ -- | Module re-exports to apply by default. defaultModuleReexports :: ModuleReexports -defaultModuleReexports = - ModuleReexports . Map.fromList $ - [ ( "Control.Lens", - l - "lens" - [ "Control.Lens.At", - "Control.Lens.Cons", - "Control.Lens.Each", - "Control.Lens.Empty", - "Control.Lens.Equality", - "Control.Lens.Fold", - "Control.Lens.Getter", - "Control.Lens.Indexed", - "Control.Lens.Iso", - "Control.Lens.Lens", - "Control.Lens.Level", - "Control.Lens.Plated", - "Control.Lens.Prism", - "Control.Lens.Reified", - "Control.Lens.Review", - "Control.Lens.Setter", - "Control.Lens.TH", - "Control.Lens.Traversal", - "Control.Lens.Tuple", - "Control.Lens.Type", - "Control.Lens.Wrapped", - "Control.Lens.Zoom" - ] - ), - ( "Servant", - l - "servant" - [ "Servant.API" - ] - ), - ( "Optics", - l - "optics" - [ "Optics.Fold", - "Optics.Operators", - "Optics.IxAffineFold", - "Optics.IxFold", - "Optics.IxTraversal", - "Optics.Traversal" - ] - ), - ( "Test.Hspec", - l - "hspec-expectations" - [ "Test.Hspec.Expectations" - ] - ) - ] - where - l packageName xs = (Just packageName,) <$> NE.fromList xs +defaultModuleReexports = ModuleReexports Map.empty -- | Fixity information that is specific to a package being formatted. It -- requires module-specific imports in order to be usable. diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -12,6 +13,8 @@ import Data.Bifunctor import Data.Char (isAlphaNum) +import Data.Choice (Choice) +import Data.Choice qualified as Choice import Data.Function (on) import Data.List (nubBy, sortBy, sortOn) import Data.Map.Strict (Map) @@ -35,14 +38,20 @@ -- Assumes input list is sorted by source location. Output list is not necessarily -- sorted by source location, so this function should be called at most once on a -- given input list. -normalizeImports :: Bool -> Set Cabal.ModuleName -> ImportGrouping -> [LImportDecl GhcPs] -> [[LImportDecl GhcPs]] -normalizeImports respectful localModules importGrouping = +normalizeImports :: + Choice "implicitPrelude" -> + Bool -> + Set Cabal.ModuleName -> + ImportGrouping -> + [LImportDecl GhcPs] -> + [[LImportDecl GhcPs]] +normalizeImports implicitPrelude respectful localModules importGrouping = map (fmap snd) . concatMap ( groupImports importGrouping localModules toImport . M.toAscList . M.fromListWith combineImports - . fmap (\x -> (importId x, g x)) + . fmap (\x -> (importId implicitPrelude x, g x)) ) . prepareExistingGroups importGrouping respectful where @@ -141,8 +150,8 @@ toBool EverythingBut = True -- | Obtain an 'ImportId' for a given import. -importId :: LImportDecl GhcPs -> ImportId -importId (L _ ImportDecl {..}) = +importId :: Choice "implicitPrelude" -> LImportDecl GhcPs -> ImportId +importId implicitPrelude (L _ ImportDecl {..}) = ImportId { importIsPrelude = isPrelude, importIdName = moduleName, @@ -158,7 +167,8 @@ importLevel = importLevelOf ideclLevelSpec } where - isPrelude = moduleNameString moduleName == "Prelude" + isPrelude = + Choice.isTrue implicitPrelude && moduleNameString moduleName == "Prelude" moduleName = unLoc ideclName importLevelOf = \case LevelStylePre l -> Just (ImportDeclLevelOrd l) diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -18,6 +19,8 @@ import Control.Monad.Except (ExceptT (..), runExceptT) import Control.Monad.IO.Class import Data.Char (isSpace) +import Data.Choice (Choice) +import Data.Choice qualified as Choice import Data.Functor import Data.Functor.Identity (Identity (..)) import Data.Generics hiding (orElse) @@ -92,8 +95,12 @@ parsePragmasIntoDynFlags baseFlags extraOpts path rawInputStringBuffer >>= \case Right res -> pure res Left err -> throwIO (OrmoluParsingFailed beginningLoc err) - let cppEnabled = EnumSet.member Cpp (GHC.extensionFlags dynFlags) - implicitPrelude = EnumSet.member ImplicitPrelude (GHC.extensionFlags dynFlags) + let cppEnabled = + Choice.fromBool $ + EnumSet.member Cpp (GHC.extensionFlags dynFlags) + implicitPrelude = + Choice.fromBool $ + EnumSet.member ImplicitPrelude (GHC.extensionFlags dynFlags) fixityImports <- parseImports dynFlags implicitPrelude path rawInputStringBuffer >>= \case Right res -> @@ -176,7 +183,10 @@ -- | Normalize a 'HsModule' by sorting its export lists, dropping -- blank comments, etc. -normalizeModule :: Config RegionDeltas -> HsModule GhcPs -> HsModule GhcPs +normalizeModule :: + Config RegionDeltas -> + HsModule GhcPs -> + HsModule GhcPs normalizeModule Config {..} hsmod = everywhere ( mkT dropBlankTypeHaddocks @@ -337,8 +347,8 @@ parseImports :: -- | Pre-set 'DynFlags' DynFlags -> - -- | Implicit Prelude? - Bool -> + -- | Whether the implicit Prelude is in effect + Choice "implicitPrelude" -> -- | File name (only for source location annotations) FilePath -> -- | Input for the parser @@ -360,7 +370,11 @@ mod' = mmoduleName `orElse` L (GHC.noAnnSrcSpan main_loc) mAIN_NAME explicitImports = hsmodImports hsmod implicitImports = - GHC.mkPrelImports (unLoc mod') main_loc implicitPrelude explicitImports + GHC.mkPrelImports + (unLoc mod') + main_loc + (Choice.toBool implicitPrelude) + explicitImports in Right (explicitImports ++ implicitImports) where popts = initParserOpts flags diff --git a/src/Ormolu/Printer.hs b/src/Ormolu/Printer.hs --- a/src/Ormolu/Printer.hs +++ b/src/Ormolu/Printer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -8,6 +9,7 @@ ) where +import Data.Choice (Choice) import Data.Text (Text) import Data.Text qualified as T import Ormolu.Config @@ -20,7 +22,7 @@ -- | Render several source snippets. printSnippets :: -- | Whether to print out debug information during printing - Bool -> + Choice "debug" -> -- | Result of parsing [SourceSnippet] -> PrinterOptsTotal -> diff --git a/src/Ormolu/Printer/Combinators.hs b/src/Ormolu/Printer/Combinators.hs --- a/src/Ormolu/Printer/Combinators.hs +++ b/src/Ormolu/Printer/Combinators.hs @@ -38,6 +38,7 @@ switchLayout, switchLayoutNoLimit, spansLayout, + enterLayout, Layout (..), vlayout, getLayout, diff --git a/src/Ormolu/Printer/Internal.hs b/src/Ormolu/Printer/Internal.hs --- a/src/Ormolu/Printer/Internal.hs +++ b/src/Ormolu/Printer/Internal.hs @@ -71,7 +71,6 @@ import Data.Bool (bool) import Data.Char (isSpace) import Data.Choice (Choice) -import Data.Choice qualified as Choice import Data.Coerce import Data.Functor ((<&>)) import Data.Functor.Identity (runIdentity) @@ -123,7 +122,7 @@ -- | Module fixity map rcModuleFixityMap :: ModuleFixityMap, -- | Whether to print out debug information during printing - rcDebug :: !Bool + rcDebug :: !(Choice "debug") } -- | State context of 'R'. @@ -195,8 +194,9 @@ EnumSet Extension -> -- | Module fixity map ModuleFixityMap -> + -- | Whether to print out debug information during printing + Choice "debug" -> -- | Resulting rendition - Bool -> Text runR (R m) sstream cstream printerOpts localModules sourceType extensions moduleFixityMap debug = TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc @@ -463,7 +463,7 @@ -- | Retrieve whether we should print out certain debug information while -- printing. askDebug :: R (Choice "debug") -askDebug = R (asks (Choice.fromBool . rcDebug)) +askDebug = R (asks rcDebug) -- | Like 'inci', but indents by exactly the given number of steps. inciBy :: Int -> R () -> R () diff --git a/src/Ormolu/Printer/Meat/Common.hs b/src/Ormolu/Printer/Meat/Common.hs --- a/src/Ormolu/Printer/Meat/Common.hs +++ b/src/Ormolu/Printer/Meat/Common.hs @@ -131,16 +131,16 @@ -- | A helper for formatting infix constructions in lhs of definitions. p_infixDefHelper :: -- | Whether to format in infix style - Bool -> + Choice "infixStyle" -> -- | Whether to bump indentation for arguments - Bool -> + Choice "indentArgs" -> -- | How to print the operator\/name R () -> -- | How to print the arguments [R ()] -> R () p_infixDefHelper isInfix indentArgs name args = - case (isInfix, args) of + case (Choice.toBool isInfix, args) of (True, p0 : p1 : ps) -> do let parens' = if null ps @@ -153,14 +153,15 @@ name space p1 - unless (null ps) . inciIf indentArgs $ do + unless (null ps) . inciIf (Choice.toBool indentArgs) $ do breakpoint sitcc (sep breakpoint sitcc ps) (_, ps) -> do name unless (null ps) $ do breakpoint - inciIf indentArgs $ sitcc (sep breakpoint sitcc args) + inciIf (Choice.toBool indentArgs) $ + sitcc (sep breakpoint sitcc args) -- | Print a Haddock. p_hsDoc :: diff --git a/src/Ormolu/Printer/Meat/Declaration/Class.hs b/src/Ormolu/Printer/Meat/Declaration/Class.hs --- a/src/Ormolu/Printer/Meat/Declaration/Class.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Class.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -- | Rendering of type class declarations. @@ -10,6 +13,8 @@ import Control.Arrow import Control.Monad +import Data.Choice (pattern Is) +import Data.Choice qualified as Choice import Data.Foldable import Data.Function (on) import Data.List (sortBy) @@ -61,8 +66,8 @@ for_ ctx p_classContext switchLayout signatureSpans $ p_infixDefHelper - (isInfix fixity) - True + (Choice.fromBool (isInfix fixity)) + (Is #indentArgs) (p_rdrName name) (located' p_hsTyVarBndr <$> hsq_explicit) inci (p_classFundeps fdeps) diff --git a/src/Ormolu/Printer/Meat/Declaration/Data.hs b/src/Ormolu/Printer/Meat/Declaration/Data.hs --- a/src/Ormolu/Printer/Meat/Declaration/Data.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Data.hs @@ -81,8 +81,8 @@ forM_ dd_ctxt p_lhsContext switchLayout constructorSpans $ p_infixDefHelper - (isInfix fixity) - True + (Choice.fromBool (isInfix fixity)) + (Is #indentArgs) (p_rdrName name) (p_tyVar <$> tyVars) forM_ dd_kindSig $ \k -> do diff --git a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs --- a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs +++ b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs @@ -129,9 +129,27 @@ -- place the operator in a trailing position (because it would be -- read as being part of the do-block) && not (isDoBlock $ rightMostNode prevExpr) + -- A staircase of two or more trailing operators is only worthwhile when + -- the operand at the very end of the chain has a hanging form (a do + -- block, lambda, case, etc.): the trailing operator then introduces that + -- block. When such a chain ends in an ordinary expression (a variable, + -- literal, or plain application) the trailing layout only produces + -- ever-deepening indentation, so we fall back to the leading-operator + -- layout. A single hard splitter is exempt: it does not form a pyramid + -- and trailing is the idiomatic way to introduce its operand. + chainEndsInHangingForm = + case rightMostNode t of + OpNode (L _ n) -> exprPlacement n == Hanging + _ -> False + isSingleOperator = case ops of + [_] -> True + _ -> False -- If all operators at the current level match the conditions to be - -- trailing, then put them in a trailing position - isTrailing = all couldBeTrailing $ zip (NE.toList exprs) ops + -- trailing, and the chain is either a single operator or ends in a + -- hanging form, then put the operators in a trailing position. + isTrailing = + (isSingleOperator || chainEndsInHangingForm) + && all couldBeTrailing (zip (NE.toList exprs) ops) ub <- if isTrailing then return useBraces else opBranchBraceStyle placement indent <- getPrinterOpt poIndentation let p_x = ub $ p_exprOpTree s firstExpr diff --git a/src/Ormolu/Printer/Meat/Declaration/Type.hs b/src/Ormolu/Printer/Meat/Declaration/Type.hs --- a/src/Ormolu/Printer/Meat/Declaration/Type.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Type.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -- | Rendering of type synonym declarations. @@ -7,6 +10,7 @@ ) where +import Data.Choice (pattern Is, pattern Isn't) import GHC.Hs.Extension import GHC.Hs.Type import GHC.Parser.Annotation @@ -32,8 +36,11 @@ space switchLayout (getLocA name : map getLocA hsq_explicit) $ p_infixDefHelper - (case fixity of Infix -> True; _ -> False) - True + ( case fixity of + Infix -> Is #infixStyle + _ -> Isn't #infixStyle + ) + (Is #indentArgs) (p_rdrName name) (map (located' p_hsTyVarBndr) hsq_explicit) inci $ do diff --git a/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs b/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs --- a/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs +++ b/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -- | Rendering of data\/type families. @@ -10,6 +13,8 @@ where import Control.Monad +import Data.Choice (pattern Is) +import Data.Choice qualified as Choice import Data.Maybe (isNothing) import GHC.Hs import GHC.Types.Fixity @@ -33,8 +38,8 @@ breakpoint switchLayout headerSpns $ do p_infixDefHelper - (isInfix fdFixity) - True + (Choice.fromBool (isInfix fdFixity)) + (Is #indentArgs) (p_rdrName fdLName) (located' p_hsTyVarBndr <$> hsq_explicit) let resultSig = p_familyResultSigL fdResultSig @@ -93,8 +98,8 @@ let famLhsSpn = getLocA feqn_tycon : fmap lhsTypeArgSrcSpan feqn_pats switchLayout famLhsSpn $ p_infixDefHelper - (isInfix feqn_fixity) - True + (Choice.fromBool (isInfix feqn_fixity)) + (Is #indentArgs) (p_rdrName feqn_tycon) (p_lhsTypeArg <$> feqn_pats) inci $ do diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs b/src/Ormolu/Printer/Meat/Declaration/Value.hs --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -22,6 +22,7 @@ import Control.Monad import Data.Bool (bool) +import Data.Choice qualified as Choice import Data.Data hiding (Infix, Prefix) import Data.Function (on) import Data.Functor ((<&>)) @@ -219,8 +220,8 @@ case style of Function name -> p_infixDefHelper - isInfix - indentBody + (Choice.fromBool isInfix) + (Choice.fromBool indentBody) (p_rdrName name) (located' p_pat <$> m_pats) PatternBind -> stdCase @@ -280,11 +281,18 @@ breakpoint (located' (p_grhs' placement placer render groupStyle)) (NE.toList grhssGRHSs) + localBindsWhereSpan = case grhssLocalBinds of + HsValBinds (EpAnn {anns = AnnList {al_rest}}) _ -> + locA al_rest + HsIPBinds (EpAnn {anns = AnnList {al_rest}}) _ -> + locA al_rest + EmptyLocalBinds _ -> noSrcSpan p_where = do unless (eqEmptyLocalBinds grhssLocalBinds) $ do breakpoint indentWhere <- getPrinterOpt poIndentWheres - bool (inciByFrac (-1 / 2)) id indentWhere $ txt "where" + bool (inciByFrac (-1 / 2)) id indentWhere $ do + located (L localBindsWhereSpan ()) $ \_ -> txt "where" breakpoint inciIf indentWhere $ p_hsLocalBinds grhssLocalBinds inciIf indentBody $ do @@ -407,14 +415,15 @@ UnhelpfulSpan _ -> f x RealSrcSpan currentSpn _ -> do getSpanMark >>= \case - -- Spacing before comments will be handled by the code - -- that prints comments, so we just have to deal with - -- blank lines between statements here. - Just (StatementSpan lastSpn) -> - if srcSpanStartLine currentSpn > srcSpanEndLine lastSpn + 1 - then newline - else return () - _ -> return () + -- We deal with blank lines between statements here. The last mark + -- may be a 'StatementSpan' (the usual case) or a comment span: the + -- latter happens when the previous statement ended with a trailing + -- comment, in which case we still want to preserve a blank line that + -- followed that comment in the original input. + Just lastMark -> + let lastSpn = spanMarkSpan lastMark + in when (srcSpanStartLine currentSpn > srcSpanEndLine lastSpn + 1) newline + Nothing -> return () f x -- In some cases the (f x) expression may insert a new mark. We want -- to be careful not to override comment marks. diff --git a/src/Ormolu/Printer/Meat/ImportExport.hs b/src/Ormolu/Printer/Meat/ImportExport.hs --- a/src/Ormolu/Printer/Meat/ImportExport.hs +++ b/src/Ormolu/Printer/Meat/ImportExport.hs @@ -8,6 +8,7 @@ module Ormolu.Printer.Meat.ImportExport ( p_hsmodExports, p_hsmodImport, + enterMultilineLayoutIfContainsDocEntries, ) where @@ -28,12 +29,13 @@ p_hsmodExports :: [LIE GhcPs] -> R () p_hsmodExports xs = - parens' False $ do - layout <- getLayout - sep - breakpoint - (\(isAllPrevDoc, p, l) -> sitcc (located (addDocSrcSpan l) (p_lie layout isAllPrevDoc p))) - (withAllPrevDoc $ attachRelativePos xs) + enterMultilineLayoutIfContainsDocEntries xs $ + parens' False $ do + layout <- getLayout + sep + breakpoint + (\(isAllPrevDoc, p, l) -> sitcc (located (addDocSrcSpan l) (p_lie layout isAllPrevDoc p))) + (withAllPrevDoc $ attachRelativePos xs) where -- In order to correctly set the layout when a doc comment is present. addDocSrcSpan lie@(L l ie) = case ieExportDoc ie of @@ -195,6 +197,19 @@ IEGroup {} -> Nothing IEDoc {} -> Nothing IEDocNamed {} -> Nothing + +enterMultilineLayoutIfContainsDocEntries :: [LIE GhcPs] -> R () -> R () +enterMultilineLayoutIfContainsDocEntries xs = + if any (isDocEntry . unLoc) xs + then enterLayout MultiLine + else id + +isDocEntry :: (IE pass) -> Bool +isDocEntry = \case + IEDoc {} -> True + IEGroup {} -> True + IEDocNamed {} -> True + _ -> False ---------------------------------------------------------------------------- diff --git a/src/Ormolu/Printer/Meat/Module.hs b/src/Ormolu/Printer/Meat/Module.hs --- a/src/Ormolu/Printer/Meat/Module.hs +++ b/src/Ormolu/Printer/Meat/Module.hs @@ -12,7 +12,9 @@ import Control.Monad import Data.Choice (pattern With) +import Data.Choice qualified as Choice import GHC.Hs hiding (comment) +import GHC.LanguageExtensions (Extension (ImplicitPrelude)) import GHC.Types.SrcLoc import Ormolu.Config import Ormolu.Imports (normalizeImports) @@ -40,27 +42,39 @@ let XModulePs {..} = hsmodExt deprecSpan = maybe [] (pure . getLocA) hsmodDeprecMessage exportSpans = maybe [] (pure . getLocA) hsmodExports - switchLayout (deprecSpan <> exportSpans) $ do - forM_ mstackHeader $ \(L spn comment) -> do - spitCommentNow spn comment + switchLayout (deprecSpan <> exportSpans) $ + enterMultilineLayoutIfContainsDocEntries (maybe [] unLoc hsmodExports) $ do + forM_ mstackHeader $ \(L spn comment) -> do + spitCommentNow spn comment + newline newline - newline - p_pragmas pragmas - newline - mapM_ (p_hsModuleHeader hsmod) hsmodName - newline - respectful <- getPrinterOpt poRespectful - localModules <- getLocalModules - importGrouping <- getPrinterOpt poImportGrouping - forM_ (normalizeImports respectful localModules importGrouping hsmodImports) $ \importGroup -> do - forM_ importGroup (located' p_hsmodImport) + p_pragmas pragmas newline - declNewline - switchLayout (getLocA <$> hsmodDecls) $ do - preserveSpacing <- getPrinterOpt poRespectful - (if preserveSpacing then p_hsDeclsRespectGrouping else p_hsDecls) Free hsmodDecls + mapM_ (p_hsModuleHeader hsmod) hsmodName newline - spitRemainingComments + importGroups <- normalizeImportsR hsmodImports + forM_ importGroups $ \importGroup -> do + forM_ importGroup (located' p_hsmodImport) + newline + declNewline + switchLayout (getLocA <$> hsmodDecls) $ do + preserveSpacing <- getPrinterOpt poRespectful + (if preserveSpacing then p_hsDeclsRespectGrouping else p_hsDecls) Free hsmodDecls + newline + spitRemainingComments + where + normalizeImportsR imports = do + implicitPrelude <- Choice.fromBool <$> isExtensionEnabled ImplicitPrelude + respectful <- getPrinterOpt poRespectful + localModules <- getLocalModules + importGrouping <- getPrinterOpt poImportGrouping + pure $ + normalizeImports + implicitPrelude + respectful + localModules + importGrouping + imports p_hsModuleHeader :: HsModule GhcPs -> LocatedA ModuleName -> R () p_hsModuleHeader HsModule {hsmodExt = XModulePs {..}, ..} moduleName = do diff --git a/src/Ormolu/Printer/Operators.hs b/src/Ormolu/Printer/Operators.hs --- a/src/Ormolu/Printer/Operators.hs +++ b/src/Ormolu/Printer/Operators.hs @@ -203,9 +203,9 @@ indices -> splitTree noptExprs noptOps indices where indicesOfHardSplitter = - fmap fst $ - filter (isHardSplitterOp . opiFixityApproximation . snd) $ - zip [0 ..] noptOps + fmap fst + $ filter (isHardSplitterOp . opiFixityApproximation . snd) + $ zip [0 ..] noptOps indexOfMinMaxPrecOps [] = (Nothing, Nothing) indexOfMinMaxPrecOps (oo : oos) = go oos 1 oo (Just [0]) oo (Just [0]) where diff --git a/src/Ormolu/Processing/Preprocess.hs b/src/Ormolu/Processing/Preprocess.hs --- a/src/Ormolu/Processing/Preprocess.hs +++ b/src/Ormolu/Processing/Preprocess.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -12,6 +13,8 @@ import Data.Array as A import Data.Bifunctor (bimap) import Data.Char (isSpace) +import Data.Choice (Choice) +import Data.Choice qualified as Choice import Data.Function ((&)) import Data.IntMap (IntMap) import Data.IntMap.Strict qualified as IntMap @@ -29,13 +32,14 @@ -- and subregions to be formatted. preprocess :: -- | Whether CPP is enabled - Bool -> + Choice "cppEnabled" -> RegionDeltas -> Text -> [Either Text RegionDeltas] preprocess cppEnabled region rawInput = rawSnippetsAndRegionsToFormat where - (linesNotToFormat', replacementLines) = linesNotToFormat cppEnabled region rawInput + (linesNotToFormat', replacementLines) = + linesNotToFormat cppEnabled region rawInput regionsToFormat = intSetToRegions rawLineLength $ IntSet.fromAscList [1 .. rawLineLength] IntSet.\\ linesNotToFormat' @@ -91,7 +95,7 @@ -- for specific lines. linesNotToFormat :: -- | Whether CPP is enabled - Bool -> + Choice "cppEnabled" -> RegionDeltas -> Text -> (IntSet, IntMap Text) @@ -100,13 +104,16 @@ where unconsidered = IntSet.fromAscList $ - [1 .. regionPrefixLength] <> [totalLines - regionSuffixLength + 1 .. totalLines] + [1 .. regionPrefixLength] + <> [totalLines - regionSuffixLength + 1 .. totalLines] totalLines = length (T.lines input) regionLines = linesInRegion region input (magicDisabled, lineUpdates) = magicDisabledLines regionLines otherDisabled = mconcat allLines regionLines where - allLines = [shebangLines, linePragmaLines] <> [cppLines | cppEnabled] + allLines = + [shebangLines, linePragmaLines] + <> [cppLines | Choice.isTrue cppEnabled] -- | Ormolu state. data OrmoluState diff --git a/src/Ormolu/Utils/IO.hs b/src/Ormolu/Utils/IO.hs --- a/src/Ormolu/Utils/IO.hs +++ b/src/Ormolu/Utils/IO.hs @@ -16,7 +16,7 @@ import Data.Map.Lazy qualified as M import System.Directory import System.FilePath -import System.IO.Error (isDoesNotExistError) +import System.IO.Error (isDoesNotExistError, isPermissionError) -- | Find the path to the closest file higher in the file hierarchy that -- satisfies a given predicate. @@ -30,25 +30,36 @@ m (Maybe FilePath) findClosestFileSatisfying isRightFile rootOfSearch = liftIO $ do parentDir <- takeDirectory <$> makeAbsolute rootOfSearch - dirEntries <- - listDirectory parentDir `catch` \case - (isDoesNotExistError -> True) -> pure [] + maybeDirEntries <- + (Just <$> listDirectory parentDir) `catch` \case + -- The directory does not exist. This is expected: the search may start + -- from a path that does not exist yet (e.g. a file about to be created), + -- whose absolute form still lies below existing parent directories. + -- Treat it as empty and keep searching upwards. + (isDoesNotExistError -> True) -> pure (Just []) + -- We lack the permissions to read the directory, e.g. when running in a + -- sandbox that restricts access to parent directories. Abort the search: + -- we almost certainly cannot read any parent directory either. + (isPermissionError -> True) -> pure Nothing e -> throwIO e - let searchAtParentDirLevel = \case - [] -> pure Nothing - x : xs -> - if isRightFile x - then - doesFileExist (parentDir x) >>= \case - True -> pure (Just x) - False -> searchAtParentDirLevel xs - else searchAtParentDirLevel xs - searchAtParentDirLevel dirEntries >>= \case - Just foundFile -> pure . Just $ parentDir foundFile - Nothing -> - if isDrive parentDir - then pure Nothing - else findClosestFileSatisfying isRightFile parentDir + case maybeDirEntries of + Nothing -> pure Nothing + Just entries -> do + let searchAtParentDirLevel = \case + [] -> pure Nothing + x : xs -> + if isRightFile x + then + doesFileExist (parentDir x) >>= \case + True -> pure (Just x) + False -> searchAtParentDirLevel xs + else searchAtParentDirLevel xs + searchAtParentDirLevel entries >>= \case + Just foundFile -> pure . Just $ parentDir foundFile + Nothing -> + if isDrive parentDir + then pure Nothing + else findClosestFileSatisfying isRightFile parentDir newtype Cache k v = Cache (IORef (Map k v)) diff --git a/tests/Ormolu/Config/PrinterOptsSpec.hs b/tests/Ormolu/Config/PrinterOptsSpec.hs --- a/tests/Ormolu/Config/PrinterOptsSpec.hs +++ b/tests/Ormolu/Config/PrinterOptsSpec.hs @@ -410,7 +410,7 @@ Nothing -> expectationFailure "Output does not exist. Try running with ORMOLU_REGENERATE_EXAMPLES=1" Just expected -> - when (actual /= expected) $ + when (actual /= expected) $ do expectationFailure . T.unpack $ getDiff ("actual", actual) ("expected", expected) @@ -460,9 +460,9 @@ getDiff :: (String, Text) -> (String, Text) -> Text getDiff (s1Name, s1) (s2Name, s2) = - T.pack . Doc.render $ - Diff.prettyContextDiff (Doc.text s1Name) (Doc.text s2Name) (Doc.text . T.unpack . Diff.unnumber) $ - Diff.getContextDiff (Just 2) (T.lines s1) (T.lines s2) + T.pack . Doc.render + $ Diff.prettyContextDiff (Doc.text s1Name) (Doc.text s2Name) (Doc.text . T.unpack . Diff.unnumber) + $ Diff.getContextDiff (Just 2) (T.lines s1) (T.lines s2) renderOrmoluException :: OrmoluException -> IO String renderOrmoluException e = diff --git a/tests/Ormolu/FixitySpec.hs b/tests/Ormolu/FixitySpec.hs --- a/tests/Ormolu/FixitySpec.hs +++ b/tests/Ormolu/FixitySpec.hs @@ -201,44 +201,32 @@ ["esqueleto"] [package_ "bob" $ import_ "Database.Esqueleto.Experimental"] [(unqual "++.", defaultFixityApproximation)] - it "default module re-exports: Control.Lens brings into scope Control.Lens.Lens" $ + it "re-exports baked into the database: Control.Lens brings <+~ into scope" $ checkFixities ["lens"] - ( applyModuleReexports - defaultModuleReexports - [import_ "Control.Lens"] - ) + [import_ "Control.Lens"] [(unqual "<+~", FixityApproximation (Just InfixR) 4 4)] - it "default module re-exports: Control.Lens qualified brings into scope Control.Lens.Lens" $ + it "re-exports baked into the database: Control.Lens qualified" $ checkFixities ["lens"] - ( applyModuleReexports - defaultModuleReexports - [import_ "Control.Lens" & qualified_] - ) + [import_ "Control.Lens" & qualified_] [ (unqual "<+~", defaultFixityApproximation), - (qual "Control.Lens.Lens" "<+~", defaultFixityApproximation), (qual "Control.Lens" "<+~", FixityApproximation (Just InfixR) 4 4) ] - it "default module re-exports: Control.Lens qualified as brings into scope Control.Lens.Lens" $ + it "re-exports baked into the database: Control.Lens qualified as" $ checkFixities ["lens"] - ( applyModuleReexports - defaultModuleReexports - [import_ "Control.Lens" & qualified_ & as_ "L"] - ) + [import_ "Control.Lens" & qualified_ & as_ "L"] [ (unqual "<+~", defaultFixityApproximation), - (qual "Control.Lens.Lens" "<+~", defaultFixityApproximation), (qual "Control.Lens" "<+~", defaultFixityApproximation), (qual "L" "<+~", FixityApproximation (Just InfixR) 4 4) ] it "re-export chains: exported module can itself re-export another module" $ do let reexports = ModuleReexports $ - Map.insert + Map.singleton "Foo" ((Nothing, "Control.Lens") :| []) - (unModuleReexports defaultModuleReexports) checkFixities ["lens"] ( applyModuleReexports diff --git a/tests/Ormolu/PrinterSpec.hs b/tests/Ormolu/PrinterSpec.hs --- a/tests/Ormolu/PrinterSpec.hs +++ b/tests/Ormolu/PrinterSpec.hs @@ -64,6 +64,10 @@ "esqueleto", "hspec", "lens", + "megaparsec", + "optics", + "relude", + "rio", "servant" ] }