diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,610 @@ +## Ormolu 0.9.0.0 + +* Comments are now attached to the syntax tree by position, before anything + is printed, rather than by a cursor advanced as the printer walks the + tree. Which element owns a comment no longer depends on the order in which + the printer happens to visit things, so comments stop escaping the + construct they were written in when Ormolu sorts or regroups it: a comment + inside an import list stays there, a comment after a quasi-quote stops + floating to the bottom of the file, and a comment attached to an import + travels with that import when the imports are sorted. [Issue + 1074](https://github.com/tweag/ormolu/issues/1074) and [issue + 1076](https://github.com/tweag/ormolu/issues/1076). + +* Haddock comments are now printed as they were written instead of being + rebuilt from the documentation string GHC parsed out of them. A `{- | … + -}` stays a block comment rather than becoming `--` lines, an empty `-- |` + is no longer dropped, and a `{- *** … -}` section heading keeps its + meaning. [Issue 641](https://github.com/tweag/ormolu/issues/641), [issue + 822](https://github.com/tweag/ormolu/issues/822), and [issue + 1159](https://github.com/tweag/ormolu/issues/1159). + + Ormolu still puts a space after a Haddock's trigger, re-indents a block + Haddock to line up with the code it documents, and rewrites a trailing `-- + ^ X` as a leading `-- | X` when it moves the comment in front of what it + documents. + +* Backslashes are no longer added to lines in the middle of a comment block, + where Haddock does not look for a trigger anyway. [Issue + 1131](https://github.com/tweag/ormolu/issues/1131). + +* A comment written on its own line in front of an operator no longer + strands the operator at the start of the next line. In a `do` block that + changed what the code meant, because `$` at the beginning of a line is + read as a new statement rather than as a continuation of the previous one. + [Issue 1028](https://github.com/tweag/ormolu/issues/1028). + +* A comment written after `=`, `->`, or a lambda arrow now stays on that + line instead of being pushed onto the next one, and the result is + idempotent. `f x = -- note` no longer becomes an `=` stranded on a line of + its own. [Issue 786](https://github.com/tweag/ormolu/issues/786), [issue + 810](https://github.com/tweag/ormolu/issues/810), and [issue + 936](https://github.com/tweag/ormolu/issues/936). + +* Layout decisions now take comments into account. A comment that falls + inside a construct can no longer be squeezed into a single-line rendering + of it. + +* A comment block that trails a line of code and continues below it no + longer drops to the start of the line, which could put the rest of the + block outside the construct it was written in. + +* A construct that brackets its contents is no longer put on one line when + something inside it is documented with a `-- |` Haddock. Such a Haddock + takes whole lines, so it used to swallow the closing bracket: a documented + `deriving` clause came out as `deriving (-- | B`, and a documented field + of a short record as `{-- | …`, which did not even parse. [Issue + 752](https://github.com/tweag/ormolu/issues/752) and [issue + 1164](https://github.com/tweag/ormolu/issues/1164). + + A `{- | … -}` Haddock is self-delimiting and does not force anything, so + a declaration documented that way is left as it was written rather than + being broken up: `data A = A {- | a number -} Int Bool` stays on one line + where it used to be spread over five. + +* Only pragmas in the file header are hoisted to the top of the module now. + A `LANGUAGE` or `OPTIONS_GHC` pragma written after the first import or + declaration stays where it is, and no longer drags the comments above it + to the top of the file. GHC reads the header and stops, so such a pragma + never affected compilation; moving it was giving it an effect it did not + have. [Issue 1168](https://github.com/tweag/ormolu/issues/1168). + +* A comment above a `{-# LANGUAGE A, B #-}` pragma is no longer duplicated + when the pragma is split into one per extension; it stays with the first. + [Issue 787](https://github.com/tweag/ormolu/issues/787). + +* Ormolu now checks that the comments of the output correspond to the + comments of the input—none dropped, duplicated, invented, or reordered—and + refuses to format when they do not. This runs alongside the existing check + that the AST is unchanged, is disabled by `--unsafe`, and costs nothing + extra: the printer already records where it put each comment. + +## 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). + +## 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 + +* 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: + * 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). + +* Fix printing of multi-line or-patterns inside as-patterns. [Issue + 1183](https://github.com/tweag/ormolu/issues/1183). + +* Fix an issue where or-patterns would be indented twice. [Issue + 1188](https://github.com/tweag/ormolu/issues/1188). + +* Add support for `ExplicitLevelImports`. [Issue + 1192](https://github.com/tweag/ormolu/issues/1192). + +## Ormolu 0.8.0.2 + +* Fix a performance regression introduced in 0.8.0.0. [Issue + 1176](https://github.com/tweag/ormolu/issues/1176). + +## Ormolu 0.8.0.1 + +* Correctly format edge cases where fully collapsing string gaps changes the + string represented by a string literal. [Issue + 1160](https://github.com/tweag/ormolu/issues/1160). + +* Fix false positives in AST diffing in fixity declarations with implicit + fixity, such as `infix +`. [Issue + 1166](https://github.com/tweag/ormolu/issues/1166). + +* Make multiline function signatures in RequiredTypeArguments consistent with + types [PR 1170](https://github.com/tweag/ormolu/pull/1170). + +* Correctly format single-line `MultiWayIf`s. [Issue + 1171](https://github.com/tweag/ormolu/issues/1171). + +## Ormolu 0.8.0.0 + +* Format multiple files in parallel. [Issue + 1128](https://github.com/tweag/ormolu/issues/1128). + +* Fractional precedences are now allowed in `.ormolu` files for more precise + control over formatting of complex operator chains. [Issue + 1106](https://github.com/tweag/ormolu/issues/1106). + +* Correctly format type applications of `QuasiQuotes`. [Issue + 1134](https://github.com/tweag/ormolu/issues/1134). + +* Correctly format multi-line parentheses in arrow `do` blocks. [Issue + 1144](https://github.com/tweag/ormolu/issues/1144). + +* Switched to `ghc-lib-parser-9.12`, with the following new syntactic features: + * GHC proposal [#522](https://github.com/ghc-proposals/ghc-proposals/blob/c9401f037cb22d1661931b2ec621925101052997/proposals/0522-or-patterns.rst): `OrPatterns` (enabled by default) + * GHC proposal [#569](https://github.com/ghc-proposals/ghc-proposals/blob/c9401f037cb22d1661931b2ec621925101052997/proposals/0569-multiline-strings.rst): `MultilineStrings` (disabled by default) + * GHC proposal [#409](https://github.com/ghc-proposals/ghc-proposals/blob/f79438cf8dbfcd90187f7af3a380515ffe45dbdc/proposals/0409-exportable-named-default.rst): `NamedDefaults` (enabled by default) + * GHC proposal [#281](https://github.com/ghc-proposals/ghc-proposals/blob/c9401f037cb22d1661931b2ec621925101052997/proposals/0281-visible-forall.rst): accept more types in terms: `forall` quantifications, constraint arrows `=>`, type arrows `->` (enabled by default) + * Part of GHC proposal [#425](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0425-decl-invis-binders.rst): wildcard binders (enabled by default) + +* Correctly format non-promoted type-level tuples with `NoListTuplePuns`. [Issue + 1146](https://github.com/tweag/ormolu/issues/1146). + +* Updated to `Cabal-syntax-3.14`. [Issue + 1152](https://github.com/tweag/ormolu/issues/1152). + +## Ormolu 0.7.7.0 + +* Use single-line layout for parens around single-line content. [Issue + 1120](https://github.com/tweag/ormolu/issues/1120). + +* Allow function arguments to be on the same line even if the full type + (with constraints and foralls) are on multiple lines. [PR + 1125](https://github.com/tweag/ormolu/pull/1125). + +## Ormolu 0.7.6.0 + +* Fix Haddock comments on infix constructors. [Issue + 758](https://github.com/tweag/ormolu/issues/758). + +* Don't require a trailing newline in `.ormolu` files. [Issue + 1122](https://github.com/tweag/ormolu/issues/1122). + +* Remove unnecessary indentation from list comprehensions. [Issue + 966](https://github.com/tweag/ormolu/issues/966). + +## Ormolu 0.7.5.0 + +* Switched to `ghc-lib-parser-9.10`, with the following new syntactic features/behaviors: + * GHC proposal [#575](https://github.com/ghc-proposals/ghc-proposals/blob/10290a668608d608c3f6c6010be265cf7a02e1fc/proposals/0575-deprecated-instances.rst): deprecated instances. + * GHC proposal [#281](https://github.com/ghc-proposals/ghc-proposals/blob/10290a668608d608c3f6c6010be265cf7a02e1fc/proposals/0281-visible-forall.rst): visible forall in types of terms. + Enabled by `RequiredTypeArguments` (enabled by default). + * `LinearTypes`: `let` and `where` bindings can now be linear, in particular have multiplicity annotations. + * Using `forall` as an identifier is now a parse error. + * GHC proposal [#65](https://github.com/ghc-proposals/ghc-proposals/blob/10290a668608d608c3f6c6010be265cf7a02e1fc/proposals/0065-type-infix.rst): namespacing fixity declarations for type names and WARNING/DEPRECATED pragmas. + * `TypeAbstractions` now supports `@`-binders in lambdas and function equations. + * Support for the `GHC2024` language. + +* Updated to `Cabal-syntax-3.12`. + +## Ormolu 0.7.4.0 + +* Don't error when the `JavaScriptFFI` language pragma is present. [Issue + 1087](https://github.com/tweag/ormolu/issues/1087). +* Improve comment placement in if-then-else blocks. [Issue + 998](https://github.com/tweag/ormolu/issues/998). +* Now command line options for fixity overrides and module re-exports + overwrite information from `.ormolu` files. [Issue + 1030](https://github.com/tweag/ormolu/issues/1030). +* Respect newlines in data declarations in more cases. [Issue + 1077](https://github.com/tweag/ormolu/issues/1077) and [issue + 947](https://github.com/tweag/ormolu/issues/947). +* The `-d / --debug` command line option now makes Ormolu print out debug + information regarding operator fixity inference. [Issue + 1060](https://github.com/tweag/ormolu/issues/1060). + +## Ormolu 0.7.3.0 + +* Switched to `ghc-lib-parser-9.8`, with the following new syntactic features: + * `ExtendedLiterals`: `123#Int8` is a literal of type `Int8#`. (disabled by + default) + * `TypeAbstractions`: `@k`-binders in data type declarations (enabled by + default) + * GHC proposal [#134](https://github.com/ghc-proposals/ghc-proposals/blob/0b652bd70258e354dfe4a05940182007596f8bf7/proposals/0134-deprecating-exports-proposal.rst): deprecating/warning about exports + * GHC proposal [#541](https://github.com/ghc-proposals/ghc-proposals/blob/0b652bd70258e354dfe4a05940182007596f8bf7/proposals/0541-warning-pragmas-with-categories.rst): warning categories + +## Ormolu 0.7.2.0 + +* Preserve necessary braces for final function arguments. [Issue + 1044](https://github.com/tweag/ormolu/issues/1044). + +* Put `"this"` `PackageImports` at the end. [Issue + 1048](https://github.com/tweag/ormolu/issues/1048). + +* Format parenthesized operators starting with a `#` correctly in the presence + of `UnboxedSums`. [Issue 1062](https://github.com/tweag/ormolu/issues/1062). + +* Fix false positives in AST diffing related to empty Haddock comments in data + declarations. [Issue 1065](https://github.com/tweag/ormolu/issues/1065). + +## Ormolu 0.7.1.0 + +* Include `base` fixity information when formatting a Haskell file that's + not mentioned in an existing cabal file. [Issue + 1032](https://github.com/tweag/ormolu/issues/1032) + +* Update `displayException` for `OrmoluException` to pretty print the + exception. [PR 1031](https://github.com/tweag/ormolu/pull/1031). + +* Ormolu is now aware of more common module re-exports by default. + +* Support explicit mention of target package name in module re-exports. Even + if the exported package is not specified as a direct dependency of the + component being formatted it will still be taken into account correctly. + [Issue 1037](https://github.com/tweag/ormolu/issues/1037). + +* Ormolu no longer fails when CPP directly follows the import section (a + regression introduced in 0.7.0.0). [Issue + 1040](https://github.com/tweag/ormolu/issues/1040). + +## Ormolu 0.7.0.0 + +* Inference of operator fixity information is now more precise and takes + into account the import section of the module being formatted. [Issue + 892](https://github.com/tweag/ormolu/issues/892) and [issue + 929](https://github.com/tweag/ormolu/issues/929). + +* Ormolu can now be made aware of module re-exports through either special + declarations in `.ormolu` files (see the readme for a description of the + syntax), or on the command line with the `--reexport`/`-r` option. [Issue + 1017](https://github.com/tweag/ormolu/issues/1017). + +* Ormolu now looks for `.ormolu` files independently of `.cabal` files. This + means that it is now possible to have one `.ormolu` file for multiple + Cabal packages. [Issue 1019](https://github.com/tweag/ormolu/issues/1019). + +* Consistently format `do` blocks/`case`s/`MultiWayIf`s with 4 spaces if and + only if they occur as the applicand. [Issue + 1002](https://github.com/tweag/ormolu/issues/1002) and [issue + 730](https://github.com/tweag/ormolu/issues/730). + +* Support the (deprecated) `DatatypeContexts` extension to avoid surprises. + [Issue 1012](https://github.com/tweag/ormolu/issues/1012). + +* Don't let comments escape from empty export lists. [Issue + 906](https://github.com/tweag/ormolu/issues/906). + +* Format `\cases` with multiple patterns across multiple lines correctly. [Issue + 1025](https://github.com/tweag/ormolu/issues/1025). + +## Ormolu 0.6.0.1 + +* Fix false positives in AST diffing related to `UnicodeSyntax`. [PR + 1009](https://github.com/tweag/ormolu/pull/1009). + +## Ormolu 0.6.0.0 + +* Haddocks attached to arguments of a data constructor are now formatted in + the pipe style (rather than the caret style), consistent with everything + else. As a consequence, now Ormolu's output will be deemed invalid by the + Haddock shipped with GHC <9.0. [Issue + 844](https://github.com/tweag/ormolu/issues/844) and [issue + 828](https://github.com/tweag/ormolu/issues/828). + +* Insert space before char literals in ticked promoted constructs when + necessary. [Issue 1000](https://github.com/tweag/ormolu/issues/1000). + +* Switched to `ghc-lib-parser-9.6`: + * Extended `OverloadedLabels`: `#Foo`, `#3`, `#"Hello there"`. + + Also, it is now disabled by default, as it causes e.g. `a#b` to be parsed + differently. + * New extension: `TypeData`, enabled by default. + * Parse errors now include error codes, cf. https://errors.haskell.org. + +* Updated to `Cabal-syntax-3.10`. + +* Now whenever Ormolu fails to parse a `.cabal` file it also explains why. + [PR 999](https://github.com/tweag/ormolu/pull/999). + +## Ormolu 0.5.3.0 + +* Stop making empty `let`s move comments. [Issue + 917](https://github.com/tweag/ormolu/issues/917). + +* Now `.ormolu` fixity override files can use both LF and CRLF line endings. + [PR 969](https://github.com/tweag/ormolu/pull/969). + +* Normalize parentheses around constraints. [Issue + 264](https://github.com/tweag/ormolu/issues/264). + +* The `ormolu` function now consumes `Text` instead of `String` due to an + internal refactoring. + +* Exposed a more complete public API in the `Ormolu` module. The API is + supposed to be stable and change according to + [PVP](https://pvp.haskell.org/). + +* Now warnings regarding Ormolu not being able to find `.cabal` files or + finding such files but them not mentioning the source file in question are + only displayed when `--debug` is used. Printing the warnings by default + seems to have been confusing, see e.g. [Issue + 971](https://github.com/tweag/ormolu/issues/971) and [issue + 924](https://github.com/tweag/ormolu/issues/924). + +## Ormolu 0.5.2.0 + +* Eliminated the `fixity-th` Cabal flag because it caused issues on GHC 9.4 as + well as on aarch64. See [issue + 941](https://github.com/tweag/ormolu/issues/941) and [issue + 927](https://github.com/tweag/ormolu/issues/927). + +* Now operators without explicitly specified fixity default to left + associativity and highest precedence. [Issue + 907](https://github.com/tweag/ormolu/issues/907). + +## Ormolu 0.5.1.0 + +* Imports are now sorted by package qualifier, if one is present. + [Issue 905](https://github.com/tweag/ormolu/issues/905). + +* Extension packs like `GHC2021` and `Haskell2010` are now bumped to the top of + the list of language pragmas. [Issue + 922](https://github.com/tweag/ormolu/issues/922). + +* Fix formatting of `SCC` pragmas in `do` blocks. [Issue + 925](https://github.com/tweag/ormolu/issues/925). + +* Support type applications in patterns. [Issue + 930](https://github.com/tweag/ormolu/issues/930). + +* Handle `UnicodeSyntax` variants more consistently. [Issue + 934](https://github.com/tweag/ormolu/issues/934). + +* Fix an inconsistency in formatting of types in GADT declarations in + certain cases. [PR 932](https://github.com/tweag/ormolu/pull/932). + +* Switched to `ghc-lib-parser-9.4`, which brings support for the following new + syntactic features: + * `\cases` via `LambdaCase` + * `OPAQUE` pragmas + * Unboxed sum type constructors like `(# | #)`. + +* Updated to `Cabal-syntax-3.8`, supporting `cabal-version: 3.8`. + +## Ormolu 0.5.0.1 + +* 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. + [Issue 893](https://github.com/tweag/ormolu/issues/893). + +* Fix `hs-source-dirs: .` resulting in failing to find a `.cabal` file for a + Haskell source file. [Issue 909](https://github.com/tweag/ormolu/issues/909). + +* Comments in closed type family declarations are now indented correctly. + [Issue 913](https://github.com/tweag/ormolu/issues/913). + +* Cache `.cabal` file parsing and processing when given multiple input files in + the same project. This results in dramatic speedups on projects which have + both huge `.cabal` files and a large number of individual modules. [Issue + 897](https://github.com/tweag/ormolu/issues/897). + +## Ormolu 0.5.0.0 + +* Changed the way operator fixities and precedences are inferred. + * Ormolu now tries to locate `.cabal` files of source files by default and + in addition to default extensions it also infers the list of + dependencies. + * Ormolu comes equipped with extensive knowledge of all packages on + Hackage and operators that those packages define. Knowing the names of + the dependencies it can select the right fixity and precedence info from + its knowledge base. + * You can ask Ormolu not to look for `.cabal` files by using the + `--no-cabal` switch. + * Dependencies can be selected manually by using the `-p / --package` + option (can be repeated many times). + * The default heuristic algorithm will still try to guess the right + fixities and precedence. + * Fixity overrides can be provided by the user in the familiar Haskell + notation (e.g. `infixr 9 .`, one declaration per line). They are loaded + by default from the `.ormolu` file that is expected to be in the same + directory as the `.cabal` file of a given source file. However, if + `--no-cabal` is supplied, the `.ormolu` file will not be looked for either. + Fixity declarations can be also provided by using the `-f / --fixity` + command line option, which see. + * This resolves the following issues: [Issue + 826](https://github.com/tweag/ormolu/issues/826), [Issue + 785](https://github.com/tweag/ormolu/issues/785), [Issue + 690](https://github.com/tweag/ormolu/issues/690), [Issue + 825](https://github.com/tweag/ormolu/issues/825). + +* Invalid haddock comments are formatted in a more consistent way. Leading + haddock triggers (`|`, `^`) in an invalid haddock comment block are now + escaped with a backslash `\`. [Issue + 816](https://github.com/tweag/ormolu/issues/816). + +* Type synonyms and families are now formatted correctly when the equals sign + is preceded by a comment. [Issue 829]( + https://github.com/tweag/ormolu/issues/829). + +* Bidirectional pattern synonyms are formatted nicer in certain cases. + [Issue 843](https://github.com/tweag/ormolu/issues/843). + +* Magic comments (like `{- ORMOLU_DISABLED -}`) now allow arbitrary + succeeding text. This fixes use cases like [Issue + 856](https://github.com/tweag/ormolu/issues/856). + +* Remove discrepancies between unboxed types and terms. [Issue 856 + ](https://github.com/tweag/ormolu/issues/856). + * Unboxed sum types are now formatted with a space before each `|`. + * Unboxed unit tuples on type and value levels are formatted as `(# #)`. + +* Errors caused by AST differences now print before/after diffs. + [Issue 877](https://github.com/tweag/ormolu/issues/877). + +* Improved formatting of data declarations in the case of single-constructor + record with a Haddock. [Issue + 881](https://github.com/tweag/ormolu/issues/881). + +## Ormolu 0.4.0.0 + +* When a guard is located on its own line, the body associated with this + guard is indented by one extra level, so that it can easily be + distinguished from the guard predicate or pattern. [Issue + 806](https://github.com/tweag/ormolu/issues/806). + +* Now a space is forced after `--` in line comments. [Issue + 808](https://github.com/tweag/ormolu/issues/808). + +* Allow formatting Backpack signature files (`.hsig`). The switch between + regular module mode and signature mode is based on the file extension by + default, but can be overridden with the `-t / --source-type` command line + option. [Issue 600](https://github.com/tweag/ormolu/issues/600). + +* Blank Haddock comments are now eliminated. This also fixes issues with + differing ASTs in some special cases. [Issue + 726](https://github.com/tweag/ormolu/issues/726). + +* Rewrite rules that are never active are now formatted correctly. + [Issue 823](https://github.com/tweag/ormolu/issues/823). + +* Promoted infix data constructors are now formatted correctly. [Issue 768]( + https://github.com/tweag/ormolu/issues/768). + +* Switched to `ghc-lib-parser-9.2`. + [Issue 794](https://github.com/tweag/ormolu/issues/794). + * Support for the new syntax-related language extensions: + `OverloadedRecordDot` and `OverloadedRecordUpdate` + (disabled by default). + [Issue 709](https://github.com/tweag/ormolu/issues/709). + * Removed support for `record-dot-preprocessor`. For the getter syntax, + consider using `OverloadedRecordDot` instead. [Issue + 659](https://github.com/tweag/ormolu/issues/659). [Issue + 705](https://github.com/tweag/ormolu/issues/705). + * Support for the `GHC2021` language. + +## Ormolu 0.3.1.0 + +* Allow check mode when working with stdin input. [Issue 634]( + https://github.com/tweag/ormolu/issues/634). + +* Now guards are printed on a new line if at least one guard is multiline or + if all guards together occupy more than one line. The body of each guard + is also indented one level deeper in that case. [Issue + 712](https://github.com/tweag/ormolu/issues/712). + +* Invalid Haddock comments are no longer silently deleted, but rather converted + into regular comments. [Issue 474](https://github.com/tweag/ormolu/issues/474). + +## Ormolu 0.3.0.1 + +* Improvements to `.cabal` file handling: + * When looking for a `.cabal` file, directories were previously + erroneously also considered. [Issue 781]( + https://github.com/tweag/ormolu/issues/781). + * We now print a note if Ormolu was told to consider + `.cabal` files, but no suitable one could be found. + * Handle an empty `hs-source-dirs` correctly. + * Also consider modules which are only conditionally listed + in the `.cabal` file. + +* The special handling of CPP is now only applied if CPP is + actually enabled. [Issue 782](https://github.com/tweag/ormolu/issues/782). + +* The left hand side of the `:` operator now uses braces if + necessary. [Issue 780](https://github.com/tweag/ormolu/issues/780). + +## Ormolu 0.3.0.0 + +* Data declarations with multiline kind signatures are now formatted + correctly. [Issue 749](https://github.com/tweag/ormolu/issues/749). + +* Infix arrow command formations are formatted like usual operators. + This fixes [Issue 748](https://github.com/tweag/ormolu/issues/748). + +* `do` arrow commands are formatted more flexibly. Fixes [Issue + 753](https://github.com/tweag/ormolu/issues/753). + +* Source code is always read and written using UTF8 and ignoring the native + line ending conventions. [Issue + 717](https://github.com/tweag/ormolu/issues/717). + +* Opt-in support to respect default-extensions and default-language + from .cabal files. [Issue 517](https://github.com/tweag/ormolu/issues/517). + +* Empty case expressions are now rendered with braces. [Issue + 765](https://github.com/tweag/ormolu/issues/765). + +* Omit braces on repeated application of `do` blocks. [Issue + 735](https://github.com/tweag/ormolu/issues/735). + +* Improved handling of disabled regions. [PR 773]( + https://github.com/tweag/ormolu/pull/773). + * Disabled regions are now exactly preserved, in particular + empty lines and trailing spaces. [Issue + 673](https://github.com/tweag/ormolu/issues/673). + * Strings like `-}` can now be present in disabled regions. + [Issue 708](https://github.com/tweag/ormolu/issues/708). + + This means that using CPP or magic comments in certain ways which + were only supported as a side effect previously (like in + [Issue 601](https://github.com/tweag/ormolu/issues/601)) + will now result in formatting failures. Also see [Issue 774]( + https://github.com/tweag/ormolu/issues/774). + ## Ormolu 0.2.0.0 * Now standalone kind signatures are grouped with type synonyms. [Issue @@ -54,7 +661,7 @@ Previously, if an extension was disabled via the CLI, it could not be re-enabled per file. -* `LexicalNegation` is no longer enabled by default. Also, spaces after +* `NegativeLiterals` is no longer enabled by default. Also, spaces after negation via `-` are removed where possible. [Issue 694](https://github.com/tweag/ormolu/issues/694). @@ -64,9 +671,10 @@ * Added support for left-to-right arrow application. [Issue 737](https://github.com/tweag/ormolu/issues/737). -* Now `--mode check` fails on missing trailing blank lines. +* 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 @@ -79,7 +687,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). @@ -89,7 +697,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). ## Ormolu 0.1.3.0 @@ -105,7 +713,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 @@ -130,48 +738,48 @@ * 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). ## 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). @@ -179,17 +787,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`. @@ -216,7 +824,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 @@ -237,7 +845,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 @@ -255,15 +863,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. @@ -275,7 +883,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 @@ -293,20 +901,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 @@ -326,7 +934,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/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -1,64 +1,52 @@ # Contributing -Issues (bugs, feature requests or otherwise feedback) may be reported in -[the GitHub issue tracker for this project][issues]. Pull requests are also +Issues (bugs, feature requests, or other feedback) may be reported in [the +GitHub issue tracker for this project][issues]. Pull requests are also welcome. When contributing to this repository, please first discuss the change you wish to make via an issue, unless it's entirely trivial (typo fixes, etc.). If there is already an issue that describes the change you have in mind, -comment on it indicating that you're going to work on that. This way we can -avoid the situation when several people work on the same thing. +comment on it to indicate that you're going to work on it. This way we can +avoid situations where several people work on the same thing. -Please make sure that all non-trivial changes are described in commit +Please make sure that all non-trivial changes are described in the commit messages and PR descriptions. -## What to hack on? - -* [Fixing bugs][bugs]. This is the main focus right now. - -### Testing +## Testing -Testing has been taken good care of and now it amounts to just adding -examples under `data/examples`. Each example is a pair of files: -`.hs` for input and `-out.hs` for corresponding -expected output. +Testing is well taken care of, so it usually amounts to just adding examples +under `data/examples`. Each example is a pair of files: `.hs` +for the input and `-out.hs` for the corresponding expected +output. -Testing is performed as following: +Testing is performed as follows: -* Given snippet of source code is parsed and pretty-printed. -* The result of printing is parsed back again and the AST is compared to the - AST obtained from the original file. They should match. -* The output of printer is checked against the expected output. -* Idempotence property is verified: formatting already formatted code +* The given snippet of source code is parsed and pretty-printed. +* The result of printing is parsed again, and its AST is compared to the AST + obtained from the original file. The two should match. +* The output of the printer is checked against the expected output. +* The idempotence property is verified: formatting already formatted code results in exactly the same output. -Examples can be organized in sub-directories, see the existing ones for +Examples can be organized into sub-directories; see the existing ones for inspiration. -Please note that we try to keep individual files at most 25 lines long -because otherwise it's hard to figure out want went wrong when a test fails. - -## CI - -We use Circle CI. Some outside contributors may have problems, as in, CI -won't run for PRs opened from forks with “unauthorized” errors. In that case -the best we can do is to add you as a contributor or to restart your build -manually. +Please note that we try to keep individual files at most 25 lines long, +because otherwise it's hard to figure out what went wrong when a test fails. -If you have been added as a contributor but the builds still do not start, -try clicking +To regenerate outputs that have changed, you can set the +`ORMOLU_REGENERATE_EXAMPLES` environment variable before running tests. -``` -User settings -> Account integrations -> Refresh permissions -``` +## Formatting -in Circle CI app. + - Use the `nix run .#format` script to format Ormolu with the current + version of Ormolu. -## Formatting + - Additional formatters are configured via a pre-commit hook, which is + installed automatically when you enter the Nix shell. You can also run it + via `pre-commit run` or `pre-commit run -a`. -Use `format.sh` script to format Ormolu with current version of Ormolu. If -Ormolu is not formatted like this, the CI will fail. +If Ormolu is not formatted this way, CI will fail. -[issues]: https://github.com/tweag/ormolu/issues -[bugs]: https://github.com/tweag/ormolu/issues?q=is%3Aissue+is%3Aopen+label%3Abug +[issues]: https://github.com/mrkkrp/ormolu/issues diff --git a/DESIGN.md b/DESIGN.md --- a/DESIGN.md +++ b/DESIGN.md @@ -19,10 +19,10 @@ * [Why not contribute to/fork Hindent or Brittany?](#why-not-contribute-tofork-hindent-or-brittany) * [Examples](#examples) -This document describes design of a new formatter for Haskell source code. +This document describes the design of a new formatter for Haskell source code. It also includes recommendations for future implementers. -We set for the following goals (mostly taken from +We set the following goals (mostly taken from [brittany](https://github.com/lspitzner/brittany)): * Preserve the meaning of the formatted functions when no CPP is used; * Make reasonable use of screen space; @@ -38,12 +38,12 @@ ### Brittany [Brittany][brittany] builds on top of [`ghc-exactprint`][ghc-exactprint]—a -library that uses parser of GHC itself for parsing and thus it guarantees -that at least parsing phase is bug-free (which is admittedly the cause of -majority of bugs in other projects, see below). +library that uses the parser of GHC itself for parsing and thus it guarantees +that at least the parsing phase is bug-free (which is admittedly the cause of +the majority of bugs in other projects, see below). -After parsing, Haskell AST and a collection of annotations are available. -The annotations are there because Haskell AST doesn't provide enough +After parsing, the Haskell AST and a collection of annotations are available. +The annotations are there because the Haskell AST doesn't provide enough information to reconstruct source code (for example it doesn't include comments). The AST and the annotations are converted into a `BriDoc` value. A `BriDoc` value is a document representation like the `Doc` from the @@ -65,13 +65,13 @@ of which fit in linear space. So care is necessary to keep memory bounded. -The compexities of the `BriDoc` structure, together with the lack of +The complexities of the `BriDoc` structure, together with the lack of documentation, make Brittany at least challenging to maintain. ### Hindent [Hindent][hindent] uses [`haskell-src-exts`][haskell-src-exts] for parsing -like all older projects. `haskell-src-exts` does not use parser of GHC +like all older projects. `haskell-src-exts` does not use the parser of GHC itself, and is a source of endless parsing bugs. `Hindent` is affected by these upstream issues as well as Stylish Haskell and Haskell formatter (see below). This already makes all these projects unusable with some valid @@ -83,13 +83,13 @@ that the 70-80% of what the code does is a printing traversal. Hindent code is easier to read and debug. Pretty-printing functions are -very straightforward. If there is a bug (in pretty-printer, not in parser +very straightforward. If there is a bug (in the pretty-printer, not in the parser which Hindent cannot control), it's easy to fix AFAIU. Hindent is also notable for its ability to handle CPP and inputs that do not -constitute complete modules. It splits input stream into so-called “code +constitute complete modules. It splits the input stream into so-called “code blocks” recognizing CPP macros and then only pretty-prints “normal code” -without touching CPP directives. After that CPP is inserted between +without touching CPP directives. After that, CPP is inserted between pretty-printed blocks of source code. The approach fails when CPP breaks code in such a way that separate blocks do not form valid Haskell expressions, see @@ -98,22 +98,22 @@ Looking at the bug tracker there are many bugs. Part of them is because of the use of `haskell-src-exts`, the other part is because the maintainer doesn't care (anymore?) and doesn't fix them. Well it's as simple as that, -with any sort of commercial backing the bugs in pretty printer would be -fixed long time ago. +with any sort of commercial backing the bugs in the pretty printer would +have been fixed a long time ago. ### Stylish Haskell [Stylish Haskell][stylish-haskell] also uses `haskell-src-exts` and suffers from the same upstream problems. I haven't studied the transformations it performs, but it looks like it transforms the parsed source code partially -by manipulating AST and partially by manipulating raw text (e.g. to drop -trailing whitspace from each line). CPP Macros are just filtered out +by manipulating the AST and partially by manipulating raw text (e.g. to drop +trailing whitespace from each line). CPP macros are just filtered out silently as a preprocessing step before feeding the code to `haskell-src-exts`. -Stylish Haskell is not so invasive as the other formatters and most reported +Stylish Haskell is not as invasive as the other formatters and most reported bugs are about parsing issues and CPP. As I understand it, people mostly use -it to screw their import lists. +it to sort their import lists. ### Haskell formatter @@ -147,7 +147,7 @@ There are the following challenges when formatting a module with CPP: -* GHC parser won't accept anything but a valid, complete module. Therefore, +* The GHC parser won't accept anything but a valid, complete module. Therefore, formatting the Haskell code between CPP directives is not an option. * Ignoring the CPP directives and formatting the Haskell code can change @@ -225,8 +225,8 @@ directives, constraining how directives can be inserted in Haskell code to avoid changing the meaning by reformatting. But this would introduce additional complexity, and the problem would -need to be solved repeteadly for every tool out there which wants -to parse Haskell modules. If CPP is replaced with some language +need to be solved repeatedly for every tool out there which wants +to parse Haskell modules. If CPP is replaced by some language extension or mechanism to do conditional compilation, all tools will benefit from it. @@ -313,7 +313,7 @@ might be used in multiple projects, and we prefer to have it formatted the same in all of them. -See this [this +See [this post][hindent-5-blog] by Chris Done (the author of Hindent) which says that as long as the default style is conventional and good it doesn't really matter how code gets formatted. Consistency is more important. @@ -323,10 +323,10 @@ Some language extensions affect how parsing is done. We are going to deal with those in two ways: -* When language pragmas are present in source file, we must parse them +* When language pragmas are present in the source file, we must parse them before we run the main parser (I guess) and they should determine how the main parsing will be done. -* There also should be configuration file that may enable other language +* There should also be a configuration file that may enable other language extensions to be used on all files. * Later we could try to locate Cabal files and fetch the list of extensions that are enabled by default from there. @@ -337,11 +337,11 @@ pretty-printing code and new issues are discovered. For each Haskell module that we want to test, we perform the following steps: -1. Given input snippet of source code parse it and pretty print it. -2. Parse the result of pretty-printing again and make sure that AST is the - same as AST of original snippet module span positions. We could make +1. Given an input snippet of source code, parse it and pretty print it. +2. Parse the result of pretty-printing again and make sure that the AST is the + same as the AST of the original snippet module span positions. We could make this part of a self-check in the formatter. -3. Check the output against expected output. Thus all tests should include +3. Check the output against the expected output. Thus all tests should include two files: input and expected output. 4. Check that running the formatter on the output produces the same output again (the transformation is idempotent). @@ -366,7 +366,7 @@ * An option to specify location of config file. * Options to specify parameters that come from config files on command line instead (currently this is just dynamic options enabled by default, such - as langauge extensions). + as language extensions). ### Why not contribute to/fork HIndent or Brittany? @@ -386,8 +386,8 @@ Forking or contributing to Hindent is not an option because if we replace `haskell-src-exts` with `ghc` (or `ghc-exact-print`) then we'll have to work with a different AST type and all the code in Hindent will become -incompatible and there won't be much code to be re-used in that case. It is -also possible that we'll find a nicer way to write pretty-printer. +incompatible and there won't be much code to be reused in that case. It is +also possible that we'll find a nicer way to write the pretty-printer. ## Examples diff --git a/LICENSE.md b/LICENSE.md --- a/LICENSE.md +++ b/LICENSE.md @@ -1,4 +1,4 @@ -Copyright © 2018–present Tweag I/O +Copyright © 2018–2026 Tweag I/O, 2026–present Mark Karpov All rights reserved. @@ -12,7 +12,7 @@ notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. -* Neither the name Tweag I/O nor the names of contributors may be used to +* Neither the names Tweag I/O and Mark Karpov nor the names of contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,108 +4,125 @@ [![Hackage](https://img.shields.io/hackage/v/ormolu.svg?style=flat)](https://hackage.haskell.org/package/ormolu) [![Stackage Nightly](http://stackage.org/package/ormolu/badge/nightly)](http://stackage.org/nightly/package/ormolu) [![Stackage LTS](http://stackage.org/package/ormolu/badge/lts)](http://stackage.org/lts/package/ormolu) -[![Build status](https://badge.buildkite.com/8e3b0951f3652b77e1c422b361904136a539b0522029156354.svg?branch=master)](https://buildkite.com/tweag-1/ormolu) +[![CI](https://github.com/mrkkrp/ormolu/actions/workflows/ci.yml/badge.svg)](https://github.com/mrkkrp/ormolu/actions/workflows/ci.yml) -* [Building and installation](#building-and-installation) - * [Arch Linux](#arch-linux) +*Ormolu gratefully acknowledges the support and contributions of +[Tweag][tweag] during the period 2019–2026.* + +* [Installation](#installation) +* [Building from source](#building-from-source) * [Usage](#usage) + * [Ormolu Live](#ormolu-live) * [Editor integration](#editor-integration) - * [GitHub actions](#github-actions) + * [Haskell Language Server](#haskell-language-server) + * [GitHub Actions](#github-actions) + * [Language extensions, dependencies, and fixities](#language-extensions-dependencies-and-fixities) * [Magic comments](#magic-comments) + * [Regions](#regions) * [Exit codes](#exit-codes) + * [Using as a library](#using-as-a-library) +* [Troubleshooting](#troubleshooting) + * [Operators are being formatted weirdly!](#operators-are-being-formatted-weirdly) * [Limitations](#limitations) * [Running on Hackage](#running-on-hackage) +* [Forks and modifications](#forks-and-modifications) * [Contributing](#contributing) * [License](#license) Ormolu is a formatter for Haskell source code. The project was created with the following goals in mind: -* Using GHC's own parser to avoid parsing problems caused by +* Use GHC's own parser to avoid the parsing problems caused by [`haskell-src-exts`][haskell-src-exts]. -* Let some whitespace be programmable. The layout of the input influences - the layout choices in the output. This means that the choices between - single-line/multi-line layouts in certain situations are made by the user, - not by an algorithm. This makes the implementation simpler and leaves some - control to the user while still guaranteeing that the formatted code is - stylistically consistent. -* Writing code in such a way so it's easy to modify and maintain. -* Implementing one “true” formatting style which admits no configuration. -* The formatting style aims to result in minimal diffs. +* Make some whitespace programmable. The layout of the input influences the + layout choices in the output, so the choice between single-line and + multi-line layouts is made by the user rather than by an algorithm. This + keeps the implementation simpler and leaves some control to the user while + still guaranteeing that the formatted code is stylistically consistent. +* Implement one “true” formatting style that admits no configuration. +* Produce minimal diffs. * Choose a style compatible with modern dialects of Haskell. As new Haskell - extensions enter broad use, we may change the style to accommodate them. -* Idempotence: formatting already formatted code doesn't change it. -* Be well-tested and robust so that the formatter can be used in large + extensions enter broad use, we may adjust the style to accommodate them. +* Guarantee idempotence: formatting already formatted code doesn't change it. +* Stay well-tested and robust, so that the formatter can be used in large projects. -## Building and installation +Try it out in your browser at ! +See [Ormolu Live](#ormolu-live) for more info. -The easiest way to build the project is with Nix: +## Installation +The [release page][releases] has binaries for Linux, macOS, and Windows. + +You can also install Ormolu with `cabal` or `stack`: + ```console -$ nix-build -A ormolu +$ cabal install ormolu +$ stack install ormolu ``` -Or with `cabal-install` from the Nix shell: +Ormolu is also included in several package repositories. For example, on Arch +Linux you can use [the package on AUR][aur]: ```console -$ nix-shell --run "cabal new-build" +$ yay -S ormolu ``` -Alternatively, `stack` could be used with a `stack.yaml` file as follows. +## Building from source +The easiest way to build the project is with Nix: + ```console -$ cat stack.yaml -resolver: lts-16.0 -packages: -- '.' +$ nix build +``` +Make sure to accept the offered Nix binary caches, otherwise building may +take a very long time. The flake declares the relevant caches (the IOG cache +and the project's own `ormolu.cachix.org`, which is populated by CI) via its +`nixConfig`, but Nix uses them only if you allow it to. The simplest way is +to pass `--accept-flake-config`: + +```console +$ nix build --accept-flake-config +``` + +To avoid repeating the flag, add the following to your Nix configuration +(`/etc/nix/nix.conf`, or `nix.settings` on NixOS): + +``` +extra-substituters = https://cache.iog.io https://ormolu.cachix.org +extra-trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= ormolu.cachix.org-1:0L9Y4A+6dGpvfGtaeaq5w44pgX0AVRivKMfi2fiOzYE= +``` + +Alternatively, you can use `stack`: + +```console $ stack build # to build $ stack install # to install ``` -To use Ormolu directly from GitHub with Nix, this snippet may come in handy: +To use Ormolu directly from GitHub with Nix flakes, this snippet may come in +handy: ```nix -# This overlay adds Ormolu straight from GitHub. -self: super: - -let source = super.fetchFromGitHub { - owner = "tweag"; - repo = "ormolu"; - rev = "de279d80122b287374d4ed87c7b630db1f157642"; # update as necessary - sha256 = "0qrxfk62ww6b60ha9sqcgl4nb2n5fhf66a65wszjngwkybwlzmrv"; # same - }; - ormolu = import source { pkgs = self; }; -in { - haskell = super.haskell // { - packages = super.haskell.packages // { - "${ormolu.ormoluCompiler}" = super.haskell.packages.${ormolu.ormoluCompiler}.override { - overrides = ormolu.ormoluOverlay; - }; - }; +{ + inputs.ormolu.url = "github:mrkkrp/ormolu"; + outputs = { ormolu, ... }: { + # use ormolu.packages.${system}.default here }; } ``` -### Arch Linux - -To install Ormolu on Arch Linux, one can use [the package on AUR][aur]: - -```console -yay -S ormolu -``` - ## Usage -The following will print the formatted output to the standard output. +The following prints the formatted output to the standard output: ```console $ ormolu Module.hs ``` Add `--mode inplace` to replace the contents of the input file with the -formatted output. +formatted output: ```console $ ormolu --mode inplace Module.hs @@ -123,12 +140,27 @@ $ ormolu --mode inplace $(git ls-files '*.hs') ``` -To check if files are are already formatted (useful on CI): +To check whether files are already formatted (useful on CI): ```console $ ormolu --mode check $(find . -name '*.hs') ``` +#### :zap: Beware git's `core.autocrlf` on Windows :zap: +Ormolu's output always uses LF line endings. In particular, +`ormolu --mode check` will fail if its input is correctly formatted +*except* that it has CRLF line endings. This situation can happen on Windows +when checking out a git repository without having set [`core.autocrlf`]( +https://www.git-scm.com/docs/git-config#Documentation/git-config.txt-coreautocrlf) +to `false`. + +### Ormolu Live + +On every new commit to `master`, [Ormolu Live](./ormolu-live) is deployed to +https://ormolu-live.markkarpov.com. Older versions are available at +https://COMMITHASH--ormolu.netlify.app, where `COMMITHASH` is the hash of the +commit you want. + ### Editor integration We know of the following editor integrations: @@ -137,11 +169,79 @@ * [VS Code][vs-code-plugin] * Vim: [neoformat][neoformat], [vim-ormolu][vim-ormolu] -### GitHub actions +### Haskell Language Server -[`ormolu-action`][ormolu-action] is the recommended way to ensure that a -project is formatted with Ormolu. +[Haskell Language Server](https://haskell-language-server.readthedocs.io) +has built-in support for using Ormolu as a formatter. +### GitHub Actions + +[`run-ormolu`][run-ormolu] is the recommended way to ensure that a project +stays formatted with Ormolu. + +### Language extensions, dependencies, and fixities + +Ormolu automatically locates the Cabal file that corresponds to a given +source file. Cabal files are used to extract both default extensions and +dependencies. Default extensions directly affect the behavior of the GHC +parser, while dependencies are used to determine the fixities of operators +that appear in the source code. Fixities can also be overridden via an +`.ormolu` file, which should be located higher in the file system hierarchy +than the source file being formatted. When the input comes from stdin, you +can pass `--stdin-input-file` to tell Ormolu which location to use as the +starting point when searching for `.cabal` and `.ormolu` files. + +Here is an example of an `.ormolu` file: + +```haskell +infixr 9 . +infixr 5 ++ +infixl 4 <$ +infixl 1 >>, >>= +infixr 1 =<< +infixr 0 $, $! +infixl 4 <*>, <*, *>, <**> + +infixr 3 >~< +infixr 3.3 |~| +infixr 3.7 <~> +``` + +It uses exactly the same syntax as ordinary Haskell fixity declarations, +which makes it easier for Haskellers to edit and maintain. Since Ormolu +0.7.8.0, fractional precedences are supported for more precise control over +the formatting of complex operator chains. + +As of Ormolu 0.7.0.0, `.ormolu` files can also contain instructions about +module re-exports that Ormolu should be aware of. This can be useful because +Ormolu cannot know about every possible module re-export in the ecosystem, +and only a few of them actually matter for fixity deduction. In 99% of cases +you won't have to do anything, especially since the most common re-exports +are already built into Ormolu. (You are welcome to open PRs to make Ormolu +aware of more re-exports by default.) However, when the fixity of an operator +is not inferred correctly, making Ormolu aware of a re-export may help. Here +is an example: + +```haskell +module Control.Lens exports Control.Lens.At +module Control.Lens exports "lens" Control.Lens.Lens +``` + +Module re-export declarations can be mixed freely with fixity overrides, as +long as each declaration is on its own line. As of Ormolu 0.7.1.0 explicit +package names are allowed in re-export declarations (see the example above). + +Finally, all of the above-mentioned parameters can be controlled from the +command line: + +* Language extensions can be specified with the `-o` or `--ghc-opt` flag. +* Dependencies can be specified with the `-p` or `--package` flag. +* Fixities can be specified with the `-f` or `--fixity` flag. +* Re-exports can be specified with the `-r` or `--reexport` flag. + +Searching for `.cabal` and `.ormolu` files can be disabled by passing +`--no-cabal` and `--no-dot-ormolu` respectively. + ### Magic comments Ormolu understands two magic comments: @@ -156,13 +256,22 @@ {- ORMOLU_ENABLE -} ``` -This allows us to disable formatting selectively for code between these -markers or disable it for the entire file. To achieve the latter, just put -`{- ORMOLU_DISABLE -}` at the very top. Note that for Ormolu to work the -source code must still be parseable even when the disabled regions are -omitted. Because of that the magic comments cannot be placed arbitrarily, -but rather must enclose independent top-level definitions. +These let you disable formatting selectively for the code between the two +markers, or for the entire file. To disable formatting for the whole file, +just put `{- ORMOLU_DISABLE -}` at the very top. Note that the fragments +where Ormolu is enabled must be parseable on their own. Because of this, the +magic comments cannot be placed arbitrarily; they must enclose independent +top-level definitions. +### Regions + +You can ask Ormolu to format a region of the input and leave the rest +unformatted by passing the `--start-line` and `--end-line` command line +options. `--start-line` defaults to the beginning of the file, and +`--end-line` defaults to the end. + +Note that the selected region needs to be parseable Haskell code on its own. + ### Exit codes Exit code | Meaning @@ -175,51 +284,99 @@ 5 | AST of original and formatted code differs 6 | Formatting is not idempotent 7 | Unrecognized GHC options +8 | Cabal file parsing failed +9 | Missing input file path when using stdin input and accounting for .cabal files +10 | Parse error while parsing fixity overrides +11 | Comments of original and formatted code differ 100 | In checking mode: unformatted files -101 | Inplace and check modes do not work with stdin +101 | Inplace mode does not work with stdin 102 | Other issue (with multiple input files) +### Using as a library + +The `ormolu` package can also be used as a dependency from other Haskell +programs. For this purpose, only the top-level `Ormolu` module should be +considered stable. It follows the [PVP](https://pvp.haskell.org/) starting +from version 0.5.3.0. Rely on other modules at your own risk. + +## Troubleshooting + +### Operators are being formatted weirdly! + +This can happen when Ormolu doesn't know or can't determine the fixity of an +operator. + +* If this is a custom operator, see the instructions in the [Language + extensions, dependencies, and + fixities](#language-extensions-dependencies-and-fixities) section to + specify the correct fixities in a `.ormolu` file. + +* If this is a third-party operator (e.g. from `base` or some other package + on Hackage), Ormolu probably doesn't recognize that the operator is the + same as the third-party one. + + Some possible reasons for this: + + * You have a custom Prelude that re-exports things from the standard + Prelude. + * You have `-XNoImplicitPrelude` turned on. + + If either of these applies, make sure to specify the re-exports correctly + in a `.ormolu` file. + +You can see how Ormolu decides the fixity of operators by using `--debug`. + ## Limitations * 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][design-cpp] section in the design notes for a + correctly, so Ormolu treats CPP sections as unchangeable snippets. This + works only in simple cases, where CPP conditionals surround top-level + declarations. See the [CPP][design-cpp] section of the design notes for a discussion of the dangers. -* Input modules should be parsable by Haddock, which is a bit stricter - criterion than just being valid Haskell modules. ## Running on Hackage -It's possible to try Ormolu on arbitrary packages from Hackage. For that -execute (from the root of the cloned repo): +You can try Ormolu on arbitrary packages from Hackage. To do so, run the +following from the root of the cloned repo: ```console -$ nix-build -A hackage. +$ nix build .#hackage. ``` -Then inspect `result/log.txt` for possible problems. The derivation will -also contain formatted `.hs` files for inspection and original inputs with -`.hs-original` extension (those are with CPP dropped, exactly what is fed -into Ormolu). +Then inspect `result/log.txt` for possible problems. The derivation also +contains the formatted `.hs` files for inspection, along with the original +inputs under the `.hs-original` extension (these have CPP dropped and are +exactly what is fed into Ormolu). +## Forks and modifications + +We know of the following actively maintained forks: + +* [Fourmolu][fourmolu], which uses 4-space indentation and allows arbitrary + configuration. + ## Contributing -See [CONTRIBUTING.md][contributing]. +Contributions of all kinds are welcome, from bug reports and documentation +fixes to new features. Please see [CONTRIBUTING.md][contributing] to get +started. ## License See [LICENSE.md][license]. -Copyright © 2018–present Tweag I/O +Copyright © 2018–2026 Tweag I/O, 2026–present Mark Karpov +[tweag]: https://tweag.io/ [aur]: https://aur.archlinux.org/packages/ormolu -[contributing]: https://github.com/tweag/ormolu/blob/master/CONTRIBUTING.md -[design-cpp]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp +[design-cpp]: https://github.com/mrkkrp/ormolu/blob/master/DESIGN.md#cpp [emacs-package]: https://github.com/vyorkin/ormolu.el [haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts -[license]: https://github.com/tweag/ormolu/blob/master/LICENSE.md [neoformat]: https://github.com/sbdchd/neoformat -[ormolu-action]: https://github.com/marketplace/actions/ormolu-action +[releases]: https://github.com/mrkkrp/ormolu/releases +[run-ormolu]: https://github.com/haskell-actions/run-ormolu [vim-ormolu]: https://github.com/sdiehl/vim-ormolu [vs-code-plugin]: https://marketplace.visualstudio.com/items?itemName=sjurmillidahl.ormolu-vscode +[fourmolu]: https://github.com/fourmolu/fourmolu +[contributing]: https://github.com/mrkkrp/ormolu/blob/master/CONTRIBUTING.md +[license]: https://github.com/mrkkrp/ormolu/blob/master/LICENSE.md diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,34 +1,55 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} module Main (main) where +import Control.Concurrent (MVar, newMVar, withMVar) +import Control.Exception (throwIO) import Control.Monad import Data.Bool (bool) import Data.List (intercalate, sort) -import Data.Maybe (mapMaybe) -import qualified Data.Text.IO as TIO +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, mapMaybe, maybeToList) +import Data.Set qualified as Set +import Data.Text.IO.Utf8 qualified as T.Utf8 import Data.Version (showVersion) -import Development.GitRev +import Distribution.ModuleName (ModuleName) +import Distribution.Types.PackageName (PackageName) +import Language.Haskell.TH.Env (envQ) import Options.Applicative import Ormolu import Ormolu.Diff.Text (diffText, printTextDiff) +import Ormolu.Fixity import Ormolu.Parser (manualExts) import Ormolu.Terminal import Ormolu.Utils (showOutputable) +import Ormolu.Utils.Fixity import Paths_ormolu (version) +import System.Directory import System.Exit (ExitCode (..), exitWith) -import qualified System.FilePath as FP +import System.FilePath qualified as FP import System.IO (hPutStrLn, stderr) +import UnliftIO.Async (pooledMapConcurrently) -- | Entry point of the program. main :: IO () main = do Opts {..} <- execParser optsParserInfo - let formatOne' = formatOne optMode optConfig + -- We use this to guard writes to stdout in order to avoid + -- garbled output from concurrent formatting processes. + outputLock <- newMVar () + let formatOne' = + formatOne + optConfigFileOpts + optMode + optSourceType + optConfig + outputLock exitCode <- case optInputFiles of [] -> formatOne' Nothing ["-"] -> formatOne' Nothing @@ -38,7 +59,8 @@ ExitSuccess -> Nothing ExitFailure n -> Just n errorCodes <- - mapMaybe selectFailure <$> mapM (formatOne' . Just) (sort xs) + mapMaybe selectFailure + <$> pooledMapConcurrently (formatOne' . Just) (sort xs) return $ if null errorCodes then ExitSuccess @@ -51,59 +73,149 @@ -- | Format a single input. formatOne :: + -- | How to use .cabal files + ConfigFileOpts -> -- | Mode of operation Mode -> + -- | The 'SourceType' requested by the user + Maybe SourceType -> -- | Configuration Config RegionIndices -> + -- | Lock for writing to output handles + MVar () -> -- | File to format or stdin as 'Nothing' Maybe FilePath -> IO ExitCode -formatOne mode config mpath = withPrettyOrmoluExceptions (cfgColorMode config) $ - case FP.normalise <$> mpath of - Nothing -> do - r <- ormoluStdin config - case mode of - Stdout -> do - TIO.putStr r - return ExitSuccess - _ -> do - hPutStrLn - stderr - "This feature is not supported when input comes from stdin." - -- 101 is different from all the other exit codes we already use. - return (ExitFailure 101) - Just inputFile -> do - originalInput <- TIO.readFile inputFile - formattedInput <- ormoluFile config inputFile - case mode of - Stdout -> do - TIO.putStr formattedInput - return ExitSuccess - InPlace -> do - -- Only write when the contents have changed, in order to avoid - -- updating the modified timestamp if the file was already correctly - -- formatted. - when (formattedInput /= originalInput) $ - TIO.writeFile inputFile formattedInput - return ExitSuccess - Check -> - case diffText originalInput formattedInput inputFile of - Nothing -> return ExitSuccess - Just diff -> do - runTerm (printTextDiff diff) (cfgColorMode config) stderr - -- 100 is different to all the other exit code that are emitted - -- either from an 'OrmoluException' or from 'error' and - -- 'notImplemented'. - return (ExitFailure 100) +formatOne ConfigFileOpts {..} mode reqSourceType rawConfig outputLock mpath = + withPrettyOrmoluExceptions (cfgColorMode rawConfig) $ do + let getCabalInfoForSourceFile' sourceFile = do + cabalSearchResult <- getCabalInfoForSourceFile sourceFile + let debugEnabled = cfgDebug rawConfig + case cabalSearchResult of + CabalNotFound -> do + when debugEnabled $ + withMVar outputLock $ \_ -> + hPutStrLn stderr $ + "Could not find a .cabal file for " <> sourceFile + return Nothing + CabalDidNotMention cabalInfo -> do + when debugEnabled $ do + relativeCabalFile <- + makeRelativeToCurrentDirectory (ciCabalFilePath cabalInfo) + withMVar outputLock $ \_ -> + hPutStrLn stderr $ + "Found .cabal file " + <> relativeCabalFile + <> ", but it did not mention " + <> sourceFile + return (Just cabalInfo) + CabalFound cabalInfo -> return (Just cabalInfo) + getDotOrmoluForSourceFile' sourceFile = do + if optDoNotUseDotOrmolu + then return Nothing + else Just <$> getDotOrmoluForSourceFile sourceFile + case FP.normalise <$> mpath of + -- input source = STDIN + Nothing -> do + mcabalInfo <- case (optStdinInputFile, optDoNotUseCabal) of + (_, True) -> return Nothing + (Nothing, False) -> throwIO OrmoluMissingStdinInputFile + (Just inputFile, False) -> getCabalInfoForSourceFile' inputFile + mdotOrmolu <- case optStdinInputFile of + Nothing -> return Nothing + Just inputFile -> getDotOrmoluForSourceFile' inputFile + config <- patchConfig Nothing mcabalInfo mdotOrmolu + case mode of + Stdout -> do + output <- ormoluStdin config + withMVar outputLock $ \_ -> + T.Utf8.putStr output + return ExitSuccess + InPlace -> do + hPutStrLn + stderr + "In-place editing is not supported when the input comes from stdin." + -- 101 is different from all the other exit codes we already use. + return (ExitFailure 101) + Check -> do + -- ormoluStdin is not used because we need the originalInput + originalInput <- T.Utf8.getContents + let stdinRepr = "" + formattedInput <- + ormolu config stdinRepr originalInput + handleDiff originalInput formattedInput stdinRepr + -- input source = a file + Just inputFile -> do + mcabalInfo <- + if optDoNotUseCabal + then return Nothing + else getCabalInfoForSourceFile' inputFile + mdotOrmolu <- getDotOrmoluForSourceFile' inputFile + config <- + patchConfig + (Just (detectSourceType inputFile)) + mcabalInfo + mdotOrmolu + case mode of + Stdout -> do + output <- ormoluFile config inputFile + withMVar outputLock $ \_ -> + T.Utf8.putStr output + return ExitSuccess + InPlace -> do + -- ormoluFile is not used because we need originalInput + originalInput <- T.Utf8.readFile inputFile + formattedInput <- + ormolu config inputFile originalInput + when (formattedInput /= originalInput) $ + T.Utf8.writeFile inputFile formattedInput + return ExitSuccess + Check -> do + -- ormoluFile is not used because we need originalInput + originalInput <- T.Utf8.readFile inputFile + formattedInput <- + ormolu config inputFile originalInput + handleDiff originalInput formattedInput inputFile + where + patchConfig mdetectedSourceType mcabalInfo mdotOrmolu = do + let sourceType = + fromMaybe + ModuleSource + (reqSourceType <|> mdetectedSourceType) + return $ + refineConfig + sourceType + mcabalInfo + (Just (cfgFixityOverrides rawConfig)) + (Just (cfgModuleReexports rawConfig)) + ( rawConfig + { cfgFixityOverrides = maybe defaultFixityOverrides fst mdotOrmolu, + cfgModuleReexports = maybe defaultModuleReexports snd mdotOrmolu + } + ) + handleDiff originalInput formattedInput fileRepr = + case diffText originalInput formattedInput fileRepr of + Nothing -> return ExitSuccess + Just diff -> do + runTerm (printTextDiff diff) (cfgColorMode rawConfig) stderr + -- 100 is different from all the other exit codes that are emitted + -- either from an 'OrmoluException' or from 'error' and + -- 'notImplemented'. + return (ExitFailure 100) ---------------------------------------------------------------------------- -- Command line options parsing +-- | All command line options. data Opts = Opts { -- | Mode of operation optMode :: !Mode, -- | Ormolu 'Config' optConfig :: !(Config RegionIndices), + -- | Options related to info extracted from files + optConfigFileOpts :: ConfigFileOpts, + -- | Source type option, where 'Nothing' means autodetection + optSourceType :: !(Maybe SourceType), -- | Haskell source files to format or stdin (when the list is empty) optInputFiles :: ![FilePath] } @@ -119,6 +231,18 @@ Check deriving (Eq, Show) +-- | Options related to configuration stored in the file system. +data ConfigFileOpts = ConfigFileOpts + { -- | DO NOT extract default-extensions and dependencies from .cabal files + optDoNotUseCabal :: Bool, + -- | DO NOT look for @.ormolu@ files + optDoNotUseDotOrmolu :: Bool, + -- | Optional path to a file which will be used to find a .cabal file + -- when using input from stdin + optStdinInputFile :: Maybe FilePath + } + deriving (Show) + optsParserInfo :: ParserInfo Opts optsParserInfo = info (helper <*> ver <*> exts <*> optsParser) . mconcat $ @@ -134,12 +258,9 @@ verStr = intercalate "\n" - [ unwords - [ "ormolu", - showVersion version, - $gitBranch, - $gitHash - ], + [ unwords $ + ["ormolu", showVersion version] + <> maybeToList $$(envQ @String "ORMOLU_REV"), "using ghc-lib-parser " ++ VERSION_ghc_lib_parser ] exts :: Parser (a -> a) @@ -166,11 +287,29 @@ ] ) <*> configParser + <*> configFileOptsParser + <*> sourceTypeParser <*> (many . strArgument . mconcat) [ metavar "FILE", help "Haskell source files to format or stdin (the default)" ] +configFileOptsParser :: Parser ConfigFileOpts +configFileOptsParser = + ConfigFileOpts + <$> (switch . mconcat) + [ long "no-cabal", + help "Do not extract default-extensions and dependencies from .cabal files" + ] + <*> (switch . mconcat) + [ long "no-dot-ormolu", + help "Do not look for .ormolu files" + ] + <*> (optional . strOption . mconcat) + [ long "stdin-input-file", + help "Path which will be used to find the .cabal file when using input from stdin" + ] + configParser :: Parser (Config RegionIndices) configParser = Config @@ -180,6 +319,32 @@ metavar "OPT", help "GHC options to enable (e.g. language extensions)" ] + <*> ( fmap (FixityOverrides . Map.fromList . mconcat) + . many + . option parseFixityDeclaration + . mconcat + ) + [ long "fixity", + short 'f', + metavar "FIXITY", + help "Fixity declaration to use (an override)" + ] + <*> ( fmap (ModuleReexports . Map.fromListWith (<>) . mconcat . pure) + . many + . option parseModuleReexportDeclaration + . mconcat + ) + [ long "reexport", + short 'r', + metavar "REEXPORT", + help "Module re-export that Ormolu should know about" + ] + <*> (fmap Set.fromList . many . strOption . mconcat) + [ long "package", + short 'p', + metavar "PACKAGE", + help "Explicitly specified dependency (for operator fixity/precedence only)" + ] <*> (switch . mconcat) [ long "unsafe", short 'u', @@ -195,6 +360,10 @@ short 'c', help "Fail if formatting is not idempotent" ] + -- We cannot parse the source type here, because we might need to do + -- autodetection based on the input file extension (not available here) + -- before storing the resolved value in the config struct. + <*> pure ModuleSource <*> (option parseColorMode . mconcat) [ long "color", metavar "WHEN", @@ -214,6 +383,16 @@ ] ) +sourceTypeParser :: Parser (Maybe SourceType) +sourceTypeParser = + (option parseSourceType . mconcat) + [ long "source-type", + short 't', + metavar "TYPE", + value Nothing, + help "Set the type of source; TYPE can be 'module', 'sig', or 'auto' (the default)" + ] + ---------------------------------------------------------------------------- -- Helpers @@ -225,9 +404,28 @@ "check" -> Right Check s -> Left $ "unknown mode: " ++ s +-- | Parse a fixity declaration. +parseFixityDeclaration :: ReadM [(OpName, FixityInfo)] +parseFixityDeclaration = eitherReader parseFixityDeclarationStr + +-- | Parse a module reexport declaration. +parseModuleReexportDeclaration :: + ReadM (ModuleName, NonEmpty (Maybe PackageName, ModuleName)) +parseModuleReexportDeclaration = eitherReader parseModuleReexportDeclarationStr + +-- | Parse 'ColorMode'. parseColorMode :: ReadM ColorMode parseColorMode = eitherReader $ \case "never" -> Right Never "always" -> Right Always "auto" -> Right Auto s -> Left $ "unknown color mode: " ++ s + +-- | Parse the 'SourceType'. 'Nothing' means that autodetection based on +-- file extension is requested. +parseSourceType :: ReadM (Maybe SourceType) +parseSourceType = eitherReader $ \case + "module" -> Right (Just ModuleSource) + "sig" -> Right (Just SignatureSource) + "auto" -> Right Nothing + s -> Left $ "unknown source type: " ++ s diff --git a/data/cabal-tests/Bar.hs b/data/cabal-tests/Bar.hs new file mode 100644 --- /dev/null +++ b/data/cabal-tests/Bar.hs @@ -0,0 +1,3 @@ +module Foo where + +import Data.List qualified as List diff --git a/data/cabal-tests/Foo.hs b/data/cabal-tests/Foo.hs new file mode 100644 --- /dev/null +++ b/data/cabal-tests/Foo.hs @@ -0,0 +1,3 @@ +module Foo where + +import Data.List qualified as List diff --git a/data/cabal-tests/test.cabal b/data/cabal-tests/test.cabal new file mode 100644 --- /dev/null +++ b/data/cabal-tests/test.cabal @@ -0,0 +1,13 @@ +cabal-version: 2.4 +name: test +version: 0 + +library + exposed-modules: Foo + hs-source-dirs: . + default-extensions: ImportQualifiedPost + +executable app + main-is: Main + other-modules: Bar + default-extensions: ImportQualifiedPost diff --git a/data/diff-tests/inputs/applicative-after.hs b/data/diff-tests/inputs/applicative-after.hs new file mode 100644 --- /dev/null +++ b/data/diff-tests/inputs/applicative-after.hs @@ -0,0 +1,8 @@ +testPermParser :: Permutation Parser String +testPermParser = + f + <$> toPermutationWithDefault 'x' (char 'a') + <*> toPermutationWithDefault 'y' (char 'b') + <*> toPermutationWithDefault 'z' (char 'c') + where + f a b c = [a, b, c] diff --git a/data/diff-tests/inputs/applicative-before.hs b/data/diff-tests/inputs/applicative-before.hs new file mode 100644 --- /dev/null +++ b/data/diff-tests/inputs/applicative-before.hs @@ -0,0 +1,7 @@ +testPermParser :: Permutation Parser String +testPermParser = + f <$> toPermutationWithDefault 'x' (char 'a') + <*> toPermutationWithDefault 'y' (char 'b') + <*> toPermutationWithDefault 'z' (char 'c') + where + f a b c = [a, b, c] diff --git a/data/diff-tests/inputs/longer-v2.hs b/data/diff-tests/inputs/longer-v2.hs new file mode 100644 --- /dev/null +++ b/data/diff-tests/inputs/longer-v2.hs @@ -0,0 +1,16 @@ +module Main (foo) where + +a +b +c + +main :: IO () +main = return () + +d +e +f +g + +foo :: Int +foo = 6 diff --git a/data/diff-tests/inputs/longer.hs b/data/diff-tests/inputs/longer.hs new file mode 100644 --- /dev/null +++ b/data/diff-tests/inputs/longer.hs @@ -0,0 +1,16 @@ +module Main (main) where + +a +b +c + +main :: IO () +main = return () + +d +e +f +g + +foo :: Int +foo = 5 diff --git a/data/diff-tests/outputs/no-preceding.txt b/data/diff-tests/outputs/no-preceding.txt --- a/data/diff-tests/outputs/no-preceding.txt +++ b/data/diff-tests/outputs/no-preceding.txt @@ -1,6 +1,7 @@ TEST -@@ -1,3 +1,3 @@ +@@ -1,4 +1,4 @@ - module Main (foo) where + module Main (main) where + main :: IO () main = return () diff --git a/data/diff-tests/outputs/simple-hunk.txt b/data/diff-tests/outputs/simple-hunk.txt --- a/data/diff-tests/outputs/simple-hunk.txt +++ b/data/diff-tests/outputs/simple-hunk.txt @@ -1,9 +1,10 @@ TEST -@@ -1,6 +1,6 @@ +@@ -1,7 +1,7 @@ module Main (main) where main :: IO () - main = return () + main = pure () + foo :: Int foo = 5 diff --git a/data/diff-tests/outputs/trimming-trailing-both-eof.txt b/data/diff-tests/outputs/trimming-trailing-both-eof.txt new file mode 100644 --- /dev/null +++ b/data/diff-tests/outputs/trimming-trailing-both-eof.txt @@ -0,0 +1,10 @@ +TEST +@@ -1,6 +1,7 @@ + testPermParser :: Permutation Parser String + testPermParser = +- f <$> toPermutationWithDefault 'x' (char 'a') ++ f ++ <$> toPermutationWithDefault 'x' (char 'a') + <*> toPermutationWithDefault 'y' (char 'b') + <*> toPermutationWithDefault 'z' (char 'c') + where diff --git a/data/diff-tests/outputs/trimming-trailing-both-out-of-margin.txt b/data/diff-tests/outputs/trimming-trailing-both-out-of-margin.txt new file mode 100644 --- /dev/null +++ b/data/diff-tests/outputs/trimming-trailing-both-out-of-margin.txt @@ -0,0 +1,13 @@ +TEST +@@ -1,4 +1,4 @@ +- module Main (main) where ++ module Main (foo) where + + a + b +@@ -13,4 +13,4 @@ + g + + foo :: Int +- foo = 5 ++ foo = 6 diff --git a/data/examples/declaration/class/default-signatures-out.hs b/data/examples/declaration/class/default-signatures-out.hs --- a/data/examples/declaration/class/default-signatures-out.hs +++ b/data/examples/declaration/class/default-signatures-out.hs @@ -14,9 +14,7 @@ ( Read a, Semigroup a ) => - a -> - a -> - a + a -> a -> a -- Even more pointless comment bar a diff --git a/data/examples/declaration/class/default-signatures-simple-out.hs b/data/examples/declaration/class/default-signatures-simple-out.hs --- a/data/examples/declaration/class/default-signatures-simple-out.hs +++ b/data/examples/declaration/class/default-signatures-simple-out.hs @@ -4,5 +4,5 @@ class Foo a where -- | Foo foo :: a -> String - default foo :: Show a => a -> String + default foo :: (Show a) => a -> String foo = show diff --git a/data/examples/declaration/class/super-classes-out.hs b/data/examples/declaration/class/super-classes-out.hs --- a/data/examples/declaration/class/super-classes-out.hs +++ b/data/examples/declaration/class/super-classes-out.hs @@ -1,6 +1,6 @@ class Foo a -class Foo a => Bar a +class (Foo a) => Bar a class (Foo a, Bar a) => diff --git a/data/examples/declaration/data/comment-in-empty-record-out.hs b/data/examples/declaration/data/comment-in-empty-record-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/comment-in-empty-record-out.hs @@ -0,0 +1,6 @@ +instance StateKey ExampleReq where + data State ExampleReq = ExampleState + { + -- in here you can put any state that the + -- run. + } diff --git a/data/examples/declaration/data/comment-in-empty-record.hs b/data/examples/declaration/data/comment-in-empty-record.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/comment-in-empty-record.hs @@ -0,0 +1,5 @@ +instance StateKey ExampleReq where + data State ExampleReq = ExampleState { + -- in here you can put any state that the + -- run. + } diff --git a/data/examples/declaration/data/ctype-0-out.hs b/data/examples/declaration/data/ctype-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/ctype-0-out.hs @@ -0,0 +1,1 @@ +data {-# CTYPE "unistd.h" "useconds_t" #-} T diff --git a/data/examples/declaration/data/ctype-0.hs b/data/examples/declaration/data/ctype-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/ctype-0.hs @@ -0,0 +1,1 @@ +data {-# CTYPE "unistd.h" "useconds_t" #-} T diff --git a/data/examples/declaration/data/ctype-1-out.hs b/data/examples/declaration/data/ctype-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/ctype-1-out.hs @@ -0,0 +1,6 @@ +data + {-# CTYPE "header.h" "an-ffi-type-with-along-name" #-} + AnFFITypeWithAlongName = AnFFITypeWithAlongName + { a :: X, + b :: Y + } diff --git a/data/examples/declaration/data/ctype-1.hs b/data/examples/declaration/data/ctype-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/ctype-1.hs @@ -0,0 +1,6 @@ +data + {-# CTYPE "header.h" "an-ffi-type-with-along-name" #-} + AnFFITypeWithAlongName = AnFFITypeWithAlongName + { a :: X, + b :: Y + } diff --git a/data/examples/declaration/data/ctype-out.hs b/data/examples/declaration/data/ctype-out.hs deleted file mode 100644 --- a/data/examples/declaration/data/ctype-out.hs +++ /dev/null @@ -1,1 +0,0 @@ -data {-# CTYPE "unistd.h" "useconds_t" #-} T diff --git a/data/examples/declaration/data/ctype.hs b/data/examples/declaration/data/ctype.hs deleted file mode 100644 --- a/data/examples/declaration/data/ctype.hs +++ /dev/null @@ -1,1 +0,0 @@ -data {-# CTYPE "unistd.h" "useconds_t" #-} T diff --git a/data/examples/declaration/data/datatype-contexts-out.hs b/data/examples/declaration/data/datatype-contexts-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/datatype-contexts-out.hs @@ -0,0 +1,11 @@ +data (IsString s) => T s = T + +data + (IsString s) => + T s = T + +data + ( IsString s, + IsString s + ) => + T s = T diff --git a/data/examples/declaration/data/datatype-contexts.hs b/data/examples/declaration/data/datatype-contexts.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/datatype-contexts.hs @@ -0,0 +1,8 @@ +data IsString s => T s = T + +data IsString s => + T s = T + +data + ( IsString s + , IsString s ) => T s = T diff --git a/data/examples/declaration/data/existential-multiline-out.hs b/data/examples/declaration/data/existential-multiline-out.hs --- a/data/examples/declaration/data/existential-multiline-out.hs +++ b/data/examples/declaration/data/existential-multiline-out.hs @@ -2,7 +2,7 @@ data Foo = forall a. MkFoo a (a -> Bool) - | forall a. Eq a => MkBar a + | forall a. (Eq a) => MkBar a data Bar = forall x y. diff --git a/data/examples/declaration/data/existential-out.hs b/data/examples/declaration/data/existential-out.hs --- a/data/examples/declaration/data/existential-out.hs +++ b/data/examples/declaration/data/existential-out.hs @@ -2,4 +2,4 @@ data Foo = forall a. MkFoo a (a -> Bool) -data Bar = forall a b. a + b => Bar a b +data Bar = forall a b. (a + b) => Bar a b diff --git a/data/examples/declaration/data/existential-unicode-out.hs b/data/examples/declaration/data/existential-unicode-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/existential-unicode-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE UnicodeSyntax #-} + +data Foo + = forall a. + Foo + +data Bar + = forall a. + Bar diff --git a/data/examples/declaration/data/existential-unicode.hs b/data/examples/declaration/data/existential-unicode.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/existential-unicode.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE UnicodeSyntax #-} + +data Foo = forall + a. Foo + +data Bar = ∀ + a. Bar diff --git a/data/examples/declaration/data/field-layout/record-0-out.hs b/data/examples/declaration/data/field-layout/record-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/field-layout/record-0-out.hs @@ -0,0 +1,10 @@ +-- | Foo. +data Foo = Foo + { -- | Something + foo :: Foo Int Int, + -- | Something else + bar :: + Bar + Char + Char + } diff --git a/data/examples/declaration/data/field-layout/record-0.hs b/data/examples/declaration/data/field-layout/record-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/field-layout/record-0.hs @@ -0,0 +1,9 @@ +-- | Foo. + +data Foo = Foo + { foo :: Foo Int Int + -- ^ Something + , bar :: Bar Char + Char + -- ^ Something else + } diff --git a/data/examples/declaration/data/field-layout/record-1-out.hs b/data/examples/declaration/data/field-layout/record-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/field-layout/record-1-out.hs @@ -0,0 +1,11 @@ +-- | Foo. +data Foo + = Foo + { -- | Something + foo :: Foo Int Int, + -- | Something else + bar :: + Bar + Char + Char + } diff --git a/data/examples/declaration/data/field-layout/record-1.hs b/data/examples/declaration/data/field-layout/record-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/field-layout/record-1.hs @@ -0,0 +1,10 @@ +-- | Foo. + +data Foo = + Foo + { foo :: Foo Int Int + -- ^ Something + , bar :: Bar Char + Char + -- ^ Something else + } diff --git a/data/examples/declaration/data/field-layout/record-2-out.hs b/data/examples/declaration/data/field-layout/record-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/field-layout/record-2-out.hs @@ -0,0 +1,7 @@ +data IndexWithInfo schema + = forall x. + IndexWithInfo + { checkedIndex :: Index schema x, + checkedIndexName :: U.Variable, + checkedIndexType :: Type x + } diff --git a/data/examples/declaration/data/field-layout/record-2.hs b/data/examples/declaration/data/field-layout/record-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/field-layout/record-2.hs @@ -0,0 +1,7 @@ +data IndexWithInfo schema = + forall x. + IndexWithInfo + { checkedIndex :: Index schema x + , checkedIndexName :: U.Variable + , checkedIndexType :: Type x + } diff --git a/data/examples/declaration/data/field-layout/record-out.hs b/data/examples/declaration/data/field-layout/record-out.hs deleted file mode 100644 --- a/data/examples/declaration/data/field-layout/record-out.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Main where - --- | Foo. -data Foo = Foo - { -- | Something - foo :: Foo Int Int, - -- | Something else - bar :: - Bar - Char - Char - } diff --git a/data/examples/declaration/data/field-layout/record.hs b/data/examples/declaration/data/field-layout/record.hs deleted file mode 100644 --- a/data/examples/declaration/data/field-layout/record.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Main where - --- | Foo. - -data Foo = Foo - { foo :: Foo Int Int - -- ^ Something - , bar :: Bar Char - Char - -- ^ Something else - } diff --git a/data/examples/declaration/data/gadt/multiline-out.hs b/data/examples/declaration/data/gadt/multiline-out.hs --- a/data/examples/declaration/data/gadt/multiline-out.hs +++ b/data/examples/declaration/data/gadt/multiline-out.hs @@ -9,17 +9,11 @@ forall a b. (Show a, Eq b) => -- foo -- bar - a -> - b -> - Foo 'Int + a -> b -> Foo 'Int -- | But 'Bar' is also not too bad. Bar :: - Int -> - Maybe Text -> - Foo 'Bool + Int -> Maybe Text -> Foo 'Bool -- | So is 'Baz'. Baz :: - forall a. - a -> - Foo 'String + forall a. a -> Foo 'String (:~>) :: Foo a -> Foo a -> Foo a diff --git a/data/examples/declaration/data/gadt/multiline-where-out.hs b/data/examples/declaration/data/gadt/multiline-where-out.hs --- a/data/examples/declaration/data/gadt/multiline-where-out.hs +++ b/data/examples/declaration/data/gadt/multiline-where-out.hs @@ -5,3 +5,26 @@ c where Foo :: a -> b -> c -> Foo a b c + +data + Foo :: + Type -> + Type -> + Type + where + Foo :: Foo a b + +data + Foo a b c :: + Type -> Type -> Type -> Type + where + Foo :: Foo a b c + +data + Vec :: + Type -> + Type -> + Type + where + Nil :: Vec a Ze + Cons :: a -> Vec a n -> Vec a (Su n) diff --git a/data/examples/declaration/data/gadt/multiline-where.hs b/data/examples/declaration/data/gadt/multiline-where.hs --- a/data/examples/declaration/data/gadt/multiline-where.hs +++ b/data/examples/declaration/data/gadt/multiline-where.hs @@ -4,3 +4,20 @@ b c where Foo :: a -> b -> c -> Foo a b c + +data Foo :: Type + -> Type + -> Type where + Foo :: Foo a b + +data Foo a b c :: + Type -> Type -> Type -> Type where + Foo :: Foo a b c + +data Vec + :: Type + -> Type + -> Type + where + Nil :: Vec a Ze + Cons :: a -> Vec a n -> Vec a (Su n) diff --git a/data/examples/declaration/data/gadt/multiple-declaration-out.hs b/data/examples/declaration/data/gadt/multiple-declaration-out.hs --- a/data/examples/declaration/data/gadt/multiple-declaration-out.hs +++ b/data/examples/declaration/data/gadt/multiple-declaration-out.hs @@ -4,12 +4,10 @@ data GADT1 a where GADT11, GADT12 :: - Int -> - GADT1 a + Int -> GADT1 a data GADT2 a where GADT21, GADT21, GADT22 :: - Int -> - GADT2 a + Int -> GADT2 a diff --git a/data/examples/declaration/data/gadt/unicode-out.hs b/data/examples/declaration/data/gadt/unicode-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/gadt/unicode-out.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE UnicodeSyntax #-} + +data Foo :: Type -> Type where + Foo :: a -> Foo a diff --git a/data/examples/declaration/data/gadt/unicode.hs b/data/examples/declaration/data/gadt/unicode.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/gadt/unicode.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE UnicodeSyntax #-} + +data Foo ∷ Type → Type where + Foo ∷ a → Foo a diff --git a/data/examples/declaration/data/haddock-before-deriving-out.hs b/data/examples/declaration/data/haddock-before-deriving-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/haddock-before-deriving-out.hs @@ -0,0 +1,5 @@ +data A = A + deriving + ( -- | B + Eq + ) diff --git a/data/examples/declaration/data/haddock-before-deriving.hs b/data/examples/declaration/data/haddock-before-deriving.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/haddock-before-deriving.hs @@ -0,0 +1,3 @@ +data A = A + -- | B + deriving (Eq) diff --git a/data/examples/declaration/data/haddock-before-record-braces-out.hs b/data/examples/declaration/data/haddock-before-record-braces-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/haddock-before-record-braces-out.hs @@ -0,0 +1,6 @@ +module Example where + +data Hello = Hello + { -- | hello world + hello :: String + } diff --git a/data/examples/declaration/data/haddock-before-record-braces.hs b/data/examples/declaration/data/haddock-before-record-braces.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/haddock-before-record-braces.hs @@ -0,0 +1,5 @@ +module Example where + +data Hello = Hello + -- | hello world + {hello :: String} diff --git a/data/examples/declaration/data/infix-haddocks-out.hs b/data/examples/declaration/data/infix-haddocks-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/infix-haddocks-out.hs @@ -0,0 +1,51 @@ +{- https://github.com/tweag/ormolu/issues/758 -} + +data A + = -- | Docs for :# + A :# A + +data WithDocs + = forall left right. + (Show left) => + -- | Docs for left arg + left + -- | Docs for op + :*: + -- | Docs for right arg + right + +data MixedDocs + = forall left right. + (Show left) => + left -- ^ before + :*: + -- | after + right + +data DocPartial + = Left -- ^ left docs + -- on multiple + -- lines + :*: + Right + | -- | op + Left + :*: + Right + | Left + :*: + -- | right + Right + | -- | op + Left + :*: + Right + | -- | op + Left + :*: + Right + +data NoDocs + = Left + :*: + Right diff --git a/data/examples/declaration/data/infix-haddocks.hs b/data/examples/declaration/data/infix-haddocks.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/infix-haddocks.hs @@ -0,0 +1,43 @@ +{- https://github.com/tweag/ormolu/issues/758 -} + +data A = A :# A -- ^ Docs for :# + +data WithDocs + = forall left right. + Show left => + left -- ^ Docs for left arg + :*: -- ^ Docs for op + right -- ^ Docs for right arg + +data MixedDocs + -- | before + = forall left right. + Show left => + left :*: right + -- ^ after + +data DocPartial + = Left -- ^ left docs + -- on multiple + -- lines + :*: Right + | Left + :*: -- ^ op + Right + | Left + :*: + -- | right + Right + | -- | op + Left + :*: + Right + | Left + :*: + Right + -- ^ op + +data NoDocs + = Left + :*: + Right diff --git a/data/examples/declaration/data/invisible-binders-out.hs b/data/examples/declaration/data/invisible-binders-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/invisible-binders-out.hs @@ -0,0 +1,2 @@ +type T :: forall k. k -> forall j. j -> Type +data T @k (a :: k) @(j :: Type) (b :: j) diff --git a/data/examples/declaration/data/invisible-binders.hs b/data/examples/declaration/data/invisible-binders.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/invisible-binders.hs @@ -0,0 +1,2 @@ +type T :: forall k. k -> forall j. j -> Type +data T @k (a :: k) @(j :: Type) (b :: j) diff --git a/data/examples/declaration/data/linear-out.hs b/data/examples/declaration/data/linear-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/linear-out.hs @@ -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 diff --git a/data/examples/declaration/data/linear.hs b/data/examples/declaration/data/linear.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/linear.hs @@ -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 diff --git a/data/examples/declaration/data/record-empty-haddock-out.hs b/data/examples/declaration/data/record-empty-haddock-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/record-empty-haddock-out.hs @@ -0,0 +1,5 @@ +data A = A + { -- \| + -- + a :: Int + } diff --git a/data/examples/declaration/data/record-empty-haddock.hs b/data/examples/declaration/data/record-empty-haddock.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/record-empty-haddock.hs @@ -0,0 +1,6 @@ +data A = A + { + -- | + -- + a :: Int + } diff --git a/data/examples/declaration/data/record-fancy-existential-out.hs b/data/examples/declaration/data/record-fancy-existential-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/record-fancy-existential-out.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ExistentialQuantification #-} + +data Foo = forall a b. (Show a, Eq b) => Bar + { foo :: a, + bars :: b + } diff --git a/data/examples/declaration/data/record-fancy-existential.hs b/data/examples/declaration/data/record-fancy-existential.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/record-fancy-existential.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ExistentialQuantification #-} +data Foo = forall a b . (Show a, Eq b) => Bar + { foo :: a + , bars :: b + } diff --git a/data/examples/declaration/data/record-out.hs b/data/examples/declaration/data/record-out.hs --- a/data/examples/declaration/data/record-out.hs +++ b/data/examples/declaration/data/record-out.hs @@ -12,7 +12,7 @@ fooGag, fooGog :: NonEmpty - ( Indentity + ( Identity Bool ), -- | Huh! diff --git a/data/examples/declaration/data/record.hs b/data/examples/declaration/data/record.hs --- a/data/examples/declaration/data/record.hs +++ b/data/examples/declaration/data/record.hs @@ -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 diff --git a/data/examples/declaration/data/required-type-arguments-out.hs b/data/examples/declaration/data/required-type-arguments-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/required-type-arguments-out.hs @@ -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) diff --git a/data/examples/declaration/data/required-type-arguments.hs b/data/examples/declaration/data/required-type-arguments.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/required-type-arguments.hs @@ -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) diff --git a/data/examples/declaration/data/simple-broken-out.hs b/data/examples/declaration/data/simple-broken-out.hs --- a/data/examples/declaration/data/simple-broken-out.hs +++ b/data/examples/declaration/data/simple-broken-out.hs @@ -1,7 +1,8 @@ module Main where -- | Here we go. -data Foo = Foo {unFoo :: Int} +data Foo + = Foo {unFoo :: Int} deriving (Eq) -- | And once again. diff --git a/data/examples/declaration/data/single-constructor-with-haddock-out.hs b/data/examples/declaration/data/single-constructor-with-haddock-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/single-constructor-with-haddock-out.hs @@ -0,0 +1,7 @@ +data FutureSumType + = -- | This is what the documentation for this type looks like. + -- It is pretty awkward that the @--@s aren't aligned. + SingleConstructor + { someRecordField :: Bool, + someOtherRecordField :: Int + } diff --git a/data/examples/declaration/data/single-constructor-with-haddock.hs b/data/examples/declaration/data/single-constructor-with-haddock.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/single-constructor-with-haddock.hs @@ -0,0 +1,6 @@ +data FutureSumType = -- | This is what the documentation for this type looks like. + -- It is pretty awkward that the @--@s aren't aligned. + SingleConstructor + { someRecordField :: Bool, + someOtherRecordField :: Int + } diff --git a/data/examples/declaration/data/type-data-out.hs b/data/examples/declaration/data/type-data-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/type-data-out.hs @@ -0,0 +1,8 @@ +type data Universe = Character | Number | Boolean + +type data Maybe a + = Just a + | Nothing + +type data P :: Type -> Type -> Type where + MkP :: (a ~ Natural, b ~~ Char) => P a b diff --git a/data/examples/declaration/data/type-data.hs b/data/examples/declaration/data/type-data.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/type-data.hs @@ -0,0 +1,7 @@ +type data Universe = Character | Number | Boolean + +type data Maybe a = Just a + | Nothing + +type data P :: Type -> Type -> Type where + MkP :: (a ~ Natural, b ~~ Char) => P a b diff --git a/data/examples/declaration/data/unnamed-field-comment-0-out.hs b/data/examples/declaration/data/unnamed-field-comment-0-out.hs --- a/data/examples/declaration/data/unnamed-field-comment-0-out.hs +++ b/data/examples/declaration/data/unnamed-field-comment-0-out.hs @@ -1,7 +1,7 @@ data Foo = -- | Bar Bar + -- | Field 1 Field1 - -- ^ Field 1 + -- | Field 2 Field2 - -- ^ Field 2 diff --git a/data/examples/declaration/data/unnamed-field-comment-1-out.hs b/data/examples/declaration/data/unnamed-field-comment-1-out.hs --- a/data/examples/declaration/data/unnamed-field-comment-1-out.hs +++ b/data/examples/declaration/data/unnamed-field-comment-1-out.hs @@ -1,5 +1,5 @@ data X = B + -- | y !Int - -- ^ y C diff --git a/data/examples/declaration/data/unnamed-field-comment-2-out.hs b/data/examples/declaration/data/unnamed-field-comment-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-2-out.hs @@ -0,0 +1,11 @@ +-- | Describes what sort of dictionary to generate for type class instances +data Evidence + = -- | An existing named instance + NamedInstance (Qualified Ident) + | -- | Computed instances + WarnInstance + -- | Warn type class with a user-defined warning message + SourceType + | -- | The IsSymbol type class for a given Symbol literal + IsSymbolInstance PSString + deriving (Show, Eq) diff --git a/data/examples/declaration/data/unnamed-field-comment-2.hs b/data/examples/declaration/data/unnamed-field-comment-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-2.hs @@ -0,0 +1,9 @@ +-- | Describes what sort of dictionary to generate for type class instances +data Evidence + -- | An existing named instance + = NamedInstance (Qualified Ident) + + -- | Computed instances + | WarnInstance SourceType -- ^ Warn type class with a user-defined warning message + | IsSymbolInstance PSString -- ^ The IsSymbol type class for a given Symbol literal + deriving (Show, Eq) diff --git a/data/examples/declaration/data/unnamed-field-comment-3-out.hs b/data/examples/declaration/data/unnamed-field-comment-3-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-3-out.hs @@ -0,0 +1,1 @@ +data A = A {- | a number -} Int Bool diff --git a/data/examples/declaration/data/unnamed-field-comment-3.hs b/data/examples/declaration/data/unnamed-field-comment-3.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-3.hs @@ -0,0 +1,1 @@ +data A = A {- | a number -} Int Bool diff --git a/data/examples/declaration/data/unpack-field-comment-0-out.hs b/data/examples/declaration/data/unpack-field-comment-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unpack-field-comment-0-out.hs @@ -0,0 +1,4 @@ +data Buffer + = Buffer + {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array + {-# UNPACK #-} !(Ptr Word8) -- beginning of slice diff --git a/data/examples/declaration/data/unpack-field-comment-0.hs b/data/examples/declaration/data/unpack-field-comment-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unpack-field-comment-0.hs @@ -0,0 +1,2 @@ +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) -- underlying pinned array + {-# UNPACK #-} !(Ptr Word8) -- beginning of slice diff --git a/data/examples/declaration/data/unpack-field-comment-1-out.hs b/data/examples/declaration/data/unpack-field-comment-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unpack-field-comment-1-out.hs @@ -0,0 +1,4 @@ +data P + = P + {-# UNPACK #-} !Word32 -- left word + {-# UNPACK #-} !Word32 -- right word diff --git a/data/examples/declaration/data/unpack-field-comment-1.hs b/data/examples/declaration/data/unpack-field-comment-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unpack-field-comment-1.hs @@ -0,0 +1,2 @@ +data P = P {-# UNPACK #-} !Word32 -- left word + {-# UNPACK #-} !Word32 -- right word diff --git a/data/examples/declaration/data/unpack-field-comment-2-out.hs b/data/examples/declaration/data/unpack-field-comment-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unpack-field-comment-2-out.hs @@ -0,0 +1,4 @@ +data TBQueue a + = TBQueue + {-# UNPACK #-} !(TVar Natural) -- CR: read capacity + {-# UNPACK #-} !(TVar [a]) -- R: elements waiting to be read diff --git a/data/examples/declaration/data/unpack-field-comment-2.hs b/data/examples/declaration/data/unpack-field-comment-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unpack-field-comment-2.hs @@ -0,0 +1,3 @@ +data TBQueue a + = TBQueue {-# UNPACK #-} !(TVar Natural) -- CR: read capacity + {-# UNPACK #-} !(TVar [a]) -- R: elements waiting to be read diff --git a/data/examples/declaration/data/unpack-field-comment-3-out.hs b/data/examples/declaration/data/unpack-field-comment-3-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unpack-field-comment-3-out.hs @@ -0,0 +1,4 @@ +data Builder + = Builder + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- used units diff --git a/data/examples/declaration/data/unpack-field-comment-3.hs b/data/examples/declaration/data/unpack-field-comment-3.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unpack-field-comment-3.hs @@ -0,0 +1,3 @@ +data Builder = Builder + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- used units diff --git a/data/examples/declaration/data/wildcard-binders-out.hs b/data/examples/declaration/data/wildcard-binders-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/wildcard-binders-out.hs @@ -0,0 +1,1 @@ +data Proxy _ = Proxy diff --git a/data/examples/declaration/data/wildcard-binders.hs b/data/examples/declaration/data/wildcard-binders.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/wildcard-binders.hs @@ -0,0 +1,1 @@ +data Proxy _ = Proxy diff --git a/data/examples/declaration/default/default-out.hs b/data/examples/declaration/default/default-out.hs --- a/data/examples/declaration/default/default-out.hs +++ b/data/examples/declaration/default/default-out.hs @@ -1,3 +1,5 @@ +module MyModule (default Monoid) where + default (Int, Foo, Bar) default @@ -5,3 +7,9 @@ Foo, Bar ) + +default Num (Int, Float) + +default IsList ([], Vector) + +default IsString (Text.Text, Foundation.String, String) diff --git a/data/examples/declaration/default/default.hs b/data/examples/declaration/default/default.hs --- a/data/examples/declaration/default/default.hs +++ b/data/examples/declaration/default/default.hs @@ -1,6 +1,13 @@ +module MyModule (default Monoid) where + default ( Int , Foo , Bar ) default ( Int , Foo, Bar ) + +default Num (Int, Float) +default IsList ([], Vector) + +default IsString (Text.Text, Foundation.String, String) diff --git a/data/examples/declaration/foreign/foreign-import-multiline-out.hs b/data/examples/declaration/foreign/foreign-import-multiline-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/foreign/foreign-import-multiline-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MultilineStrings #-} + +foreign import capi + """ + foo + bar + """ + foo :: Int -> Int diff --git a/data/examples/declaration/foreign/foreign-import-multiline.hs b/data/examples/declaration/foreign/foreign-import-multiline.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/foreign/foreign-import-multiline.hs @@ -0,0 +1,6 @@ +{-# language MultilineStrings #-} + +foreign import capi """ + foo + bar + """ foo :: Int -> Int diff --git a/data/examples/declaration/instance/contexts-out.hs b/data/examples/declaration/instance/contexts-out.hs --- a/data/examples/declaration/instance/contexts-out.hs +++ b/data/examples/declaration/instance/contexts-out.hs @@ -1,4 +1,4 @@ -instance Eq a => Eq [a] where (==) _ _ = False +instance (Eq a) => Eq [a] where (==) _ _ = False instance ( Ord a, diff --git a/data/examples/declaration/instance/newlines-between-methods-out.hs b/data/examples/declaration/instance/newlines-between-methods-out.hs --- a/data/examples/declaration/instance/newlines-between-methods-out.hs +++ b/data/examples/declaration/instance/newlines-between-methods-out.hs @@ -1,4 +1,4 @@ -instance Num a => Num (Diff a) where +instance (Num a) => Num (Diff a) where D u dudx + D v dvdx = D (u + v) (dudx + dvdx) D u dudx - D v dvdx = D (u - v) (dudx - dvdx) D u dudx * D v dvdx = D (u * v) (u * dvdx + v * dudx) diff --git a/data/examples/declaration/rewrite-rule/never-active-out.hs b/data/examples/declaration/rewrite-rule/never-active-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/never-active-out.hs @@ -0,0 +1,1 @@ +{-# RULES "map-loop" [~] forall f. map' f = map' (id . f) #-} diff --git a/data/examples/declaration/rewrite-rule/never-active.hs b/data/examples/declaration/rewrite-rule/never-active.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/never-active.hs @@ -0,0 +1,1 @@ +{-# RULES "map-loop" [ ~ ] forall f . map' f = map' (id . f) #-} diff --git a/data/examples/declaration/rewrite-rule/prelude2-out.hs b/data/examples/declaration/rewrite-rule/prelude2-out.hs --- a/data/examples/declaration/rewrite-rule/prelude2-out.hs +++ b/data/examples/declaration/rewrite-rule/prelude2-out.hs @@ -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 diff --git a/data/examples/declaration/rewrite-rule/prelude2.hs b/data/examples/declaration/rewrite-rule/prelude2.hs --- a/data/examples/declaration/rewrite-rule/prelude2.hs +++ b/data/examples/declaration/rewrite-rule/prelude2.hs @@ -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 diff --git a/data/examples/declaration/rewrite-rule/prelude4-out.hs b/data/examples/declaration/rewrite-rule/prelude4-out.hs --- a/data/examples/declaration/rewrite-rule/prelude4-out.hs +++ b/data/examples/declaration/rewrite-rule/prelude4-out.hs @@ -2,6 +2,7 @@ "unpack" [~1] forall a. unpackCString # a = build (unpackFoldrCString # a) "unpack-list" [1] forall a. unpackFoldrCString # a (:) [] = unpackCString # a "unpack-append" forall a n. unpackFoldrCString # a (:) n = unpackAppendCString # a n + -- There's a built-in rule (in PrelRules.lhs) for -- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n #-} diff --git a/data/examples/declaration/rewrite-rule/type-signature-out.hs b/data/examples/declaration/rewrite-rule/type-signature-out.hs --- a/data/examples/declaration/rewrite-rule/type-signature-out.hs +++ b/data/examples/declaration/rewrite-rule/type-signature-out.hs @@ -8,9 +8,7 @@ z ( g :: forall b. - (a -> b -> b) -> - b -> - b + (a -> b -> b) -> b -> b ). foldr k z (build g) = g k z diff --git a/data/examples/declaration/signature/fixity/infix-out.hs b/data/examples/declaration/signature/fixity/infix-out.hs --- a/data/examples/declaration/signature/fixity/infix-out.hs +++ b/data/examples/declaration/signature/fixity/infix-out.hs @@ -1,3 +1,9 @@ infix 0 infix 9 <^-^> + +infix 2 -> + +infix 0 type + +infix 9 + diff --git a/data/examples/declaration/signature/fixity/infix.hs b/data/examples/declaration/signature/fixity/infix.hs --- a/data/examples/declaration/signature/fixity/infix.hs +++ b/data/examples/declaration/signature/fixity/infix.hs @@ -1,2 +1,8 @@ infix 0 infix 9 <^-^> + +infix 2 -> + +infix 0 type + +infix + diff --git a/data/examples/declaration/signature/fixity/infixl-out.hs b/data/examples/declaration/signature/fixity/infixl-out.hs --- a/data/examples/declaration/signature/fixity/infixl-out.hs +++ b/data/examples/declaration/signature/fixity/infixl-out.hs @@ -1,3 +1,5 @@ infixl 8 *** infixl 0 $, *, +, &&, ** + +infixl 9 type $ diff --git a/data/examples/declaration/signature/fixity/infixl.hs b/data/examples/declaration/signature/fixity/infixl.hs --- a/data/examples/declaration/signature/fixity/infixl.hs +++ b/data/examples/declaration/signature/fixity/infixl.hs @@ -1,2 +1,4 @@ infixl 8 *** infixl 0 $, *, +, &&, ** + +infixl 9 type $ diff --git a/data/examples/declaration/signature/fixity/infixr-out.hs b/data/examples/declaration/signature/fixity/infixr-out.hs --- a/data/examples/declaration/signature/fixity/infixr-out.hs +++ b/data/examples/declaration/signature/fixity/infixr-out.hs @@ -1,3 +1,5 @@ infixr 8 `Foo` infixr 0 ***, &&& + +infixr 0 data $ diff --git a/data/examples/declaration/signature/fixity/infixr.hs b/data/examples/declaration/signature/fixity/infixr.hs --- a/data/examples/declaration/signature/fixity/infixr.hs +++ b/data/examples/declaration/signature/fixity/infixr.hs @@ -1,2 +1,4 @@ infixr 8 `Foo` infixr 0 ***, &&& + +infixr 0 data $ diff --git a/data/examples/declaration/signature/inline/noinline-out.hs b/data/examples/declaration/signature/inline/noinline-out.hs --- a/data/examples/declaration/signature/inline/noinline-out.hs +++ b/data/examples/declaration/signature/inline/noinline-out.hs @@ -9,3 +9,7 @@ baz :: Int -> Int baz = id {-# NOINLINE [~2] baz #-} + +blub :: Int -> Int +blub = baz +{-# OPAQUE blub #-} diff --git a/data/examples/declaration/signature/inline/noinline.hs b/data/examples/declaration/signature/inline/noinline.hs --- a/data/examples/declaration/signature/inline/noinline.hs +++ b/data/examples/declaration/signature/inline/noinline.hs @@ -11,3 +11,7 @@ baz = id {-# NOINLINE [~2] baz #-} + +blub :: Int -> Int +blub = baz +{-# opaque blub #-} diff --git a/data/examples/declaration/signature/specialize/specialize-2-out.hs b/data/examples/declaration/signature/specialize/specialize-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/specialize/specialize-2-out.hs @@ -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) + #-} diff --git a/data/examples/declaration/signature/specialize/specialize-2.hs b/data/examples/declaration/signature/specialize/specialize-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/specialize/specialize-2.hs @@ -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) #-} diff --git a/data/examples/declaration/signature/specialize/specialize-3-out.hs b/data/examples/declaration/signature/specialize/specialize-3-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/specialize/specialize-3-out.hs @@ -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 #-} diff --git a/data/examples/declaration/signature/specialize/specialize-3.hs b/data/examples/declaration/signature/specialize/specialize-3.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/specialize/specialize-3.hs @@ -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 #-} diff --git a/data/examples/declaration/signature/specialize/specialize-instance-out.hs b/data/examples/declaration/signature/specialize/specialize-instance-out.hs --- a/data/examples/declaration/signature/specialize/specialize-instance-out.hs +++ b/data/examples/declaration/signature/specialize/specialize-instance-out.hs @@ -8,7 +8,6 @@ instance (Num r, V.Vector v r, Factored m r) => Num (VT v m r) where {-# SPECIALIZE instance - ( Factored m Int => Num (VT U.Vector m Int) - ) + ((Factored m Int) => Num (VT U.Vector m Int)) #-} VT x + VT y = VT $ V.zipWith (+) x y diff --git a/data/examples/declaration/signature/specialize/specialize-out.hs b/data/examples/declaration/signature/specialize/specialize-out.hs --- a/data/examples/declaration/signature/specialize/specialize-out.hs +++ b/data/examples/declaration/signature/specialize/specialize-out.hs @@ -1,13 +1,13 @@ -foo :: Num a => a -> a +foo :: (Num a) => a -> a foo = id {-# SPECIALIZE foo :: Int -> Int #-} {-# SPECIALIZE INLINE foo :: Float -> Float #-} {-# SPECIALIZE NOINLINE [2] bar :: Int -> Int #-} -bar :: Num a => a -> a +bar :: (Num a) => a -> a bar = id -baz :: Num a => a -> a +baz :: (Num a) => a -> a baz = id {-# SPECIALIZE [~2] baz :: Int -> @@ -20,5 +20,5 @@ Bool, Integer -> Bool #-} -fits13Bits :: Integral a => a -> Bool +fits13Bits :: (Integral a) => a -> Bool fits13Bits x = x >= -4096 && x < 4096 diff --git a/data/examples/declaration/signature/type/unicode-out.hs b/data/examples/declaration/signature/type/unicode-out.hs --- a/data/examples/declaration/signature/type/unicode-out.hs +++ b/data/examples/declaration/signature/type/unicode-out.hs @@ -1,4 +1,4 @@ {-# LANGUAGE UnicodeSyntax #-} -foo :: forall a. Show a => a -> String +foo :: forall a. (Show a) => a -> String foo = const () diff --git a/data/examples/declaration/splice/bracket-unicode-out.hs b/data/examples/declaration/splice/bracket-unicode-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/bracket-unicode-out.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} + +ascii = [|x|] + +unicode = [|x|] diff --git a/data/examples/declaration/splice/bracket-unicode.hs b/data/examples/declaration/splice/bracket-unicode.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/bracket-unicode.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} + +ascii = [|x|] + +unicode = ⟦x⟧ diff --git a/data/examples/declaration/splice/quasiquote-out.hs b/data/examples/declaration/splice/quasiquote-out.hs --- a/data/examples/declaration/splice/quasiquote-out.hs +++ b/data/examples/declaration/splice/quasiquote-out.hs @@ -10,3 +10,7 @@ [d| foo bar |] + +header = + [here| +#include foo|] diff --git a/data/examples/declaration/splice/quasiquote.hs b/data/examples/declaration/splice/quasiquote.hs --- a/data/examples/declaration/splice/quasiquote.hs +++ b/data/examples/declaration/splice/quasiquote.hs @@ -9,3 +9,6 @@ [d| foo bar |] + +header = [here| +#include foo|] diff --git a/data/examples/declaration/splice/typed-splice-out.hs b/data/examples/declaration/splice/typed-splice-out.hs --- a/data/examples/declaration/splice/typed-splice-out.hs +++ b/data/examples/declaration/splice/typed-splice-out.hs @@ -1,7 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} x = - $$( foo bar - ) + $$(foo bar) x = $$foo diff --git a/data/examples/declaration/type-families/closed-type-family/multi-line-out.hs b/data/examples/declaration/type-families/closed-type-family/multi-line-out.hs --- a/data/examples/declaration/type-families/closed-type-family/multi-line-out.hs +++ b/data/examples/declaration/type-families/closed-type-family/multi-line-out.hs @@ -23,3 +23,7 @@ F Bool = Char F a = String + +type family F a where + F a = -- foo + a diff --git a/data/examples/declaration/type-families/closed-type-family/multi-line.hs b/data/examples/declaration/type-families/closed-type-family/multi-line.hs --- a/data/examples/declaration/type-families/closed-type-family/multi-line.hs +++ b/data/examples/declaration/type-families/closed-type-family/multi-line.hs @@ -12,3 +12,7 @@ F Bool = Char F a = String + +type family F a where + F a -- foo + = a diff --git a/data/examples/declaration/type-families/closed-type-family/promotion-out.hs b/data/examples/declaration/type-families/closed-type-family/promotion-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/promotion-out.hs @@ -0,0 +1,2 @@ +type family Foo a where + Foo '( 'x', a) = a diff --git a/data/examples/declaration/type-families/closed-type-family/promotion.hs b/data/examples/declaration/type-families/closed-type-family/promotion.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/promotion.hs @@ -0,0 +1,2 @@ +type family Foo a where + Foo '( 'x', a) = a diff --git a/data/examples/declaration/type-families/closed-type-family/with-comments-out.hs b/data/examples/declaration/type-families/closed-type-family/with-comments-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/with-comments-out.hs @@ -0,0 +1,10 @@ +type family LT a b where + -- 0 + LT 0 _ = True + -- 1 + LT 1 0 = False + LT 1 _ = True + -- 2 + LT 2 0 = False + LT 2 1 = False + LT 2 _ = True diff --git a/data/examples/declaration/type-families/closed-type-family/with-comments.hs b/data/examples/declaration/type-families/closed-type-family/with-comments.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/with-comments.hs @@ -0,0 +1,12 @@ +type family LT a b where + -- 0 + LT 0 _ = True + + -- 1 + LT 1 0 = False + LT 1 _ = True + + -- 2 + LT 2 0 = False + LT 2 1 = False + LT 2 _ = True diff --git a/data/examples/declaration/type-synonyms/multi-line-out.hs b/data/examples/declaration/type-synonyms/multi-line-out.hs --- a/data/examples/declaration/type-synonyms/multi-line-out.hs +++ b/data/examples/declaration/type-synonyms/multi-line-out.hs @@ -1,3 +1,5 @@ +import Servant.API + type Foo a b c = Bar c a b @@ -16,3 +18,6 @@ "route1" :> ApiRoute1 :<|> "route2" :> ApiRoute2 -- comment here :<|> OmitDocs :> "i" :> ASomething API + +type A = -- foo + B diff --git a/data/examples/declaration/type-synonyms/multi-line.hs b/data/examples/declaration/type-synonyms/multi-line.hs --- a/data/examples/declaration/type-synonyms/multi-line.hs +++ b/data/examples/declaration/type-synonyms/multi-line.hs @@ -1,3 +1,5 @@ +import Servant.API + type Foo a b c = Bar c a b @@ -15,3 +17,6 @@ = "route1" :> ApiRoute1 :<|> "route2" :> ApiRoute2 -- comment here :<|> OmitDocs :> "i" :> ASomething API + +type A -- foo + = B diff --git a/data/examples/declaration/type/parens-comments-out.hs b/data/examples/declaration/type/parens-comments-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/parens-comments-out.hs @@ -0,0 +1,4 @@ +type Test = + ( -- a + x + ) diff --git a/data/examples/declaration/type/parens-comments.hs b/data/examples/declaration/type/parens-comments.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/parens-comments.hs @@ -0,0 +1,3 @@ +type Test = ( + -- a + x) diff --git a/data/examples/declaration/type/promotion-1-out.hs b/data/examples/declaration/type/promotion-1-out.hs --- a/data/examples/declaration/type/promotion-1-out.hs +++ b/data/examples/declaration/type/promotion-1-out.hs @@ -13,3 +13,7 @@ type E = TypeError ('Text "Some text") type G = '[ '( 'Just, 'Bool)] + +type X = () '`PromotedInfix` () + +type A = '[ 'a'] diff --git a/data/examples/declaration/type/promotion-1.hs b/data/examples/declaration/type/promotion-1.hs --- a/data/examples/declaration/type/promotion-1.hs +++ b/data/examples/declaration/type/promotion-1.hs @@ -7,3 +7,7 @@ type E = TypeError ('Text "Some text") type G = '[ '( 'Just, 'Bool) ] + +type X = () '`PromotedInfix` () + +type A = '[ 'a' ] diff --git a/data/examples/declaration/type/promotion-no-puns-out.hs b/data/examples/declaration/type/promotion-no-puns-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/promotion-no-puns-out.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NoListTuplePuns #-} + +type X = (Int, String) + +type Y = [String, Int] diff --git a/data/examples/declaration/type/promotion-no-puns.hs b/data/examples/declaration/type/promotion-no-puns.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/promotion-no-puns.hs @@ -0,0 +1,5 @@ +{-# Language NoListTuplePuns #-} + +type X = (Int, String) + +type Y = [String, Int] diff --git a/data/examples/declaration/type/wildcard-binders-out.hs b/data/examples/declaration/type/wildcard-binders-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/wildcard-binders-out.hs @@ -0,0 +1,1 @@ +type Const a _ = a diff --git a/data/examples/declaration/type/wildcard-binders.hs b/data/examples/declaration/type/wildcard-binders.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/wildcard-binders.hs @@ -0,0 +1,1 @@ +type Const a _ = a diff --git a/data/examples/declaration/value/function/application-1-out.hs b/data/examples/declaration/value/function/application-1-out.hs --- a/data/examples/declaration/value/function/application-1-out.hs +++ b/data/examples/declaration/value/function/application-1-out.hs @@ -1,19 +1,19 @@ main = do - x - y - z + x + y + z main = case foo of - x -> a - foo - a - b + x -> a + foo + a + b main = do - if x then y else z - foo - a - b + if x then y else z + foo + a + b diff --git a/data/examples/declaration/value/function/application-2-out.hs b/data/examples/declaration/value/function/application-2-out.hs --- a/data/examples/declaration/value/function/application-2-out.hs +++ b/data/examples/declaration/value/function/application-2-out.hs @@ -1,13 +1,11 @@ {-# LANGUAGE TemplateHaskell #-} foo = do - $( bar - ) + $(bar) baz foo = do - $$( bar - ) + $$(bar) baz foo = do @@ -16,8 +14,8 @@ foo = do do - (+ 1) - 2 + (+ 1) + 2 foo = do case () of () -> (+ 1) @@ -25,8 +23,8 @@ foo = do case () of - () -> (+ 1) - 2 + () -> (+ 1) + 2 foo = do \case 2 -> 3 @@ -34,5 +32,5 @@ foo = do \case - 2 -> 3 - 2 + 2 -> 3 + 2 diff --git a/data/examples/declaration/value/function/arrow/proc-applications2-out.hs b/data/examples/declaration/value/function/arrow/proc-applications2-out.hs --- a/data/examples/declaration/value/function/arrow/proc-applications2-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-applications2-out.hs @@ -8,4 +8,5 @@ LT -> \a -> returnA -< x + a EQ -> \b -> returnA -< y + z + b GT -> \c -> returnA -< z + x - ) 1 + ) + 1 diff --git a/data/examples/declaration/value/function/arrow/proc-do-complex-out.hs b/data/examples/declaration/value/function/arrow/proc-do-complex-out.hs --- a/data/examples/declaration/value/function/arrow/proc-do-complex-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-complex-out.hs @@ -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 @@ -58,5 +58,8 @@ -< ( i + x - * y -- Just do the calculation + * y -- Just do the calculation ) + +traverseA_ f = proc (e, (xs, s)) -> + (| foldlA' (\() x -> do (e, (x, s)) >- f; () >- returnA) |) () xs diff --git a/data/examples/declaration/value/function/arrow/proc-do-complex.hs b/data/examples/declaration/value/function/arrow/proc-do-complex.hs --- a/data/examples/declaration/value/function/arrow/proc-do-complex.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-complex.hs @@ -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 @@ -47,3 +47,6 @@ returnA -< (i + x * y) -- Just do the calculation + +traverseA_ f = proc (e, (xs, s)) -> + (| foldlA' (\() x -> do { (e, (x, s)) >- f; () >- returnA }) |) () xs diff --git a/data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs b/data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs --- a/data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs @@ -1,7 +1,6 @@ {-# LANGUAGE Arrows #-} -bar f = proc a -> do - b <- f -< a +bar f = proc a -> do b <- f -< a barbar f g = proc a -> do b <- f -< a @@ -16,3 +15,15 @@ f -< a + +foo = + proc x -> + do + returnA -< x + 1 + +foo a = + proc x -> + case Left x of + Left x -> returnA -< x + a diff --git a/data/examples/declaration/value/function/arrow/proc-do-simple1.hs b/data/examples/declaration/value/function/arrow/proc-do-simple1.hs --- a/data/examples/declaration/value/function/arrow/proc-do-simple1.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-simple1.hs @@ -18,3 +18,13 @@ -< a +foo = + proc x -> do + returnA -< x + 1 + +foo a = + proc x -> + case Left x of + Left x -> returnA -< x + a diff --git a/data/examples/declaration/value/function/arrow/proc-do-simple2-out.hs b/data/examples/declaration/value/function/arrow/proc-do-simple2-out.hs --- a/data/examples/declaration/value/function/arrow/proc-do-simple2-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-simple2-out.hs @@ -1,7 +1,6 @@ {-# LANGUAGE Arrows #-} -foo f = proc a -> do - f -< a +foo f = proc a -> do f -< a bazbaz f g h = proc (a, b, c) -> do x <- @@ -20,3 +19,5 @@ returnA -< (x, y, z) + +bar f = proc x -> do { f -< x } <+> do f -< x diff --git a/data/examples/declaration/value/function/arrow/proc-do-simple2.hs b/data/examples/declaration/value/function/arrow/proc-do-simple2.hs --- a/data/examples/declaration/value/function/arrow/proc-do-simple2.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-simple2.hs @@ -18,3 +18,5 @@ ) returnA -< (x, y, z) + +bar f = proc x -> do {f -< x} <+> do f -< x diff --git a/data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs b/data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs --- a/data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs @@ -10,4 +10,12 @@ (| bar (bindA -< y) - |) z + |) + z + +foo2 = proc () -> do + ( proc () -> + returnA -< () + ) + -< + () diff --git a/data/examples/declaration/value/function/arrow/proc-form-do-indent.hs b/data/examples/declaration/value/function/arrow/proc-form-do-indent.hs --- a/data/examples/declaration/value/function/arrow/proc-form-do-indent.hs +++ b/data/examples/declaration/value/function/arrow/proc-form-do-indent.hs @@ -11,3 +11,8 @@ bar (bindA -< y) |) z + +foo2 = proc () -> do + (proc () -> + returnA -< () + ) -< () diff --git a/data/examples/declaration/value/function/arrow/proc-forms2-out.hs b/data/examples/declaration/value/function/arrow/proc-forms2-out.hs --- a/data/examples/declaration/value/function/arrow/proc-forms2-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-forms2-out.hs @@ -15,27 +15,32 @@ ( (h f . h g) -< (y x) . y z - ) ||| - ( (h g . h f) - -< - y z . (y x) - ) + ) + ||| ( (h g . h f) + -< + y z . (y x) + ) bar4 = proc x -> case x of Just f -> f -< () Nothing -> x -< () - <+> do - g -< x + <+> do + g -< x expr' = proc x -> do returnA -< x - <+> do - symbol Plus -< () - y <- term -< () - expr' -< x + y - <+> do - symbol Minus -< () - y <- term -< () - expr' -< x - y + <+> do + symbol Plus -< () + y <- term -< () + expr' -< x + y + <+> do + symbol Minus -< () + y <- term -< () + expr' -< x - y + +bar f = proc (a, b) -> do + (f a -< b) + >-> (\y -> f b >- a) + >-> (\y -> f b >- a) diff --git a/data/examples/declaration/value/function/arrow/proc-forms2.hs b/data/examples/declaration/value/function/arrow/proc-forms2.hs --- a/data/examples/declaration/value/function/arrow/proc-forms2.hs +++ b/data/examples/declaration/value/function/arrow/proc-forms2.hs @@ -34,3 +34,8 @@ symbol Minus -< () y <- term -< () expr' -< x - y + +bar f = proc (a, b) -> do + (f a -< b) + >-> (\y -> f b >- a) + >-> (\y -> f b >- a) diff --git a/data/examples/declaration/value/function/arrow/proc-parentheses-out.hs b/data/examples/declaration/value/function/arrow/proc-parentheses-out.hs --- a/data/examples/declaration/value/function/arrow/proc-parentheses-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-parentheses-out.hs @@ -4,8 +4,7 @@ bar f g = proc a -> ( ( (f) - ( g - ) + (g) ) -< ( ( ( ( ( ( g diff --git a/data/examples/declaration/value/function/awkward-comment-0-out.hs b/data/examples/declaration/value/function/awkward-comment-0-out.hs --- a/data/examples/declaration/value/function/awkward-comment-0-out.hs +++ b/data/examples/declaration/value/function/awkward-comment-0-out.hs @@ -1,6 +1,5 @@ mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a -mergeErrorReply err1 reply -- XXX where to put it? - = +mergeErrorReply err1 reply = -- XXX where to put it? case reply of Ok x state err2 -> Ok x state (mergeError err1 err2) Error err2 -> Error (mergeError err1 err2) diff --git a/data/examples/declaration/value/function/awkward-comment-1-out.hs b/data/examples/declaration/value/function/awkward-comment-1-out.hs --- a/data/examples/declaration/value/function/awkward-comment-1-out.hs +++ b/data/examples/declaration/value/function/awkward-comment-1-out.hs @@ -1,8 +1,7 @@ doForeign :: Vars -> [Name] -> [Term] -> Idris LExp doForeign x = x where - splitArg tm | (_, [_, _, l, r]) <- unApply tm -- pair, two implicits - = + splitArg tm | (_, [_, _, l, r]) <- unApply tm = -- pair, two implicits do let l' = toFDesc l r' <- irTerm (sMN 0 "__foreignCall") vs env r diff --git a/data/examples/declaration/value/function/block-arguments-out.hs b/data/examples/declaration/value/function/block-arguments-out.hs --- a/data/examples/declaration/value/function/block-arguments-out.hs +++ b/data/examples/declaration/value/function/block-arguments-out.hs @@ -32,3 +32,5 @@ do a do b do c + +f11 = do a do b do c do d diff --git a/data/examples/declaration/value/function/block-arguments.hs b/data/examples/declaration/value/function/block-arguments.hs --- a/data/examples/declaration/value/function/block-arguments.hs +++ b/data/examples/declaration/value/function/block-arguments.hs @@ -28,3 +28,5 @@ do { a } do { b } do c + +f11 = do a do b do c do d diff --git a/data/examples/declaration/value/function/case-comment-after-pattern-out.hs b/data/examples/declaration/value/function/case-comment-after-pattern-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-comment-after-pattern-out.hs @@ -0,0 +1,3 @@ +foo = case a of + b -> -- comment + c diff --git a/data/examples/declaration/value/function/case-comment-after-pattern.hs b/data/examples/declaration/value/function/case-comment-after-pattern.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-comment-after-pattern.hs @@ -0,0 +1,3 @@ +foo = case a of + b -- comment + -> c diff --git a/data/examples/declaration/value/function/case-comment-between-alt-and-where-out.hs b/data/examples/declaration/value/function/case-comment-between-alt-and-where-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-comment-between-alt-and-where-out.hs @@ -0,0 +1,6 @@ +foo = + case x of + _ -> 1 + -- comment + where + x = 1 diff --git a/data/examples/declaration/value/function/case-comment-between-alt-and-where.hs b/data/examples/declaration/value/function/case-comment-between-alt-and-where.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-comment-between-alt-and-where.hs @@ -0,0 +1,6 @@ +foo = + case x of + _ -> 1 + -- comment + where + x = 1 diff --git a/data/examples/declaration/value/function/case-empty-out.hs b/data/examples/declaration/value/function/case-empty-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-empty-out.hs @@ -0,0 +1,6 @@ +absurd x = case x of {} +absurd = \case {} +absurd x = case x of {} +absurd = \case {} + +foo = case () of {} 1 diff --git a/data/examples/declaration/value/function/case-empty.hs b/data/examples/declaration/value/function/case-empty.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-empty.hs @@ -0,0 +1,6 @@ +absurd x = case x of +absurd = \case +absurd x = case x of {} +absurd = \case {} + +foo = case () of {} 1 diff --git a/data/examples/declaration/value/function/case-multi-line-guards-out.hs b/data/examples/declaration/value/function/case-multi-line-guards-out.hs --- a/data/examples/declaration/value/function/case-multi-line-guards-out.hs +++ b/data/examples/declaration/value/function/case-multi-line-guards-out.hs @@ -3,8 +3,8 @@ case x of x | x > 10 -> - foo - + bar + foo + + bar x | x > 5 -> 10 _ -> 20 diff --git a/data/examples/declaration/value/function/case-multi-line-out.hs b/data/examples/declaration/value/function/case-multi-line-out.hs --- a/data/examples/declaration/value/function/case-multi-line-out.hs +++ b/data/examples/declaration/value/function/case-multi-line-out.hs @@ -21,7 +21,6 @@ quux x = case x of x -> x -funnyComment = - -- comment +funnyComment = -- comment case () of () -> () diff --git a/data/examples/declaration/value/function/case-single-line-with-braces-out.hs b/data/examples/declaration/value/function/case-single-line-with-braces-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-single-line-with-braces-out.hs @@ -0,0 +1,2 @@ +getValue :: Maybe Int -> Int +getValue x = case x of Just n -> n; Nothing -> 0 diff --git a/data/examples/declaration/value/function/case-single-line-with-braces.hs b/data/examples/declaration/value/function/case-single-line-with-braces.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-single-line-with-braces.hs @@ -0,0 +1,2 @@ +getValue :: Maybe Int -> Int +getValue x = case x of {Just n -> n; Nothing -> 0} 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/comprehension/transform-monad-out.hs b/data/examples/declaration/value/function/comprehension/transform-monad-out.hs --- a/data/examples/declaration/value/function/comprehension/transform-monad-out.hs +++ b/data/examples/declaration/value/function/comprehension/transform-monad-out.hs @@ -5,14 +5,14 @@ [ ( x, y ) - | x <- xs, - y <- ys, - then group by - -- First comment - ( x - + y - ) - using - -- Second comment - groupWith -- Third comment + | x <- xs, + y <- ys, + then group by + -- First comment + ( x + + y + ) + using + -- Second comment + groupWith -- Third comment ] diff --git a/data/examples/declaration/value/function/comprehension/transform-multi-line1-out.hs b/data/examples/declaration/value/function/comprehension/transform-multi-line1-out.hs --- a/data/examples/declaration/value/function/comprehension/transform-multi-line1-out.hs +++ b/data/examples/declaration/value/function/comprehension/transform-multi-line1-out.hs @@ -4,9 +4,9 @@ [ ( x, y ) - | x <- xs, - y <- ys, - then - -- First comment - reverse -- Second comment + | x <- xs, + y <- ys, + then + -- First comment + reverse -- Second comment ] diff --git a/data/examples/declaration/value/function/comprehension/transform-multi-line2-out.hs b/data/examples/declaration/value/function/comprehension/transform-multi-line2-out.hs --- a/data/examples/declaration/value/function/comprehension/transform-multi-line2-out.hs +++ b/data/examples/declaration/value/function/comprehension/transform-multi-line2-out.hs @@ -4,13 +4,13 @@ [ ( x, y ) - | x <- xs, - y <- ys, - then - -- First comment - sortWith - by - ( x - + y -- Second comment - ) + | x <- xs, + y <- ys, + then + -- First comment + sortWith + by + ( x + + y -- Second comment + ) ] diff --git a/data/examples/declaration/value/function/comprehension/transform-multi-line3-out.hs b/data/examples/declaration/value/function/comprehension/transform-multi-line3-out.hs --- a/data/examples/declaration/value/function/comprehension/transform-multi-line3-out.hs +++ b/data/examples/declaration/value/function/comprehension/transform-multi-line3-out.hs @@ -4,9 +4,9 @@ [ ( x, y ) - | x <- xs, - y <- ys, - then group using - -- First comment - permutations -- Second comment + | x <- xs, + y <- ys, + then group using + -- First comment + permutations -- Second comment ] diff --git a/data/examples/declaration/value/function/comprehension/transform-multi-line4-out.hs b/data/examples/declaration/value/function/comprehension/transform-multi-line4-out.hs --- a/data/examples/declaration/value/function/comprehension/transform-multi-line4-out.hs +++ b/data/examples/declaration/value/function/comprehension/transform-multi-line4-out.hs @@ -4,14 +4,14 @@ [ ( x, y ) - | x <- xs, - y <- ys, - then group by - -- First comment - ( x - + y - ) - using - -- Second comment - groupWith -- Third comment + | x <- xs, + y <- ys, + then group by + -- First comment + ( x + + y + ) + using + -- Second comment + groupWith -- Third comment ] diff --git a/data/examples/declaration/value/function/do-multiline-with-case-out.hs b/data/examples/declaration/value/function/do-multiline-with-case-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-multiline-with-case-out.hs @@ -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 diff --git a/data/examples/declaration/value/function/do-multiline-with-case.hs b/data/examples/declaration/value/function/do-multiline-with-case.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-multiline-with-case.hs @@ -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 diff --git a/data/examples/declaration/value/function/do-single-line-case-guards-out.hs b/data/examples/declaration/value/function/do-single-line-case-guards-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-case-guards-out.hs @@ -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" } diff --git a/data/examples/declaration/value/function/do-single-line-case-guards.hs b/data/examples/declaration/value/function/do-single-line-case-guards.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-case-guards.hs @@ -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"}} diff --git a/data/examples/declaration/value/function/do-single-line-lambda-case-out.hs b/data/examples/declaration/value/function/do-single-line-lambda-case-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-lambda-case-out.hs @@ -0,0 +1,2 @@ +processValue :: Maybe Int -> IO () +processValue x = do putStrLn "Processing:"; \case { Just n -> print n; Nothing -> putStrLn "Empty" } x; putStrLn "Done" diff --git a/data/examples/declaration/value/function/do-single-line-lambda-case.hs b/data/examples/declaration/value/function/do-single-line-lambda-case.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-lambda-case.hs @@ -0,0 +1,2 @@ +processValue :: Maybe Int -> IO () +processValue x = do {putStrLn "Processing:"; \case {Just n -> print n; Nothing -> putStrLn "Empty"} x; putStrLn "Done"} diff --git a/data/examples/declaration/value/function/do-single-line-multiple-cases-out.hs b/data/examples/declaration/value/function/do-single-line-multiple-cases-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-multiple-cases-out.hs @@ -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" } diff --git a/data/examples/declaration/value/function/do-single-line-multiple-cases.hs b/data/examples/declaration/value/function/do-single-line-multiple-cases.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-multiple-cases.hs @@ -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"}} diff --git a/data/examples/declaration/value/function/do-single-line-nested-case-out.hs b/data/examples/declaration/value/function/do-single-line-nested-case-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-nested-case-out.hs @@ -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" diff --git a/data/examples/declaration/value/function/do-single-line-nested-case.hs b/data/examples/declaration/value/function/do-single-line-nested-case.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-nested-case.hs @@ -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"} diff --git a/data/examples/declaration/value/function/do-single-line-with-case-out.hs b/data/examples/declaration/value/function/do-single-line-with-case-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-with-case-out.hs @@ -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!" } diff --git a/data/examples/declaration/value/function/do-single-line-with-case.hs b/data/examples/declaration/value/function/do-single-line-with-case.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-line-with-case.hs @@ -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!"}} diff --git a/data/examples/declaration/value/function/do/do-dollar-mixed-chain-out.hs b/data/examples/declaration/value/function/do/do-dollar-mixed-chain-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do/do-dollar-mixed-chain-out.hs @@ -0,0 +1,23 @@ +module A (a) where + +a :: Int +a = do + f + . do + g + $ do + 1 + + 2 + * 3 + $ ( 6 + * 5 + + 4 + ) + +b = + f a <> 1 + 2 <> do + 3 + +c = + f b $ 1 + 2 $ do + 3 diff --git a/data/examples/declaration/value/function/do/do-dollar-mixed-chain.hs b/data/examples/declaration/value/function/do/do-dollar-mixed-chain.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do/do-dollar-mixed-chain.hs @@ -0,0 +1,23 @@ +module A (a) where + +a :: Int +a = do + f + . do + g + $ do + 1 + + 2 + * 3 + $ ( 6 * + 5 + + 4 + ) + +b = + f a <> 1 + 2 <> do + 3 + +c = + f b $ 1 + 2 $ do + 3 diff --git a/data/examples/declaration/value/function/fancy-forall-0-out.hs b/data/examples/declaration/value/function/fancy-forall-0-out.hs --- a/data/examples/declaration/value/function/fancy-forall-0-out.hs +++ b/data/examples/declaration/value/function/fancy-forall-0-out.hs @@ -2,9 +2,8 @@ forall outertag innertag t outer inner m a. ( forall x. Coercible (t m x) (m x), forall m'. - HasCatch outertag outer m' => + (HasCatch outertag outer m') => HasCatch innertag inner (t m'), HasCatch outertag outer m ) => - (forall m'. HasCatch innertag inner m' => m' a) -> - m a + (forall m'. (HasCatch innertag inner m') => m' a) -> m a diff --git a/data/examples/declaration/value/function/fancy-forall-1-out.hs b/data/examples/declaration/value/function/fancy-forall-1-out.hs --- a/data/examples/declaration/value/function/fancy-forall-1-out.hs +++ b/data/examples/declaration/value/function/fancy-forall-1-out.hs @@ -2,9 +2,8 @@ forall outertag innertag t outer inner m a. ( forall x. Coercible (t m x) (m x), forall m'. - HasReader outertag outer m' => + (HasReader outertag outer m') => HasReader innertag inner (t m'), HasReader outertag outer m ) => - (forall m'. HasReader innertag inner m' => m' a) -> - m a + (forall m'. (HasReader innertag inner m') => m' a) -> m a diff --git a/data/examples/declaration/value/function/guards-out.hs b/data/examples/declaration/value/function/guards-out.hs --- a/data/examples/declaration/value/function/guards-out.hs +++ b/data/examples/declaration/value/function/guards-out.hs @@ -10,3 +10,5 @@ quux :: Int -> Int quux x | x < 0 = x quux x = x + +(a, b) | c = d diff --git a/data/examples/declaration/value/function/guards.hs b/data/examples/declaration/value/function/guards.hs --- a/data/examples/declaration/value/function/guards.hs +++ b/data/examples/declaration/value/function/guards.hs @@ -10,3 +10,5 @@ quux :: Int -> Int quux x | x < 0 = x quux x = x + +(a, b) | c = d diff --git a/data/examples/declaration/value/function/if-single-line-functions-do-out.hs b/data/examples/declaration/value/function/if-single-line-functions-do-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-single-line-functions-do-out.hs @@ -0,0 +1,5 @@ +foo x = do + y <- quux + if x > 2 + then bar x + else baz y diff --git a/data/examples/declaration/value/function/if-single-line-functions-do.hs b/data/examples/declaration/value/function/if-single-line-functions-do.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-single-line-functions-do.hs @@ -0,0 +1,5 @@ +foo x = do + y <- quux + if x > 2 + then bar x + else baz y diff --git a/data/examples/declaration/value/function/if-single-line-functions-out.hs b/data/examples/declaration/value/function/if-single-line-functions-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-single-line-functions-out.hs @@ -0,0 +1,4 @@ +foo x = + if x > 2 + then bar x + else baz x diff --git a/data/examples/declaration/value/function/if-single-line-functions.hs b/data/examples/declaration/value/function/if-single-line-functions.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-single-line-functions.hs @@ -0,0 +1,4 @@ +foo x = + if x > 2 + then bar x + else baz x diff --git a/data/examples/declaration/value/function/if-with-comment-above-branches-out.hs b/data/examples/declaration/value/function/if-with-comment-above-branches-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-above-branches-out.hs @@ -0,0 +1,7 @@ +foo = + if undefined + -- then comment + then undefined + -- else comment + else do + undefined diff --git a/data/examples/declaration/value/function/if-with-comment-above-branches.hs b/data/examples/declaration/value/function/if-with-comment-above-branches.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-above-branches.hs @@ -0,0 +1,8 @@ +foo = + if undefined + -- then comment + then undefined + -- else comment + else + do + undefined diff --git a/data/examples/declaration/value/function/if-with-comment-before-do-blocks-out.hs b/data/examples/declaration/value/function/if-with-comment-before-do-blocks-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-before-do-blocks-out.hs @@ -0,0 +1,10 @@ +foo = + if something + -- then comment + then do + stuff + stuff + -- else comment + else do + stuff + stuff diff --git a/data/examples/declaration/value/function/if-with-comment-before-do-blocks.hs b/data/examples/declaration/value/function/if-with-comment-before-do-blocks.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-before-do-blocks.hs @@ -0,0 +1,10 @@ +foo = + if something + -- then comment + then do + stuff + stuff + -- else comment + else do + stuff + stuff diff --git a/data/examples/declaration/value/function/if-with-comment-in-branches-out.hs b/data/examples/declaration/value/function/if-with-comment-in-branches-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-in-branches-out.hs @@ -0,0 +1,14 @@ +foo = + if x + then + -- comment 1 + -- comment 2 + case a of + Just b -> _ + Nothing -> _ + else + -- comment 3 + -- comment 4 + case a of + Just b -> _ + Nothing -> _ diff --git a/data/examples/declaration/value/function/if-with-comment-in-branches-with-functions-out.hs b/data/examples/declaration/value/function/if-with-comment-in-branches-with-functions-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-in-branches-with-functions-out.hs @@ -0,0 +1,12 @@ +foo = + if x + then + -- comment 1 + -- comment 2 + foo 1 2 3 + else + -- comment 3 + -- comment 4 + foo + "here" + "there" diff --git a/data/examples/declaration/value/function/if-with-comment-in-branches-with-functions.hs b/data/examples/declaration/value/function/if-with-comment-in-branches-with-functions.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-in-branches-with-functions.hs @@ -0,0 +1,12 @@ +foo = + if x + then + -- comment 1 + -- comment 2 + foo 1 2 3 + else + -- comment 3 + -- comment 4 + foo + "here" + "there" diff --git a/data/examples/declaration/value/function/if-with-comment-in-branches.hs b/data/examples/declaration/value/function/if-with-comment-in-branches.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-in-branches.hs @@ -0,0 +1,14 @@ +foo = + if x + then + -- comment 1 + -- comment 2 + case a of + Just b -> _ + Nothing -> _ + else + -- comment 3 + -- comment 4 + case a of + Just b -> _ + Nothing -> _ diff --git a/data/examples/declaration/value/function/if-with-comment-next-to-keyword-out.hs b/data/examples/declaration/value/function/if-with-comment-next-to-keyword-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-next-to-keyword-out.hs @@ -0,0 +1,10 @@ +foo = + if x + then -- comment 1 + -- comment 2 + foo 1 2 3 + else -- comment 3 + -- comment 4 + foo + "here" + "there" diff --git a/data/examples/declaration/value/function/if-with-comment-next-to-keyword.hs b/data/examples/declaration/value/function/if-with-comment-next-to-keyword.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-next-to-keyword.hs @@ -0,0 +1,10 @@ +foo = + if x + then -- comment 1 + -- comment 2 + foo 1 2 3 + else -- comment 3 + -- comment 4 + foo + "here" + "there" diff --git a/data/examples/declaration/value/function/if-with-comment-out.hs b/data/examples/declaration/value/function/if-with-comment-out.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/if-with-comment-out.hs +++ /dev/null @@ -1,8 +0,0 @@ -foo = - if undefined - then -- then comment - undefined - else -- else comment - - do - undefined diff --git a/data/examples/declaration/value/function/if-with-comment.hs b/data/examples/declaration/value/function/if-with-comment.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/if-with-comment.hs +++ /dev/null @@ -1,8 +0,0 @@ -foo = - if undefined - -- then comment - then undefined - -- else comment - else - do - undefined diff --git a/data/examples/declaration/value/function/implicit-params-out.hs b/data/examples/declaration/value/function/implicit-params-out.hs --- a/data/examples/declaration/value/function/implicit-params-out.hs +++ b/data/examples/declaration/value/function/implicit-params-out.hs @@ -11,6 +11,5 @@ a -> a -> Bool, ?foo :: Int ) => - [a] -> - [a] + [a] -> [a] sort' = sort diff --git a/data/examples/declaration/value/function/infix/applicative-out.hs b/data/examples/declaration/value/function/infix/applicative-out.hs --- a/data/examples/declaration/value/function/infix/applicative-out.hs +++ b/data/examples/declaration/value/function/infix/applicative-out.hs @@ -1,4 +1,5 @@ f = - Foo <$> bar + Foo + <$> bar <*> baz <*> baz' 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 new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-1-out.hs @@ -0,0 +1,22 @@ +module Main where + +foo = + fmap escapeLeadingDollar + . dropPaddingSpace + . dropWhileEnd T.null + . fmap (T.stripEnd . T.pack) + . lines + $ unpackHDS docStr + +foo = + when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $ + throwIO (OrmoluCppEnabled path) + +foo = + bar + $ baz + $ quux + +x = + case l of { A -> B } $ + case q of r -> s diff --git a/data/examples/declaration/value/function/infix/dollar-chains-1.hs b/data/examples/declaration/value/function/infix/dollar-chains-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-1.hs @@ -0,0 +1,22 @@ +module Main where + +foo = + fmap escapeLeadingDollar + . dropPaddingSpace + . dropWhileEnd T.null + . fmap (T.stripEnd . T.pack) + . lines + $ unpackHDS docStr + +foo = + when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $ + throwIO (OrmoluCppEnabled path) + +foo = + bar + $ baz + $ quux + +x = + case l of { A -> B } $ + case q of r -> s diff --git a/data/examples/declaration/value/function/infix/dollar-chains-2-out.hs b/data/examples/declaration/value/function/infix/dollar-chains-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-2-out.hs @@ -0,0 +1,17 @@ +module Main where + +foo = + bar + $ do 1 + $ quux + +abc = + a1 $ + a2 $ do + 3 + +cde = + b1 $ + b2 $ + b3 $ \c -> + putStrLn "foo" diff --git a/data/examples/declaration/value/function/infix/dollar-chains-2.hs b/data/examples/declaration/value/function/infix/dollar-chains-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-2.hs @@ -0,0 +1,18 @@ +module Main where + +foo = + bar $ + do 1 + $ + quux + +abc = + a1 $ + a2 $ do + 3 + +cde = + b1 + $ b2 + $ b3 $ \c -> + putStrLn "foo" 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 new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-3-out.hs @@ -0,0 +1,11 @@ +ex1 = + f1 + $ arg1 + $ arg2 + $ arg3 + +ex3 = + f1 + $ arg1 + $ arg2 + $ 1 + 3 diff --git a/data/examples/declaration/value/function/infix/dollar-chains-3.hs b/data/examples/declaration/value/function/infix/dollar-chains-3.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-3.hs @@ -0,0 +1,9 @@ +ex1 = + f1 $ + arg1 $ + arg2 $ arg3 + +ex3 = + f1 $ + arg1 $ + arg2 $ 1 + 3 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 new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-4-out.hs @@ -0,0 +1,5 @@ +ex2 = + f1 + $ arg1 + $ arg2 + $ f2 arg3 diff --git a/data/examples/declaration/value/function/infix/dollar-chains-4.hs b/data/examples/declaration/value/function/infix/dollar-chains-4.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-4.hs @@ -0,0 +1,4 @@ +ex2 = + f1 $ + arg1 $ + arg2 $ f2 arg3 diff --git a/data/examples/declaration/value/function/infix/dollar-chains-5-out.hs b/data/examples/declaration/value/function/infix/dollar-chains-5-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-5-out.hs @@ -0,0 +1,11 @@ +ex4 = + f1 $ + arg1 $ + arg2 $ do + arg3 + +ex6 = + f1 $ + arg1 $ + arg2 $ + do arg3 diff --git a/data/examples/declaration/value/function/infix/dollar-chains-5.hs b/data/examples/declaration/value/function/infix/dollar-chains-5.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-5.hs @@ -0,0 +1,10 @@ +ex4 = + f1 $ + arg1 $ + arg2 $ do + arg3 + +ex6 = + f1 $ + arg1 $ + arg2 $ do arg3 diff --git a/data/examples/declaration/value/function/infix/dollar-chains-6-out.hs b/data/examples/declaration/value/function/infix/dollar-chains-6-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-6-out.hs @@ -0,0 +1,11 @@ +ex5 = + f1 $ + arg1 $ + arg2 $ \c -> + 3 * c + +ex7 = + f1 $ + arg1 $ + arg2 $ + \c -> 3 * c diff --git a/data/examples/declaration/value/function/infix/dollar-chains-6.hs b/data/examples/declaration/value/function/infix/dollar-chains-6.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-6.hs @@ -0,0 +1,10 @@ +ex5 = + f1 $ + arg1 $ + arg2 $ \c -> + 3 * c + +ex7 = + f1 $ + arg1 $ + arg2 $ \c -> 3 * c diff --git a/data/examples/declaration/value/function/infix/dollar-chains-out.hs b/data/examples/declaration/value/function/infix/dollar-chains-out.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/infix/dollar-chains-out.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Main where - -foo = - fmap escapeLeadingDollar - . dropPaddingSpace - . dropWhileEnd T.null - . fmap (T.stripEnd . T.pack) - . lines - $ unpackHDS docStr - -foo = - when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $ - throwIO (OrmoluCppEnabled path) - -foo = - bar $ - baz $ - quux - -x = - case l of { A -> B } $ - case q of r -> s diff --git a/data/examples/declaration/value/function/infix/dollar-chains.hs b/data/examples/declaration/value/function/infix/dollar-chains.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/infix/dollar-chains.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Main where - -foo = - fmap escapeLeadingDollar - . dropPaddingSpace - . dropWhileEnd T.null - . fmap (T.stripEnd . T.pack) - . lines - $ unpackHDS docStr - -foo = - when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $ - throwIO (OrmoluCppEnabled path) - -foo = - bar - $ baz - $ quux - -x = - case l of { A -> B } $ - case q of r -> s diff --git a/data/examples/declaration/value/function/infix/esqueleto-0-out.hs b/data/examples/declaration/value/function/infix/esqueleto-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/esqueleto-0-out.hs @@ -0,0 +1,12 @@ +import Database.Esqueleto.Experimental + +foo = select $ do + t <- + from $ + table @Bar + `innerJoin` table @Baz + `on` do + \(br :& bz) -> whatever + where_ $ + t ^. BarInt ==. val 3 + &&. t ^. BarName `in_` valList ["hello", "world"] diff --git a/data/examples/declaration/value/function/infix/esqueleto-0.hs b/data/examples/declaration/value/function/infix/esqueleto-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/esqueleto-0.hs @@ -0,0 +1,10 @@ +import Database.Esqueleto.Experimental + +foo = select $ do + t <- from $ table @Bar + `innerJoin` table @Baz + `on` do + \(br :& bz) -> whatever + where_ $ + t ^. BarInt ==. val 3 + &&. t ^. BarName `in_` valList ["hello", "world"] diff --git a/data/examples/declaration/value/function/infix/esqueleto-1-out.hs b/data/examples/declaration/value/function/infix/esqueleto-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/esqueleto-1-out.hs @@ -0,0 +1,9 @@ +import qualified Database.Esqueleto.Experimental as E + +foo = + E.from $ + E.table + `E.innerJoin` E.table + `E.on` ( \(a :& b) -> + a E.^. AField E.==. b E.^. BField + ) diff --git a/data/examples/declaration/value/function/infix/esqueleto-1.hs b/data/examples/declaration/value/function/infix/esqueleto-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/esqueleto-1.hs @@ -0,0 +1,9 @@ +import qualified Database.Esqueleto.Experimental as E + +foo = + E.from $ + E.table + `E.innerJoin` E.table + `E.on` ( \(a :& b) -> + a E.^. AField E.==. b E.^. BField + ) diff --git a/data/examples/declaration/value/function/infix/fractional-precedence-out.hs b/data/examples/declaration/value/function/infix/fractional-precedence-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/fractional-precedence-out.hs @@ -0,0 +1,3 @@ +startFormTok |~| messageTag + >~< startMessageTok |~| name + >~< p' |~| endMessageTok |~| endFormTok diff --git a/data/examples/declaration/value/function/infix/fractional-precedence.hs b/data/examples/declaration/value/function/infix/fractional-precedence.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/fractional-precedence.hs @@ -0,0 +1,3 @@ +startFormTok |~| messageTag + >~< startMessageTok |~| name + >~< p' |~| endMessageTok |~| endFormTok diff --git a/data/examples/declaration/value/function/infix/hspec-expectation-out.hs b/data/examples/declaration/value/function/infix/hspec-expectation-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/hspec-expectation-out.hs @@ -0,0 +1,8 @@ +import Test.Hspec + +my_tests = do + context "my context" $ + it "does something" $ + property $ \pos xs0 xs1 -> + FancyError pos xs0 <> FancyError pos xs1 + `shouldBe` (FancyError pos (E.union xs0 xs1) :: PE) diff --git a/data/examples/declaration/value/function/infix/hspec-expectation.hs b/data/examples/declaration/value/function/infix/hspec-expectation.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/hspec-expectation.hs @@ -0,0 +1,8 @@ +import Test.Hspec + +my_tests = do + context "my context" $ + it "does something" $ + property $ \pos xs0 xs1 -> + FancyError pos xs0 <> FancyError pos xs1 + `shouldBe` (FancyError pos (E.union xs0 xs1) :: PE) 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,12 +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 @@ -15,7 +17,8 @@ wreq = let opts = - defaults & auth ?~ awsAuth AWSv4 "key" "secret" + defaults + & auth ?~ awsAuth AWSv4 "key" "secret" & header "Accept" .~ ["application/json"] & header "Runscope-Bucket-Auth" .~ ["1example-1111-4yyyy-zzzz-xxxxxxxx"] in getWith opts diff --git a/data/examples/declaration/value/function/infix/lenses.hs b/data/examples/declaration/value/function/infix/lenses.hs --- a/data/examples/declaration/value/function/infix/lenses.hs +++ b/data/examples/declaration/value/function/infix/lenses.hs @@ -1,3 +1,5 @@ +import Control.Lens + lenses = Just $ M.fromList $ "type" .= ("user.connection" :: Text) # "connection" .= uc diff --git a/data/examples/declaration/value/function/infix/op-chain-colon-do-out.hs b/data/examples/declaration/value/function/infix/op-chain-colon-do-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-colon-do-out.hs @@ -0,0 +1,10 @@ +-- chain mixing : and do-blocks +d = + do + 1 + : do + 2 + : do + 3 + : do + 4 diff --git a/data/examples/declaration/value/function/infix/op-chain-colon-do.hs b/data/examples/declaration/value/function/infix/op-chain-colon-do.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-colon-do.hs @@ -0,0 +1,10 @@ +-- chain mixing : and do-blocks +d = + do + 1 + : do + 2 + : do + 3 + : do + 4 diff --git a/data/examples/declaration/value/function/infix/op-chain-l-eq-out.hs b/data/examples/declaration/value/function/infix/op-chain-l-eq-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-l-eq-out.hs @@ -0,0 +1,11 @@ +-- Left chain, 2 operators with p(a) == p(b) +s :: Int +s = + 1 + + 2 + + 3 + + 4 + - 5 + + 6 + + 7 + + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-l-eq.hs b/data/examples/declaration/value/function/infix/op-chain-l-eq.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-l-eq.hs @@ -0,0 +1,11 @@ +-- Left chain, 2 operators with p(a) == p(b) +s :: Int +s = + 1 + + 2 + + 3 + + 4 - + 5 + + 6 + + 7 + + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-l-gt-out.hs b/data/examples/declaration/value/function/infix/op-chain-l-gt-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-l-gt-out.hs @@ -0,0 +1,11 @@ +-- Left chain, 2 operators with p(a) > p(b) +t :: Int +t = + 1 + + 2 + + 3 + + 4 + >> 5 + + 6 + + 7 + + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-l-gt.hs b/data/examples/declaration/value/function/infix/op-chain-l-gt.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-l-gt.hs @@ -0,0 +1,11 @@ +-- Left chain, 2 operators with p(a) > p(b) +t :: Int +t = + 1 + + 2 + + 3 + + 4 >> + 5 + + 6 + + 7 + + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-l-lt-out.hs b/data/examples/declaration/value/function/infix/op-chain-l-lt-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-l-lt-out.hs @@ -0,0 +1,11 @@ +-- Left chain, 2 operators with p(a) < p(b) +u :: Int +u = + 1 + + 2 + + 3 + + 4 + * 5 + + 6 + + 7 + + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-l-lt.hs b/data/examples/declaration/value/function/infix/op-chain-l-lt.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-l-lt.hs @@ -0,0 +1,11 @@ +-- Left chain, 2 operators with p(a) < p(b) +u :: Int +u = + 1 + + 2 + + 3 + + 4 * + 5 + + 6 + + 7 + + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-l-s-out.hs b/data/examples/declaration/value/function/infix/op-chain-l-s-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-l-s-out.hs @@ -0,0 +1,7 @@ +-- Left chain, 1 operator type +r :: Int +r = + 1 + + 2 + + 3 + + 4 diff --git a/data/examples/declaration/value/function/infix/op-chain-l-s.hs b/data/examples/declaration/value/function/infix/op-chain-l-s.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-l-s.hs @@ -0,0 +1,7 @@ +-- Left chain, 1 operator type +r :: Int +r = + 1 + + 2 + + 3 + + 4 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-eq-colon-1-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-eq-colon-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-colon-1-out.hs @@ -0,0 +1,11 @@ +-- Right chain, : case, 2 operators with p(:) == p(b) +h :: Int +h = + 1 + : 2 + : 3 + : 4 + ++ 5 + : 6 + : 7 + : 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-eq-colon-1.hs b/data/examples/declaration/value/function/infix/op-chain-r-eq-colon-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-colon-1.hs @@ -0,0 +1,11 @@ +-- Right chain, : case, 2 operators with p(:) == p(b) +h :: Int +h = + 1 : + 2 : + 3 : + 4 ++ + 5 : + 6 : + 7 : + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-eq-colon-2-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-eq-colon-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-colon-2-out.hs @@ -0,0 +1,11 @@ +-- Right chain, : case, 2 operators with p(a) == p(:) +k :: Int +k = + 1 + ++ 2 + ++ 3 + ++ 4 + : 5 + ++ 6 + ++ 7 + ++ 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-eq-colon-2.hs b/data/examples/declaration/value/function/infix/op-chain-r-eq-colon-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-colon-2.hs @@ -0,0 +1,11 @@ +-- Right chain, : case, 2 operators with p(a) == p(:) +k :: Int +k = + 1 ++ + 2 ++ + 3 ++ + 4 : + 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 new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-1-out.hs @@ -0,0 +1,11 @@ +-- Right chain, $ case, 2 operators with p($) == p(b) +n :: Int +n = + 1 + $ 2 + $ 3 + $ 4 + `seq` 5 + $ 6 + $ 7 + $ 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-1.hs b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-1.hs @@ -0,0 +1,11 @@ +-- Right chain, $ case, 2 operators with p($) == p(b) +n :: Int +n = + 1 $ + 2 $ + 3 $ + 4 `seq` + 5 $ + 6 $ + 7 $ + 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 new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-2-out.hs @@ -0,0 +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 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-2.hs b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-dollar-2.hs @@ -0,0 +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 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-eq-normal-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-eq-normal-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-normal-out.hs @@ -0,0 +1,11 @@ +-- Right chain, normal case, 2 operators with p(a) == p(b) +e :: Int +e = + 1 + ^^ 2 + ^^ 3 + ^^ 4 + ^ 5 + ^^ 6 + ^^ 7 + ^^ 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-eq-normal.hs b/data/examples/declaration/value/function/infix/op-chain-r-eq-normal.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-eq-normal.hs @@ -0,0 +1,11 @@ +-- Right chain, normal case, 2 operators with p(a) == p(b) +e :: Int +e = + 1 ^^ + 2 ^^ + 3 ^^ + 4 ^ + 5 ^^ + 6 ^^ + 7 ^^ + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-gt-colon-1-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-gt-colon-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-gt-colon-1-out.hs @@ -0,0 +1,11 @@ +-- Right chain, : case, 2 operators with p(:) > p(b) +i :: Int +i = + 1 + : 2 + : 3 + : 4 + `seq` 5 + : 6 + : 7 + : 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-gt-colon-1.hs b/data/examples/declaration/value/function/infix/op-chain-r-gt-colon-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-gt-colon-1.hs @@ -0,0 +1,11 @@ +-- Right chain, : case, 2 operators with p(:) > p(b) +i :: Int +i = + 1 : + 2 : + 3 : + 4 `seq` + 5 : + 6 : + 7 : + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-gt-colon-2-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-gt-colon-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-gt-colon-2-out.hs @@ -0,0 +1,11 @@ +-- Right chain, : case, 2 operators with p(a) > p(:) +l :: Int +l = + 1 + ^^ 2 + ^^ 3 + ^^ 4 + : 5 + ^^ 6 + ^^ 7 + ^^ 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-gt-colon-2.hs b/data/examples/declaration/value/function/infix/op-chain-r-gt-colon-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-gt-colon-2.hs @@ -0,0 +1,11 @@ +-- Right chain, : case, 2 operators with p(a) > p(:) +l :: Int +l = + 1 ^^ + 2 ^^ + 3 ^^ + 4 : + 5 ^^ + 6 ^^ + 7 ^^ + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-gt-dollar-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-gt-dollar-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-gt-dollar-out.hs @@ -0,0 +1,11 @@ +-- Right chain, $ case, 2 operators with p(a) > p($) +q :: Int +q = + 1 + ++ 2 + ++ 3 + ++ 4 + $ 5 + ++ 6 + ++ 7 + ++ 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-gt-dollar.hs b/data/examples/declaration/value/function/infix/op-chain-r-gt-dollar.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-gt-dollar.hs @@ -0,0 +1,11 @@ +-- Right chain, $ case, 2 operators with p(a) > p($) +q :: Int +q = + 1 ++ + 2 ++ + 3 ++ + 4 $ + 5 ++ + 6 ++ + 7 ++ + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-gt-normal-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-gt-normal-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-gt-normal-out.hs @@ -0,0 +1,11 @@ +-- Right chain, normal case, 2 operators with p(a) > p(b) +f :: Int +f = + 1 + ^^ 2 + ^^ 3 + ^^ 4 + ++ 5 + ^^ 6 + ^^ 7 + ^^ 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-gt-normal.hs b/data/examples/declaration/value/function/infix/op-chain-r-gt-normal.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-gt-normal.hs @@ -0,0 +1,11 @@ +-- Right chain, normal case, 2 operators with p(a) > p(b) +f :: Int +f = + 1 ^^ + 2 ^^ + 3 ^^ + 4 ++ + 5 ^^ + 6 ^^ + 7 ^^ + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-lt-colon-1-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-lt-colon-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-lt-colon-1-out.hs @@ -0,0 +1,11 @@ +-- Right chain, : case, 2 operators with p(:) < p(b) +j :: Int +j = + 1 + : 2 + : 3 + : 4 + ^^ 5 + : 6 + : 7 + : 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-lt-colon-1.hs b/data/examples/declaration/value/function/infix/op-chain-r-lt-colon-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-lt-colon-1.hs @@ -0,0 +1,11 @@ +-- Right chain, : case, 2 operators with p(:) < p(b) +j :: Int +j = + 1 : + 2 : + 3 : + 4 ^^ + 5 : + 6 : + 7 : + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-lt-colon-2-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-lt-colon-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-lt-colon-2-out.hs @@ -0,0 +1,11 @@ +-- Right chain, : case, 2 operators with p(a) < p(:) +m :: Int +m = + 1 + || 2 + || 3 + || 4 + : 5 + || 6 + || 7 + || 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-lt-colon-2.hs b/data/examples/declaration/value/function/infix/op-chain-r-lt-colon-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-lt-colon-2.hs @@ -0,0 +1,11 @@ +-- Right chain, : case, 2 operators with p(a) < p(:) +m :: Int +m = + 1 || + 2 || + 3 || + 4 : + 5 || + 6 || + 7 || + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-lt-dollar-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-lt-dollar-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-lt-dollar-out.hs @@ -0,0 +1,11 @@ +-- Right chain, $ case, 2 operators with p($) < p(b) +o :: Int +o = + 1 + $ 2 + $ 3 + $ 4 + ++ 5 + $ 6 + $ 7 + $ 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-lt-dollar.hs b/data/examples/declaration/value/function/infix/op-chain-r-lt-dollar.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-lt-dollar.hs @@ -0,0 +1,11 @@ +-- Right chain, $ case, 2 operators with p($) < p(b) +o :: Int +o = + 1 $ + 2 $ + 3 $ + 4 ++ + 5 $ + 6 $ + 7 $ + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-lt-normal-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-lt-normal-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-lt-normal-out.hs @@ -0,0 +1,11 @@ +-- Right chain, normal case, 2 operators with p(a) < p(b) +g :: Int +g = + 1 + ++ 2 + ++ 3 + ++ 4 + ^^ 5 + ++ 6 + ++ 7 + ++ 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-lt-normal.hs b/data/examples/declaration/value/function/infix/op-chain-r-lt-normal.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-lt-normal.hs @@ -0,0 +1,11 @@ +-- Right chain, normal case, 2 operators with p(a) < p(b) +g :: Int +g = + 1 ++ + 2 ++ + 3 ++ + 4 ^^ + 5 ++ + 6 ++ + 7 ++ + 8 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-s-colon-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-s-colon-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-s-colon-out.hs @@ -0,0 +1,7 @@ +-- Right chain, : case, 1 operator type +b :: Int +b = + 1 + : 2 + : 3 + : 4 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-s-colon.hs b/data/examples/declaration/value/function/infix/op-chain-r-s-colon.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-s-colon.hs @@ -0,0 +1,7 @@ +-- Right chain, : case, 1 operator type +b :: Int +b = + 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 new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-s-dollar-out.hs @@ -0,0 +1,7 @@ +-- Right chain, $ case, 1 operator type +c :: Int +c = + 1 + $ 2 + $ 3 + $ 4 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-s-dollar.hs b/data/examples/declaration/value/function/infix/op-chain-r-s-dollar.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-s-dollar.hs @@ -0,0 +1,7 @@ +-- Right chain, $ case, 1 operator type +c :: Int +c = + 1 $ + 2 $ + 3 $ + 4 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-s-normal-out.hs b/data/examples/declaration/value/function/infix/op-chain-r-s-normal-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-s-normal-out.hs @@ -0,0 +1,7 @@ +-- Right chain, normal case, 1 operator type +a :: Int +a = + 1 + ++ 2 + ++ 3 + ++ 4 diff --git a/data/examples/declaration/value/function/infix/op-chain-r-s-normal.hs b/data/examples/declaration/value/function/infix/op-chain-r-s-normal.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/op-chain-r-s-normal.hs @@ -0,0 +1,7 @@ +-- Right chain, normal case, 1 operator type +a :: Int +a = + 1 ++ + 2 ++ + 3 ++ + 4 diff --git a/data/examples/declaration/value/function/infix/qualified-ops-out.hs b/data/examples/declaration/value/function/infix/qualified-ops-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/qualified-ops-out.hs @@ -0,0 +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.# [] diff --git a/data/examples/declaration/value/function/infix/qualified-ops.hs b/data/examples/declaration/value/function/infix/qualified-ops.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/qualified-ops.hs @@ -0,0 +1,7 @@ +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.# [] diff --git a/data/examples/declaration/value/function/infix/qualified-prelude-out.hs b/data/examples/declaration/value/function/infix/qualified-prelude-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/qualified-prelude-out.hs @@ -0,0 +1,12 @@ +module StreamSpec where + +import Prelude (($)) +import qualified Prelude + +spec :: Spec +spec = do + describe "Comparing list function to" $ do + qit "yieldMany" $ + \(mono :: Seq Int) -> + yieldMany mono + `checkProducer` otoList mono diff --git a/data/examples/declaration/value/function/infix/qualified-prelude.hs b/data/examples/declaration/value/function/infix/qualified-prelude.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/qualified-prelude.hs @@ -0,0 +1,12 @@ +module StreamSpec where + +import qualified Prelude +import Prelude (($)) + +spec :: Spec +spec = do + describe "Comparing list function to" $ do + qit "yieldMany" $ + \(mono :: Seq Int) -> + yieldMany mono `checkProducer` + otoList mono diff --git a/data/examples/declaration/value/function/infix/tricky-colon-chain-out.hs b/data/examples/declaration/value/function/infix/tricky-colon-chain-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/tricky-colon-chain-out.hs @@ -0,0 +1,9 @@ +b :: [Int] +b = + 1 + : do + 2 + : do + 3 + : do + [4] diff --git a/data/examples/declaration/value/function/infix/tricky-colon-chain.hs b/data/examples/declaration/value/function/infix/tricky-colon-chain.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/tricky-colon-chain.hs @@ -0,0 +1,9 @@ +b :: [Int] +b = + 1 : + do + 2 + : do + 3 + : do + [4] diff --git a/data/examples/declaration/value/function/lambda-case-out.hs b/data/examples/declaration/value/function/lambda-case-out.hs --- a/data/examples/declaration/value/function/lambda-case-out.hs +++ b/data/examples/declaration/value/function/lambda-case-out.hs @@ -7,3 +7,17 @@ 5 -> 10 i | i > 5 -> 11 _ -> 12 + +foo :: Maybe a -> Maybe a -> Maybe a -> Int +foo = \cases Nothing Just {} Nothing -> 1; _ _ _ -> 0 + +foo :: Maybe Int -> Maybe Int -> Int +foo = \cases + (Just a) (Just a) -> a + a + _ _ -> 0 + +foo :: Bool -> Bool -> Bool +foo = \cases + True + True -> True + _ _ -> False diff --git a/data/examples/declaration/value/function/lambda-case.hs b/data/examples/declaration/value/function/lambda-case.hs --- a/data/examples/declaration/value/function/lambda-case.hs +++ b/data/examples/declaration/value/function/lambda-case.hs @@ -7,3 +7,17 @@ 5 -> 10 i | i > 5 -> 11 _ -> 12 + +foo :: Maybe a -> Maybe a -> Maybe a -> Int +foo = \cases Nothing Just{} Nothing -> 1; _ _ _ -> 0 + +foo :: Maybe Int -> Maybe Int -> Int +foo = \cases + (Just a) (Just a) -> a + a + _ _ -> 0 + +foo :: Bool -> Bool -> Bool +foo = \cases + True + True -> True + _ _ -> False diff --git a/data/examples/declaration/value/function/lambda-comment-after-arrow-out.hs b/data/examples/declaration/value/function/lambda-comment-after-arrow-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/lambda-comment-after-arrow-out.hs @@ -0,0 +1,2 @@ +f = \a -> -- foo + a diff --git a/data/examples/declaration/value/function/lambda-comment-after-arrow.hs b/data/examples/declaration/value/function/lambda-comment-after-arrow.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/lambda-comment-after-arrow.hs @@ -0,0 +1,2 @@ +f = \a -> -- foo + a diff --git a/data/examples/declaration/value/function/let-multi-line-out.hs b/data/examples/declaration/value/function/let-multi-line-out.hs --- a/data/examples/declaration/value/function/let-multi-line-out.hs +++ b/data/examples/declaration/value/function/let-multi-line-out.hs @@ -17,7 +17,7 @@ () -> undefined in go -implicitParams :: HasCallStack => Int +implicitParams :: (HasCallStack) => Int implicitParams = let ?cs = ?callstack in foo cs diff --git a/data/examples/declaration/value/function/linear-bindings-out.hs b/data/examples/declaration/value/function/linear-bindings-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/linear-bindings-out.hs @@ -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 () diff --git a/data/examples/declaration/value/function/linear-bindings.hs b/data/examples/declaration/value/function/linear-bindings.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/linear-bindings.hs @@ -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 () diff --git a/data/examples/declaration/value/function/list-comprehensions-out.hs b/data/examples/declaration/value/function/list-comprehensions-out.hs --- a/data/examples/declaration/value/function/list-comprehensions-out.hs +++ b/data/examples/declaration/value/function/list-comprehensions-out.hs @@ -4,21 +4,40 @@ barbaz x y z w = [ (a, b, c, d) -- Foo - | a <- - x, -- Bar - b <- y, -- Baz - any even [a, b], - c <- - z - * z ^ 2, -- Bar baz - d <- - w - + w, -- Baz bar - all - even - [ a, - b, - c, - d - ] + | a <- + x, -- Bar + b <- y, -- Baz + any even [a, b], + c <- + z + * z ^ 2, -- Bar baz + d <- + w + + w, -- Baz bar + all + even + [ a, + b, + c, + d + ] + ] + +a = do + d <- + [ x + 1 + | x <- b + ] + + [ c + | c <- d + ] + +trans = + [ x + | x <- xs, + then + reverse, + then + reverse ] diff --git a/data/examples/declaration/value/function/list-comprehensions.hs b/data/examples/declaration/value/function/list-comprehensions.hs --- a/data/examples/declaration/value/function/list-comprehensions.hs +++ b/data/examples/declaration/value/function/list-comprehensions.hs @@ -20,3 +20,19 @@ c, d ] ] + +a = do + d <- + [ x + 1 + | x <- b + ] + + [ c + | c <- d ] + +trans = + [ x + | x <- xs + , then reverse + , then reverse + ] diff --git a/data/examples/declaration/value/function/list-notation-0-out.hs b/data/examples/declaration/value/function/list-notation-0-out.hs --- a/data/examples/declaration/value/function/list-notation-0-out.hs +++ b/data/examples/declaration/value/function/list-notation-0-out.hs @@ -1,5 +1,5 @@ foo = - testCase "Foo" testFoo : - testCase "Bar" testBar : - testCase "Baz" testBaz : - [] + testCase "Foo" testFoo + : testCase "Bar" testBar + : testCase "Baz" testBaz + : [] diff --git a/data/examples/declaration/value/function/list-notation-1-out.hs b/data/examples/declaration/value/function/list-notation-1-out.hs --- a/data/examples/declaration/value/function/list-notation-1-out.hs +++ b/data/examples/declaration/value/function/list-notation-1-out.hs @@ -1,8 +1,8 @@ instance A.ToJSON UpdateTable where toJSON a = A.object $ - "TableName" .= updateTableName a : - "ProvisionedThroughput" .= updateProvisionedThroughput a : - case updateGlobalSecondaryIndexUpdates a of - [] -> [] - l -> ["GlobalSecondaryIndexUpdates" .= l] + "TableName" .= updateTableName a + : "ProvisionedThroughput" .= updateProvisionedThroughput a + : case updateGlobalSecondaryIndexUpdates a of + [] -> [] + l -> ["GlobalSecondaryIndexUpdates" .= l] diff --git a/data/examples/declaration/value/function/list-notation-2-out.hs b/data/examples/declaration/value/function/list-notation-2-out.hs --- a/data/examples/declaration/value/function/list-notation-2-out.hs +++ b/data/examples/declaration/value/function/list-notation-2-out.hs @@ -1,6 +1,6 @@ -- A list of the element and all its parents up to the root node. getPath tree t = - t : - case Map.lookup (getId t) tree of - Nothing -> [] - Just parent -> getPath tree parent + t + : case Map.lookup (getId t) tree of + Nothing -> [] + Just parent -> getPath tree parent diff --git a/data/examples/declaration/value/function/list-notation-3-out.hs b/data/examples/declaration/value/function/list-notation-3-out.hs --- a/data/examples/declaration/value/function/list-notation-3-out.hs +++ b/data/examples/declaration/value/function/list-notation-3-out.hs @@ -1,12 +1,10 @@ foo = - reportSDoc "tc.cc" 30 $ - sep $ do - (prettyTCM q <+> " before compilation") : do - map (prettyTCM . map unArg . clPats) cls + reportSDoc "tc.cc" 30 $ sep $ do + (prettyTCM q <+> " before compilation") : do + map (prettyTCM . map unArg . clPats) cls foo = - reportSDoc "tc.cc" 30 $ - sep $ do - (prettyTCM q <+> " before compilation") : - do - map (prettyTCM . map unArg . clPats) cls + reportSDoc "tc.cc" 30 $ sep $ do + (prettyTCM q <+> " before compilation") + : do + map (prettyTCM . map unArg . clPats) cls diff --git a/data/examples/declaration/value/function/multi-way-if-out.hs b/data/examples/declaration/value/function/multi-way-if-out.hs --- a/data/examples/declaration/value/function/multi-way-if-out.hs +++ b/data/examples/declaration/value/function/multi-way-if-out.hs @@ -4,13 +4,15 @@ bar x y = if - | x > y -> x - | x < y -> + | x > y -> x + | x < y -> y - | otherwise -> x + | otherwise -> x baz = if | p -> f | otherwise -> g x + +x y = if | foo -> False | otherwise -> True diff --git a/data/examples/declaration/value/function/multi-way-if.hs b/data/examples/declaration/value/function/multi-way-if.hs --- a/data/examples/declaration/value/function/multi-way-if.hs +++ b/data/examples/declaration/value/function/multi-way-if.hs @@ -12,3 +12,5 @@ if | p -> f | otherwise -> g x + +x y = if | foo -> False | otherwise -> True diff --git a/data/examples/declaration/value/function/multiline-strings-0-out.hs b/data/examples/declaration/value/function/multiline-strings-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-0-out.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE MultilineStrings #-} + +s = + """Line 1 + Line 2 + Line 3 + """ + +s_2 = + """\ \Line 1 + Line 2 + Line 3 + """ + +-- equivalent to +s' = "Line 1\n Line 2\nLine 3" + +-- the following are equivalent +s = """hello world""" + +s' = "hello world" + +s = + """ hello + world + """ + +-- equivalent to +s' = " hello\nworld" diff --git a/data/examples/declaration/value/function/multiline-strings-0.hs b/data/examples/declaration/value/function/multiline-strings-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-0.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE MultilineStrings #-} + +s = + """Line 1 + Line 2 + Line 3 + """ + +s_2 = + """\ + \Line 1 + Line 2 + Line 3 + """ + +-- equivalent to +s' = "Line 1\n Line 2\nLine 3" + + +-- the following are equivalent +s = """hello world""" +s' = "hello world" + + +s = + """ hello + world + """ + +-- equivalent to +s' = " hello\nworld" diff --git a/data/examples/declaration/value/function/multiline-strings-1-out.hs b/data/examples/declaration/value/function/multiline-strings-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-1-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE MultilineStrings #-} + +s = + """ + a b\ \ c d e + f g + """ + +-- equivalent to +s' = "a b c d e\nf g" + +weirdGap = """\65\ \0""" diff --git a/data/examples/declaration/value/function/multiline-strings-1.hs b/data/examples/declaration/value/function/multiline-strings-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-1.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE MultilineStrings #-} + +s = + """ + a b\ + \ c d e + f g + """ + +-- equivalent to +s' = "a b c d e\nf g" + +weirdGap = """\65\ \0""" diff --git a/data/examples/declaration/value/function/multiline-strings-2-out.hs b/data/examples/declaration/value/function/multiline-strings-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-2-out.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MultilineStrings #-} + +s = + """ + a + b + c + """ + +-- equivalent to +s' = "a\nb\nc" diff --git a/data/examples/declaration/value/function/multiline-strings-2.hs b/data/examples/declaration/value/function/multiline-strings-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MultilineStrings #-} + +s = + """ + a + b + c + """ + +-- equivalent to +s' = "a\nb\nc" diff --git a/data/examples/declaration/value/function/multiline-strings-3-out.hs b/data/examples/declaration/value/function/multiline-strings-3-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-3-out.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE MultilineStrings #-} + +s = + """ + + a + b + c + """ + +-- equivalent to +s' = "\na\nb\nc" + +s1 = + """ a + b + c + """ + +s2 = + """ + a + b + c + """ + +-- In the current proposal, these are equivalent to +-- the below. If leading newline were removed at the +-- beginning, both would result in s1'. +s1' = " a\nb\nc" + +s2' = "a\nb\nc" diff --git a/data/examples/declaration/value/function/multiline-strings-3.hs b/data/examples/declaration/value/function/multiline-strings-3.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-3.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE MultilineStrings #-} + +s = + """ + + a + b + c + """ + +-- equivalent to +s' = "\na\nb\nc" + + +s1 = + """ a + b + c + """ + +s2 = + """ + a + b + c + """ + +-- In the current proposal, these are equivalent to +-- the below. If leading newline were removed at the +-- beginning, both would result in s1'. +s1' = " a\nb\nc" +s2' = "a\nb\nc" diff --git a/data/examples/declaration/value/function/multiline-strings-4-out.hs b/data/examples/declaration/value/function/multiline-strings-4-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-4-out.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE MultilineStrings #-} + +s = + """ + a + b + + """ + +-- equivalent to +s' = "a\nb\n" + +s1 = + """ + line 1 + line 2 + """ + +s2 = "line 3" + +s3 = + """ + line 4 + line 5 + """ diff --git a/data/examples/declaration/value/function/multiline-strings-4.hs b/data/examples/declaration/value/function/multiline-strings-4.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-4.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE MultilineStrings #-} + +s = + """ + a + b + + """ + +-- equivalent to +s' = "a\nb\n" + + +s1 = + """ + line 1 + line 2 + """ + +s2 = "line 3" + +s3 = + """ + line 4 + line 5 + """ diff --git a/data/examples/declaration/value/function/multiline-strings-5-out.hs b/data/examples/declaration/value/function/multiline-strings-5-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-5-out.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE MultilineStrings #-} + +s1 = + """ + a + b + c + """ + +s1' = "a\nb\nc" + +s2 = + """ + \& a + b + c + """ + +s2_2 = + """ + \& a + \& b + \& c + """ + +s2' = " a\n b\n c" diff --git a/data/examples/declaration/value/function/multiline-strings-5.hs b/data/examples/declaration/value/function/multiline-strings-5.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-5.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE MultilineStrings #-} + +s1 = + """ + a + b + c + """ + +s1' = "a\nb\nc" + +s2 = + """ + \& a + b + c + """ + +s2_2 = + """ + \& a + \& b + \& c + """ + +s2' = " a\n b\n c" diff --git a/data/examples/declaration/value/function/multiline-strings-6-out.hs b/data/examples/declaration/value/function/multiline-strings-6-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-6-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MultilineStrings #-} + +x = + """ + This is a literal multiline string: + \"\"\" + Hello + world! + \""" + """ diff --git a/data/examples/declaration/value/function/multiline-strings-6.hs b/data/examples/declaration/value/function/multiline-strings-6.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-6.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MultilineStrings #-} + +x = + """ + This is a literal multiline string: + \"\"\" + Hello + world! + \""" + """ diff --git a/data/examples/declaration/value/function/multiline-strings-7-out.hs b/data/examples/declaration/value/function/multiline-strings-7-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-7-out.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE MultilineStrings #-} + +printf + """ + instance Aeson.FromJSON %s where + parseJSON = + Aeson.withText "%s" $ \\s -> + either Aeson.parseFail pure $ + parsePrinterOptType (Text.unpack s) + + instance PrinterOptsFieldType %s where + parsePrinterOptType s = + case s of + %s + _ -> + Left . unlines $ + [ "unknown value: " <> show s + , "Valid values are: %s" + ] + + """ + fieldTypeName + fieldTypeName + fieldTypeName + ( unlines_ + [ printf " \"%s\" -> Right %s" val con + | (con, val) <- enumOptions + ] + ) + (renderEnumOptions enumOptions) diff --git a/data/examples/declaration/value/function/multiline-strings-7.hs b/data/examples/declaration/value/function/multiline-strings-7.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-7.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE MultilineStrings #-} + +printf + """ + instance Aeson.FromJSON %s where + parseJSON = + Aeson.withText "%s" $ \\s -> + either Aeson.parseFail pure $ + parsePrinterOptType (Text.unpack s) + + instance PrinterOptsFieldType %s where + parsePrinterOptType s = + case s of + %s + _ -> + Left . unlines $ + [ "unknown value: " <> show s + , "Valid values are: %s" + ] + + """ + fieldTypeName + fieldTypeName + fieldTypeName + ( unlines_ + [ printf " \"%s\" -> Right %s" val con + | (con, val) <- enumOptions + ] + ) + (renderEnumOptions enumOptions) diff --git a/data/examples/declaration/value/function/multiline-strings-8-out.hs b/data/examples/declaration/value/function/multiline-strings-8-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-8-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE MultilineStrings #-} + +type Foo = + """ + yeah + yeah""" + +foo = + foo + @"""yeah + yeah + """ diff --git a/data/examples/declaration/value/function/multiline-strings-8.hs b/data/examples/declaration/value/function/multiline-strings-8.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-8.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MultilineStrings #-} + +type Foo = """ + yeah + yeah""" + +foo = foo @"""yeah + yeah + """ diff --git a/data/examples/declaration/value/function/multiline-strings-9-out.hs b/data/examples/declaration/value/function/multiline-strings-9-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-9-out.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MultilineStrings #-} + +multilineBlank = + """ + 1 + + + + + 6 + """ diff --git a/data/examples/declaration/value/function/multiline-strings-9.hs b/data/examples/declaration/value/function/multiline-strings-9.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-strings-9.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MultilineStrings #-} + +multilineBlank = + """ + 1 + + + + + 6 + """ diff --git a/data/examples/declaration/value/function/multiline-types-out.hs b/data/examples/declaration/value/function/multiline-types-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-types-out.hs @@ -0,0 +1,17 @@ +foo :: + (Monad m, Show a) => + a -> + m String +bar :: + ( Monad m, + Show a + ) => + a -> m String +multiConstraints :: + (Show a) => + a -> + a -> + a -> + (Eq a) => + (Num a) => + a -> a -> () diff --git a/data/examples/declaration/value/function/multiline-types.hs b/data/examples/declaration/value/function/multiline-types.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-types.hs @@ -0,0 +1,15 @@ +foo :: + (Monad m, Show a) => + a -> + m String + +bar :: + (Monad m, + Show a) => + a -> m String + +multiConstraints :: + Show a => + a -> a -> a -> + Eq a => Num a => + a -> a -> () diff --git a/data/examples/declaration/value/function/multiple-guards-out.hs b/data/examples/declaration/value/function/multiple-guards-out.hs --- a/data/examples/declaration/value/function/multiple-guards-out.hs +++ b/data/examples/declaration/value/function/multiple-guards-out.hs @@ -6,9 +6,9 @@ bar :: Int -> Int bar x | x == 5 = - foo x - + foo 10 + foo x + + foo 10 | x == 6 = - foo x - + foo 20 + foo x + + foo 20 | otherwise = foo 100 diff --git a/data/examples/declaration/value/function/multiple-guards.hs b/data/examples/declaration/value/function/multiple-guards.hs --- a/data/examples/declaration/value/function/multiple-guards.hs +++ b/data/examples/declaration/value/function/multiple-guards.hs @@ -1,7 +1,6 @@ foo :: Int -> Int -foo x - | x == 5 = 10 - | otherwise = 12 +foo x | x == 5 = 10 + | otherwise = 12 bar :: Int -> Int bar x diff --git a/data/examples/declaration/value/function/newline-single-line-body-out.hs b/data/examples/declaration/value/function/newline-single-line-body-out.hs --- a/data/examples/declaration/value/function/newline-single-line-body-out.hs +++ b/data/examples/declaration/value/function/newline-single-line-body-out.hs @@ -4,7 +4,6 @@ function' :: String -> String function' s = case s of - "ThisString" -> - -- And a comment here is okay + "ThisString" -> -- And a comment here is okay "Yay" _ -> "Boo" diff --git a/data/examples/declaration/value/function/operator-comments-3-out.hs b/data/examples/declaration/value/function/operator-comments-3-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-comments-3-out.hs @@ -0,0 +1,5 @@ +data X = X {x :: Int} + +f = + id + . (\s -> s {x = 1}) -- Some comment diff --git a/data/examples/declaration/value/function/operator-comments-3.hs b/data/examples/declaration/value/function/operator-comments-3.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-comments-3.hs @@ -0,0 +1,5 @@ +data X = X { x :: Int } + +f = id + . -- Some comment + (\s -> s { x = 1 }) diff --git a/data/examples/declaration/value/function/operator-comments-4-out.hs b/data/examples/declaration/value/function/operator-comments-4-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-comments-4-out.hs @@ -0,0 +1,4 @@ +foo = do + bar + -- txt + $ baz diff --git a/data/examples/declaration/value/function/operator-comments-4.hs b/data/examples/declaration/value/function/operator-comments-4.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-comments-4.hs @@ -0,0 +1,4 @@ +foo = do + bar + -- txt + $ baz diff --git a/data/examples/declaration/value/function/operator-fixity-defaulting-out.hs b/data/examples/declaration/value/function/operator-fixity-defaulting-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-fixity-defaulting-out.hs @@ -0,0 +1,12 @@ +def1 = + (,,) + <$> gvar (primitiveGVar "natToHex") + `foo` ne + <*> con cNothing + `foo` tcon tChar + +def2 = + tds1 + && lc1 == mempty + && gc1 `M.isSubmapOf` gc2 + && sh1 == sh2 diff --git a/data/examples/declaration/value/function/operator-fixity-defaulting.hs b/data/examples/declaration/value/function/operator-fixity-defaulting.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-fixity-defaulting.hs @@ -0,0 +1,12 @@ +def1 = + (,,) + <$> gvar (primitiveGVar "natToHex") + `foo` ne + <*> con cNothing + `foo` tcon tChar + +def2 = + tds1 + && lc1 == mempty + && gc1 `M.isSubmapOf` gc2 + && sh1 == sh2 diff --git a/data/examples/declaration/value/function/operator-hash-with-unboxed-sums-out.hs b/data/examples/declaration/value/function/operator-hash-with-unboxed-sums-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-hash-with-unboxed-sums-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE UnboxedSums #-} + +module Foo (( #<| )) where + +( #<| ) :: Int -> Int -> Int +( #<| ) = (+) + +(+) = (+) diff --git a/data/examples/declaration/value/function/operator-hash-with-unboxed-sums.hs b/data/examples/declaration/value/function/operator-hash-with-unboxed-sums.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-hash-with-unboxed-sums.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE UnboxedSums #-} + +module Foo (( #<| )) where + +( #<| ) :: Int -> Int -> Int +( #<| ) = (+) + +(+) = (+) diff --git a/data/examples/declaration/value/function/operator-hash-without-unboxed-sums-out.hs b/data/examples/declaration/value/function/operator-hash-without-unboxed-sums-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-hash-without-unboxed-sums-out.hs @@ -0,0 +1,6 @@ +module Foo ((#<|)) where + +(#<|) :: Int -> Int -> Int +(#<|) = (+) + +(+) = (+) diff --git a/data/examples/declaration/value/function/operator-hash-without-unboxed-sums.hs b/data/examples/declaration/value/function/operator-hash-without-unboxed-sums.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-hash-without-unboxed-sums.hs @@ -0,0 +1,6 @@ +module Foo (( #<| )) where + +( #<| ) :: Int -> Int -> Int +( #<| ) = (+) + +(+) = (+) diff --git a/data/examples/declaration/value/function/operators-0-out.hs b/data/examples/declaration/value/function/operators-0-out.hs --- a/data/examples/declaration/value/function/operators-0-out.hs +++ b/data/examples/declaration/value/function/operators-0-out.hs @@ -1,5 +1,8 @@ +import Control.Lens.Operators + a = - b & c .~ d + b + & c .~ d & e %~ f g diff --git a/data/examples/declaration/value/function/operators-0.hs b/data/examples/declaration/value/function/operators-0.hs --- a/data/examples/declaration/value/function/operators-0.hs +++ b/data/examples/declaration/value/function/operators-0.hs @@ -1,3 +1,5 @@ +import Control.Lens.Operators + a = b & c .~ d & e %~ f diff --git a/data/examples/declaration/value/function/operators-2-out.hs b/data/examples/declaration/value/function/operators-2-out.hs --- a/data/examples/declaration/value/function/operators-2-out.hs +++ b/data/examples/declaration/value/function/operators-2-out.hs @@ -1,4 +1,6 @@ foo n - | x || y && z || n ** x + | x + || y && z + || n ** x || x && n = - 42 + 42 diff --git a/data/examples/declaration/value/function/operators-3-out.hs b/data/examples/declaration/value/function/operators-3-out.hs --- a/data/examples/declaration/value/function/operators-3-out.hs +++ b/data/examples/declaration/value/function/operators-3-out.hs @@ -1,3 +1,8 @@ +import Control.Arrow + foo = - op <> n <+> colon <+> prettySe <+> text "=" + op <> n + <+> colon + <+> prettySe + <+> text "=" <+> prettySe <> text sc diff --git a/data/examples/declaration/value/function/operators-3.hs b/data/examples/declaration/value/function/operators-3.hs --- a/data/examples/declaration/value/function/operators-3.hs +++ b/data/examples/declaration/value/function/operators-3.hs @@ -1,3 +1,5 @@ +import Control.Arrow + foo = op <> n <+> colon <+> prettySe <+> text "=" <+> prettySe <> text sc diff --git a/data/examples/declaration/value/function/operators-4-out.hs b/data/examples/declaration/value/function/operators-4-out.hs --- a/data/examples/declaration/value/function/operators-4-out.hs +++ b/data/examples/declaration/value/function/operators-4-out.hs @@ -1,3 +1,8 @@ +import Control.Arrow + foo = - line <> bindingOf <+> text "=" <+> tPretty <+> colon + line <> bindingOf + <+> text "=" + <+> tPretty + <+> colon <+> align <> prettyPs diff --git a/data/examples/declaration/value/function/operators-4.hs b/data/examples/declaration/value/function/operators-4.hs --- a/data/examples/declaration/value/function/operators-4.hs +++ b/data/examples/declaration/value/function/operators-4.hs @@ -1,3 +1,5 @@ +import Control.Arrow + foo = line <> bindingOf <+> text "=" <+> tPretty <+> colon <+> align <> prettyPs diff --git a/data/examples/declaration/value/function/operators-6-out.hs b/data/examples/declaration/value/function/operators-6-out.hs --- a/data/examples/declaration/value/function/operators-6-out.hs +++ b/data/examples/declaration/value/function/operators-6-out.hs @@ -1,3 +1,5 @@ +import Servant.API + type PermuteRef = "a" :> ( "b" :> "c" :> End diff --git a/data/examples/declaration/value/function/operators-6.hs b/data/examples/declaration/value/function/operators-6.hs --- a/data/examples/declaration/value/function/operators-6.hs +++ b/data/examples/declaration/value/function/operators-6.hs @@ -1,3 +1,5 @@ +import Servant.API + type PermuteRef = "a" :> ( "b" :> "c" :> End :<|> "c" :> "b" :> End diff --git a/data/examples/declaration/value/function/operators-7-out.hs b/data/examples/declaration/value/function/operators-7-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-7-out.hs @@ -0,0 +1,1 @@ +foo c = case c of { _ -> c } : [] diff --git a/data/examples/declaration/value/function/operators-7.hs b/data/examples/declaration/value/function/operators-7.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-7.hs @@ -0,0 +1,1 @@ +foo c = case c of {_->c} : [] diff --git a/data/examples/declaration/value/function/overloaded-labels-out.hs b/data/examples/declaration/value/function/overloaded-labels-out.hs --- a/data/examples/declaration/value/function/overloaded-labels-out.hs +++ b/data/examples/declaration/value/function/overloaded-labels-out.hs @@ -3,3 +3,36 @@ foo = #field bar = (#this) (#that) + +baz = #Foo #"Hello world!" #"\"" #3 #"\n" + +-- from https://gitlab.haskell.org/ghc/ghc/-/blob/ghc-9.6.1-alpha3/testsuite/tests/overloadedrecflds/should_run/T11671_run.hs +-- unnecessary once https://github.com/tweag/ormolu/issues/821 lands +main = + traverse_ + putStrLn + [ #a, + #number17, + #do, + #type, + #Foo, + #3, + #"199.4", + #17a23b, + #f'a', + #'a', + #', + #''notTHSplice, + #"...", + #привет, + #こんにちは, + #"3", + #":", + #"Foo", + #"The quick brown fox", + #"\"", + (++) #hello #world, + (++) #"hello" #"world", + #"hello" # 1, -- equivalent to `(fromLabel @"hello") # 1` + f "hello" #2 -- equivalent to `f ("hello"# :: Addr#) 2` + ] diff --git a/data/examples/declaration/value/function/overloaded-labels.hs b/data/examples/declaration/value/function/overloaded-labels.hs --- a/data/examples/declaration/value/function/overloaded-labels.hs +++ b/data/examples/declaration/value/function/overloaded-labels.hs @@ -2,3 +2,33 @@ foo = #field bar = (#this ) ( #that) +baz = #Foo #"Hello world!" #"\"" #3 #"\n" + +-- from https://gitlab.haskell.org/ghc/ghc/-/blob/ghc-9.6.1-alpha3/testsuite/tests/overloadedrecflds/should_run/T11671_run.hs +-- unnecessary once https://github.com/tweag/ormolu/issues/821 lands +main = traverse_ putStrLn + [ #a + , #number17 + , #do + , #type + , #Foo + , #3 + , #"199.4" + , #17a23b + , #f'a' + , #'a' + , #' + , #''notTHSplice + , #"..." + , #привет + , #こんにちは + , #"3" + , #":" + , #"Foo" + , #"The quick brown fox" + , #"\"" + , (++) #hello#world + , (++) #"hello"#"world" + , #"hello"# 1 -- equivalent to `(fromLabel @"hello") # 1` + , f "hello"#2 -- equivalent to `f ("hello"# :: Addr#) 2` + ] diff --git a/data/examples/declaration/value/function/parallel-comprehensions-complex-out.hs b/data/examples/declaration/value/function/parallel-comprehensions-complex-out.hs --- a/data/examples/declaration/value/function/parallel-comprehensions-complex-out.hs +++ b/data/examples/declaration/value/function/parallel-comprehensions-complex-out.hs @@ -10,26 +10,26 @@ i, j ) - | a <- -- Foo 1 - x, -- Foo 2 - b <- -- Bar 1 - y, -- Bar 2 + | a <- -- Foo 1 + x, -- Foo 2 + b <- -- Bar 1 + y, -- Bar 2 + a + `mod` b -- Value + == 0 + | c <- -- Baz 1 + z + * z -- Baz 2 + -- Baz 3 + | d <- w -- Other + | e <- x * x -- Foo bar + | f <- -- Foo baz 1 + y + y -- Foo baz 2 + | h <- z + z * w ^ 2 -- Bar foo + | i <- -- Bar bar 1 a - `mod` b -- Value - == 0 - | c <- -- Baz 1 - z - * z -- Baz 2 - -- Baz 3 - | d <- w -- Other - | e <- x * x -- Foo bar - | f <- -- Foo baz 1 - y + y -- Foo baz 2 - | h <- z + z * w ^ 2 -- Bar foo - | i <- -- Bar bar 1 - a - + b, -- Bar bar 2 - -- Bar bar 3 - j <- -- Bar baz 1 - a + b -- Bar baz 2 + + b, -- Bar bar 2 + -- Bar bar 3 + j <- -- Bar baz 1 + a + b -- Bar baz 2 ] diff --git a/data/examples/declaration/value/function/parens-comments-out.hs b/data/examples/declaration/value/function/parens-comments-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/parens-comments-out.hs @@ -0,0 +1,4 @@ +test = + ( -- a + x + ) diff --git a/data/examples/declaration/value/function/parens-comments.hs b/data/examples/declaration/value/function/parens-comments.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/parens-comments.hs @@ -0,0 +1,3 @@ +test = ( + -- a + x) diff --git a/data/examples/declaration/value/function/pattern/many-guards-in-singleline-out.hs b/data/examples/declaration/value/function/pattern/many-guards-in-singleline-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/many-guards-in-singleline-out.hs @@ -0,0 +1,3 @@ +foobar x | x <- 5 = 5 | x <- 6 = 6 | otherwise = 7 + +foobaz | x <- 5 = 5 | x <- 6 = 6 | otherwise = 7 diff --git a/data/examples/declaration/value/function/pattern/many-guards-in-singleline.hs b/data/examples/declaration/value/function/pattern/many-guards-in-singleline.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/many-guards-in-singleline.hs @@ -0,0 +1,3 @@ +foobar x | x <- 5 = 5 | x <- 6 = 6 | otherwise = 7 + +foobaz | x <- 5 = 5 | x <- 6 = 6 | otherwise = 7 diff --git a/data/examples/declaration/value/function/pattern/multiline-guard-statement-out.hs b/data/examples/declaration/value/function/pattern/multiline-guard-statement-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/multiline-guard-statement-out.hs @@ -0,0 +1,6 @@ +foobarbar :: Int -> Bool +foobarbar + | x <- + 5 = case x of + 5 -> True + _ -> False diff --git a/data/examples/declaration/value/function/pattern/multiline-guard-statement.hs b/data/examples/declaration/value/function/pattern/multiline-guard-statement.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/multiline-guard-statement.hs @@ -0,0 +1,5 @@ +foobarbar :: Int -> Bool +foobarbar | x <- + 5 = case x of + 5 -> True + _ -> False diff --git a/data/examples/declaration/value/function/pattern/multiple-guard-statements-out.hs b/data/examples/declaration/value/function/pattern/multiple-guard-statements-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/multiple-guard-statements-out.hs @@ -0,0 +1,6 @@ +foobarbar :: Int -> Bool +foobarbar + | x <- 5, + y <- 6 = case x of + 5 -> True + _ -> False diff --git a/data/examples/declaration/value/function/pattern/multiple-guard-statements.hs b/data/examples/declaration/value/function/pattern/multiple-guard-statements.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/multiple-guard-statements.hs @@ -0,0 +1,4 @@ +foobarbar :: Int -> Bool +foobarbar | x <- 5, y <- 6 = case x of + 5 -> True + _ -> False diff --git a/data/examples/declaration/value/function/pattern/or-patterns-out.hs b/data/examples/declaration/value/function/pattern/or-patterns-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/or-patterns-out.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE PatternSynonyms #-} + +tasty (Cupcake; Cookie) = True +tasty (Liquorice; Raisins) = False + +f :: (Eq a, Show a) => a -> a -> Bool +f a ((== a) -> True; show -> "yes") = True +f _ _ = False + +small (abs -> (0; 1; 2); 3) = True -- -3 is not small +small _ = False + +type Coll a = Either [a] (Set a) + +pattern None <- (Left []; Right (toList -> [])) + +case e of + 1; 2; 3 -> x + 4; (5; 6) -> y + +sane e = case e of + 1 + 2 + 3 -> + a + 4 + 5 + 6 -> b + 7; 8 -> c + +insane e = case e of + A _ _ + B _ + C -> 3 + (D; E (Just _) Nothing) -> + 4 + F -> 5 + +food + foo@( A; + B; + C + ) = Just foo +food _ = Nothing diff --git a/data/examples/declaration/value/function/pattern/or-patterns.hs b/data/examples/declaration/value/function/pattern/or-patterns.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/or-patterns.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE PatternSynonyms #-} + +tasty (Cupcake; Cookie) = True +tasty (Liquorice; Raisins) = False + +f :: (Eq a, Show a) => a -> a -> Bool +f a ((== a) -> True; show -> "yes") = True +f _ _ = False + +small (abs -> (0; 1; 2); 3) = True -- -3 is not small +small _ = False + +type Coll a = Either [a] (Set a) +pattern None <- (Left []; Right (toList -> [])) + +case e of + 1; 2; 3 -> x + 4; (5; 6) -> y + +sane e = case e of + 1 + 2 + 3 -> + a + 4 + 5;6 -> b + 7;8 -> c + +insane e = case e of + A _ _; B _ + C -> 3 + (D; E (Just _) Nothing) + -> 4 + F -> 5 + +food foo@(A; + B; + C) = Just foo +food _ = Nothing diff --git a/data/examples/declaration/value/function/pragmas-out.hs b/data/examples/declaration/value/function/pragmas-out.hs --- a/data/examples/declaration/value/function/pragmas-out.hs +++ b/data/examples/declaration/value/function/pragmas-out.hs @@ -1,8 +1,13 @@ -sccfoo = {-# SCC foo #-} 1 +sccfoo = {-# SCC "foo" #-} 1 sccbar = {-# SCC "barbaz" #-} "hello" + +foo = do + {-# SCC "foo" #-} + fmap succ $ do + {-# SCC "bar" #-} pure 1 -- CORE pragma got removed in https://gitlab.haskell.org/ghc/ghc/-/commit/12f9035200424ec8104484f154a040d612fee99d diff --git a/data/examples/declaration/value/function/pragmas.hs b/data/examples/declaration/value/function/pragmas.hs --- a/data/examples/declaration/value/function/pragmas.hs +++ b/data/examples/declaration/value/function/pragmas.hs @@ -2,6 +2,10 @@ sccbar = {-# SCC "barbaz"#-} "hello" +foo = do + {-# SCC "foo" #-} fmap succ $ do + {-# SCC "bar" #-} pure 1 + -- CORE pragma got removed in https://gitlab.haskell.org/ghc/ghc/-/commit/12f9035200424ec8104484f154a040d612fee99d corefoo = {-# CORE "foo"#-} 1 diff --git a/data/examples/declaration/value/function/primitive-literals-out.hs b/data/examples/declaration/value/function/primitive-literals-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/primitive-literals-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ExtendedLiterals #-} +{-# LANGUAGE MagicHash #-} + +foo = 1# + +bar = 2## + +baz = 3#Word32 + +baz = 0b1010#Int64 diff --git a/data/examples/declaration/value/function/primitive-literals.hs b/data/examples/declaration/value/function/primitive-literals.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/primitive-literals.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ExtendedLiterals, MagicHash #-} + +foo = 1# + +bar = 2## + +baz = 3#Word32 + +baz = 0b1010#Int64 diff --git a/data/examples/declaration/value/function/record/dot-multiline-out.hs b/data/examples/declaration/value/function/record/dot-multiline-out.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record/dot-multiline-out.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -bar' = - (Foo 1){bar = 2 - } - -fooplus'''' f n = - f{foo = n, - bar = n - } - -fooplus''''' f n = - f - { foo = n - } diff --git a/data/examples/declaration/value/function/record/dot-multiline.hs b/data/examples/declaration/value/function/record/dot-multiline.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record/dot-multiline.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} -bar' = (Foo 1){bar = 2 - } - -fooplus'''' f n = f{foo = n, - bar = n - } - -fooplus''''' f n = f - { foo = n } diff --git a/data/examples/declaration/value/function/record/dot-singleline-out.hs b/data/examples/declaration/value/function/record/dot-singleline-out.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record/dot-singleline-out.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -data Foo = Foo {bar :: Int} - -mfoo = fmap (.bar) $ Nothing - -bar = (Foo 1).bar - -fooplus f n = f{foo = f.bar + n} - -fooplus' f n = f {foo = f.bar + n} - -fooplus'' f n = f {foo = f.bar + n} - -fooplus''' f n = f {foo = f.bar + n} diff --git a/data/examples/declaration/value/function/record/dot-singleline.hs b/data/examples/declaration/value/function/record/dot-singleline.hs deleted file mode 100644 --- a/data/examples/declaration/value/function/record/dot-singleline.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} -data Foo = Foo { bar :: Int } - -mfoo = fmap (.bar) $ Nothing - -bar = ( Foo 1).bar - -fooplus f n = f{foo = f.bar + n} - -fooplus' f n = f { foo = f.bar + n} - -fooplus'' f n = f {foo = f.bar + n} - -fooplus''' f n = f{ foo = f.bar + n} diff --git a/data/examples/declaration/value/function/record/record-dot-out.hs b/data/examples/declaration/value/function/record/record-dot-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/record/record-dot-out.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedRecordUpdate #-} + +data Foo = Foo {bar :: Foo} + +mfoo = fmap (.bar) $ Nothing + +bar = (Foo 1).bar + +fooplus f n = f {foo = f.bar + n} + +nestedFoo f = f.bar.bar.bar.bar.bar + +nestedFooUpdate f = f {bar.bar = f.bar} <> f {bar.bar.bar.bar} + +operatorUpdate f = f {(+) = 1} diff --git a/data/examples/declaration/value/function/record/record-dot.hs b/data/examples/declaration/value/function/record/record-dot.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/record/record-dot.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedRecordUpdate #-} + +data Foo = Foo { bar :: Foo } + +mfoo = fmap (.bar) $ Nothing + +bar = ( Foo 1).bar + +fooplus f n = f{foo = f.bar + n} + +nestedFoo f = f.bar.bar.bar.bar.bar + +nestedFooUpdate f = f {bar.bar = f.bar } <> f {bar.bar.bar.bar} + +operatorUpdate f = f { (+) = 1 } diff --git a/data/examples/declaration/value/function/record/wildcard-comments-0-out.hs b/data/examples/declaration/value/function/record/wildcard-comments-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/record/wildcard-comments-0-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE RecordWildCards #-} + +example = + Record + { -- A + field = (), -- B + -- C + field = (), -- D + -- E + -- F + .. + } -- G diff --git a/data/examples/declaration/value/function/record/wildcard-comments-0.hs b/data/examples/declaration/value/function/record/wildcard-comments-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/record/wildcard-comments-0.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE RecordWildCards #-} + +example = + Record + { -- A + field = (), -- B + -- C + field = (), -- D + -- E + .. -- F + } -- G diff --git a/data/examples/declaration/value/function/record/wildcard-comments-1-out.hs b/data/examples/declaration/value/function/record/wildcard-comments-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/record/wildcard-comments-1-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE RecordWildCards #-} + +example = + Record + { -- A + field = (), + -- C + field = (), + -- E + -- F + .. + } -- G diff --git a/data/examples/declaration/value/function/record/wildcard-comments-1.hs b/data/examples/declaration/value/function/record/wildcard-comments-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/record/wildcard-comments-1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE RecordWildCards #-} + +example = + Record + { -- A + field = (), + -- C + field = (), + -- E + .. -- F + } -- G diff --git a/data/examples/declaration/value/function/required-type-arguments-2-out.hs b/data/examples/declaration/value/function/required-type-arguments-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/required-type-arguments-2-out.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} + +ex1 = f (forall a. Proxy a) + +ex2 = f ((ctx) => Int) + +ex2' = f ((ctx, ctx') => Int) + +ex3 = f (String -> Bool) + +long = + f + ( forall m a. + (A a, M m) => + String -> + Bool %1 -> + Maybe Int -> + Maybe + (String, Int) %1 -> + Word %m -> + Text + ) diff --git a/data/examples/declaration/value/function/required-type-arguments-2.hs b/data/examples/declaration/value/function/required-type-arguments-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/required-type-arguments-2.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE LinearTypes #-} + +ex1 = f (forall a. Proxy a) +ex2 = f (ctx => Int) +ex2' = f ((ctx,ctx') => Int) +ex3 = f (String -> Bool) + +long = f (forall m a. (A a, M m) => String + -> Bool %1 -> + Maybe Int + -> Maybe + (String,Int) + ⊸ Word %m -> Text ) diff --git a/data/examples/declaration/value/function/required-type-arguments-out.hs b/data/examples/declaration/value/function/required-type-arguments-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/required-type-arguments-out.hs @@ -0,0 +1,21 @@ +vshow :: forall a -> (Show a) => a -> String +vshow t x = show (x :: t) + +s1 = vshow Int 42 + +s2 = vshow Double 42 + +a1 = f (type (Int -> Bool)) + +a2 = f (type ((Read T) => T)) + +a3 = f (type (forall a. a)) + +a4 = f (type (forall a. (Read a) => String -> a)) + +foo = + f + ( type ( Maybe + Int + ) + ) diff --git a/data/examples/declaration/value/function/required-type-arguments.hs b/data/examples/declaration/value/function/required-type-arguments.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/required-type-arguments.hs @@ -0,0 +1,13 @@ +vshow :: forall a -> Show a => a -> String +vshow t x = show (x :: t) + +s1 = vshow Int 42 +s2 = vshow Double 42 + +a1 = f (type (Int -> Bool)) +a2 = f (type (Read T => T)) +a3 = f (type (forall a. a)) +a4 = f (type (forall a. Read a => String -> a)) + +foo = f (type (Maybe + Int)) diff --git a/data/examples/declaration/value/function/strings-out.hs b/data/examples/declaration/value/function/strings-out.hs --- a/data/examples/declaration/value/function/strings-out.hs +++ b/data/examples/declaration/value/function/strings-out.hs @@ -2,9 +2,13 @@ foo = "foobar" -bar = "foo\&barbaz" +bar = "foo\&bar\ \baz" baz = "foo\ \bar\ \baz" + +weirdGap = "\65\ \0" + +weirdEscape = "\^\ " diff --git a/data/examples/declaration/value/function/strings.hs b/data/examples/declaration/value/function/strings.hs --- a/data/examples/declaration/value/function/strings.hs +++ b/data/examples/declaration/value/function/strings.hs @@ -5,3 +5,7 @@ baz = "foo\ \bar\ \baz" + +weirdGap = "\65\ \0" + +weirdEscape = "\^\ " diff --git a/data/examples/declaration/value/function/type-abstractions-out.hs b/data/examples/declaration/value/function/type-abstractions-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/type-abstractions-out.hs @@ -0,0 +1,9 @@ +id :: forall a. a -> a +id @t x = x :: t + +f1 :: forall a. a -> forall b. b -> (a, b) +f1 @a x @b y = (x :: a, y :: b) + +f2 = + (\ @a x @b y -> (x :: a, y :: b)) :: + forall a. a -> forall b. b -> (a, b) diff --git a/data/examples/declaration/value/function/type-abstractions.hs b/data/examples/declaration/value/function/type-abstractions.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/type-abstractions.hs @@ -0,0 +1,8 @@ +id :: forall a. a -> a +id @t x = x :: t + +f1 :: forall a. a -> forall b. b -> (a, b) +f1 @a x @b y = (x :: a, y :: b) + +f2 = (\ @a x @b y -> (x :: a, y :: b) ) + :: forall a. a -> forall b. b -> (a, b) diff --git a/data/examples/declaration/value/function/type-applications-out.hs b/data/examples/declaration/value/function/type-applications-out.hs --- a/data/examples/declaration/value/function/type-applications-out.hs +++ b/data/examples/declaration/value/function/type-applications-out.hs @@ -14,3 +14,13 @@ @(HASH TPraosStandardCrypto) @ByteString "And the lamb lies down on Broadway" + +test x = case x of + Foo @t -> show @t 0 + Bar + @t + @u + v -> + "" + +foo = foo @[k|bar|] diff --git a/data/examples/declaration/value/function/type-applications.hs b/data/examples/declaration/value/function/type-applications.hs --- a/data/examples/declaration/value/function/type-applications.hs +++ b/data/examples/declaration/value/function/type-applications.hs @@ -11,3 +11,11 @@ @(HASH TPraosStandardCrypto) @ByteString "And the lamb lies down on Broadway" + +test x = case x of + Foo @t -> show @t 0 + Bar + @t @u v + -> "" + +foo = foo @[k|bar|] diff --git a/data/examples/declaration/value/function/unboxed-sums-out.hs b/data/examples/declaration/value/function/unboxed-sums-out.hs --- a/data/examples/declaration/value/function/unboxed-sums-out.hs +++ b/data/examples/declaration/value/function/unboxed-sums-out.hs @@ -1,10 +1,26 @@ {-# LANGUAGE UnboxedSums #-} +foo :: (# Int | Bool #) foo = (# 1 | #) +bar :: (# Int | Int | Int | Int #) bar = (# | | 2 | #) +baz :: + (# + Int | + Int | + Int | + Int | + Int | + Int | + Int | + Int | + Int + #) baz = (# | | | 10 | | | | | #) + +type UbxPair = (# | #) diff --git a/data/examples/declaration/value/function/unboxed-sums.hs b/data/examples/declaration/value/function/unboxed-sums.hs --- a/data/examples/declaration/value/function/unboxed-sums.hs +++ b/data/examples/declaration/value/function/unboxed-sums.hs @@ -1,7 +1,16 @@ {-# LANGUAGE UnboxedSums #-} +foo :: (# Int|Bool #) foo = (# 1 | #) + +bar :: (#Int|Int|Int|Int #) bar = (# | |2| #) + +baz :: (# Int | + Int | Int | Int | Int | Int | Int | + Int | Int #) baz = (# | | | 10 | | | | | #) + +type UbxPair = (# | #) diff --git a/data/examples/declaration/value/function/unboxed-tuples-out.hs b/data/examples/declaration/value/function/unboxed-tuples-out.hs --- a/data/examples/declaration/value/function/unboxed-tuples-out.hs +++ b/data/examples/declaration/value/function/unboxed-tuples-out.hs @@ -8,3 +8,6 @@ 2, 3 #) + +unit :: (# #) +unit = (# #) diff --git a/data/examples/declaration/value/function/unboxed-tuples.hs b/data/examples/declaration/value/function/unboxed-tuples.hs --- a/data/examples/declaration/value/function/unboxed-tuples.hs +++ b/data/examples/declaration/value/function/unboxed-tuples.hs @@ -5,3 +5,6 @@ 1, 2, 3 #) + +unit :: (##) +unit = (##) diff --git a/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-out.hs b/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-out.hs --- a/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-out.hs +++ b/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-out.hs @@ -2,8 +2,7 @@ pattern P a <- C a where P a = C a -pattern HeadC x <- - x : xs +pattern HeadC x <- x : xs where HeadC x = [x] @@ -12,8 +11,7 @@ where HeadC' x = [x] -pattern Simple <- - "Simple" +pattern Simple <- "Simple" where Simple = "Complicated" diff --git a/data/examples/declaration/warning/warning-multiline-out.hs b/data/examples/declaration/warning/warning-multiline-out.hs --- a/data/examples/declaration/warning/warning-multiline-out.hs +++ b/data/examples/declaration/warning/warning-multiline-out.hs @@ -7,3 +7,12 @@ #-} test :: IO () test = pure () + +instance + {-# WARNING "Don't use" #-} + Show G1 where + show = "G1" + +deriving instance + {-# WARNING "to be removed" #-} + Eq G2 diff --git a/data/examples/declaration/warning/warning-multiline.hs b/data/examples/declaration/warning/warning-multiline.hs --- a/data/examples/declaration/warning/warning-multiline.hs +++ b/data/examples/declaration/warning/warning-multiline.hs @@ -2,3 +2,11 @@ foo ["These are bad functions", "Really bad!"] #-} test :: IO () test = pure () + +instance + {-# WARNING "Don't use" #-} + Show G1 where + show = "G1" + +deriving instance + {-# WARNING "to be removed" #-} Eq G2 diff --git a/data/examples/declaration/warning/warning-single-line-out.hs b/data/examples/declaration/warning/warning-single-line-out.hs --- a/data/examples/declaration/warning/warning-single-line-out.hs +++ b/data/examples/declaration/warning/warning-single-line-out.hs @@ -6,8 +6,19 @@ bar = 3 {-# DEPRECATED bar "Bar is deprecated" #-} -{-# DEPRECATED baz "Baz is also deprecated" #-} +{-# DEPRECATED data baz "Baz is also deprecated" #-} baz = 5 data Number = Number Dobule -{-# DEPRECATED Number "Use Scientific instead." #-} +{-# DEPRECATED type Number "Use Scientific instead." #-} + +head (a : _) = a +{-# WARNING in "x-partial" head "This function is partial..." #-} + +instance {-# DEPRECATED "Don't use" #-} Show T1 + +instance {-# WARNING "Don't use either" #-} Show G1 + +deriving instance {-# DEPRECATED "to be removed" #-} Eq T2 + +deriving instance {-# WARNING "to be removed as well" #-} Eq G2 diff --git a/data/examples/declaration/warning/warning-single-line.hs b/data/examples/declaration/warning/warning-single-line.hs --- a/data/examples/declaration/warning/warning-single-line.hs +++ b/data/examples/declaration/warning/warning-single-line.hs @@ -8,8 +8,17 @@ {-# Deprecated bar "Bar is deprecated" #-} -{-# DEPRECATED baz "Baz is also deprecated" #-} +{-# DEPRECATED data baz "Baz is also deprecated" #-} baz = 5 data Number = Number Dobule -{-# DEPRECATED Number "Use Scientific instead." #-} +{-# DEPRECATED type Number "Use Scientific instead." #-} + +head (a:_) = a +{-# WARNING in "x-partial" head "This function is partial..." #-} + +instance {-# DEPRECATED "Don't use" #-} Show T1 where +instance {-# WARNING "Don't use either" #-} Show G1 where + +deriving instance {-# DEPRECATED "to be removed" #-} Eq T2 +deriving instance {-# WARNING "to be removed as well" #-} Eq G2 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-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-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-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-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-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/comment-before-merged-import-lists-out.hs b/data/examples/import/comment-before-merged-import-lists-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/comment-before-merged-import-lists-out.hs @@ -0,0 +1,7 @@ +-- their own formatters. +import Test.Hspec.Core.Formatters.V1.Monad + ( FormatM, + Formatter (..), + Item (..), + interpretWith, + ) diff --git a/data/examples/import/comment-before-merged-import-lists.hs b/data/examples/import/comment-before-merged-import-lists.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/comment-before-merged-import-lists.hs @@ -0,0 +1,7 @@ +-- their own formatters. +import Test.Hspec.Core.Formatters.V1.Monad ( + Formatter(..) + , FormatM + ) + +import Test.Hspec.Core.Formatters.V1.Monad (Item(..), interpretWith) diff --git a/data/examples/import/comment-before-merged-imports-out.hs b/data/examples/import/comment-before-merged-imports-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/comment-before-merged-imports-out.hs @@ -0,0 +1,7 @@ +-- Import stuff from Prelude explicitly +import Prelude + ( Eq (..), + Int, + ($), + (.), + ) diff --git a/data/examples/import/comment-before-merged-imports.hs b/data/examples/import/comment-before-merged-imports.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/comment-before-merged-imports.hs @@ -0,0 +1,3 @@ +-- Import stuff from Prelude explicitly +import Prelude (Eq(..), Int) +import Prelude ((.), ($)) diff --git a/data/examples/import/comment-between-merged-imports-out.hs b/data/examples/import/comment-between-merged-imports-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/comment-between-merged-imports-out.hs @@ -0,0 +1,7 @@ +import HscMain (newHscEnv) +-- Implementations of the various modes +import LoadIface + ( -- Imports for --abi-hash + loadUserInterface, + showIface, + ) diff --git a/data/examples/import/comment-between-merged-imports.hs b/data/examples/import/comment-between-merged-imports.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/comment-between-merged-imports.hs @@ -0,0 +1,6 @@ +-- Implementations of the various modes +import LoadIface ( showIface ) +import HscMain ( newHscEnv ) + +-- Imports for --abi-hash +import LoadIface ( loadUserInterface ) diff --git a/data/examples/import/comment-inside-empty-import-list-out.hs b/data/examples/import/comment-inside-empty-import-list-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/comment-inside-empty-import-list-out.hs @@ -0,0 +1,6 @@ +import Package1 +import Package2 +import Package3 + ( + -- , import1 + ) diff --git a/data/examples/import/comment-inside-empty-import-list.hs b/data/examples/import/comment-inside-empty-import-list.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/comment-inside-empty-import-list.hs @@ -0,0 +1,5 @@ +import Package1 +import Package3 ( + -- , import1 + ) +import Package2 diff --git a/data/examples/import/comment-inside-sorted-import-list-out.hs b/data/examples/import/comment-inside-sorted-import-list-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/comment-inside-sorted-import-list-out.hs @@ -0,0 +1,7 @@ +import Package1 +import Package2 +import Package3 + ( hi, + -- , import1 + test, + ) diff --git a/data/examples/import/comment-inside-sorted-import-list.hs b/data/examples/import/comment-inside-sorted-import-list.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/comment-inside-sorted-import-list.hs @@ -0,0 +1,7 @@ +import Package1 +import Package3 ( + hi, + -- , import1 + test, + ) +import Package2 diff --git a/data/examples/import/comments-inside-imports-out.hs b/data/examples/import/comments-inside-imports-out.hs --- a/data/examples/import/comments-inside-imports-out.hs +++ b/data/examples/import/comments-inside-imports-out.hs @@ -1,7 +1,6 @@ --- x - import qualified -- x Bar import qualified -- x Baz -import Foo +import -- x + Foo diff --git a/data/examples/import/comments-per-import-out.hs b/data/examples/import/comments-per-import-out.hs --- a/data/examples/import/comments-per-import-out.hs +++ b/data/examples/import/comments-per-import-out.hs @@ -1,4 +1,3 @@ --- (1) import Bar -- (2) import Baz -- (3) -import Foo +import Foo -- (1) diff --git a/data/examples/import/data-out.hs b/data/examples/import/data-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/data-out.hs @@ -0,0 +1,7 @@ +module Bar (data P, T (data P), data f) where + +import N + ( T (data P), + data P, + data f, + ) diff --git a/data/examples/import/data.hs b/data/examples/import/data.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/data.hs @@ -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) diff --git a/data/examples/import/deprecated-export-multi-line-out.hs b/data/examples/import/deprecated-export-multi-line-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/deprecated-export-multi-line-out.hs @@ -0,0 +1,7 @@ +module X + ( {-# DEPRECATE D(D1) "D1 will not be exposed in a version 0.2 and later" #-} + D (D1, D2), + ) +where + +data D = D1 | D2 diff --git a/data/examples/import/deprecated-export-multi-line.hs b/data/examples/import/deprecated-export-multi-line.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/deprecated-export-multi-line.hs @@ -0,0 +1,5 @@ +module X + ( {-# DEPRECATE D(D1) "D1 will not be exposed in a version 0.2 and later" #-} + D(D1, D2) + ) where +data D = D1 | D2 diff --git a/data/examples/import/deprecated-export-single-line-out.hs b/data/examples/import/deprecated-export-single-line-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/deprecated-export-single-line-out.hs @@ -0,0 +1,3 @@ +module A ({-# DEPRECATED "blah" #-} x) where + +x = True diff --git a/data/examples/import/deprecated-export-single-line.hs b/data/examples/import/deprecated-export-single-line.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/deprecated-export-single-line.hs @@ -0,0 +1,1 @@ +module A ( {-# DEPRECATED "blah" #-} x ) where { x = True } diff --git a/data/examples/import/docstrings-after-exports-out.hs b/data/examples/import/docstrings-after-exports-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/docstrings-after-exports-out.hs @@ -0,0 +1,12 @@ +module Test + ( since1, -- ^ @since 1.0 + since2, -- ^ @since 2.0 + since3, -- ^ @since 3.0 + SinceType (..), -- ^ @since 4.0 + SinceClass (..), -- ^ @since 5.0 + Multi (..), + -- ^ since 6.0 + -- multi + -- line + ) +where diff --git a/data/examples/import/docstrings-after-exports.hs b/data/examples/import/docstrings-after-exports.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/docstrings-after-exports.hs @@ -0,0 +1,11 @@ +module Test ( + since1, -- ^ @since 1.0 + since2 -- ^ @since 2.0 + , since3 -- ^ @since 3.0 + , SinceType(..) -- ^ @since 4.0 + , SinceClass(..) -- ^ @since 5.0 + , Multi(..) + -- ^ since 6.0 + -- multi + -- line + ) where diff --git a/data/examples/import/explicit-imports-with-comments-out.hs b/data/examples/import/explicit-imports-with-comments-out.hs --- a/data/examples/import/explicit-imports-with-comments-out.hs +++ b/data/examples/import/explicit-imports-with-comments-out.hs @@ -1,7 +1,5 @@ import qualified MegaModule as M - ( -- (1) - -- (2) - Either, -- (3) - (<<<), - (>>>), + ( Either, -- (3) + (<<<), -- (2) + (>>>), -- (1) ) diff --git a/data/examples/import/explicit-level-imports-out.hs b/data/examples/import/explicit-level-imports-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-level-imports-out.hs @@ -0,0 +1,16 @@ +{-# 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) diff --git a/data/examples/import/explicit-level-imports-qualified-post-out.hs b/data/examples/import/explicit-level-imports-qualified-post-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-level-imports-qualified-post-out.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE ImportQualifiedPost #-} + +import quote A qualified as QA +import B quote qualified as QB diff --git a/data/examples/import/explicit-level-imports-qualified-post.hs b/data/examples/import/explicit-level-imports-qualified-post.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-level-imports-qualified-post.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE ImportQualifiedPost #-} + +import qualified B quote as QB +import quote qualified A as QA diff --git a/data/examples/import/explicit-level-imports.hs b/data/examples/import/explicit-level-imports.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-level-imports.hs @@ -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 () 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/merging-0-out.hs b/data/examples/import/merging-0-out.hs --- a/data/examples/import/merging-0-out.hs +++ b/data/examples/import/merging-0-out.hs @@ -1,3 +1,6 @@ import Foo -import Foo (bar, foo) +import Foo + ( bar, + foo, + ) import Foo as F diff --git a/data/examples/import/merging-1-out.hs b/data/examples/import/merging-1-out.hs --- a/data/examples/import/merging-1-out.hs +++ b/data/examples/import/merging-1-out.hs @@ -1,2 +1,5 @@ import "bar" Foo (bar) -import "foo" Foo (baz, foo) +import "foo" Foo + ( baz, + foo, + ) diff --git a/data/examples/import/merging-2-out.hs b/data/examples/import/merging-2-out.hs --- a/data/examples/import/merging-2-out.hs +++ b/data/examples/import/merging-2-out.hs @@ -1,2 +1,8 @@ -import Foo hiding (bar4, foo2) -import qualified Foo (bar3, foo1) +import Foo hiding + ( bar4, + foo2, + ) +import qualified Foo + ( bar3, + foo1, + ) 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-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/import/simple-out.hs b/data/examples/import/simple-out.hs --- a/data/examples/import/simple-out.hs +++ b/data/examples/import/simple-out.hs @@ -1,5 +1,13 @@ import Data.Text -import Data.Text (a, b, c) -import Data.Text hiding (a, b, c) +import Data.Text + ( a, + b, + c, + ) +import Data.Text hiding + ( a, + b, + c, + ) import qualified Data.Text (a, b, c) import qualified Data.Text as T diff --git a/data/examples/import/sorted-package-imports-out.hs b/data/examples/import/sorted-package-imports-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/sorted-package-imports-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PackageImports #-} + +import D +import "a" Ab +import "b" Aa +import "b" Bb +import "c" Ba +import "zzzz" Z +import "this" Y diff --git a/data/examples/import/sorted-package-imports.hs b/data/examples/import/sorted-package-imports.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/sorted-package-imports.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PackageImports #-} + +import "b" Aa +import "a" Ab +import "c" Ba +import D +import "b" Bb + +import "this" Y +import "zzzz" Z 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/module-header/empty-haddock-out.hs b/data/examples/module-header/empty-haddock-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/empty-haddock-out.hs @@ -0,0 +1,3 @@ +-- \| +-- +module Test where diff --git a/data/examples/module-header/empty-haddock.hs b/data/examples/module-header/empty-haddock.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/empty-haddock.hs @@ -0,0 +1,3 @@ +-- | +-- +module Test where diff --git a/data/examples/module-header/multiline-empty-comment-out.hs b/data/examples/module-header/multiline-empty-comment-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/multiline-empty-comment-out.hs @@ -0,0 +1,4 @@ +module Foo + ( -- test + ) +where diff --git a/data/examples/module-header/multiline-empty-comment.hs b/data/examples/module-header/multiline-empty-comment.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/multiline-empty-comment.hs @@ -0,0 +1,2 @@ +module Foo ( -- test + ) where diff --git a/data/examples/other/argument-comment-out.hs b/data/examples/other/argument-comment-out.hs --- a/data/examples/other/argument-comment-out.hs +++ b/data/examples/other/argument-comment-out.hs @@ -5,12 +5,12 @@ foo _ = True foo :: - Foo a => + (Foo a) => -- | Foo Int -> Int foo :: - Foo a => + (Foo a) => -- | Foo Int -> Int diff --git a/data/examples/other/block-comment-before-argument-out.hs b/data/examples/other/block-comment-before-argument-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/block-comment-before-argument-out.hs @@ -0,0 +1,5 @@ +checkPragma = + ifM + (anyM isBuiltin [builtinNat, builtinBool]) + {-then-} ok + {-else-} notPostulate diff --git a/data/examples/other/block-comment-before-argument.hs b/data/examples/other/block-comment-before-argument.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/block-comment-before-argument.hs @@ -0,0 +1,4 @@ +checkPragma = + ifM (anyM isBuiltin [builtinNat, builtinBool]) + {-then-} ok + {-else-} notPostulate diff --git a/data/examples/other/block-comment-before-element-out.hs b/data/examples/other/block-comment-before-element-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/block-comment-before-element-out.hs @@ -0,0 +1,6 @@ +eeExtensions = + catMaybes + [ {- 0x00 -} sniExt, + {- 0x0a -} groupExt, + {- 0x10 -} alpnExt + ] diff --git a/data/examples/other/block-comment-before-element.hs b/data/examples/other/block-comment-before-element.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/block-comment-before-element.hs @@ -0,0 +1,6 @@ +eeExtensions = + catMaybes + [ {- 0x00 -} sniExt + , {- 0x0a -} groupExt + , {- 0x10 -} alpnExt + ] diff --git a/data/examples/other/comment-around-quasiquote-out.hs b/data/examples/other/comment-around-quasiquote-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-around-quasiquote-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE QuasiQuotes #-} + +example = + [ -- A + [u||], -- B + -- C + [u||] -- D + -- E + ] -- F diff --git a/data/examples/other/comment-around-quasiquote.hs b/data/examples/other/comment-around-quasiquote.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-around-quasiquote.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE QuasiQuotes #-} + +example = + [ -- A + [u||], -- B + -- C + [u||] -- D + -- E + ] -- F diff --git a/data/examples/other/comment-block-section-heading-out.hs b/data/examples/other/comment-block-section-heading-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-block-section-heading-out.hs @@ -0,0 +1,3 @@ +{- *** + aaa +-} diff --git a/data/examples/other/comment-block-section-heading.hs b/data/examples/other/comment-block-section-heading.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-block-section-heading.hs @@ -0,0 +1,3 @@ +{- *** + aaa +-} diff --git a/data/examples/other/comment-empty-let-out.hs b/data/examples/other/comment-empty-let-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-empty-let-out.hs @@ -0,0 +1,6 @@ +foo = + let + in 10 + +-- a comment +bar = 20 diff --git a/data/examples/other/comment-empty-let.hs b/data/examples/other/comment-empty-let.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-empty-let.hs @@ -0,0 +1,6 @@ +foo = + let + in 10 + +-- a comment +bar = 20 diff --git a/data/examples/other/comment-glued-together-out.hs b/data/examples/other/comment-glued-together-out.hs --- a/data/examples/other/comment-glued-together-out.hs +++ b/data/examples/other/comment-glued-together-out.hs @@ -1,6 +1,6 @@ module Main (main) where --- | Foo. +{- | Foo. -} -- Bar main :: IO () diff --git a/data/examples/other/comment-in-empty-list-out.hs b/data/examples/other/comment-in-empty-list-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-in-empty-list-out.hs @@ -0,0 +1,9 @@ +tests_Cli_Utils = + testGroup + "Utils" + [ + + -- testGroup "journalApplyValue" [ + -- testCase "time" $ do + -- ] + ] diff --git a/data/examples/other/comment-in-empty-list.hs b/data/examples/other/comment-in-empty-list.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-in-empty-list.hs @@ -0,0 +1,6 @@ +tests_Cli_Utils = testGroup "Utils" [ + + -- testGroup "journalApplyValue" [ + -- testCase "time" $ do + -- ] + ] diff --git a/data/examples/other/comment-opening-a-list-out.hs b/data/examples/other/comment-opening-a-list-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-opening-a-list-out.hs @@ -0,0 +1,11 @@ +module Hledger.Cli.Commands where + +commandsList :: String -> [String] -> [String] +commandsList progversion othercmds = + map (bold' . accent) _banner_smslant + ++ [ -- XXX not showing bold, why ? + -- Keep the following synced with: + -- commands.m4 + "----------", + progversion + ] diff --git a/data/examples/other/comment-opening-a-list.hs b/data/examples/other/comment-opening-a-list.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-opening-a-list.hs @@ -0,0 +1,11 @@ +module Hledger.Cli.Commands where + +commandsList :: String -> [String] -> [String] +commandsList progversion othercmds = + map (bold' . accent) _banner_smslant ++ -- XXX not showing bold, why ? + [ + -- Keep the following synced with: + -- commands.m4 + "----------" + ,progversion + ] diff --git a/data/examples/other/comment-spacing-out.hs b/data/examples/other/comment-spacing-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-spacing-out.hs @@ -0,0 +1,7 @@ +-- | Something. +foo :: + -- | Foo. + Int -> + -- | Bar. + IO () +foo _ = pure () -- comment diff --git a/data/examples/other/comment-spacing.hs b/data/examples/other/comment-spacing.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-spacing.hs @@ -0,0 +1,7 @@ +-- |Something. +foo :: + -- |Foo. + Int -> + -- |Bar. + IO () +foo _ = pure () --comment diff --git a/data/examples/other/comment-style-transform-out.hs b/data/examples/other/comment-style-transform-out.hs --- a/data/examples/other/comment-style-transform-out.hs +++ b/data/examples/other/comment-style-transform-out.hs @@ -1,17 +1,20 @@ --- | --- Module: Data.Aeson.TH --- Copyright: (c) 2011-2016 Bryan O'Sullivan --- (c) 2011 MailRank, Inc. --- License: BSD3 --- Stability: experimental --- Portability: portable +{-| +Module: Data.Aeson.TH +Copyright: (c) 2011-2016 Bryan O'Sullivan + (c) 2011 MailRank, Inc. +License: BSD3 +Stability: experimental +Portability: portable +-} module Main where --- | --- --- Here is a snippet: --- --- @ --- x = y + 2 --- @ +{- | + +Here is a snippet: + +@ +x = y + 2 +@ + +-} x = y + 2 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-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-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-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-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/examples/other/comment-trigger-escaping-out.hs b/data/examples/other/comment-trigger-escaping-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trigger-escaping-out.hs @@ -0,0 +1,15 @@ +-- Excessive backslashes in multi line: +{- +* +| +-} + +test = do + -- Maybe excessive in single line: + -- \* (if there's nothing after the * the line is completely dropped) + line1 + -- Maybe excessive in multi line: + {- \| is this excessive? + * no excessive here at least + -} + line2 diff --git a/data/examples/other/comment-trigger-escaping.hs b/data/examples/other/comment-trigger-escaping.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trigger-escaping.hs @@ -0,0 +1,15 @@ +-- Excessive backslashes in multi line: +{- +* +| +-} + +test = do + -- Maybe excessive in single line: + -- * (if there's nothing after the * the line is completely dropped) + line1 + -- Maybe excessive in multi line: + {- | is this excessive? + * no excessive here at least + -} + line2 diff --git a/data/examples/other/comment-two-blocks-out.hs b/data/examples/other/comment-two-blocks-out.hs --- a/data/examples/other/comment-two-blocks-out.hs +++ b/data/examples/other/comment-two-blocks-out.hs @@ -2,7 +2,8 @@ newNames = let (*) = flip (,) in [ "Control" * "Monad" - -- Foo - -- Bar + -- Foo + + -- Bar ] diff --git a/data/examples/other/cpp/continuation-out.hs b/data/examples/other/cpp/continuation-out.hs --- a/data/examples/other/cpp/continuation-out.hs +++ b/data/examples/other/cpp/continuation-out.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + foo :: Int foo = 5 diff --git a/data/examples/other/cpp/continuation.hs b/data/examples/other/cpp/continuation.hs --- a/data/examples/other/cpp/continuation.hs +++ b/data/examples/other/cpp/continuation.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + foo :: Int foo = 5 diff --git a/data/examples/other/cpp/cpp-and-imports-out.hs b/data/examples/other/cpp/cpp-and-imports-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/cpp/cpp-and-imports-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} + +module Bug where + +#ifdef flag +constant :: Int +constant = 1312 +#endif diff --git a/data/examples/other/cpp/cpp-and-imports.hs b/data/examples/other/cpp/cpp-and-imports.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/cpp/cpp-and-imports.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} + +module Bug where + +#ifdef flag +constant :: Int +constant = 1312 +#endif diff --git a/data/examples/other/cpp/lonely-hash-out.hs b/data/examples/other/cpp/lonely-hash-out.hs --- a/data/examples/other/cpp/lonely-hash-out.hs +++ b/data/examples/other/cpp/lonely-hash-out.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Main (main) where import Data.Void diff --git a/data/examples/other/cpp/lonely-hash.hs b/data/examples/other/cpp/lonely-hash.hs --- a/data/examples/other/cpp/lonely-hash.hs +++ b/data/examples/other/cpp/lonely-hash.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Main (main) where import Data.Void diff --git a/data/examples/other/cpp/separation-0a-out.hs b/data/examples/other/cpp/separation-0a-out.hs --- a/data/examples/other/cpp/separation-0a-out.hs +++ b/data/examples/other/cpp/separation-0a-out.hs @@ -1,7 +1,8 @@ -instance Stream s => Monad (ParsecT e s m) where +{-# LANGUAGE CPP #-} + +instance (Stream s) => Monad (ParsecT e s m) where return = pure (>>=) = pBind - #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail #endif diff --git a/data/examples/other/cpp/separation-0a.hs b/data/examples/other/cpp/separation-0a.hs --- a/data/examples/other/cpp/separation-0a.hs +++ b/data/examples/other/cpp/separation-0a.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + instance Stream s => Monad (ParsecT e s m) where return = pure (>>=) = pBind diff --git a/data/examples/other/cpp/separation-0b-out.hs b/data/examples/other/cpp/separation-0b-out.hs --- a/data/examples/other/cpp/separation-0b-out.hs +++ b/data/examples/other/cpp/separation-0b-out.hs @@ -1,7 +1,8 @@ -instance Stream s => Monad (ParsecT e s m) where +{-# LANGUAGE CPP #-} + +instance (Stream s) => Monad (ParsecT e s m) where return = pure (>>=) = pBind - #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail #endif diff --git a/data/examples/other/cpp/separation-0b.hs b/data/examples/other/cpp/separation-0b.hs --- a/data/examples/other/cpp/separation-0b.hs +++ b/data/examples/other/cpp/separation-0b.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + instance Stream s => Monad (ParsecT e s m) where return = pure (>>=) = pBind diff --git a/data/examples/other/cpp/separation-1a-out.hs b/data/examples/other/cpp/separation-1a-out.hs --- a/data/examples/other/cpp/separation-1a-out.hs +++ b/data/examples/other/cpp/separation-1a-out.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE CPP #-} + decompressingPipe :: (PrimMonad m, MonadThrow m, MonadResource m) => CompressionMethod -> ConduitT ByteString ByteString m () decompressingPipe Store = C.awaitForever C.yield decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15) - #ifdef ENABLE_BZIP2 decompressingPipe BZip2 = BZ.bunzip2 #else diff --git a/data/examples/other/cpp/separation-1a.hs b/data/examples/other/cpp/separation-1a.hs --- a/data/examples/other/cpp/separation-1a.hs +++ b/data/examples/other/cpp/separation-1a.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + decompressingPipe :: (PrimMonad m, MonadThrow m, MonadResource m) => CompressionMethod diff --git a/data/examples/other/cpp/separation-1b-out.hs b/data/examples/other/cpp/separation-1b-out.hs --- a/data/examples/other/cpp/separation-1b-out.hs +++ b/data/examples/other/cpp/separation-1b-out.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE CPP #-} + decompressingPipe :: (PrimMonad m, MonadThrow m, MonadResource m) => CompressionMethod -> ConduitT ByteString ByteString m () decompressingPipe Store = C.awaitForever C.yield decompressingPipe Deflate = Z.decompress $ Z.WindowBits (-15) - #ifdef ENABLE_BZIP2 decompressingPipe BZip2 = BZ.bunzip2 #else diff --git a/data/examples/other/cpp/separation-1b.hs b/data/examples/other/cpp/separation-1b.hs --- a/data/examples/other/cpp/separation-1b.hs +++ b/data/examples/other/cpp/separation-1b.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + decompressingPipe :: (PrimMonad m, MonadThrow m, MonadResource m) => CompressionMethod diff --git a/data/examples/other/cpp/separation-2a-out.hs b/data/examples/other/cpp/separation-2a-out.hs --- a/data/examples/other/cpp/separation-2a-out.hs +++ b/data/examples/other/cpp/separation-2a-out.hs @@ -1,5 +1,6 @@ -ffff, ffffffff :: Natural +{-# LANGUAGE CPP #-} +ffff, ffffffff :: Natural #ifdef HASKELL_ZIP_DEV_MODE ffff = 200 ffffffff = 5000 diff --git a/data/examples/other/cpp/separation-2a.hs b/data/examples/other/cpp/separation-2a.hs --- a/data/examples/other/cpp/separation-2a.hs +++ b/data/examples/other/cpp/separation-2a.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ffff, ffffffff :: Natural #ifdef HASKELL_ZIP_DEV_MODE ffff = 200 diff --git a/data/examples/other/cpp/separation-2b-out.hs b/data/examples/other/cpp/separation-2b-out.hs --- a/data/examples/other/cpp/separation-2b-out.hs +++ b/data/examples/other/cpp/separation-2b-out.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ffff, ffffffff :: Natural #ifdef HASKELL_ZIP_DEV_MODE ffff = 200 diff --git a/data/examples/other/cpp/separation-2b.hs b/data/examples/other/cpp/separation-2b.hs --- a/data/examples/other/cpp/separation-2b.hs +++ b/data/examples/other/cpp/separation-2b.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ffff, ffffffff :: Natural #ifdef HASKELL_ZIP_DEV_MODE ffff = 200 diff --git a/data/examples/other/cpp/shifted-out.hs b/data/examples/other/cpp/shifted-out.hs --- a/data/examples/other/cpp/shifted-out.hs +++ b/data/examples/other/cpp/shifted-out.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + sinkData h compression = do (uncompressedSize, crc32, compressedSize) <- case compression of diff --git a/data/examples/other/cpp/shifted.hs b/data/examples/other/cpp/shifted.hs --- a/data/examples/other/cpp/shifted.hs +++ b/data/examples/other/cpp/shifted.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + sinkData h compression = do (uncompressedSize, crc32, compressedSize) <- case compression of diff --git a/data/examples/other/cpp/simple-import-out.hs b/data/examples/other/cpp/simple-import-out.hs --- a/data/examples/other/cpp/simple-import-out.hs +++ b/data/examples/other/cpp/simple-import-out.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Main (main) where import Data.Void diff --git a/data/examples/other/cpp/simple-import.hs b/data/examples/other/cpp/simple-import.hs --- a/data/examples/other/cpp/simple-import.hs +++ b/data/examples/other/cpp/simple-import.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Main (main) where import Data.Void diff --git a/data/examples/other/disabling/closing-comment-in-disabled-region-out.hs b/data/examples/other/disabling/closing-comment-in-disabled-region-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/closing-comment-in-disabled-region-out.hs @@ -0,0 +1,3 @@ +{- ORMOLU_DISABLE -} +a::String +a="-}" diff --git a/data/examples/other/disabling/closing-comment-in-disabled-region.hs b/data/examples/other/disabling/closing-comment-in-disabled-region.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/closing-comment-in-disabled-region.hs @@ -0,0 +1,3 @@ +{- ORMOLU_DISABLE -} +a::String +a="-}" diff --git a/data/examples/other/disabling/empty-disabled-region-out.hs b/data/examples/other/disabling/empty-disabled-region-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/empty-disabled-region-out.hs @@ -0,0 +1,7 @@ +{- ORMOLU_DISABLE -} +{- ORMOLU_ENABLE -} +foo = 0 +{- ORMOLU_DISABLE -} +{- ORMOLU_ENABLE -} +bar = 1 +{- ORMOLU_DISABLE -} diff --git a/data/examples/other/disabling/empty-disabled-region.hs b/data/examples/other/disabling/empty-disabled-region.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/empty-disabled-region.hs @@ -0,0 +1,7 @@ +{- ORMOLU_DISABLE -} +{- ORMOLU_ENABLE -} +foo = 0 +{- ORMOLU_DISABLE -} +{- ORMOLU_ENABLE -} +bar = 1 +{- ORMOLU_DISABLE -} diff --git a/data/examples/other/disabling/indented-fragment-out.hs b/data/examples/other/disabling/indented-fragment-out.hs deleted file mode 100644 --- a/data/examples/other/disabling/indented-fragment-out.hs +++ /dev/null @@ -1,7 +0,0 @@ -foo = - {- ORMOLU_DISABLE -} - testCase "Foo" testFoo : - testCase "Bar" testBar : - testCase "Baz" testBaz : - {- ORMOLU_ENABLE -} - [] diff --git a/data/examples/other/disabling/indented-fragment.hs b/data/examples/other/disabling/indented-fragment.hs deleted file mode 100644 --- a/data/examples/other/disabling/indented-fragment.hs +++ /dev/null @@ -1,7 +0,0 @@ -foo = - {- ORMOLU_DISABLE -} - testCase "Foo" testFoo : - testCase "Bar" testBar : - testCase "Baz" testBaz : - {- ORMOLU_ENABLE -} - [] diff --git a/data/examples/other/disabling/line-pragma-in-disabled-region-out.hs b/data/examples/other/disabling/line-pragma-in-disabled-region-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/line-pragma-in-disabled-region-out.hs @@ -0,0 +1,7 @@ +module Foo (foo) where + +{- ORMOLU_DISABLE -} +foo= +{-# LINE 11 "Abc.hs" #-} + this . line $ ((is automatically generated) Haskell<>code) +{- ORMOLU_ENABLE -} diff --git a/data/examples/other/disabling/line-pragma-in-disabled-region.hs b/data/examples/other/disabling/line-pragma-in-disabled-region.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/line-pragma-in-disabled-region.hs @@ -0,0 +1,7 @@ +module Foo(foo) where + +{- ORMOLU_DISABLE -} +foo= +{-# LINE 11 "Abc.hs" #-} + this . line $ ((is automatically generated) Haskell<>code) +{- ORMOLU_ENABLE -} diff --git a/data/examples/other/disabling/normalize-magic-comments-out.hs b/data/examples/other/disabling/normalize-magic-comments-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/normalize-magic-comments-out.hs @@ -0,0 +1,8 @@ +{- ORMOLU_DISABLE -} + {- ORMOLU_DISABLE -} +foo=bar +{- ORMOLU_ENABLE -} +{-ORMOLU_ENABLE -} +bar = baz +{- ORMOLU_DISABLE -} +baz=foo diff --git a/data/examples/other/disabling/normalize-magic-comments.hs b/data/examples/other/disabling/normalize-magic-comments.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/normalize-magic-comments.hs @@ -0,0 +1,8 @@ + {-ORMOLU_DISABLE -} + {- ORMOLU_DISABLE -} +foo=bar +{- ORMOLU_ENABLE-} + {-ORMOLU_ENABLE -} +bar=baz +{- ORMOLU_DISABLE-} +baz=foo diff --git a/data/examples/other/disabling/preserve-empty-lines-out.hs b/data/examples/other/disabling/preserve-empty-lines-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/preserve-empty-lines-out.hs @@ -0,0 +1,11 @@ +{- ORMOLU_DISABLE -} +bar :: Int +bar = 2 + + +baz :: Int +baz = 3 +{- ORMOLU_ENABLE -} + +foo :: Int +foo = 1 diff --git a/data/examples/other/disabling/preserve-empty-lines.hs b/data/examples/other/disabling/preserve-empty-lines.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/preserve-empty-lines.hs @@ -0,0 +1,12 @@ +{- ORMOLU_DISABLE -} +bar :: Int +bar = 2 + + +baz :: Int +baz = 3 +{- ORMOLU_ENABLE -} + + +foo :: Int +foo = 1 diff --git a/data/examples/other/disabling/preserve-trailing-whitespace-out.hs b/data/examples/other/disabling/preserve-trailing-whitespace-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/preserve-trailing-whitespace-out.hs @@ -0,0 +1,5 @@ +foo = 2 + +{- ORMOLU_DISABLE -} +bar = 3 +{- ORMOLU_ENABLE -} diff --git a/data/examples/other/disabling/preserve-trailing-whitespace.hs b/data/examples/other/disabling/preserve-trailing-whitespace.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/preserve-trailing-whitespace.hs @@ -0,0 +1,5 @@ +foo = 2 + +{- ORMOLU_DISABLE -} +bar = 3 +{- ORMOLU_ENABLE -} diff --git a/data/examples/other/disabling/suffix-comment-out.hs b/data/examples/other/disabling/suffix-comment-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/suffix-comment-out.hs @@ -0,0 +1,1 @@ +{- ORMOLU_DISABLE -} -- foo diff --git a/data/examples/other/disabling/suffix-comment.hs b/data/examples/other/disabling/suffix-comment.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/disabling/suffix-comment.hs @@ -0,0 +1,1 @@ +{- ORMOLU_DISABLE -} -- foo diff --git a/data/examples/other/empty-forall-out.hs b/data/examples/other/empty-forall-out.hs --- a/data/examples/other/empty-forall-out.hs +++ b/data/examples/other/empty-forall-out.hs @@ -12,7 +12,7 @@ forall. T x = x {-# RULES -"r" +"r" forall. r a = () #-} diff --git a/data/examples/other/empty-haddock-out.hs b/data/examples/other/empty-haddock-out.hs --- a/data/examples/other/empty-haddock-out.hs +++ b/data/examples/other/empty-haddock-out.hs @@ -1,5 +1,13 @@ -module Main where +-- \| +module Test + ( -- \| + test, + ) +where --- | -foo :: Int -foo = 5 +-- \| +test :: + -- \| + test + +data T = T {- \^ -} diff --git a/data/examples/other/empty-haddock.hs b/data/examples/other/empty-haddock.hs --- a/data/examples/other/empty-haddock.hs +++ b/data/examples/other/empty-haddock.hs @@ -1,6 +1,13 @@ -module Main where +-- | +module Test + ( -- | + test, + ) +where -- | +test :: + -- | + test -foo :: Int -foo = 5 +data T = T {- ^ -} diff --git a/data/examples/other/inline-comment-1-out.hs b/data/examples/other/inline-comment-1-out.hs --- a/data/examples/other/inline-comment-1-out.hs +++ b/data/examples/other/inline-comment-1-out.hs @@ -1,12 +1,16 @@ showPs env ((n, _, Let _ t v) : bs) = - " " ++ show n ++ " : " + " " + ++ show n + ++ " : " ++ showEnv env ({- normalise ctxt env -} t) ++ " = " ++ showEnv env ({- normalise ctxt env -} v) ++ "\n" ++ showPs env bs showPs env ((n, _, b) : bs) = - " " ++ show n ++ " : " + " " + ++ show n + ++ " : " ++ showEnv env ({- normalise ctxt env -} (binderTy b)) ++ "\n" ++ showPs env bs diff --git a/data/examples/other/invalid-haddock-1-out.hs b/data/examples/other/invalid-haddock-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/invalid-haddock-1-out.hs @@ -0,0 +1,11 @@ +test = undefined + where + a :: + -- \** foo + Int -> + -- \| misplaced + -- blablabla + Int + -- \|misplaced + -- blablabla + a = undefined diff --git a/data/examples/other/invalid-haddock-1.hs b/data/examples/other/invalid-haddock-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/invalid-haddock-1.hs @@ -0,0 +1,11 @@ +test = undefined + where + a :: + -- ** foo + Int -> + -- | misplaced + -- blablabla + Int + -- |misplaced + -- blablabla + a = undefined diff --git a/data/examples/other/invalid-haddock-2-out.hs b/data/examples/other/invalid-haddock-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/invalid-haddock-2-out.hs @@ -0,0 +1,9 @@ +test = undefined + where + -- \| Comment + -- 2nd invalid line + a = undefined + + -- \| A multiline + -- \| comment + b = b diff --git a/data/examples/other/invalid-haddock-2.hs b/data/examples/other/invalid-haddock-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/invalid-haddock-2.hs @@ -0,0 +1,9 @@ +test = undefined + where + -- | Comment + -- 2nd invalid line + a = undefined + + -- | A multiline + -- | comment + b = b diff --git a/data/examples/other/invalid-haddock-double-trigger-out.hs b/data/examples/other/invalid-haddock-double-trigger-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/invalid-haddock-double-trigger-out.hs @@ -0,0 +1,8 @@ +test = + foo + -- \|| Invalid haddock, with double trigger + -- \|| second line + + bar + -- \||Invalid haddock 2, with double trigger + -- \||second line + + baz diff --git a/data/examples/other/invalid-haddock-double-trigger.hs b/data/examples/other/invalid-haddock-double-trigger.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/invalid-haddock-double-trigger.hs @@ -0,0 +1,7 @@ +test = foo + -- || Invalid haddock, with double trigger + -- || second line + + bar + -- ||Invalid haddock 2, with double trigger + -- ||second line + + baz diff --git a/data/examples/other/invalid-haddock-weird-out.hs b/data/examples/other/invalid-haddock-weird-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/invalid-haddock-weird-out.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TemplateHaskell #-} + +foo = foo -- \|# ${ diff --git a/data/examples/other/invalid-haddock-weird.hs b/data/examples/other/invalid-haddock-weird.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/invalid-haddock-weird.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TemplateHaskell #-} + +foo = foo -- |# ${ diff --git a/data/examples/other/jsffi-out.hs b/data/examples/other/jsffi-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/jsffi-out.hs @@ -0,0 +1,1 @@ +{-# LANGUAGE JavaScriptFFI #-} diff --git a/data/examples/other/jsffi.hs b/data/examples/other/jsffi.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/jsffi.hs @@ -0,0 +1,1 @@ +{-# language JavaScriptFFI #-} diff --git a/data/examples/other/multiline-forall-out.hs b/data/examples/other/multiline-forall-out.hs --- a/data/examples/other/multiline-forall-out.hs +++ b/data/examples/other/multiline-forall-out.hs @@ -22,8 +22,7 @@ ) (x :: *) (y :: *). - f x y -> - G + f x y -> G f :: forall @@ -32,8 +31,7 @@ ) (x :: *) (y :: *). - f x y -> - () + f x y -> () f = const () type family T f x y where diff --git a/data/examples/other/necessary-brackets-out.hs b/data/examples/other/necessary-brackets-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/necessary-brackets-out.hs @@ -0,0 +1,3 @@ +insertEmDash = Text.concat . map \case { x | x == "--" -> "—"; x -> x } . Text.groupBy ((==) `on` Char.isSpace) + +foo f a b c = f do { a } + f do { b } + f do c diff --git a/data/examples/other/necessary-brackets.hs b/data/examples/other/necessary-brackets.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/necessary-brackets.hs @@ -0,0 +1,3 @@ +insertEmDash = Text.concat . map \case{ x | x == "--" -> "—"; x -> x } . Text.groupBy ((==) `on` Char.isSpace) + +foo f a b c = f do {a} + f do {b} + f do {c} diff --git a/data/examples/other/no-linear-arrows-out.hs b/data/examples/other/no-linear-arrows-out.hs deleted file mode 100644 --- a/data/examples/other/no-linear-arrows-out.hs +++ /dev/null @@ -1,5 +0,0 @@ -type a % b = (a, b) - -type Foo a m b = a % m -> b - -type Bar a m b = a % m -> b diff --git a/data/examples/other/no-linear-arrows.hs b/data/examples/other/no-linear-arrows.hs deleted file mode 100644 --- a/data/examples/other/no-linear-arrows.hs +++ /dev/null @@ -1,4 +0,0 @@ -type a % b = (a,b) - -type Foo a m b = a % m -> b -type Bar a m b = a %m -> b diff --git a/data/examples/other/pragma-below-header-out.hs b/data/examples/other/pragma-below-header-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/pragma-below-header-out.hs @@ -0,0 +1,19 @@ +module Plugin.Data.Spec where + +{- +foo bar boz +-} +monoConstructor :: Int +monoConstructor = 1 + +-- hello world + +-- | A type of rose trees with empty leaves. +data EmptyRose = EmptyRose [EmptyRose] + +-- This seems to cause issue +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + +-- bob alice eve +f :: () +f = () diff --git a/data/examples/other/pragma-below-header.hs b/data/examples/other/pragma-below-header.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/pragma-below-header.hs @@ -0,0 +1,18 @@ +module Plugin.Data.Spec where + +{- +foo bar boz +-} +monoConstructor :: Int +monoConstructor = 1 + +-- hello world +-- | A type of rose trees with empty leaves. +data EmptyRose = EmptyRose [EmptyRose] + +-- This seems to cause issue +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + +-- bob alice eve +f :: () +f = () diff --git a/data/examples/other/pragma-comment-multi-extension-out.hs b/data/examples/other/pragma-comment-multi-extension-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/pragma-comment-multi-extension-out.hs @@ -0,0 +1,5 @@ +-- comment +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +module Foo where diff --git a/data/examples/other/pragma-comment-multi-extension.hs b/data/examples/other/pragma-comment-multi-extension.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/pragma-comment-multi-extension.hs @@ -0,0 +1,4 @@ +-- comment +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} + +module Foo where diff --git a/data/examples/other/pragma-sorting-out.hs b/data/examples/other/pragma-sorting-out.hs --- a/data/examples/other/pragma-sorting-out.hs +++ b/data/examples/other/pragma-sorting-out.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} diff --git a/data/examples/other/pragma-sorting.hs b/data/examples/other/pragma-sorting.hs --- a/data/examples/other/pragma-sorting.hs +++ b/data/examples/other/pragma-sorting.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE GHC2021 #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NondecreasingIndentation #-} diff --git a/data/parse-failures/disabling-preserves-error-location.hs b/data/parse-failures/disabling-preserves-error-location.hs new file mode 100644 --- /dev/null +++ b/data/parse-failures/disabling-preserves-error-location.hs @@ -0,0 +1,11 @@ +module Main (main) where + +{- ORMOLU_DISABLE -} +foo Int +foo Int +foo 5 EU>>>> + +{- ORMOLU_ENABLE -} + +main :: IO () +main = return <<< diff --git a/data/parse-failures/line-pragma.hs b/data/parse-failures/line-pragma.hs new file mode 100644 --- /dev/null +++ b/data/parse-failures/line-pragma.hs @@ -0,0 +1,5 @@ +module Foo (foo,bar,baz) where +bar = foo +{-# LINE 113 "Abc.hs" #-} +foo = (some <$> ( automatically $ generated ))))))))) invalid Haskell code +baz = bar diff --git a/extract-hackage-info/hackage-info.bin b/extract-hackage-info/hackage-info.bin new file mode 100644 Binary files /dev/null and b/extract-hackage-info/hackage-info.bin differ diff --git a/ormolu.cabal b/ormolu.cabal --- a/ormolu.cabal +++ b/ormolu.cabal @@ -1,158 +1,225 @@ -cabal-version: 2.4 -name: ormolu -version: 0.2.0.0 -license: BSD-3-Clause -license-file: LICENSE.md -maintainer: Mark Karpov -tested-with: ghc ==8.8.4 ghc ==8.10.4 ghc ==9.0.1 -homepage: https://github.com/tweag/ormolu -bug-reports: https://github.com/tweag/ormolu/issues -synopsis: A formatter for Haskell source code -description: A formatter for Haskell source code. -category: Development, Formatting -build-type: Simple +cabal-version: 2.4 +name: ormolu +version: 0.9.0.0 +license: BSD-3-Clause +license-file: LICENSE.md +maintainer: Mark Karpov +tested-with: + ghc ==9.10.3 + ghc ==9.12.4 + ghc ==9.14.1 + +homepage: https://github.com/mrkkrp/ormolu +bug-reports: https://github.com/mrkkrp/ormolu/issues +synopsis: A formatter for Haskell source code +description: A formatter for Haskell source code. +category: Development, Formatting +build-type: Simple extra-source-files: - data/**/*.hs - data/**/*.txt + data/**/*.cabal + data/**/*.hs + data/**/*.txt + extract-hackage-info/hackage-info.bin extra-doc-files: - CONTRIBUTING.md - CHANGELOG.md - DESIGN.md - README.md + CHANGELOG.md + CONTRIBUTING.md + DESIGN.md + README.md source-repository head - type: git - location: https://github.com/tweag/ormolu.git + type: git + location: https://github.com/mrkkrp/ormolu.git flag dev - description: Turn on development settings. - default: False - manual: True + description: Turn on development settings. + default: False + manual: True library - exposed-modules: - Ormolu - Ormolu.Config - Ormolu.Diff.ParseResult - Ormolu.Diff.Text - Ormolu.Exception - Ormolu.Imports - Ormolu.Parser - Ormolu.Parser.Anns - Ormolu.Parser.CommentStream - Ormolu.Parser.Pragma - Ormolu.Parser.Result - Ormolu.Parser.Shebang - Ormolu.Printer - Ormolu.Printer.Combinators - Ormolu.Printer.Comments - Ormolu.Printer.Internal - Ormolu.Printer.Meat.Common - Ormolu.Printer.Meat.Declaration - Ormolu.Printer.Meat.Declaration.Annotation - Ormolu.Printer.Meat.Declaration.Class - Ormolu.Printer.Meat.Declaration.Data - Ormolu.Printer.Meat.Declaration.Default - Ormolu.Printer.Meat.Declaration.Foreign - Ormolu.Printer.Meat.Declaration.Instance - Ormolu.Printer.Meat.Declaration.RoleAnnotation - Ormolu.Printer.Meat.Declaration.Rule - Ormolu.Printer.Meat.Declaration.Signature - Ormolu.Printer.Meat.Declaration.Splice - Ormolu.Printer.Meat.Declaration.Type - Ormolu.Printer.Meat.Declaration.TypeFamily - Ormolu.Printer.Meat.Declaration.Value - Ormolu.Printer.Meat.Declaration.Warning - Ormolu.Printer.Meat.ImportExport - Ormolu.Printer.Meat.Module - Ormolu.Printer.Meat.Pragma - Ormolu.Printer.Meat.Type - Ormolu.Printer.Operators - Ormolu.Printer.SpanStream - Ormolu.Processing.Common - Ormolu.Processing.Cpp - Ormolu.Processing.Postprocess - Ormolu.Processing.Preprocess - Ormolu.Terminal - Ormolu.Utils - - hs-source-dirs: src - other-modules: GHC.DynFlags - default-language: Haskell2010 - build-depends: - Diff >=0.4 && <1.0, - ansi-terminal >=0.10 && <1.0, - base >=4.12 && <5.0, - bytestring >=0.2 && <0.12, - containers >=0.5 && <0.7, - dlist >=0.8 && <2.0, - exceptions >=0.6 && <0.11, - ghc-lib-parser >=9.0 && <9.1, - mtl >=2.0 && <3.0, - syb >=0.7 && <0.8, - text >=0.2 && <1.3 - - if flag(dev) - ghc-options: - -Wall -Werror -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wnoncanonical-monad-instances - -Wno-missing-home-modules + exposed-modules: + Ormolu + Ormolu.Comments.Anchor + Ormolu.Comments.Invariants + Ormolu.Comments.Tree + Ormolu.Config + Ormolu.Diff.ParseResult + Ormolu.Diff.Text + Ormolu.Exception + Ormolu.Fixity + Ormolu.Fixity.Imports + Ormolu.Fixity.Internal + Ormolu.Fixity.Parser + Ormolu.Fixity.Printer + Ormolu.Imports + Ormolu.Parser + Ormolu.Parser.CommentStream + Ormolu.Parser.Pragma + Ormolu.Parser.Result + Ormolu.Printer + Ormolu.Printer.Combinators + Ormolu.Printer.CommentPlacement + Ormolu.Printer.Comments + Ormolu.Printer.Internal + Ormolu.Printer.Meat.Common + Ormolu.Printer.Meat.Declaration + Ormolu.Printer.Meat.Declaration.Annotation + Ormolu.Printer.Meat.Declaration.Class + Ormolu.Printer.Meat.Declaration.Data + Ormolu.Printer.Meat.Declaration.Default + Ormolu.Printer.Meat.Declaration.Foreign + Ormolu.Printer.Meat.Declaration.Instance + Ormolu.Printer.Meat.Declaration.OpTree + Ormolu.Printer.Meat.Declaration.RoleAnnotation + Ormolu.Printer.Meat.Declaration.Rule + Ormolu.Printer.Meat.Declaration.Signature + Ormolu.Printer.Meat.Declaration.Splice + Ormolu.Printer.Meat.Declaration.StringLiteral + Ormolu.Printer.Meat.Declaration.Type + Ormolu.Printer.Meat.Declaration.TypeFamily + Ormolu.Printer.Meat.Declaration.Value + Ormolu.Printer.Meat.Declaration.Warning + Ormolu.Printer.Meat.ImportExport + Ormolu.Printer.Meat.Module + Ormolu.Printer.Meat.Pragma + Ormolu.Printer.Meat.Type + Ormolu.Printer.Operators + Ormolu.Processing.Common + Ormolu.Processing.Cpp + Ormolu.Processing.Preprocess + Ormolu.Terminal + Ormolu.Terminal.QualifiedDo + Ormolu.Utils + Ormolu.Utils.Cabal + Ormolu.Utils.Fixity + Ormolu.Utils.IO - else - ghc-options: -O2 -Wall + hs-source-dirs: src + other-modules: GHC.DynFlags + default-language: GHC2021 + build-depends: + Cabal-syntax >=3.16 && <3.17, + Diff >=0.4 && <2, + MemoTrie >=0.6 && <0.7, + ansi-terminal >=0.10 && <1.2, + array >=0.5 && <0.6, + base >=4.14 && <5, + binary >=0.8 && <0.9, + bytestring >=0.2 && <0.13, + choice >=0.2.4.1 && <0.3, + containers >=0.5 && <0.9, + directory ^>=1.3, + file-embed >=0.0.15 && <0.1, + filepath >=1.2 && <1.6, + ghc-lib-parser >=9.14 && <9.15, + megaparsec >=9, + mtl >=2 && <3, + syb >=0.7 && <0.8, + text >=2.1 && <3, - if impl(ghc <8.10.0) - ghc-options: -fmax-pmcheck-iterations=3000000 + if flag(dev) + ghc-options: + -Wall + -Werror + -Wredundant-constraints + -Wpartial-fields + -Wunused-packages + -haddock + -Winvalid-haddock + else + ghc-options: + -O2 + -Wall executable ormolu - main-is: Main.hs - hs-source-dirs: app - other-modules: Paths_ormolu - autogen-modules: Paths_ormolu - default-language: Haskell2010 - build-depends: - base >=4.12 && <5.0, - filepath >=1.2 && <1.5, - ghc-lib-parser >=9.0 && <9.1, - gitrev >=1.3 && <1.4, - optparse-applicative >=0.14 && <0.17, - ormolu, - text >=0.2 && <1.3 + main-is: Main.hs + hs-source-dirs: app + other-modules: Paths_ormolu + autogen-modules: Paths_ormolu + default-language: GHC2021 + build-depends: + Cabal-syntax >=3.16 && <3.17, + base >=4.12 && <5, + containers >=0.5 && <0.9, + directory ^>=1.3, + filepath >=1.2 && <1.6, + ghc-lib-parser >=9.14 && <9.15, + optparse-applicative >=0.14 && <0.20, + ormolu, + text >=2.1 && <3, + th-env >=0.1.1 && <0.2, + unliftio >=0.2.10 && <0.3, - if flag(dev) - ghc-options: - -Wall -Werror -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wnoncanonical-monad-instances - -optP-Wno-nonportable-include-path + -- We use parallelism so we need a threaded runtime to get any + -- benefit. + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N - else - ghc-options: -O2 -Wall -rtsopts + if flag(dev) + ghc-options: + -Wall + -Werror + -Wredundant-constraints + -Wpartial-fields + -Wunused-packages + -Wwarn=unused-packages + -haddock + -Winvalid-haddock + else + ghc-options: + -O2 + -Wall test-suite tests - type: exitcode-stdio-1.0 - main-is: Spec.hs - build-tool-depends: hspec-discover:hspec-discover >=2.0 && <3.0 - hs-source-dirs: tests - other-modules: - Ormolu.Diff.TextSpec - Ormolu.Parser.OptionsSpec - Ormolu.Parser.PragmaSpec - Ormolu.PrinterSpec - - default-language: Haskell2010 - build-depends: - base >=4.12 && <5.0, - containers >=0.5 && <0.7, - filepath >=1.2 && <1.5, - hspec >=2.0 && <3.0, - ormolu, - path >=0.6 && <0.10, - path-io >=1.4.2 && <2.0, - text >=0.2 && <1.3 + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover >=2 && <3 + hs-source-dirs: tests + other-modules: + Ormolu.CabalInfoSpec + Ormolu.Comments.AnchorSpec + Ormolu.Diff.TextSpec + Ormolu.Fixity.ParserSpec + Ormolu.Fixity.PrinterSpec + Ormolu.FixitySpec + Ormolu.OpTreeSpec + Ormolu.Parser.OptionsSpec + Ormolu.Parser.ParseFailureSpec + Ormolu.Parser.PragmaSpec + Ormolu.PrinterSpec + Ormolu.TestConfig - if flag(dev) - ghc-options: -Wall -Werror + default-language: GHC2021 + build-depends: + Cabal-syntax >=3.16 && <3.17, + QuickCheck >=2.14, + base >=4.14 && <5, + choice >=0.2.4.1 && <0.3, + containers >=0.5 && <0.9, + directory ^>=1.3, + filepath >=1.2 && <1.6, + ghc-lib-parser >=9.14 && <9.15, + hspec >=2 && <3, + hspec-megaparsec >=2.2, + megaparsec >=9, + ormolu, + path >=0.6 && <0.10, + path-io >=1.4.2 && <2, + temporary ^>=1.3, + text >=2.1 && <3, - else - ghc-options: -O2 -Wall + if flag(dev) + ghc-options: + -Wall + -Werror + -Wredundant-constraints + -Wpartial-fields + -Wunused-packages + -haddock + -Winvalid-haddock + else + ghc-options: + -O2 + -Wall diff --git a/src/GHC/DynFlags.hs b/src/GHC/DynFlags.hs --- a/src/GHC/DynFlags.hs +++ b/src/GHC/DynFlags.hs @@ -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 @@ -24,12 +26,13 @@ sFileSettings = FileSettings {}, sTargetPlatform = Platform - { platformWordSize = PW8, - platformMini = - PlatformMini - { platformMini_arch = ArchUnknown, - platformMini_os = OSUnknown + { platformArchOS = + ArchOS + { -- see https://github.com/tweag/ormolu/issues/1087 + archOS_arch = ArchJavaScript, + archOS_OS = OSUnknown }, + platformWordSize = PW8, platformUnregisterised = True, platformByteOrder = LittleEndian, platformHasGnuNonexecStack = False, @@ -37,11 +40,15 @@ platformHasSubsectionsViaSymbols = False, platformIsCrossCompiling = False, platformLeadingUnderscore = False, - platformTablesNextToCode = False + platformTablesNextToCode = False, + platformHasLibm = False, + platform_constants = Nothing }, sPlatformMisc = PlatformMisc {}, - sPlatformConstants = - PlatformConstants {pc_DYNAMIC_BY_DEFAULT = False, pc_WORD_SIZE = 8}, + sUnitSettings = + UnitSettings + { unitSettings_baseUnitId = UnitId $ fsLit "ormolu" + }, sToolSettings = ToolSettings { toolSettings_opt_P_fingerprint = fingerprint0, @@ -49,8 +56,5 @@ } } -fakeLlvmConfig :: LlvmConfig -fakeLlvmConfig = LlvmConfig [] [] - baseDynFlags :: DynFlags -baseDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig +baseDynFlags = defaultDynFlags fakeSettings diff --git a/src/Ormolu.hs b/src/Ormolu.hs --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -1,15 +1,37 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} --- | A formatter for Haskell source code. +-- | A formatter for Haskell source code. This module exposes the official +-- stable API; other modules may not be as reliable. module Ormolu - ( ormolu, + ( -- * Top-level formatting functions + ormolu, ormoluFile, ormoluStdin, + + -- * Configuration Config (..), ColorMode (..), RegionIndices (..), + SourceType (..), defaultConfig, + detectSourceType, + refineConfig, DynOption (..), + + -- * Cabal info + CabalUtils.CabalSearchResult (..), + CabalUtils.CabalInfo (..), + CabalUtils.getCabalInfoForSourceFile, + + -- * Fixity overrides and module re-exports + FixityOverrides, + defaultFixityOverrides, + ModuleReexports, + defaultModuleReexports, + getDotOrmoluForSourceFile, + + -- * Working with exceptions OrmoluException (..), withPrettyOrmoluExceptions, ) @@ -18,84 +40,148 @@ 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 import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T +import Data.Text.IO.Utf8 qualified as T.Utf8 import Debug.Trace -import qualified GHC.Driver.CmdLine as GHC -import qualified GHC.Types.SrcLoc as GHC +import GHC.Driver.Errors.Types +import GHC.Hs (HsModule (..), locA) +import GHC.Types.Error +import GHC.Types.SrcLoc +import GHC.Utils.Error +import Ormolu.Comments.Invariants import Ormolu.Config import Ormolu.Diff.ParseResult import Ormolu.Diff.Text import Ormolu.Exception +import Ormolu.Fixity import Ormolu.Parser +import Ormolu.Parser.CommentStream (CommentStream (..)) import Ormolu.Parser.Result import Ormolu.Printer import Ormolu.Utils (showOutputable) +import Ormolu.Utils.Cabal qualified as CabalUtils +import Ormolu.Utils.Fixity (getDotOrmoluForSourceFile) +import System.FilePath --- | Format a 'String', return formatted version as 'Text'. +-- | Format a 'Text'. -- --- The function +-- The function: -- --- * Takes 'String' because that's what GHC parser accepts. --- * Needs 'IO' because some functions from GHC that are necessary to --- setup parsing context require 'IO'. There should be no visible --- side-effects though. --- * Takes file name just to use it in parse error messages. +-- * Needs 'IO' because some GHC functions that are necessary to set up +-- the parsing context require 'IO'. There should be no visible +-- side effects, though. +-- * Takes a file name only to use it in parse error messages. -- * Throws 'OrmoluException'. +-- +-- __NOTE__: The caller is responsible for setting the appropriate value in +-- the 'cfgSourceType' field. Autodetection of source type won't happen +-- here, see 'detectSourceType'. ormolu :: - MonadIO m => + (MonadIO m) => -- | Ormolu configuration Config RegionIndices -> -- | Location of source file FilePath -> -- | Input to format - String -> + Text -> m Text -ormolu cfgWithIndices path str = do - let totalLines = length (lines str) +ormolu cfgWithIndices path originalInput = do + let totalLines = length (T.lines originalInput) cfg = regionIndicesToDeltas totalLines <$> cfgWithIndices + fixityMap = + packageFixityMap + (overapproximatedDependencies cfg) -- memoized on the set of dependencies + when (cfgDebug cfg) $ do + traceM $ unwords ["*** CONFIG ***", show cfg] (warnings, result0) <- - parseModule' cfg OrmoluParsingFailed path str + parseModule' cfg fixityMap OrmoluParsingFailed path originalInput when (cfgDebug cfg) $ do - traceM "warnings:\n" - traceM (concatMap showWarn warnings) - traceM (prettyPrintParseResult result0) - -- We're forcing 'txt' here because otherwise errors (such as messages - -- about not-yet-supported functionality) will be thrown later 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 !txt = printModule result0 + forM_ warnings $ \driverMsg -> do + let driverMsgSDoc = formatBulleted $ diagnosticMessage defaultOpts driverMsg + traceM $ unwords ["*** WARNING ***", showOutputable driverMsgSDoc] + forM_ result0 $ \case + ParsedSnippet r -> do + let CommentStream comments = prCommentStream r + forM_ comments $ \(L loc comment) -> + traceM $ unwords ["*** COMMENT ***", showOutputable loc, show comment] + _ -> pure () + -- We force 'formattedText' here because otherwise errors (such as + -- messages about not-yet-supported functionality) would be thrown later, + -- when we try to parse the rendered code back inside the GHC monad + -- wrapper, which would lead to error messages presenting the exceptions + -- as GHC bugs. + let printed = + printSnippetsWithPlacements (Choice.fromBool (cfgDebug cfg)) result0 + !formattedText = T.concat (fst <$> printed) + -- Every comment of the input should come out exactly once, and in the + -- order it went in. The AST check below does not cover this: it compares + -- the comment streams as multisets, and the comments that travel with + -- pragmas are not in the stream at all. + unless (cfgUnsafe cfg) . liftIO $ do + let violations = + concat + [ checkCommentInvariants + (getLoc <$> inputComments r) + (reorderableSpans (prParsedSource r)) + placements + | (ParsedSnippet r, (_, placements)) <- result0 `zip` printed + ] + -- Imports are sorted and merged, so a comment attached to one of + -- them may legitimately come out in a different order than it went + -- in. + reorderableSpans hsmod = + [ spn + | L l _ <- hsmodImports hsmod, + Just spn <- [srcSpanToRealSrcSpan (locA l)] + ] + unless (null violations) $ + throwIO (OrmoluCommentInvariantsViolated path violations) 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. + -- Parse the result of pretty-printing again and make sure that its AST + -- is the same as the AST of the original snippet, modulo span + -- positions. (_, result1) <- parseModule' cfg + fixityMap OrmoluOutputParsingFailed path - (T.unpack txt) - unless (cfgUnsafe cfg) $ - case diffParseResult result0 result1 of - Same -> return () - Different ss -> liftIO $ throwIO (OrmoluASTDiffers path ss) + formattedText + unless (cfgUnsafe cfg) . liftIO $ do + let diff = case diffText originalInput formattedText path of + Nothing -> error "AST differs, yet no changes have been introduced" + Just x -> x + when (length result0 /= length result1) $ + throwIO (OrmoluASTDiffers diff []) + forM_ (result0 `zip` result1) $ \case + (ParsedSnippet s, ParsedSnippet s') -> case diffParseResult s s' of + Same -> return () + Different ss -> throwIO (OrmoluASTDiffers (selectSpans ss diff) ss) + (RawSnippet {}, RawSnippet {}) -> pure () + _ -> throwIO (OrmoluASTDiffers diff []) -- Try re-formatting the formatted result to check if we get exactly -- the same output. - when (cfgCheckIdempotence cfg) $ - let txt2 = printModule result1 - in case diffText txt txt2 path of + when (cfgCheckIdempotence cfg) . liftIO $ + let reformattedText = + printSnippets (Choice.fromBool (cfgDebug cfg)) result1 + in case diffText formattedText reformattedText path of Nothing -> return () - Just diff -> - liftIO $ - throwIO (OrmoluNonIdempotentOutput diff) - return txt + Just diff -> throwIO (OrmoluNonIdempotentOutput diff) + return formattedText -- | Load a file and format it. The file stays intact and the rendered -- version is returned as 'Text'. -- --- > ormoluFile cfg path = --- > liftIO (readFile path) >>= ormolu cfg path +-- __NOTE__: The caller is responsible for setting the appropriate value in +-- the 'cfgSourceType' field. Autodetection of source type won't happen +-- here, see 'detectSourceType'. ormoluFile :: - MonadIO m => + (MonadIO m) => -- | Ormolu configuration Config RegionIndices -> -- | Location of source file @@ -103,46 +189,104 @@ -- | Resulting rendition m Text ormoluFile cfg path = - liftIO (readFile path) >>= ormolu cfg path + liftIO (T.Utf8.readFile path) >>= ormolu cfg path -- | Read input from stdin and format it. -- --- > ormoluStdin cfg = --- > liftIO (hGetContents stdin) >>= ormolu cfg "" +-- __NOTE__: The caller is responsible for setting the appropriate value in +-- the 'cfgSourceType' field. Autodetection of source type won't happen +-- here, see 'detectSourceType'. ormoluStdin :: - MonadIO m => + (MonadIO m) => -- | Ormolu configuration Config RegionIndices -> -- | Resulting rendition m Text ormoluStdin cfg = - liftIO getContents >>= ormolu cfg "" + liftIO T.Utf8.getContents >>= ormolu cfg "" +-- | Refine a 'Config' by incorporating the given 'SourceType', 'CabalInfo', +-- and fixity overrides 'FixityMap'. You can use 'detectSourceType' to deduce +-- the 'SourceType' from the file extension, +-- 'CabalUtils.getCabalInfoForSourceFile' to obtain the 'CabalInfo', and +-- 'getFixityOverridesForSourceFile' for the 'FixityMap'. +-- +-- @since 0.5.3.0 +refineConfig :: + -- | Source type to use + SourceType -> + -- | Cabal info for the file, if available + Maybe CabalUtils.CabalInfo -> + -- | Fixity overrides, if available + Maybe FixityOverrides -> + -- | Module re-exports, if available + Maybe ModuleReexports -> + -- | 'Config' to refine + Config region -> + -- | Refined 'Config' + Config region +refineConfig sourceType mcabalInfo mfixityOverrides mreexports rawConfig = + rawConfig + { cfgDynOptions = cfgDynOptions rawConfig ++ dynOptsFromCabal, + cfgFixityOverrides = + FixityOverrides $ + Map.unions + [ unFixityOverrides fixityOverrides, + unFixityOverrides (cfgFixityOverrides rawConfig), + unFixityOverrides defaultFixityOverrides + ], + cfgModuleReexports = + ModuleReexports $ + Map.unionsWith + (<>) + [ unModuleReexports reexports, + unModuleReexports (cfgModuleReexports rawConfig), + unModuleReexports defaultModuleReexports + ], + cfgDependencies = + Set.union (cfgDependencies rawConfig) depsFromCabal, + cfgSourceType = sourceType + } + where + fixityOverrides = fromMaybe defaultFixityOverrides mfixityOverrides + reexports = fromMaybe defaultModuleReexports mreexports + (dynOptsFromCabal, depsFromCabal) = + case mcabalInfo of + Nothing -> + -- If no cabal info is provided, assume base as a dependency by + -- default. + ([], defaultDependencies) + Just CabalUtils.CabalInfo {..} -> + -- It makes sense to take into account the operator info for the + -- package itself if we know it, as if it were its own dependency. + (ciDynOpts, Set.insert ciPackageName ciDependencies) + ---------------------------------------------------------------------------- -- Helpers -- | A wrapper around 'parseModule'. parseModule' :: - MonadIO m => + (MonadIO m) => -- | Ormolu configuration Config RegionDeltas -> + -- | Fixity Map for operators + PackageFixityMap -> -- | How to obtain 'OrmoluException' to throw when parsing fails - (GHC.SrcSpan -> String -> OrmoluException) -> + (SrcSpan -> String -> OrmoluException) -> -- | File name to use in errors FilePath -> -- | Actual input for the parser - String -> - m ([GHC.Warn], ParseResult) -parseModule' cfg mkException path str = do - (warnings, r) <- parseModule cfg path str + Text -> + m (DriverMessages, [SourceSnippet]) +parseModule' cfg fixityMap mkException path str = do + (warnings, r) <- parseModule cfg fixityMap path str case r of Left (spn, err) -> liftIO $ throwIO (mkException spn err) Right x -> return (warnings, x) --- | Pretty-print a 'GHC.Warn'. -showWarn :: GHC.Warn -> String -showWarn (GHC.Warn reason l) = - unlines - [ showOutputable reason, - showOutputable l - ] +-- | Detect 'SourceType' based on the file extension. +detectSourceType :: FilePath -> SourceType +detectSourceType mpath = + if takeExtension mpath == ".hsig" + then SignatureSource + else ModuleSource diff --git a/src/Ormolu/Comments/Anchor.hs b/src/Ormolu/Comments/Anchor.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Comments/Anchor.hs @@ -0,0 +1,326 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Positional comment attachment. +-- +-- This module decides who owns a comment from where it sits in the source, +-- once, before anything is printed. The answer therefore does not depend on +-- the order in which the printer visits elements, which is what made +-- reordered imports and reassociated operator trees lose comments before. +-- +-- The rule is short enough to state in full. Find the element that encloses +-- the comment most tightly. Within that element, find which gap between its +-- children the comment falls into. Then: +-- +-- * a comment that starts on the line where the preceding sibling ends +-- trails that sibling; +-- * otherwise, if a sibling follows, the comment goes before it; +-- * otherwise the comment trails the last sibling; +-- * an element with no children at all owns the comment outright. +module Ormolu.Comments.Anchor + ( CommentAnchor (..), + attachComments, + anchorFor, + + -- * Using the anchors while printing + AnchorMap, + mkAnchorMap, + noComments, + claimBefore, + commentsBefore, + claimTrailing, + claimRemaining, + pendingComments, + commentsAnchoredWithin, + ) +where + +import Data.List (find, sortOn) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (listToMaybe) +import Data.Set qualified as Set +import GHC.Types.SrcLoc +import Ormolu.Comments.Tree +import Ormolu.Parser.CommentStream + +-- | Where a comment belongs. +data CommentAnchor + = -- | On its own line(s) above the element + AnchorBefore RealSrcSpan + | -- | After the element, either on the same line or below it + AnchorTrailing RealSrcSpan + | -- | Inside the element, which has no children of its own + AnchorInside RealSrcSpan + | -- | Not inside anything: the comment belongs to the module + AnchorModule + deriving (Eq, Show) + +-- | Attach every comment of a module. +attachComments :: + -- | Comments, in source order + [LComment] -> + -- | Spans of all \"located\" elements of the module + [RealSrcSpan] -> + [(LComment, CommentAnchor)] +attachComments comments eltSpans = + joinBlocks eltSpans [(c, anchorFor forest c) | c <- comments] + where + forest = mkSpanForest eltSpans + +-- | Make a run of comment lines share one anchor. +-- +-- Consecutive lines with nothing but comment between them are one block as +-- far as the reader is concerned, so splitting them across two elements +-- would tear the block apart. The first line decides where the whole block +-- goes. +joinBlocks :: + -- | Spans of all elements, used to tell whether one stands between two + -- comments + [RealSrcSpan] -> + [(LComment, CommentAnchor)] -> + [(LComment, CommentAnchor)] +joinBlocks eltSpans = go Nothing + where + -- Only the start positions matter below, and only whether one of them + -- falls in a range, so they are held as a set: this runs for every + -- comment and scanning the module's spans each time is quadratic. + eltStarts = Set.fromList (realSrcSpanStart <$> eltSpans) + + go _ [] = [] + go previous ((c@(L spn theComment), anchor) : rest) = + let anchor' = case previous of + Just (prevSpn, prevAnchor) + | continues prevSpn -> prevAnchor + _ -> anchor + continues prevSpn = + not (hasAtomsBefore theComment) + && srcSpanEndLine prevSpn + 1 == srcSpanStartLine spn + && not (elementBetween prevSpn spn) + in (c, anchor') : go (Just (spn, anchor')) rest + + -- Consecutive lines are not one block if an element begins between + -- them. @{- 0x00 -} sniExt@ followed by @{- 0x0a -} groupExt@ is two + -- blocks, each leading its own element, not one block of two lines. It + -- is enough for the element to *start* in the gap: in @f $ {-else-} do@ + -- the @do@ block opens on the first comment's line and runs well past + -- the second, and the comment on the next line belongs inside it rather + -- than to the block above. + elementBetween from to = + case Set.lookupGE (realSrcSpanEnd from) eltStarts of + Just s -> s <= realSrcSpanStart to + Nothing -> False + +-- | Attach a single comment to the forest of element spans. +anchorFor :: [SpanTree] -> LComment -> CommentAnchor +anchorFor forest (L comment theComment) = go Nothing Nothing forest + where + go enclosing outerTrailing trees = + case find (\t -> stSpan t `containsSpan` comment) trees of + -- Descend into the element that encloses the comment, so that the + -- anchor is always as tight as the source allows. Carry down the + -- code this level has already put on the comment's line: an element + -- that opens on that line, such as the right-hand side in @f x = -- + -- c@, has nothing of its own before the comment, but the comment + -- still trails the @x@ one level up. + -- + -- Only an element that wraps a single thing may carry it. One with + -- several children is a list of items, and a comment written at the + -- head of such a list introduces the items rather than trailing + -- what stands before the bracket. In + -- + -- > xs ++ [ -- why? + -- > a, b ] + -- + -- the comment must stay inside the brackets; carrying it up would + -- pull it, and the block of comment lines below it, out of the list. + Just t + | [_] <- stChildren t -> go (Just (stSpan t)) trailingHere (stChildren t) + | otherwise -> go (Just (stSpan t)) Nothing (stChildren t) + Nothing -> case (precedingSibling, followingSibling) of + (Just p, _) + | trailsCodeOn (stSpan p) -> AnchorTrailing (innermostEndingOnLine p) + -- A comment with an element right after it on the same line and + -- nothing of its own before it leads that element: a run of @{- + -- 0x00 -} sniExt@ must not be read as trailing whatever comes + -- before and pile up in one place. This outranks the code carried + -- down from an outer level, so that the @{-a-}@ of @x = ({-a-} b, + -- c)@ stays with @b@ rather than being pulled out to trail the + -- @x@. + (_, Just n) + | startsOnCommentLine (stSpan n) -> AnchorBefore (stSpan n) + -- Nothing at this level stands before the comment, but an outer + -- level put code on its line: the comment trails that code. This + -- is what keeps @f x = -- c@ on one line, the right-hand side + -- having opened on that line with the comment as its first + -- content. + -- + -- Only a line comment may do this. It runs to the end of the line + -- either way, so trailing an element one level up still renders + -- it exactly where it was written. A block comment renders in + -- place instead, and would end up ahead of the tokens that opened + -- the element it was written inside: the pragma of @corebar = {-# + -- CORE "bar baz" #-}@ would move before the @=@. + (Nothing, _) + | not (isMultilineComment theComment), + Just p <- outerTrailing -> + AnchorTrailing (innermostEndingOnLine p) + (_, Just n) -> AnchorBefore (stSpan n) + -- A comment after the last child of an element belongs to that + -- element, but a comment after everything at the top level + -- belongs to the module: there is nothing it can trail without + -- being rendered before syntax that preceded it in the input, + -- such as the @where@ of a module header. + (Just p, Nothing) + | Just _ <- enclosing -> AnchorTrailing (stSpan p) + | otherwise -> AnchorModule + (Nothing, Nothing) -> maybe AnchorModule AnchorInside enclosing + where + followingSibling = + listToMaybe + [ t + | t <- trees, + realSrcSpanStart (stSpan t) >= realSrcSpanEnd comment + ] + startsOnCommentLine s = + srcSpanStartLine s == srcSpanEndLine comment + where + precedingSibling = + lastMaybe + [ t + | t <- trees, + realSrcSpanEnd (stSpan t) <= realSrcSpanStart comment + ] + trailingHere = case precedingSibling of + Just p | trailsCodeOn (stSpan p) -> Just p + _ -> outerTrailing + + -- A comment only trails an element when it really does sit after code + -- on that line. Checking the line alone is not enough, because the AST + -- has zero-width spans that happen to share a line with a comment while + -- standing before it. + trailsCodeOn s = + srcSpanEndLine s == srcSpanStartLine comment + && hasAtomsBefore theComment + + -- A comment that trails a bracketed construct belongs to the innermost + -- element that ends on its line, not to the bracket: @(x + y) -- c@ + -- attaches to @y@, so that the comment is rendered next to the + -- expression it was written next to rather than after the closing + -- bracket. + innermostEndingOnLine t = + case lastMaybe (filter (trailsCodeOn . stSpan) (stChildren t)) of + Nothing -> stSpan t + Just t' -> innermostEndingOnLine t' + + lastMaybe xs = if null xs then Nothing else Just (last xs) + +---------------------------------------------------------------------------- +-- Using the anchors while printing + +-- | Anchored comments, arranged so that the printer can look them up by the +-- span of the element it is entering or leaving. +-- +-- Comments are claimed rather than consumed: the first element with a given +-- span takes them, and every later element with the same span finds +-- nothing. Since several AST nodes routinely share a span, and the printer +-- enters them outermost first, this gives the comment to the outermost of +-- them, which is what one wants—a comment belongs outside the parentheses, +-- not inside them. +data AnchorMap = AnchorMap + { amBefore :: Map RealSrcSpan [LComment], + amTrailing :: Map RealSrcSpan [LComment], + amModule :: [LComment] + } + +-- | An empty map, for the first of the two rendering passes: it collects +-- the spans of the elements the printer enters, and emits no comments. +noComments :: AnchorMap +noComments = + AnchorMap {amBefore = Map.empty, amTrailing = Map.empty, amModule = []} + +-- | Arrange anchored comments for lookup. +-- +-- __NOTE__: 'AnchorInside' is currently folded into 'AnchorTrailing'. Doing +-- it properly needs a combinator for elements that can have no children at +-- all. +mkAnchorMap :: [(LComment, CommentAnchor)] -> AnchorMap +mkAnchorMap anchored = + AnchorMap + { amBefore = collect [(spn, c) | (c, AnchorBefore spn) <- anchored], + amTrailing = + collect $ + [(spn, c) | (c, AnchorTrailing spn) <- anchored] + <> [(spn, c) | (c, AnchorInside spn) <- anchored], + amModule = [c | (c, AnchorModule) <- anchored] + } + where + collect = Map.fromListWith (flip (<>)) . fmap (fmap pure) + +-- | The comments that go before the element with the given span, without +-- claiming them. +commentsBefore :: RealSrcSpan -> AnchorMap -> [LComment] +commentsBefore spn = Map.findWithDefault [] spn . amBefore + +-- | Claim the comments that go before the element with the given span. +claimBefore :: RealSrcSpan -> AnchorMap -> ([LComment], AnchorMap) +claimBefore spn am = + case Map.lookup spn (amBefore am) of + Nothing -> ([], am) + Just cs -> (cs, am {amBefore = Map.delete spn (amBefore am)}) + +-- | Claim the comments that go after the element with the given span. +claimTrailing :: RealSrcSpan -> AnchorMap -> ([LComment], AnchorMap) +claimTrailing spn am = + case Map.lookup spn (amTrailing am) of + Nothing -> ([], am) + Just cs -> (cs, am {amTrailing = Map.delete spn (amTrailing am)}) + +-- | Claim everything that is left: the comments that belong to no element, +-- plus anything that was anchored to an element the printer never entered. +claimRemaining :: AnchorMap -> ([LComment], AnchorMap) +claimRemaining am = + ( pendingComments am, + AnchorMap {amBefore = Map.empty, amTrailing = Map.empty, amModule = []} + ) + +-- | The comments anchored to the element at the given span, or to any +-- element inside it. +-- +-- This is the question the layout decision needs to ask. "Which comments +-- are contained in this element" is a different and much coarser one: a +-- comment anywhere in a declaration is contained in it, but is attached to +-- one particular element, and only that element's layout should have to +-- account for it. This runs for every element the printer enters, so it +-- must not walk the whole map. Anchors are 'RealSrcSpan's ordered by start +-- position, and all of a module's spans share a file, so the anchors that +-- could be contained in the region are the contiguous run whose start lies +-- within it. Cutting the map down to that run first makes the cost +-- proportional to the size of the region rather than to the number of +-- comments in the module. +commentsAnchoredWithin :: RealSrcSpan -> AnchorMap -> [LComment] +commentsAnchoredWithin region AnchorMap {..} = + sortOn getLoc . concat $ + within amBefore <> within amTrailing + where + within = + Map.elems + . Map.filterWithKey (\anchor _ -> region `containsSpan` anchor) + . startingWithin + + -- Antitone in map order: as keys ascend their start position never + -- decreases, so each predicate holds on a prefix and then stops. + startingWithin = + fst + . Map.spanAntitone ((<= realSrcSpanEnd region) . realSrcSpanStart) + . snd + . Map.spanAntitone ((< realSrcSpanStart region) . realSrcSpanStart) + +-- | Every comment that has not been emitted yet, in source order. +pendingComments :: AnchorMap -> [LComment] +pendingComments AnchorMap {..} = + sortOn getLoc $ + amModule + <> concat (Map.elems amBefore) + <> concat (Map.elems amTrailing) diff --git a/src/Ormolu/Comments/Invariants.hs b/src/Ormolu/Comments/Invariants.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Comments/Invariants.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Properties that comment handling has to satisfy, and the check that +-- enforces them. +-- +-- Every comment of the input should come out exactly once, and in the order +-- it went in. The check runs on every run of Ormolu, alongside the check +-- that the AST is unchanged, and is disabled by the same @--unsafe@ flag. +-- +-- This is the half of comment checking that works on where the comments went +-- rather than on what they say. It compares the /spans/ of the comments a +-- module started with against the spans recorded as the printer emitted +-- them, so it can name the comment that was dropped, duplicated, invented +-- or moved. +-- +-- It does /not/ look at the text of a comment at all: rendering one with +-- its contents mangled would pass. That is the other half, and it belongs +-- to 'Ormolu.Diff.ParseResult.diffCommentStream', which compares text and +-- ignores position. Neither check subsumes the other and both run by +-- default. +-- +-- Haddocks are outside both halves. GHC's parser makes them part of the AST +-- rather than leaving them in the comment stream, so they are neither among +-- the comments a module started with nor in what the text check compares. +-- Losing or duplicating one changes the AST itself, and that is caught by +-- the third check, 'Ormolu.Diff.ParseResult.diffParseResult' comparing the +-- two syntax trees. +module Ormolu.Comments.Invariants + ( InvariantViolation (..), + checkCommentInvariants, + renderInvariantViolation, + ) +where + +import Data.List (sort) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Types.SrcLoc +import Ormolu.Printer.CommentPlacement + +-- | A way in which the emitted comments failed to correspond to the +-- comments of the input. +data InvariantViolation + = -- | A comment of the input was never emitted + CommentDropped RealSrcSpan + | -- | A comment was emitted more than once, the given number of times + CommentDuplicated RealSrcSpan Int + | -- | A comment was emitted that does not correspond to any comment of + -- the input + CommentInvented RealSrcSpan + | -- | A comment was emitted after one that comes later in the input. The + -- first span is the comment that was emitted too late, the second is + -- the one it should have preceded. + CommentReordered RealSrcSpan RealSrcSpan + deriving (Eq, Show) + +-- | Compare the comments of a snippet against the comments that were +-- emitted while rendering it. +checkCommentInvariants :: + -- | Spans of all the comments the snippet started with + [RealSrcSpan] -> + -- | Spans of the elements the formatter is allowed to reorder, so that + -- the comments travelling with them are exempt from the order check + [RealSrcSpan] -> + -- | Placements recorded while rendering it, in the order of emission + [CommentPlacement] -> + [InvariantViolation] +checkCommentInvariants inputSpans reorderable placements = + dropped <> duplicated <> invented <> reordered + where + emitted = cpSpan <$> placements + -- Pragmas and imports are deliberately sorted and the comments attached + -- to them travel along, so the order they come out in says nothing. + -- They are still expected to come out exactly once, which is what + -- catches a comment being duplicated. + ordered = + [ spn + | CommentPlacement {cpSpan = spn, cpSlot} <- placements, + cpSlot /= SlotPragma, + not (travelsWithAReorderedElement cpSlot) + ] + travelsWithAReorderedElement slot = case slotAnchor slot of + Nothing -> False + Just anchor -> any (`containsSpan` anchor) reorderable + inputSet = Map.fromList ((,()) <$> inputSpans) + counts = Map.fromListWith (+) ((,1 :: Int) <$> emitted) + + dropped = + [CommentDropped spn | spn <- sort inputSpans, not (spn `Map.member` counts)] + duplicated = + [ CommentDuplicated spn n + | (spn, n) <- Map.toAscList counts, + n > 1 + ] + invented = + [ CommentInvented spn + | spn <- Map.keys counts, + not (spn `Map.member` inputSet) + ] + + -- Only the first emission of each comment is considered, so that a + -- comment reported as duplicated is not also reported as reordered. + reordered = go [] (dedupe [] ordered) + where + dedupe _ [] = [] + dedupe seen (x : xs) + | x `elem` seen = dedupe seen xs + | otherwise = x : dedupe (x : seen) xs + go _ [] = [] + go seen (x : xs) = + [CommentReordered x y | y <- seen, x < y] + <> go (x : seen) xs + +-- | Render a violation as a single line. +renderInvariantViolation :: InvariantViolation -> Text +renderInvariantViolation = \case + CommentDropped spn -> + "dropped " <> renderSpan spn + CommentDuplicated spn n -> + "duplicated " <> renderSpan spn <> " (emitted " <> showT n <> " times)" + CommentInvented spn -> + "invented " <> renderSpan spn + CommentReordered spn before -> + "reordered " <> renderSpan spn <> " (emitted after " <> renderSpan before <> ")" + +renderSpan :: RealSrcSpan -> Text +renderSpan spn = + renderLoc (realSrcSpanStart spn) <> "-" <> renderLoc (realSrcSpanEnd spn) + where + renderLoc l = showT (srcLocLine l) <> ":" <> showT (srcLocCol l) + +showT :: (Show a) => a -> Text +showT = T.pack . show diff --git a/src/Ormolu/Comments/Tree.hs b/src/Ormolu/Comments/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Comments/Tree.hs @@ -0,0 +1,74 @@ +-- | The containment tree of AST element spans. +-- +-- This is the structure "Ormolu.Comments.Anchor" reads to place a comment: +-- given a comment, which element encloses it most tightly, and which of +-- that element's children does it fall between. Arranging the spans by +-- containment is what makes those questions answerable from position alone, +-- without reference to the order in which the printer visits anything. +module Ormolu.Comments.Tree + ( SpanTree (..), + mkSpanForest, + countNodes, + ) +where + +import Data.List (sortOn) +import Data.Ord (Down (..)) +import GHC.Types.SrcLoc + +-- | An element span together with the element spans it encloses. Children +-- are in ascending order and do not overlap each other. +data SpanTree = SpanTree + { stSpan :: RealSrcSpan, + stChildren :: [SpanTree] + } + deriving (Eq, Show) + +-- | Arrange spans into a forest by containment. +-- +-- Duplicates are dropped: several AST nodes routinely share one span (a +-- wrapper and the thing it wraps, say), and for the purpose of owning a +-- comment they are one element. Spans that overlap another without being +-- contained in it are dropped too—the GHC AST does produce such spans +-- occasionally, and they cannot be placed in a tree. +-- +-- Zero-width spans are kept. An empty bracketed construct—an export or +-- import list, @[]@, a record with no fields—contains no element at all, so +-- the printer enters a zero-width one at its opening bracket +-- ('Ormolu.Printer.Combinators.locatedEmpty') to give a comment written +-- between the brackets something to attach to. +mkSpanForest :: [RealSrcSpan] -> [SpanTree] +mkSpanForest = goForest . dedupe . sortOn nestingOrder + where + -- Outermost first, so that a span is always seen before the spans it + -- contains. + nestingOrder s = (realSrcSpanStart s, Down (realSrcSpanEnd s)) + + dedupe (x : y : rest) | x == y = dedupe (y : rest) + dedupe (x : rest) = x : dedupe rest + dedupe [] = [] + + goForest [] = [] + goForest (s : rest) = + let (children, rest') = goChildren s rest + in SpanTree s children : goForest rest' + + goChildren parent = go [] + where + go acc [] = (reverse acc, []) + go acc (s : rest) + | parent `containsSpan` s = + let (children, rest') = goChildren s rest + in go (SpanTree s children : acc) rest' + | realSrcSpanStart s < realSrcSpanEnd parent = + -- Overlaps the parent without being contained in it; there is + -- no correct place for it, so leave it out. + go acc rest + | otherwise = (reverse acc, s : rest) + +-- | How many elements the forest holds. Used by the tests to check that +-- duplicate and overlapping spans are dropped. +countNodes :: [SpanTree] -> Int +countNodes = sum . fmap node + where + node t = 1 + countNodes (stChildren t) diff --git a/src/Ormolu/Config.hs b/src/Ormolu/Config.hs --- a/src/Ormolu/Config.hs +++ b/src/Ormolu/Config.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -- | Configuration options used by the tool. @@ -7,32 +7,57 @@ ColorMode (..), RegionIndices (..), RegionDeltas (..), + SourceType (..), defaultConfig, + overapproximatedDependencies, regionIndicesToDeltas, DynOption (..), dynOptionToLocatedStr, ) where -import qualified GHC.Types.SrcLoc as GHC +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Distribution.Types.PackageName (PackageName) +import GHC.Generics (Generic) +import GHC.Types.SrcLoc qualified as GHC +import Ormolu.Fixity import Ormolu.Terminal (ColorMode (..)) +-- | Type of sources that can be formatted by Ormolu. +data SourceType + = -- | Consider the input as a regular Haskell module + ModuleSource + | -- | Consider the input as a Backpack module signature + SignatureSource + deriving (Eq, Show) + -- | Ormolu configuration. data Config region = Config { -- | Dynamic options to pass to GHC parser cfgDynOptions :: ![DynOption], + -- | Fixity overrides + cfgFixityOverrides :: !FixityOverrides, + -- | Module re-exports to take into account when performing fixity + -- resolution + cfgModuleReexports :: !ModuleReexports, + -- | Known dependencies, if any + cfgDependencies :: !(Set PackageName), -- | Do formatting faster but without automatic detection of defects cfgUnsafe :: !Bool, -- | Output information useful for debugging cfgDebug :: !Bool, - -- | Checks if re-formatting the result is idempotent + -- | Check that re-formatting the result is idempotent cfgCheckIdempotence :: !Bool, + -- | How to parse the input (a regular Haskell module or a Backpack file) + cfgSourceType :: !SourceType, -- | Whether to use colors and other features of ANSI terminals cfgColorMode :: !ColorMode, -- | Region selection cfgRegion :: !region } - deriving (Eq, Show, Functor) + deriving (Eq, Show, Functor, Generic) -- | Region selection as the combination of start and end line numbers. data RegionIndices = RegionIndices @@ -58,9 +83,13 @@ defaultConfig = Config { cfgDynOptions = [], + cfgFixityOverrides = defaultFixityOverrides, + cfgModuleReexports = defaultModuleReexports, + cfgDependencies = Set.empty, cfgUnsafe = False, cfgDebug = False, cfgCheckIdempotence = False, + cfgSourceType = ModuleSource, cfgColorMode = Auto, cfgRegion = RegionIndices @@ -68,6 +97,21 @@ regionEndLine = Nothing } } + +-- | Return all dependencies of the module. This includes both the declared +-- dependencies of the component we are working with and all potential +-- module re-export targets. +overapproximatedDependencies :: Config region -> Set PackageName +overapproximatedDependencies Config {..} = + Set.union cfgDependencies potentialReexportTargets + where + potentialReexportTargets = + Set.fromList + . concatMap toTargetPackages + $ Map.elems (unModuleReexports cfgModuleReexports) + toTargetPackages = concatMap $ \case + (Nothing, _) -> [] + (Just x, _) -> [x] -- | Convert 'RegionIndices' into 'RegionDeltas'. regionIndicesToDeltas :: 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 @@ -1,36 +1,41 @@ -{-# LANGUAGE BangPatterns #-} --- needed on GHC 9.0 due to simplified subsumption -{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeepSubsumption #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -- | This module allows us to diff two 'ParseResult's. module Ormolu.Diff.ParseResult ( ParseResultDiff (..), diffParseResult, + diffCommentStream, ) where import Data.ByteString (ByteString) +import Data.Char (isSpace) +import Data.Foldable +import Data.Function import Data.Generics +import Data.List (sort) +import Data.Text qualified as T +import GHC.Data.FastString (FastString) import GHC.Hs -import GHC.Types.Basic +import GHC.Types.SourceText import GHC.Types.SrcLoc -import Ormolu.Imports (normalizeImports) import Ormolu.Parser.CommentStream import Ormolu.Parser.Result import Ormolu.Utils +import Type.Reflection qualified as TR -- | Result of comparing two 'ParseResult's. data ParseResultDiff = -- | Two parse results are the same Same | -- | Two parse results differ - Different [SrcSpan] + Different [RealSrcSpan] + deriving (Show) instance Semigroup ParseResultDiff where Same <> a = a @@ -40,7 +45,12 @@ instance Monoid ParseResultDiff where mempty = Same --- | Return 'Diff' of two 'ParseResult's. +-- | Compare the parse result of the input against that of the output. +-- +-- Two of Ormolu's three comment checks live here: 'diffCommentStream' for +-- the text of the comments, and the syntax tree comparison for the +-- Haddocks, which are part of the tree rather than of the comment stream. +-- The third, "Ormolu.Comments.Invariants", checks where the comments went. diffParseResult :: ParseResult -> ParseResult -> @@ -54,96 +64,183 @@ { prCommentStream = cstream1, prParsedSource = hs1 } = - matchIgnoringSrcSpans cstream0 cstream1 - <> matchIgnoringSrcSpans - hs0 {hsmodImports = normalizeImports (hsmodImports hs0)} - hs1 {hsmodImports = normalizeImports (hsmodImports hs1)} + diffCommentStream cstream0 cstream1 + <> diffHsModule hs0 hs1 --- | Compare two values for equality disregarding the following aspects: +-- | Check that formatting did not change the /text/ of any comment. -- --- * 'SrcSpan's --- * ordering of import lists --- * style (ASCII vs Unicode) of arrows --- * LayoutInfo (brace style) in extension fields -matchIgnoringSrcSpans :: Data a => a -> a -> ParseResultDiff -matchIgnoringSrcSpans a = genericQuery a +-- This is the half of comment checking that works on what the comments say +-- rather than on where they went. Ormolu edits comment text on purpose—it +-- escapes Haddock triggers, re-indents block comments and normalizes the +-- spacing after a trigger—and both sides of this comparison have been +-- through 'Ormolu.Parser.CommentStream.mkCommentStream', so the intended +-- edits cancel out and only unintended ones show up. +-- +-- What it deliberately does /not/ check: +-- +-- * __order__, because Ormolu sorts imports, import lists and pragmas, +-- and a comment attached to one of those travels with it; +-- * __which comment is which__, since the lines are compared as a +-- multiset; a failure cannot say more than that the two sides differ, +-- which is why 'Different' is returned with no spans; +-- * __comments outside the stream__ — the Stack header and the comments +-- that travel with pragmas are lifted out of it during parsing, so +-- duplicating one of those is invisible here. +-- +-- All three are covered by "Ormolu.Comments.Invariants", which compares +-- spans instead of text. Neither check subsumes the other and both run by +-- default. +diffCommentStream :: CommentStream -> CommentStream -> ParseResultDiff +diffCommentStream (CommentStream cs) (CommentStream cs') + | commentLines cs == commentLines cs' = Same + | otherwise = Different [] where + commentLines = sort . concatMap (toList . unComment . unLoc) + +-- | Compare two modules for equality disregarding certain semantically +-- irrelevant features like exact print annotations. +diffHsModule :: HsModule GhcPs -> HsModule GhcPs -> ParseResultDiff +diffHsModule = genericQuery + where genericQuery :: GenericQ (GenericQ ParseResultDiff) genericQuery x y -- 'ByteString' implements 'Data' instance manually and does not -- implement 'toConstr', so we have to deal with it in a special way. | Just x' <- cast x, Just y' <- cast y = - if x' == (y' :: ByteString) - then Same - else Different [] + if x' == (y' :: ByteString) + then Same + else Different [] + | Just rep <- isEpTokenish x, + Just rep' <- isEpTokenish y = + -- Only check whether the Ep(Uni)Tokens are of the same type; don't + -- look at the actual payload (e.g. the location). + if rep == rep' then Same else Different [] | typeOf x == typeOf y, toConstr x == toConstr y = - mconcat $ - gzipWithQ - ( genericQuery - `extQ` srcSpanEq - `extQ` commentEq - `extQ` sourceTextEq - `extQ` hsDocStringEq - `extQ` importDeclQualifiedStyleEq - `extQ` unicodeArrowStyleEq - `extQ` layoutInfoEq - `ext2Q` forLocated - ) - x - y + mconcat $ + gzipWithQ + ( genericQuery + -- EPA-related + `extQ` considerEqual @SrcSpan + `ext1Q` epAnnEq + `extQ` considerEqual @SourceText + `extQ` considerEqual @EpAnnComments -- ~ XCGRHSs GhcPs + `extQ` considerEqual @EpaLocation + `extQ` considerEqual @(Maybe EpaLocation) + `extQ` considerEqual @EpLayout + `extQ` considerEqual @AnnSig + `extQ` considerEqual @HsRuleAnn + `extQ` considerEqual @EpLinear + `extQ` considerEqual @AnnSynDecl + -- FastString (for example for string literals) + `extQ` considerEqualVia' ((==) @FastString) + -- ModuleName is a newtype of FastString + `extQ` considerEqualVia' ((==) @ModuleName) + -- Haddock strings + `extQ` hsDocStringEq + -- Whether imports are pre- or post-qualified + `extQ` importDeclQualifiedStyleEq + -- Whether a class has an empty context + `extQ` classDeclCtxEq + -- Whether there are parens around a derived type class + `extQ` derivedTyClsParensEq + -- For better error messages + `ext2Q` forLocated + ) + x + y | otherwise = Different [] - srcSpanEq :: SrcSpan -> GenericQ ParseResultDiff - srcSpanEq _ _ = Same - commentEq :: Comment -> GenericQ ParseResultDiff - commentEq (Comment _ x) d = - case cast d :: Maybe Comment of - Nothing -> Different [] - Just (Comment _ y) -> - if x == y - then Same - else Different [] - sourceTextEq :: SourceText -> GenericQ ParseResultDiff - sourceTextEq _ _ = Same - importDeclQualifiedStyleEq :: - ImportDeclQualifiedStyle -> + + -- Return the 'TR.SomeTypeRep' of the type of the given value if it is an + -- 'EpToken', an 'EpUniToken', or a list of these. + isEpTokenish :: (Typeable a) => a -> Maybe TR.SomeTypeRep + isEpTokenish = fmap TR.SomeTypeRep . go . TR.typeOf + where + go :: TR.TypeRep a -> Maybe (TR.TypeRep a) + go rep = case rep of + TR.App t t' + | Just HRefl <- TR.eqTypeRep t (TR.typeRep @[]) -> + TR.App t <$> go t' + TR.App (TR.App t _) _ -> + rep <$ TR.eqTypeRep t (TR.typeRep @EpUniToken) + TR.App t _ -> + rep <$ TR.eqTypeRep t (TR.typeRep @EpToken) + _ -> Nothing + + considerEqualVia :: + forall a. + (Typeable a) => + (a -> a -> ParseResultDiff) -> + a -> GenericQ ParseResultDiff - importDeclQualifiedStyleEq d0 d1' = - case (d0, cast d1' :: Maybe ImportDeclQualifiedStyle) of - (x, Just x') | x == x' -> Same - (QualifiedPre, Just QualifiedPost) -> Same - (QualifiedPost, Just QualifiedPre) -> Same - _ -> Different [] + considerEqualVia f x (cast -> Just x') = f x x' + considerEqualVia _ _ _ = Different [] + + considerEqualVia' f = + considerEqualVia $ \x x' -> if f x x' then Same else Different [] + + considerEqual :: forall a. (Typeable a) => a -> GenericQ ParseResultDiff + considerEqual = considerEqualVia $ \_ _ -> Same + + epAnnEq :: EpAnn a -> b -> ParseResultDiff + epAnnEq _ _ = Same + + importDeclQualifiedStyleEq :: forall a. (Data a) => ImportDeclQualifiedStyle -> a -> ParseResultDiff + importDeclQualifiedStyleEq = considerEqualVia' f + where + f QualifiedPre QualifiedPost = True + f QualifiedPost QualifiedPre = True + f x x' = x == x' + + -- Documentation is compared up to the normalizations Ormolu performs + -- on it: the space it puts after a Haddock's trigger, the + -- re-indentation it gives a @{- | … -}@ so that the comment lines up + -- with the code it documents, and the collapsing of consecutive blank + -- lines. All three change the doc string GHC parses back out, and all + -- three are intended. hsDocStringEq :: HsDocString -> GenericQ ParseResultDiff - hsDocStringEq str0 str1' = - case cast str1' :: Maybe HsDocString of - Nothing -> Different [] - Just str1 -> - if splitDocString str0 == splitDocString str1 - then Same - else Different [] + hsDocStringEq = + considerEqualVia' ((==) `on` (collapseBlanks . dedent . splitDocString)) + where + -- The printer emits at most one blank line in a row, as it does for + -- ordinary comments. + collapseBlanks = \case + (x : y : rest) + | T.null x, T.null y -> collapseBlanks (y : rest) + (x : rest) -> x : collapseBlanks rest + [] -> [] + dedent = \case + [] -> [] + (x : xs) -> + let indentOf l = T.length (T.takeWhile (== ' ') l) + indents = indentOf <$> filter (not . T.all isSpace) xs + n = if null indents then 0 else minimum indents + in x : fmap (T.drop n) xs + forLocated :: (Data e0, Data e1) => GenLocated e0 e1 -> GenericQ ParseResultDiff forLocated x@(L mspn _) y = - maybe id appendSpan (cast mspn) (genericQuery x y) - appendSpan :: SrcSpan -> ParseResultDiff -> ParseResultDiff - appendSpan s (Different ss) | fresh && helpful = Different (s : ss) + maybe id appendSpan (cast `ext1Q` (Just . epAnnLoc) $ mspn) (genericQuery x y) where - fresh = not $ any (`isSubspanOf` s) ss - helpful = isGoodSrcSpan s + epAnnLoc :: EpAnn ann -> SrcSpan + epAnnLoc = locA + appendSpan :: SrcSpan -> ParseResultDiff -> ParseResultDiff + appendSpan s' d@(Different ss) = + case s' of + RealSrcSpan s _ -> + if not $ any (`isRealSubspanOf` s) ss + then Different (s : ss) + else d + UnhelpfulSpan _ -> d appendSpan _ d = d - -- as we normalize arrow styles (e.g. -> vs →), we consider them equal here - unicodeArrowStyleEq :: HsArrow GhcPs -> GenericQ ParseResultDiff - unicodeArrowStyleEq (HsUnrestrictedArrow _) (castArrow -> Just (HsUnrestrictedArrow _)) = Same - unicodeArrowStyleEq (HsLinearArrow _) (castArrow -> Just (HsLinearArrow _)) = Same - unicodeArrowStyleEq (HsExplicitMult _ t) (castArrow -> Just (HsExplicitMult _ t')) = genericQuery t t' - unicodeArrowStyleEq _ _ = Different [] - castArrow :: Typeable a => a -> Maybe (HsArrow GhcPs) - castArrow = cast - -- LayoutInfo ~ XClassDecl GhcPs tracks brace information - layoutInfoEq :: LayoutInfo -> GenericQ ParseResultDiff - layoutInfoEq _ (cast -> Just (_ :: LayoutInfo)) = Same - layoutInfoEq _ _ = Different [] + + classDeclCtxEq :: TyClDecl GhcPs -> GenericQ ParseResultDiff + classDeclCtxEq ClassDecl {tcdCtxt = Just (L _ []), ..} tc' = genericQuery ClassDecl {tcdCtxt = Nothing, ..} tc' + classDeclCtxEq tc tc' = genericQuery tc tc' + + derivedTyClsParensEq :: DerivClauseTys GhcPs -> GenericQ ParseResultDiff + derivedTyClsParensEq (DctSingle NoExtField sigTy) dct' = genericQuery (DctMulti NoExtField [sigTy]) dct' + derivedTyClsParensEq dct dct' = genericQuery dct dct' diff --git a/src/Ormolu/Diff/Text.hs b/src/Ormolu/Diff/Text.hs --- a/src/Ormolu/Diff/Text.hs +++ b/src/Ormolu/Diff/Text.hs @@ -1,33 +1,44 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE QualifiedDo #-} {-# LANGUAGE RecordWildCards #-} -- | This module allows us to diff two 'Text' values. module Ormolu.Diff.Text ( TextDiff, diffText, + selectSpans, printTextDiff, ) where -import Control.Monad -import qualified Data.Algorithm.Diff as D +import Control.Monad (unless, when) +import Data.Algorithm.Diff qualified as D +import Data.Foldable (for_) +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet import Data.Maybe (listToMaybe) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T +import GHC.Types.SrcLoc import Ormolu.Terminal +import Ormolu.Terminal.QualifiedDo qualified as Term ---------------------------------------------------------------------------- -- Types -- | Result of diffing two 'Text's. -data TextDiff = TextDiff FilePath DiffList - deriving (Eq) - -instance Show TextDiff where - show (TextDiff path _) = "TextDiff " ++ show path ++ " _" +data TextDiff = TextDiff + { -- | Path to the file that is being diffed + textDiffPath :: FilePath, + -- | The list of differences + textDiffDiffList :: DiffList, + -- | Selected lines. Only hunks that contain selected lines will be + -- displayed, unless 'textDiffSelectedLines' is empty, in which case the + -- whole diff will be displayed. + textDiffSelectedLines :: IntSet + } + deriving (Eq, Show) -- | List of lines tagged by 'D.Both', 'D.First', or 'D.Second'. type DiffList = [D.Diff [Text]] @@ -43,6 +54,7 @@ hunkSecondLength :: Int, hunkDiff :: DiffList } + deriving (Show) ---------------------------------------------------------------------------- -- API @@ -60,7 +72,13 @@ diffText a b path = if all isBoth xs then Nothing - else Just (TextDiff path xs) + else + Just + TextDiff + { textDiffPath = path, + textDiffDiffList = xs, + textDiffSelectedLines = IntSet.empty + } where xs = D.getGroupedDiff (lines' a) (lines' b) isBoth = \case @@ -70,45 +88,59 @@ -- T.lines ignores trailing blank lines lines' = T.splitOn "\n" +-- | Select certain spans in the diff (line numbers are interpreted as +-- belonging to the “before” state). Only selected spans will be printed. +selectSpans :: [RealSrcSpan] -> TextDiff -> TextDiff +selectSpans ss textDiff = textDiff {textDiffSelectedLines = xs} + where + xs = foldl' addOneSpan (textDiffSelectedLines textDiff) ss + addOneSpan linesSoFar s = + let start = srcSpanStartLine s + end = srcSpanEndLine s + in IntSet.union + linesSoFar + (IntSet.fromAscList [start .. end]) + -- | Print the given 'TextDiff' as a 'Term' action. This function tries to -- mimic the style of @git diff@. -printTextDiff :: TextDiff -> Term () -printTextDiff (TextDiff path xs) = do - (bold . putS) path +printTextDiff :: TextDiff -> Term +printTextDiff TextDiff {..} = Term.do + (bold . put . T.pack) textDiffPath newline - forM_ (toHunks (assignLines xs)) $ \Hunk {..} -> do - cyan $ do - put "@@ -" - putS (show hunkFirstStartLine) - put "," - putS (show hunkFirstLength) - put " +" - putS (show hunkSecondStartLine) - put "," - putS (show hunkSecondLength) - put " @@" - newline - forM_ hunkDiff $ \case - D.Both ys _ -> - forM_ ys $ \y -> do - unless (T.null y) $ - put " " - put y - newline - D.First ys -> - forM_ ys $ \y -> red $ do - put "-" - unless (T.null y) $ - put " " - put y - newline - D.Second ys -> - forM_ ys $ \y -> green $ do - put "+" - unless (T.null y) $ - put " " - put y - newline + for_ (toHunks (assignLines textDiffDiffList)) $ \hunk@Hunk {..} -> + when (isSelectedLine textDiffSelectedLines hunk) $ Term.do + cyan $ Term.do + put "@@ -" + putShow hunkFirstStartLine + put "," + putShow hunkFirstLength + put " +" + putShow hunkSecondStartLine + put "," + putShow hunkSecondLength + put " @@" + newline + for_ hunkDiff $ \case + D.Both ys _ -> + for_ ys $ \y -> Term.do + unless (T.null y) $ + put " " + put y + newline + D.First ys -> + for_ ys $ \y -> red $ Term.do + put "-" + unless (T.null y) $ + put " " + put y + newline + D.Second ys -> + for_ ys $ \y -> green $ Term.do + put "+" + unless (T.null y) $ + put " " + put y + newline ---------------------------------------------------------------------------- -- Helpers @@ -124,41 +156,38 @@ let firstInc = length a secondInc = length b a' = - zipWith3 - (,,) + zip3 (iterate (+ 1) firstLine) (iterate (+ 1) secondLine) a in go (firstLine + firstInc) (secondLine + secondInc) - (acc . ((D.Both a' a') :)) + (acc . (D.Both a' a' :)) xs D.First a -> let firstInc = length a a' = - zipWith3 - (,,) + zip3 (iterate (+ 1) firstLine) (repeat secondLine) a in go (firstLine + firstInc) secondLine - (acc . ((D.First a') :)) + (acc . (D.First a' :)) xs D.Second b -> let secondInc = length b b' = - zipWith3 - (,,) + zip3 (repeat firstLine) (iterate (+ 1) secondLine) b in go firstLine (secondLine + secondInc) - (acc . ((D.Second b') :)) + (acc . (D.Second b' :)) xs -- | Form 'Hunk's from a 'DiffList''. @@ -180,8 +209,8 @@ [] -> if gotChanges then - let p = reverse (take margin bothHistory) - currentAcc' = addBothAfter p currentAcc + let currentAcc' = addBothAfter p currentAcc + p = take margin (reverse bothHistory) in case formHunk (currentAcc' []) of Nothing -> hunksAcc [] Just hunk -> hunksAcc [hunk] @@ -204,12 +233,12 @@ piece -> if gotChanges then - let p = reverse bothHistory - currentAcc' = currentAcc . addBothBefore p (piece :) + let currentAcc' = currentAcc . addBothBefore p (piece :) + p = reverse bothHistory in go 0 True hunksAcc currentAcc' [] xs else - let p = reverse (take margin bothHistory) - currentAcc' = addBothBefore p (piece :) + let currentAcc' = addBothBefore p (piece :) + p = reverse (take margin bothHistory) in go 0 True hunksAcc currentAcc' [] xs addBothBefore [] acc = acc addBothBefore p acc = (D.Both p p :) . acc @@ -227,7 +256,7 @@ hunkDiff = mapDiff (fmap third) xs return Hunk {..} --- | Trim empty “both” lines from beginning and end of a 'DiffList''. +-- | Trim empty “both” lines from the beginning and end of a 'DiffList''. trimEmpty :: DiffList' -> DiffList' trimEmpty = go True id where @@ -284,3 +313,12 @@ third :: (Int, Int, Text) -> Text third (_, _, x) = x + +isSelectedLine :: IntSet -> Hunk -> Bool +isSelectedLine selected Hunk {..} = + -- If the set of selected lines is empty, everything is selected. + IntSet.null selected + || not (IntSet.disjoint selected hunkOriginalLines) + where + hunkOriginalLines = + IntSet.fromAscList (take hunkFirstLength [hunkFirstStartLine ..]) diff --git a/src/Ormolu/Exception.hs b/src/Ormolu/Exception.hs --- a/src/Ormolu/Exception.hs +++ b/src/Ormolu/Exception.hs @@ -1,24 +1,31 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE QualifiedDo #-} -- | 'OrmoluException' type and surrounding definitions. module Ormolu.Exception ( OrmoluException (..), + printOrmoluException, withPrettyOrmoluExceptions, ) where import Control.Exception -import Control.Monad (forM_) +import Data.Foldable (for_) import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T +import Data.List.NonEmpty qualified as NE +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void (Void) +import Distribution.Parsec.Error (PError, showPError) import GHC.Types.SrcLoc +import Ormolu.Comments.Invariants (InvariantViolation, renderInvariantViolation) import Ormolu.Diff.Text (TextDiff, printTextDiff) import Ormolu.Terminal +import Ormolu.Terminal.QualifiedDo qualified as Term import System.Exit (ExitCode (..)) import System.IO +import Text.Megaparsec (ParseErrorBundle, errorBundlePretty) -- | Ormolu exception representing all cases when Ormolu can fail. data OrmoluException @@ -27,61 +34,105 @@ | -- | Parsing of formatted source code failed OrmoluOutputParsingFailed SrcSpan String | -- | Original and resulting ASTs differ - OrmoluASTDiffers FilePath [SrcSpan] + OrmoluASTDiffers TextDiff [RealSrcSpan] | -- | Formatted source code is not idempotent OrmoluNonIdempotentOutput TextDiff + | -- | The comments that came out do not correspond to the comments that + -- went in + OrmoluCommentInvariantsViolated FilePath [InvariantViolation] | -- | Some GHC options were not recognized OrmoluUnrecognizedOpts (NonEmpty String) - deriving (Eq, Show) + | -- | Cabal file parsing failed + OrmoluCabalFileParsingFailed FilePath (NonEmpty PError) + | -- | Missing input file path when using stdin input and + -- accounting for .cabal files + OrmoluMissingStdinInputFile + | -- | A parse error in a fixity overrides file + OrmoluFixityOverridesParseError (ParseErrorBundle Text Void) + deriving (Show) -instance Exception OrmoluException +instance Exception OrmoluException where + displayException = T.unpack . runTermPure . printOrmoluException -- | Print an 'OrmoluException'. printOrmoluException :: OrmoluException -> - Term () + Term printOrmoluException = \case - OrmoluParsingFailed s e -> do - bold (putSrcSpan s) + OrmoluParsingFailed s e -> Term.do + bold (putOutputable s) newline put " The GHC parser (in Haddock mode) failed:" newline put " " put (T.pack e) newline - OrmoluOutputParsingFailed s e -> do - bold (putSrcSpan s) + OrmoluOutputParsingFailed s e -> Term.do + bold (putOutputable s) newline put " Parsing of formatted code failed:" + newline put " " put (T.pack e) newline - OrmoluASTDiffers path ss -> do - putS path + OrmoluASTDiffers diff ss -> Term.do + printTextDiff diff newline put " AST of input and AST of formatted code differ." newline - forM_ ss $ \s -> do + for_ ss $ \s -> Term.do put " at " - putSrcSpan s + putOutputable s newline put " Please, consider reporting the bug." newline - OrmoluNonIdempotentOutput diff -> do + put " To format anyway, use --unsafe." + newline + OrmoluNonIdempotentOutput diff -> Term.do printTextDiff diff newline put " Formatting is not idempotent." newline put " Please, consider reporting the bug." newline - OrmoluUnrecognizedOpts opts -> do + OrmoluCommentInvariantsViolated path violations -> Term.do + put (T.pack path) + newline + for_ violations $ \violation -> Term.do + put " " + put (renderInvariantViolation violation) + newline + newline + put " The comments of the output do not correspond to the comments of" + newline + put " the input." + newline + put " Please, consider reporting the bug." + newline + put " To format anyway, use --unsafe." + newline + OrmoluUnrecognizedOpts opts -> Term.do put "The following GHC options were not recognized:" newline put " " - (putS . unwords . NE.toList) opts + (put . T.unwords . map T.pack . NE.toList) opts newline + OrmoluCabalFileParsingFailed cabalFile parseErrors -> Term.do + put "Parsing this .cabal file failed:" + newline + for_ parseErrors $ \e -> Term.do + put . T.pack $ " " <> showPError cabalFile e + newline + OrmoluMissingStdinInputFile -> Term.do + put "The --stdin-input-file option is necessary when using input" + newline + put "from stdin and accounting for .cabal files." + newline + OrmoluFixityOverridesParseError errorBundle -> Term.do + put . T.pack . errorBundlePretty $ errorBundle + newline --- | Inside this wrapper 'OrmoluException' will be caught and displayed +-- | Inside this wrapper, 'OrmoluException' will be caught and displayed -- nicely. withPrettyOrmoluExceptions :: -- | Color mode @@ -95,10 +146,14 @@ runTerm (printOrmoluException e) colorMode stderr return . ExitFailure $ case e of - -- Error code 1 is for 'error' or 'notImplemented' - -- 2 used to be for erroring out on CPP + -- Error code 1 is for 'error' or 'notImplemented'. + -- 2 used to be for erroring out on CPP. OrmoluParsingFailed {} -> 3 OrmoluOutputParsingFailed {} -> 4 OrmoluASTDiffers {} -> 5 OrmoluNonIdempotentOutput {} -> 6 + OrmoluCommentInvariantsViolated {} -> 11 OrmoluUnrecognizedOpts {} -> 7 + OrmoluCabalFileParsingFailed {} -> 8 + OrmoluMissingStdinInputFile {} -> 9 + OrmoluFixityOverridesParseError {} -> 10 diff --git a/src/Ormolu/Fixity.hs b/src/Ormolu/Fixity.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Fixity.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Definitions for fixity analysis. +module Ormolu.Fixity + ( OpName, + pattern OpName, + unOpName, + occOpName, + FixityDirection (..), + FixityInfo (..), + defaultFixityInfo, + FixityApproximation (..), + defaultFixityApproximation, + FixityOverrides (..), + defaultFixityOverrides, + ModuleReexports (..), + defaultModuleReexports, + PackageFixityMap (..), + ModuleFixityMap (..), + inferFixity, + HackageInfo (..), + hackageInfo, + defaultDependencies, + packageFixityMap, + packageFixityMap', + moduleFixityMap, + applyFixityOverrides, + ) +where + +import Data.Binary qualified as Binary +import Data.Binary.Get qualified as Binary +import Data.ByteString.Lazy qualified as BL +import Data.FileEmbed (embedFile) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Data.MemoTrie (memo) +import Data.Set (Set) +import Data.Set qualified as Set +import Distribution.ModuleName (ModuleName) +import Distribution.Types.PackageName (PackageName, mkPackageName, unPackageName) +import Language.Haskell.Syntax.ImpExp (ImportListInterpretation (..)) +import Ormolu.Fixity.Imports (FixityImport (..)) +import Ormolu.Fixity.Internal + +-- | The built-in 'HackageInfo' used by Ormolu. +hackageInfo :: HackageInfo +hackageInfo = + Binary.runGet Binary.get $ + BL.fromStrict $(embedFile "extract-hackage-info/hackage-info.bin") + +-- | Default set of packages to assume as dependencies, e.g. when no Cabal +-- file is found or taken into consideration. +defaultDependencies :: Set PackageName +defaultDependencies = Set.singleton (mkPackageName "base") + +-- | Compute the fixity map that is specific to the package we are formatting. +packageFixityMap :: + -- | Set of packages to select + Set PackageName -> + -- | Package fixity map + PackageFixityMap +packageFixityMap = packageFixityMap' hackageInfo + +-- | The same as 'packageFixityMap', except this specific version of the +-- function allows the user to specify 'HackageInfo' used to build the final +-- fixity map. +packageFixityMap' :: + -- | Hackage info + HackageInfo -> + -- | Set of packages to select + Set PackageName -> + -- | Package fixity map + PackageFixityMap +packageFixityMap' (HackageInfo m) = memoSet $ \dependencies -> + -- The core idea here is to transform: + -- + -- Map PackageName (Map ModuleName (Map OpName FixityInfo)) + -- + -- into + -- + -- Map OpName [(PackageName, ModuleName, FixityInfo)] + -- + -- which we accomplish by turning 'Map's into tuples with 'Map.toList' and + -- then flattening them with 'flatten :: [(a, [b])] -> [(a, b)]'. + -- + -- The target type results from the need to be able to quickly index by + -- the operator name when we do fixity resolution later. + PackageFixityMap + . Map.mapMaybe NE.nonEmpty + . Map.fromListWith (<>) + . fmap rearrange + . flatten + . Map.toList + . Map.map (flatten . Map.toList . Map.map Map.toList) + $ Map.restrictKeys m dependencies + where + rearrange (packageName, (moduleName, (opName, fixityInfo))) = + (opName, [(packageName, moduleName, fixityInfo)]) + flatten xs = do + (k, vs) <- xs + v <- vs + return (k, v) + +-- | Compute the fixity map that is specific to the module we are formatting. +moduleFixityMap :: + -- | Fixity information selected from dependencies of this package + PackageFixityMap -> + -- | A simplified representation of the import list in this module + [FixityImport] -> + -- | Fixity map specific to this module + ModuleFixityMap +moduleFixityMap (PackageFixityMap m) imports = + ModuleFixityMap $ + Map.insert + ":" + (Given colonFixityInfo) + (Map.map FromModuleImports (Map.mapMaybeWithKey select m)) + where + select :: + OpName -> + NonEmpty (PackageName, ModuleName, FixityInfo) -> + Maybe (NonEmpty (FixityQualification, FixityInfo)) + select opName = + let f (packageName, moduleName, fixityInfo) = + (,fixityInfo) + <$> resolveThroughImports packageName moduleName opName + in NE.nonEmpty . concatMap f + resolveThroughImports :: + PackageName -> + ModuleName -> + OpName -> + [FixityQualification] + resolveThroughImports packageName moduleName opName = + let doesImportMatch FixityImport {..} = + let packageMatches = + case fimportPackage of + Nothing -> True + Just p -> p == packageName + moduleMatches = + fimportModule == moduleName + opMatches = case fimportList of + Nothing -> True + Just (Exactly, xs) -> opName `elem` xs + Just (EverythingBut, xs) -> opName `notElem` xs + in packageMatches && moduleMatches && opMatches + in fimportQualified <$> filter doesImportMatch imports + +-- | Apply fixity overrides. +applyFixityOverrides :: + -- | User overrides + FixityOverrides -> + -- | Module fixity map + ModuleFixityMap -> + -- | Module fixity map with overrides applied + ModuleFixityMap +applyFixityOverrides (FixityOverrides o) (ModuleFixityMap m) = + ModuleFixityMap (Map.union (Map.map Given o) m) + +memoSet :: (Set PackageName -> v) -> Set PackageName -> v +memoSet f = + memo (f . Set.fromAscList . fmap mkPackageName) + . fmap unPackageName + . Set.toAscList diff --git a/src/Ormolu/Fixity/Imports.hs b/src/Ormolu/Fixity/Imports.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Fixity/Imports.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Simplified representation of the import list for the purposes of fixity +-- inference. +module Ormolu.Fixity.Imports + ( FixityImport (..), + extractFixityImports, + applyModuleReexports, + ) +where + +import Data.Bifunctor (second) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Distribution.ModuleName (ModuleName) +import Distribution.Types.PackageName +import GHC.Data.FastString qualified as GHC +import GHC.Hs hiding (ModuleName, OpName) +import GHC.Types.Name.Occurrence +import GHC.Types.PkgQual (RawPkgQual (..)) +import GHC.Types.SourceText (StringLiteral (..)) +import GHC.Types.SrcLoc +import Ormolu.Fixity.Internal +import Ormolu.Utils (ghcModuleNameToCabal) + +-- | Simplified info about an import. +data FixityImport = FixityImport + { fimportPackage :: !(Maybe PackageName), + fimportModule :: !ModuleName, + fimportQualified :: !FixityQualification, + fimportList :: !(Maybe (ImportListInterpretation, [OpName])) + } + +-- | Extract 'FixityImport's from the AST. +extractFixityImports :: + [LImportDecl GhcPs] -> + [FixityImport] +extractFixityImports = fmap (extractFixityImport . unLoc) + +-- | Extract an individual 'FixityImport'. +extractFixityImport :: ImportDecl GhcPs -> FixityImport +extractFixityImport ImportDecl {..} = + FixityImport + { fimportPackage = case ideclPkgQual of + NoRawPkgQual -> Nothing + RawPkgQual strLiteral -> + Just . mkPackageName . GHC.unpackFS . sl_fs $ strLiteral, + fimportModule = ideclName', + fimportQualified = case (ideclQualified, ideclAs') of + (QualifiedPre, Nothing) -> + OnlyQualified ideclName' + (QualifiedPost, Nothing) -> + OnlyQualified ideclName' + (QualifiedPre, Just m) -> OnlyQualified m + (QualifiedPost, Just m) -> OnlyQualified m + (NotQualified, Nothing) -> + UnqualifiedAndQualified ideclName' + (NotQualified, Just m) -> + UnqualifiedAndQualified m, + fimportList = + fmap + (second (concatMap (fmap occOpName . ieToOccNames . unLoc) . unLoc)) + ideclImportList + } + where + ideclName' = ghcModuleNameToCabal (unLoc ideclName) + ideclAs' = ghcModuleNameToCabal . unLoc <$> ideclAs + +ieToOccNames :: IE GhcPs -> [OccName] +ieToOccNames = \case + IEVar _ (L _ x) _ -> [occName x] + IEThingAbs _ (L _ x) _ -> [occName x] + IEThingAll _ (L _ x) _ -> [occName x] -- TODO not quite correct, but how to do better? + IEThingWith _ (L _ x) _ xs _ -> occName x : fmap (occName . unLoc) xs + _ -> [] + +-- | Apply the given module re-exports. +applyModuleReexports :: ModuleReexports -> [FixityImport] -> [FixityImport] +applyModuleReexports (ModuleReexports reexports) imports = imports >>= expand + where + expand i = do + case Map.lookup (fimportModule i) reexports of + Nothing -> pure i + Just exports -> + let exportToImport (mpackageName, mmodule) = + i + { fimportPackage = mpackageName, + fimportModule = mmodule + } + in NE.toList exports >>= expand . exportToImport diff --git a/src/Ormolu/Fixity/Internal.hs b/src/Ormolu/Fixity/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Fixity/Internal.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Ormolu.Fixity.Internal + ( OpName, + pattern OpName, + unOpName, + occOpName, + FixityDirection (..), + FixityInfo (..), + colonFixityInfo, + defaultFixityInfo, + FixityApproximation (..), + defaultFixityApproximation, + HackageInfo (..), + FixityOverrides (..), + defaultFixityOverrides, + ModuleReexports (..), + defaultModuleReexports, + PackageFixityMap (..), + ModuleFixityMap (..), + FixityProvenance (..), + FixityQualification (..), + inferFixity, + ) +where + +import Data.Binary (Binary) +import Data.Binary qualified as Binary +import Data.Binary.Get qualified as Binary +import Data.Binary.Put qualified as Binary +import Data.ByteString.Short (ShortByteString) +import Data.ByteString.Short qualified as SBS +import Data.Choice (Choice) +import Data.Choice qualified as Choice +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Debug.Trace (trace) +import Distribution.ModuleName (ModuleName) +import Distribution.Types.PackageName +import GHC.Data.FastString (fs_sbs) +import GHC.Generics (Generic) +import GHC.Types.Name (OccName (occNameFS)) +import GHC.Types.Name.Reader (RdrName (..), rdrNameOcc) +import Ormolu.Utils (ghcModuleNameToCabal) + +-- | An operator name. +newtype OpName = MkOpName + { -- | Invariant: UTF-8 encoded + getOpName :: ShortByteString + } + deriving newtype (Eq, Ord, Binary) + +-- | Convert an 'OpName' to 'Text'. +unOpName :: OpName -> Text +unOpName = T.decodeUtf8 . SBS.fromShort . getOpName + +pattern OpName :: Text -> OpName +pattern OpName opName <- (unOpName -> opName) + where + OpName = MkOpName . SBS.toShort . T.encodeUtf8 + +{-# COMPLETE OpName #-} + +-- | Convert an 'OccName' to an 'OpName'. +occOpName :: OccName -> OpName +occOpName = MkOpName . fs_sbs . occNameFS + +instance Show OpName where + show = T.unpack . unOpName + +instance IsString OpName where + fromString = OpName . T.pack + +-- | Fixity direction. +data FixityDirection + = InfixL + | InfixR + | InfixN + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (Binary) + +-- | Fixity information about an infix operator. This type provides precise +-- information as opposed to 'FixityApproximation'. +data FixityInfo = FixityInfo + { -- | Fixity direction + fiDirection :: FixityDirection, + -- | Precedence + fiPrecedence :: Double + } + deriving stock (Eq, Ord, Show, Generic) + +instance Binary FixityInfo where + put FixityInfo {..} = do + Binary.put fiDirection + Binary.putDoublele fiPrecedence + + get = do + fiDirection <- Binary.get + fiPrecedence <- Binary.getDoublele + pure FixityInfo {..} + +-- | Fixity info of the built-in colon data constructor. +colonFixityInfo :: FixityInfo +colonFixityInfo = FixityInfo InfixR 5 + +-- | Fixity that is implicitly assumed if no fixity declaration is present. +defaultFixityInfo :: FixityInfo +defaultFixityInfo = FixityInfo InfixL 9 + +-- | Approximation of fixity information that takes the uncertainty that can +-- arise from conflicting definitions into account. +data FixityApproximation = FixityApproximation + { -- | Fixity direction if it is known + faDirection :: Maybe FixityDirection, + -- | Minimum precedence level found in the (possibly conflicting) + -- definitions for the operator (inclusive) + faMinPrecedence :: Double, + -- | Maximum precedence level found in the (possibly conflicting) + -- definitions for the operator (inclusive) + faMaxPrecedence :: Double + } + deriving stock (Eq, Ord, Show, Generic) + +instance Binary FixityApproximation where + put FixityApproximation {..} = do + Binary.put faDirection + Binary.putDoublele faMinPrecedence + Binary.putDoublele faMaxPrecedence + + get = do + faDirection <- Binary.get + faMinPrecedence <- Binary.getDoublele + faMaxPrecedence <- Binary.getDoublele + pure FixityApproximation {..} + +-- | Gives the ability to merge two (possibly conflicting) definitions for +-- an operator, keeping the higher level of compatible information from both. +instance Semigroup FixityApproximation where + FixityApproximation {faDirection = dir1, faMinPrecedence = min1, faMaxPrecedence = max1} + <> FixityApproximation {faDirection = dir2, faMinPrecedence = min2, faMaxPrecedence = max2} = + FixityApproximation + { faDirection = dir', + faMinPrecedence = min min1 min2, + faMaxPrecedence = max max1 max2 + } + where + dir' = case (dir1, dir2) of + (Just a, Just b) | a == b -> Just a + _ -> Nothing + +-- | The lowest level of information we can have about an operator. +defaultFixityApproximation :: FixityApproximation +defaultFixityApproximation = fixityInfoToApproximation defaultFixityInfo + +-- | Convert from 'FixityInfo' to 'FixityApproximation'. +fixityInfoToApproximation :: FixityInfo -> FixityApproximation +fixityInfoToApproximation FixityInfo {..} = + FixityApproximation + { faDirection = Just fiDirection, + faMinPrecedence = fiPrecedence, + faMaxPrecedence = fiPrecedence + } + +-- | The map of operators declared by each package grouped by module name. +newtype HackageInfo + = HackageInfo (Map PackageName (Map ModuleName (Map OpName FixityInfo))) + deriving stock (Generic) + deriving anyclass (Binary) + +-- | Map from the operator name to its 'FixityInfo'. +newtype FixityOverrides = FixityOverrides + { unFixityOverrides :: Map OpName FixityInfo + } + deriving stock (Eq, Show) + +-- | Fixity overrides to use by default. +defaultFixityOverrides :: FixityOverrides +defaultFixityOverrides = FixityOverrides Map.empty + +-- | Module re-exports. +newtype ModuleReexports = ModuleReexports + { unModuleReexports :: Map ModuleName (NonEmpty (Maybe PackageName, ModuleName)) + } + deriving stock (Eq, Show) + +-- | Module re-exports to apply by default. +defaultModuleReexports :: ModuleReexports +defaultModuleReexports = ModuleReexports Map.empty + +-- | Fixity information that is specific to a package being formatted. It +-- requires module-specific imports in order to be usable. +newtype PackageFixityMap + = PackageFixityMap (Map OpName (NonEmpty (PackageName, ModuleName, FixityInfo))) + deriving stock (Eq, Show) + +-- | Fixity map that takes into account imports in a particular module. +newtype ModuleFixityMap + = ModuleFixityMap (Map OpName FixityProvenance) + deriving stock (Eq, Show) + +-- | Provenance of fixity info. +data FixityProvenance + = -- | 'FixityInfo' of a built-in operator or provided by a user override. + Given FixityInfo + | -- | 'FixityInfo' to be inferred from module imports. + FromModuleImports (NonEmpty (FixityQualification, FixityInfo)) + deriving stock (Eq, Show) + +-- | Fixity qualification that determines how 'FixityInfo' matches a +-- particular use of an operator, given whether it is qualified or +-- unqualified and the module name used. +data FixityQualification + = UnqualifiedAndQualified ModuleName + | OnlyQualified ModuleName + deriving stock (Eq, Show) + +-- | Get a 'FixityApproximation' of an operator. +inferFixity :: + -- | Whether to print debug info regarding fixity inference + Choice "debug" -> + -- | Operator name + RdrName -> + -- | Module fixity map + ModuleFixityMap -> + -- | The resulting fixity approximation + FixityApproximation +inferFixity debug rdrName (ModuleFixityMap m) = + if Choice.isTrue debug + then + trace + (renderFixityJustification opName moduleName m result) + result + else result + where + result = + case Map.lookup opName m of + Nothing -> defaultFixityApproximation + Just (Given fixityInfo) -> + fixityInfoToApproximation fixityInfo + Just (FromModuleImports xs) -> + let isMatching (provenance, _fixityInfo) = + case provenance of + UnqualifiedAndQualified mn -> + maybe True (== mn) moduleName + OnlyQualified mn -> + maybe False (== mn) moduleName + in fromMaybe defaultFixityApproximation + . foldMap (Just . fixityInfoToApproximation . snd) + $ NE.filter isMatching xs + opName = occOpName (rdrNameOcc rdrName) + moduleName = case rdrName of + Qual x _ -> Just (ghcModuleNameToCabal x) + _ -> Nothing + +-- | Render a human-readable account of why a certain 'FixityApproximation' +-- was chosen for an operator. +renderFixityJustification :: + -- | Operator name + OpName -> + -- | Qualification of the operator name + Maybe ModuleName -> + -- | Module fixity map + Map OpName FixityProvenance -> + -- | The chosen fixity approximation + FixityApproximation -> + String +renderFixityJustification opName mqualification m approximation = + concat + [ "FIXITY analysis of ", + show opName, + case mqualification of + Nothing -> "" + Just mn -> " qualified in " ++ show mn, + "\n Provenance: " ++ show (Map.lookup opName m), + "\n Inferred: " ++ show approximation + ] diff --git a/src/Ormolu/Fixity/Parser.hs b/src/Ormolu/Fixity/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Fixity/Parser.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Parser for fixity maps. +module Ormolu.Fixity.Parser + ( parseDotOrmolu, + parseFixityDeclaration, + parseModuleReexportDeclaration, + + -- * Raw parsers + pFixity, + pOperator, + pModuleName, + pPackageName, + + -- * Internal + isIdentifierFirstChar, + isIdentifierConstituent, + isOperatorConstituent, + isPackageNameConstituent, + isModuleSegmentFirstChar, + isModuleSegmentConstituent, + ) +where + +import Control.Monad (void, when) +import Data.Bifunctor (bimap) +import Data.Char (isAlphaNum, isUpper) +import Data.Char qualified as Char +import Data.Either (partitionEithers) +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void (Void) +import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName qualified as ModuleName +import Distribution.Types.PackageName (PackageName, mkPackageName) +import Ormolu.Fixity +import Text.Megaparsec +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as L + +type Parser = Parsec Void Text + +-- TODO Support fixity namespacing? +-- https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0065-type-infix.rst +-- +-- Note that currently, our fixity machinery does *not* do any namespacing: +-- +-- - https://github.com/tweag/ormolu/pull/994#pullrequestreview-1396958951 +-- brought this up in the past +-- +-- - https://github.com/tweag/ormolu/pull/1029#issue-1718217029 +-- has a concrete example (morley-prelude) where namespacing would matter + +-- | Parse textual representation of 'FixityOverrides'. +parseDotOrmolu :: + -- | Location of the file we are parsing (only for parse errors) + FilePath -> + -- | File contents to parse + Text -> + -- | Parse result + Either (ParseErrorBundle Text Void) (FixityOverrides, ModuleReexports) +parseDotOrmolu = runParser pDotOrmolu + +-- | Parse a single self-contained fixity declaration. +parseFixityDeclaration :: + -- | Text to parse + Text -> + -- | Parse result + Either (ParseErrorBundle Text Void) [(OpName, FixityInfo)] +parseFixityDeclaration = runParser (pFixity <* eof) "" + +-- | Parse a single self-contained module re-export declaration. +parseModuleReexportDeclaration :: + -- | Text to parse + Text -> + -- | Parse result + Either + (ParseErrorBundle Text Void) + (ModuleName, NonEmpty (Maybe PackageName, ModuleName)) +parseModuleReexportDeclaration = runParser (pModuleReexport <* eof) "" + +pDotOrmolu :: Parser (FixityOverrides, ModuleReexports) +pDotOrmolu = + bimap + (FixityOverrides . Map.fromList . mconcat) + (ModuleReexports . Map.map NE.sort . Map.fromListWith (<>)) + . partitionEithers + <$> (configLine `sepEndBy` (void eol *> hidden space)) + <* eof + where + configLine = eitherP pFixity pModuleReexport + +-- | Parse a single fixity declaration, such as +-- +-- > infixr 4 +++, >>> +pFixity :: Parser [(OpName, FixityInfo)] +pFixity = do + fiDirection <- pFixityDirection + hidden hspace1 + offsetAtPrecedence <- getOffset + fiPrecedence <- + try L.float + <|> (fromIntegral <$> (L.decimal :: Parser Integer)) + when (fiPrecedence > 9) $ + region + (setErrorOffset offsetAtPrecedence) + (fail "precedence should not be greater than 9") + hidden hspace1 + ops <- sepBy1 pOperator (char ',' >> hidden hspace) + hidden hspace + let fixityInfo = FixityInfo {..} + return ((,fixityInfo) <$> ops) + +pFixityDirection :: Parser FixityDirection +pFixityDirection = + choice + [ InfixL <$ string "infixl", + InfixR <$ string "infixr", + InfixN <$ string "infix" + ] + +-- | See +pOperator :: Parser OpName +pOperator = OpName <$> (tickedOperator <|> normalOperator) + where + tickedOperator = between tick tick haskellIdentifier + tick = char '`' + haskellIdentifier = + T.cons + <$> letterChar + <*> takeWhileP Nothing isIdentifierConstituent + normalOperator = + takeWhile1P (Just "operator character") isOperatorConstituent + +pModuleReexport :: Parser (ModuleName, NonEmpty (Maybe PackageName, ModuleName)) +pModuleReexport = do + void (string "module") + hidden hspace1 + exportingModule <- pModuleName + hidden hspace1 + void (string "exports") + hidden hspace1 + mexportedPackage <- + optional $ + between (char '\"') (char '\"') pPackageName <* hidden hspace1 + exportedModule <- pModuleName + hidden hspace + return (exportingModule, NE.singleton (mexportedPackage, exportedModule)) + +pModuleName :: Parser ModuleName +pModuleName = + ModuleName.fromString . intercalate "." + <$> sepBy1 pModuleSegment (char '.') + "module name" + where + pModuleSegment = do + x <- satisfy isModuleSegmentFirstChar "capital letter" + xs <- + many + ( satisfy isModuleSegmentConstituent + "module segment continuation" + ) + return (x : xs) + +pPackageName :: Parser PackageName +pPackageName = + mkPackageName <$> some (satisfy isPackageNameConstituent) "package name" + +-- Internal predicates (exposed for testing) + +isIdentifierFirstChar :: Char -> Bool +isIdentifierFirstChar = Char.isLetter + +isIdentifierConstituent :: Char -> Bool +isIdentifierConstituent x = Char.isAlphaNum x || x == '_' || x == '\'' + +isOperatorConstituent :: Char -> Bool +isOperatorConstituent x = + (Char.isSymbol x || Char.isPunctuation x) + && (x /= ',' && x /= '`' && x /= '(' && x /= ')') + +isPackageNameConstituent :: Char -> Bool +isPackageNameConstituent x = x == '-' || isAlphaNum x + +isModuleSegmentFirstChar :: Char -> Bool +isModuleSegmentFirstChar x = isAlphaNum x && isUpper x + +isModuleSegmentConstituent :: Char -> Bool +isModuleSegmentConstituent x = + x == '_' || x == '\'' || isAlphaNum x diff --git a/src/Ormolu/Fixity/Printer.hs b/src/Ormolu/Fixity/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Fixity/Printer.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Printer for fixity overrides. +module Ormolu.Fixity.Printer + ( printDotOrmolu, + ) +where + +import Data.Char qualified as Char +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict qualified as Map +import Data.Semigroup (sconcat) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Builder (Builder) +import Data.Text.Lazy.Builder qualified as B +import Data.Text.Lazy.Builder.Int qualified as B +import Data.Text.Lazy.Builder.RealFloat qualified as B +import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName qualified as ModuleName +import Distribution.Types.PackageName +import Ormolu.Fixity + +-- | Print out a textual representation of an @.ormolu@ file. +printDotOrmolu :: + FixityOverrides -> + ModuleReexports -> + Text +printDotOrmolu + (FixityOverrides fixityOverrides) + (ModuleReexports moduleReexports) = + TL.toStrict . B.toLazyText $ + (mconcat . fmap renderSingleFixityOverride . Map.toList) fixityOverrides + <> (mconcat . fmap renderSingleModuleReexport . Map.toList) moduleReexports + +renderSingleFixityOverride :: (OpName, FixityInfo) -> Builder +renderSingleFixityOverride (OpName operator, FixityInfo {..}) = + mconcat + [ case fiDirection of + InfixL -> "infixl" + InfixR -> "infixr" + InfixN -> "infix", + " ", + renderPrecedence fiPrecedence, + " ", + if isTickedOperator operator + then "`" <> B.fromText operator <> "`" + else B.fromText operator, + "\n" + ] + where + isTickedOperator = maybe True (Char.isLetter . fst) . T.uncons + +renderSingleModuleReexport :: + (ModuleName, NonEmpty (Maybe PackageName, ModuleName)) -> + Builder +renderSingleModuleReexport (exportingModule, exports) = + sconcat (renderSingle <$> exports) + where + renderSingle (mexportedPackage, exportedModule) = + mconcat + [ "module ", + renderModuleName exportingModule, + " exports ", + renderOptionalPackageName mexportedPackage, + renderModuleName exportedModule, + "\n" + ] + renderOptionalPackageName = \case + Nothing -> mempty + Just x -> "\"" <> B.fromString (unPackageName x) <> "\" " + +renderModuleName :: ModuleName -> Builder +renderModuleName = B.fromString . intercalate "." . ModuleName.components + +-- | Render precedence using integer representation for whole numbers. +renderPrecedence :: Double -> Builder +renderPrecedence x = + let (n :: Int, fraction :: Double) = properFraction x + isWholeEnough = fraction < 0.0001 + in if isWholeEnough + then B.decimal n + else B.realFloat x diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} -- | Manipulations on import lists. module Ormolu.Imports @@ -10,33 +13,39 @@ import Data.Bifunctor import Data.Char (isAlphaNum) +import Data.Choice (Choice) +import Data.Choice qualified as Choice import Data.Function (on) -import Data.List (foldl', nubBy, sortBy, sortOn) +import Data.List (nubBy, sortBy, sortOn) import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import GHC.Data.FastString (FastString) -import GHC.Hs.Extension +import Data.Map.Strict qualified as M +import Data.Ord (comparing) +import GHC.Data.FastString +import GHC.Hs import GHC.Hs.ImpExp as GHC -import GHC.Types.Basic import GHC.Types.Name.Reader +import GHC.Types.PkgQual +import GHC.Types.SourceText import GHC.Types.SrcLoc -import GHC.Unit.Module.Name -import GHC.Unit.Types import Ormolu.Utils (notImplemented, showOutputable) -- | Sort and normalize imports. -normalizeImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs] -normalizeImports = +normalizeImports :: + Choice "implicitPrelude" -> + [LImportDecl GhcPs] -> + [LImportDecl GhcPs] +normalizeImports implicitPrelude = fmap snd . M.toAscList . M.fromListWith combineImports - . fmap (\x -> (importId x, g x)) + . fmap (\x -> (importId implicitPrelude x, g x)) where + g :: LImportDecl GhcPs -> LImportDecl GhcPs g (L l ImportDecl {..}) = L l ImportDecl - { ideclHiding = second (fmap normalizeLies) <$> ideclHiding, + { ideclImportList = second (fmap normalizeLies) <$> ideclImportList, .. } @@ -46,55 +55,122 @@ LImportDecl GhcPs -> LImportDecl GhcPs -> LImportDecl GhcPs -combineImports (L lx ImportDecl {..}) (L _ y) = - L - lx - ImportDecl - { ideclHiding = case (ideclHiding, GHC.ideclHiding y) of - (Just (hiding, L l' xs), Just (_, L _ ys)) -> - Just (hiding, (L l' (normalizeLies (xs ++ ys)))) - _ -> Nothing, - .. - } +combineImports x y = + L widenedLoc earlier {ideclImportList = combinedImportList} + where + -- The merged declaration spans both of the ones it came from, so that + -- it is laid out over several lines and a comment that was written + -- between them has somewhere to go. Its own span would otherwise still + -- describe a single line. + widenedLoc = + l {entry = EpaSpan (combineSrcSpans (locA (getLoc x)) (locA (getLoc y)))} --- | Import id, a collection of all things that justify having a separate --- import entry. This is used for merging of imports. If two imports have --- the same 'ImportId' they can be merged. + -- Take the declaration that comes first in the source whole, rather + -- than mixing the span of one with the contents of the other: a + -- declaration whose span sits before its own module name or import + -- list cannot be placed in a containment tree, which is what comment + -- attachment needs. + (L l earlier, L _ later) + | startsFirst (locA (getLoc x)) (locA (getLoc y)) = (x, y) + | otherwise = (y, x) + combinedImportList = + case (GHC.ideclImportList earlier, GHC.ideclImportList later) of + (Just (hiding, L l' xs), Just (_, L _ ys)) -> + Just (hiding, L l' (normalizeLies (xs ++ ys))) + _ -> Nothing + +-- | Does the first span start before the second? Spans without a real +-- location are treated as coming first, arbitrarily but consistently. +startsFirst :: SrcSpan -> SrcSpan -> Bool +startsFirst a b = case (srcSpanToRealSrcSpan a, srcSpanToRealSrcSpan b) of + (Just a', Just b') -> realSrcSpanStart a' <= realSrcSpanStart b' + (Nothing, _) -> True + _ -> False + +-- | An import id, a collection of all the things that justify having a +-- separate import entry. This is used for merging imports: if two imports +-- have the same 'ImportId', they can be merged. data ImportId = ImportId { importIsPrelude :: Bool, + importPkgQual :: ImportPkgQual, importIdName :: ModuleName, - importPkgQual :: Maybe FastString, importSource :: IsBootInterface, importSafe :: Bool, importQualified :: Bool, - importImplicit :: Bool, importAs :: Maybe ModuleName, - importHiding :: Maybe Bool + 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 + | -- | The import is qualified by an external package name. + ImportPkgQual LexicalFastString + | -- | The import is qualified by the current package being built, using the + -- special @this@ package name. + ImportPkgQualThis + deriving stock (Eq, Ord) + +mkImportPkgQual :: RawPkgQual -> ImportPkgQual +mkImportPkgQual = \case + NoRawPkgQual -> NoImportPkgQual + RawPkgQual (sl_fs -> fs) + | fs == mkFastString "this" -> ImportPkgQualThis + | otherwise -> ImportPkgQual (LexicalFastString fs) + +-- | 'ImportListInterpretation' does not have an 'Ord' instance. +newtype ImportListInterpretationOrd = ImportListInterpretationOrd + { unImportListInterpretationOrd :: ImportListInterpretation + } + deriving stock (Eq) + +instance Ord ImportListInterpretationOrd where + compare = compare `on` toBool . unImportListInterpretationOrd + where + toBool Exactly = False + 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, - importPkgQual = sl_fs <$> ideclPkgQual, + importPkgQual = mkImportPkgQual ideclPkgQual, importSource = ideclSource, importSafe = ideclSafe, importQualified = case ideclQualified of QualifiedPre -> True QualifiedPost -> True NotQualified -> False, - importImplicit = ideclImplicit, importAs = unLoc <$> ideclAs, - importHiding = fst <$> ideclHiding + importHiding = ImportListInterpretationOrd . fst <$> ideclImportList, + 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) + LevelStylePost l -> Just (ImportDeclLevelOrd l) + NotLevelled -> Nothing --- | Normalize a collection of import\/export items. +-- | Normalize a collection of import items. normalizeLies :: [LIE GhcPs] -> [LIE GhcPs] normalizeLies = sortOn (getIewn . unLoc) . M.elems . foldl' combine M.empty where @@ -109,80 +185,80 @@ alter = \case Nothing -> Just . L new_l $ case new of - IEThingWith NoExtField n wildcard g flbl -> - IEThingWith NoExtField n wildcard (normalizeWNames g) flbl + IEThingWith x n wildcard g _ -> + IEThingWith x n wildcard (normalizeWNames g) Nothing other -> other Just old -> let f = \case - IEVar NoExtField n -> IEVar NoExtField n - IEThingAbs NoExtField _ -> new - IEThingAll NoExtField n -> IEThingAll NoExtField n - IEThingWith NoExtField n wildcard g flbl -> + IEVar _ n _ -> IEVar Nothing n Nothing + IEThingAbs _ _ _ -> new + IEThingAll x n _ -> IEThingAll x n Nothing + IEThingWith _ n wildcard g _ -> case new of - IEVar NoExtField _ -> + IEVar _ _ _ -> error "Ormolu.Imports broken presupposition" - IEThingAbs NoExtField _ -> - IEThingWith NoExtField n wildcard g flbl - IEThingAll NoExtField n' -> - IEThingAll NoExtField n' - IEThingWith NoExtField n' wildcard' g' flbl' -> + IEThingAbs x _ _ -> + IEThingWith (x, noAnn) n wildcard g Nothing + IEThingAll x n' _ -> + IEThingAll x n' Nothing + IEThingWith x n' wildcard' g' _ -> let combinedWildcard = case (wildcard, wildcard') of (IEWildcard _, _) -> IEWildcard 0 (_, IEWildcard _) -> IEWildcard 0 _ -> NoIEWildcard in IEThingWith - NoExtField + x n' combinedWildcard (normalizeWNames (g <> g')) - flbl' - IEModuleContents NoExtField _ -> notImplemented "IEModuleContents" + Nothing + IEModuleContents _ _ -> notImplemented "IEModuleContents" IEGroup NoExtField _ _ -> notImplemented "IEGroup" IEDoc NoExtField _ -> notImplemented "IEDoc" IEDocNamed NoExtField _ -> notImplemented "IEDocNamed" - IEModuleContents NoExtField _ -> notImplemented "IEModuleContents" + IEModuleContents _ _ -> notImplemented "IEModuleContents" IEGroup NoExtField _ _ -> notImplemented "IEGroup" IEDoc NoExtField _ -> notImplemented "IEDoc" IEDocNamed NoExtField _ -> notImplemented "IEDocNamed" in Just (f <$> old) in M.alter alter wname m --- | A wrapper for @'IEWrappedName' 'RdrName'@ that allows us to define an +-- | A wrapper for @'IEWrappedName' 'GhcPs'@ that allows us to define an -- 'Ord' instance for it. -newtype IEWrappedNameOrd = IEWrappedNameOrd (IEWrappedName RdrName) +newtype IEWrappedNameOrd = IEWrappedNameOrd (IEWrappedName GhcPs) deriving (Eq) instance Ord IEWrappedNameOrd where compare (IEWrappedNameOrd x) (IEWrappedNameOrd y) = compareIewn x y --- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@. +-- | Project @'IEWrappedName' 'GhcPs'@ from @'IE' 'GhcPs'@. getIewn :: IE GhcPs -> IEWrappedNameOrd getIewn = \case - IEVar NoExtField x -> IEWrappedNameOrd (unLoc x) - IEThingAbs NoExtField x -> IEWrappedNameOrd (unLoc x) - IEThingAll NoExtField x -> IEWrappedNameOrd (unLoc x) - IEThingWith NoExtField x _ _ _ -> IEWrappedNameOrd (unLoc x) - IEModuleContents NoExtField _ -> notImplemented "IEModuleContents" + IEVar _ x _ -> IEWrappedNameOrd (unLoc x) + IEThingAbs _ x _ -> IEWrappedNameOrd (unLoc x) + IEThingAll _ x _ -> IEWrappedNameOrd (unLoc x) + IEThingWith _ x _ _ _ -> IEWrappedNameOrd (unLoc x) + IEModuleContents _ _ -> notImplemented "IEModuleContents" IEGroup NoExtField _ _ -> notImplemented "IEGroup" IEDoc NoExtField _ -> notImplemented "IEDoc" IEDocNamed NoExtField _ -> notImplemented "IEDocNamed" -- | Like 'compareIewn' for located wrapped names. -compareLIewn :: LIEWrappedName RdrName -> LIEWrappedName RdrName -> Ordering +compareLIewn :: LIEWrappedName GhcPs -> LIEWrappedName GhcPs -> Ordering compareLIewn = compareIewn `on` unLoc --- | Compare two @'IEWrapppedName' 'RdrName'@ things. -compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering -compareIewn (IEName x) (IEName y) = unLoc x `compareRdrName` unLoc y -compareIewn (IEName _) (IEPattern _) = LT -compareIewn (IEName _) (IEType _) = LT -compareIewn (IEPattern _) (IEName _) = GT -compareIewn (IEPattern x) (IEPattern y) = unLoc x `compareRdrName` unLoc y -compareIewn (IEPattern _) (IEType _) = LT -compareIewn (IEType _) (IEName _) = GT -compareIewn (IEType _) (IEPattern _) = GT -compareIewn (IEType x) (IEType y) = unLoc x `compareRdrName` unLoc y +-- | Compare two @'IEWrappedName' 'GhcPs'@ things. +compareIewn :: IEWrappedName GhcPs -> IEWrappedName GhcPs -> Ordering +compareIewn = (comparing fst <> (compareRdrName `on` unLoc . snd)) `on` classify + where + classify :: IEWrappedName GhcPs -> (Int, LocatedN RdrName) + classify = \case + IEName _ x -> (0, x) + IEDefault _ x -> (1, x) + IEPattern _ x -> (2, x) + IEType _ x -> (3, x) + IEData _ x -> (4, x) compareRdrName :: RdrName -> RdrName -> Ordering compareRdrName x y = diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -1,5 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Parser for Haskell source code. @@ -10,51 +14,68 @@ where import Control.Exception +import Control.Monad +import Control.Monad.Except (ExceptT (..), runExceptT) import Control.Monad.IO.Class -import qualified Data.List as L -import qualified Data.List.NonEmpty as NE -import Data.Ord (Down (Down)) -import qualified Data.Text as T +import Data.Char (isSpace) +import Data.Choice (Choice) +import Data.Choice qualified as Choice +import Data.Functor +import Data.Generics hiding (orElse) +import Data.List qualified as L +import Data.List.NonEmpty qualified as NE +import Data.Text (Text) +import GHC.Builtin.Names (mAIN_NAME) import GHC.Data.Bag (bagToList) -import qualified GHC.Data.FastString as GHC -import qualified GHC.Data.StringBuffer as GHC -import qualified GHC.Driver.CmdLine as GHC +import GHC.Data.EnumSet qualified as EnumSet +import GHC.Data.FastString qualified as GHC +import GHC.Data.Maybe (orElse) +import GHC.Data.StringBuffer (StringBuffer) +import GHC.Driver.Config.Parser (initParserOpts, supportedLanguagePragmas) +import GHC.Driver.Errors.Types qualified as GHC import GHC.Driver.Session as GHC -import qualified GHC.Driver.Types as GHC import GHC.DynFlags (baseDynFlags) +import GHC.Hs hiding (UnicodeSyntax) import GHC.LanguageExtensions.Type (Extension (..)) -import qualified GHC.Parser as GHC -import qualified GHC.Parser.Header as GHC -import qualified GHC.Parser.Lexer as GHC +import GHC.Parser qualified as GHC +import GHC.Parser.Annotation qualified as GHC +import GHC.Parser.Header qualified as GHC +import GHC.Parser.Lexer qualified as GHC +import GHC.Types.Error qualified as GHC +import GHC.Types.SourceError qualified as GHC import GHC.Types.SrcLoc -import GHC.Unit.Module.Name -import GHC.Utils.Error (Severity (..), errMsgSeverity, errMsgSpan) -import qualified GHC.Utils.Panic as GHC +import GHC.Utils.Error +import GHC.Utils.Exception (ExceptionMonad) +import GHC.Utils.Logger (initLogger) +import GHC.Utils.Panic qualified as GHC import Ormolu.Config import Ormolu.Exception -import Ormolu.Parser.Anns +import Ormolu.Fixity hiding (packageFixityMap) +import Ormolu.Fixity.Imports (applyModuleReexports, extractFixityImports) +import Ormolu.Imports (normalizeImports) import Ormolu.Parser.CommentStream import Ormolu.Parser.Result -import Ormolu.Processing.Preprocess (preprocess) -import Ormolu.Utils (incSpanLine, removeIndentation) +import Ormolu.Processing.Common +import Ormolu.Processing.Cpp (eraseCppLines) +import Ormolu.Processing.Preprocess +import Ormolu.Utils (incSpanLine, showOutputable, textToStringBuffer) --- | Parse a complete module from string. +-- | Parse a complete module from 'Text'. parseModule :: - MonadIO m => + (MonadIO m) => -- | Ormolu configuration Config RegionDeltas -> + -- | Package fixity map + PackageFixityMap -> -- | File name (only for source location annotations) FilePath -> -- | Input for parser - String -> + Text -> m - ( [GHC.Warn], - Either (SrcSpan, String) ParseResult + ( GHC.DriverMessages, + Either (SrcSpan, String) [SourceSnippet] ) -parseModule Config {..} path rawInput = liftIO $ do - let (literalPrefix, indentedInput, literalSuffix, extraComments) = - preprocess path rawInput cfgRegion - (input, indent) = removeIndentation indentedInput +parseModule config@Config {..} packageFixityMap path rawInput = liftIO $ do -- It's important that 'setDefaultExts' is done before -- 'parsePragmasIntoDynFlags', because otherwise we might enable an -- extension that was explicitly disabled in the file. @@ -63,69 +84,181 @@ GHC.Opt_Haddock (setDefaultExts baseDynFlags) extraOpts = dynOptionToLocatedStr <$> cfgDynOptions + rawInputStringBuffer = textToStringBuffer (eraseCppLines rawInput) + beginningLoc = + mkSrcSpan + (mkSrcLoc (GHC.mkFastString path) 1 1) + (mkSrcLoc (GHC.mkFastString path) 1 1) (warnings, dynFlags) <- - parsePragmasIntoDynFlags baseFlags extraOpts path rawInput >>= \case + parsePragmasIntoDynFlags baseFlags extraOpts path rawInputStringBuffer >>= \case Right res -> pure res + Left err -> throwIO (OrmoluParsingFailed beginningLoc err) + 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 -> + pure (applyModuleReexports cfgModuleReexports (extractFixityImports res)) Left err -> - let loc = - mkSrcSpan - (mkSrcLoc (GHC.mkFastString path) 1 1) - (mkSrcLoc (GHC.mkFastString path) 1 1) - in throwIO (OrmoluParsingFailed loc err) - let useRecordDot = - "record-dot-preprocessor" == pgm_F dynFlags - || any - (("RecordDotPreprocessor" ==) . moduleNameString) - (pluginModNames dynFlags) - pStateErrors = \pstate -> - let errs = bagToList $ GHC.getErrorMessages pstate dynFlags + throwIO (OrmoluParsingFailed beginningLoc err) + let modFixityMap = + applyFixityOverrides + cfgFixityOverrides + (moduleFixityMap packageFixityMap fixityImports) + snippets <- runExceptT . forM (preprocess cppEnabled cfgRegion rawInput) $ \case + Right region -> + fmap ParsedSnippet . ExceptT $ + parseModuleSnippet (config $> region) modFixityMap dynFlags path rawInput + Left raw -> pure $ RawSnippet raw + pure (warnings, snippets) + +parseModuleSnippet :: + (MonadIO m) => + Config RegionDeltas -> + ModuleFixityMap -> + DynFlags -> + FilePath -> + Text -> + m (Either (SrcSpan, String) ParseResult) +parseModuleSnippet Config {..} modFixityMap dynFlags path rawInput = liftIO $ do + let (input, indent) = removeIndentation . linesInRegion cfgRegion $ rawInput + let pStateErrors pstate = + let errs = bagToList . GHC.getMessages $ GHC.getPsErrorMessages pstate fixupErrSpan = incSpanLine (regionPrefixLength cfgRegion) - in case L.sortOn (Down . SeverityOrd . errMsgSeverity) errs of + rateSeverity = \case + SevError -> 1 :: Int + SevWarning -> 2 + SevIgnore -> 3 + showErr (errMsgDiagnostic -> err) = codeMsg <> msg + where + codeMsg = case diagnosticCode err of + Just code -> "[" <> showOutputable code <> "] " + Nothing -> "" + msg = + showOutputable + . formatBulleted + . diagnosticMessage GHC.NoDiagnosticOpts + $ err + in case L.sortOn (rateSeverity . errMsgSeverity) errs of [] -> Nothing err : _ -> - -- Show instance returns a short error message - Just (fixupErrSpan (errMsgSpan err), show err) - r = case runParser GHC.parseModule dynFlags path input of + Just (fixupErrSpan (errMsgSpan err), showErr err) + parser = case cfgSourceType of + ModuleSource -> GHC.parseModule + SignatureSource -> GHC.parseSignature + implicitPrelude = + Choice.fromBool $ + EnumSet.member ImplicitPrelude (GHC.extensionFlags dynFlags) + r = case runParser parser dynFlags path input of GHC.PFailed pstate -> case pStateErrors pstate of Just err -> Left err Nothing -> error "PFailed does not have an error" - GHC.POk pstate (L _ hsModule) -> + GHC.POk pstate (L _ (normalizeModule implicitPrelude -> hsModule)) -> case pStateErrors pstate of - -- Some parse errors (pattern/arrow syntax in expr context) - -- do not cause a parse error, but they are replaced with "_" - -- by the parser and the modified AST is propagated to the - -- later stages; but we fail in those cases. + -- Some malformed inputs (pattern/arrow syntax in an + -- expression context) do not cause a parse error; instead the + -- parser replaces them with "_" and propagates the modified AST + -- to the later stages. We fail in those cases. Just err -> Left err Nothing -> - let (stackHeader, shebangs, pragmas, comments) = - mkCommentStream input extraComments pstate + let (stackHeader, pragmas, comments, haddockText) = + mkCommentStream input hsModule in Right ParseResult { prParsedSource = hsModule, - prAnns = mkAnns pstate, + prSourceType = cfgSourceType, prStackHeader = stackHeader, - prShebangs = shebangs, prPragmas = pragmas, prCommentStream = comments, - prUseRecordDot = useRecordDot, + prHaddockText = haddockText, prExtensions = GHC.extensionFlags dynFlags, - prLiteralPrefix = T.pack literalPrefix, - prLiteralSuffix = T.pack literalSuffix, + prModuleFixityMap = modFixityMap, prIndent = indent } - return (warnings, r) + return r +-- | Normalize a 'HsModule' by sorting its import\/export lists, dropping +-- blank comments, etc. +normalizeModule :: + Choice "implicitPrelude" -> + HsModule GhcPs -> + HsModule GhcPs +normalizeModule implicitPrelude hsmod = + everywhere + ( mkT dropBlankTypeHaddocks + `extT` dropBlankDataDeclHaddocks + `extT` dropBlankConDeclFieldHaddocks + `extT` patchContext + `extT` patchExprContext + ) + hsmod + { hsmodImports = + normalizeImports implicitPrelude (hsmodImports hsmod), + hsmodDecls = + filter (not . isBlankDocD . unLoc) (hsmodDecls hsmod), + hsmodExt = + (hsmodExt hsmod) + { hsmodHaddockModHeader = + mfilter (not . isBlankDocString) (hsmodHaddockModHeader (hsmodExt hsmod)) + }, + hsmodExports = + (fmap . fmap) (filter (not . isBlankDocIE . unLoc)) (hsmodExports hsmod) + } + where + isBlankDocString = all isSpace . renderHsDocString . hsDocString . unLoc + isBlankDocD = \case + DocD _ s -> isBlankDocString $ docDeclDoc s + _ -> False + isBlankDocIE = \case + IEGroup _ _ s -> isBlankDocString s + IEDoc _ s -> isBlankDocString s + _ -> False + dropBlankTypeHaddocks = \case + L _ (HsDocTy _ ty s) :: LHsType GhcPs + | isBlankDocString s -> ty + a -> a + -- A Haddock on a field that holds nothing but whitespace is dropped, + -- the same way one on a constructor is. Without this, whether it + -- survives depends on whether it happened to end in a space. + dropBlankConDeclFieldHaddocks = \case + CDF {cdf_doc = Just s, ..} :: HsConDeclField GhcPs + | isBlankDocString s -> CDF {cdf_doc = Nothing, ..} + a -> a + dropBlankDataDeclHaddocks = \case + ConDeclGADT {con_doc = Just s, ..} :: ConDecl GhcPs + | isBlankDocString s -> ConDeclGADT {con_doc = Nothing, ..} + ConDeclH98 {con_doc = Just s, ..} :: ConDecl GhcPs + | isBlankDocString s -> ConDeclH98 {con_doc = Nothing, ..} + a -> a + + -- For constraint contexts (both in types and in expressions), normalize + -- parentheses as decided in https://github.com/tweag/ormolu/issues/264. + patchContext :: LHsContext GhcPs -> LHsContext GhcPs + patchContext = fmap $ \case + [x@(L _ (HsParTy _ _))] -> [x] + [x@(L lx _)] -> [L lx (HsParTy noAnn x)] + xs -> xs + patchExprContext :: LHsExpr GhcPs -> LHsExpr GhcPs + patchExprContext = fmap $ \case + x@(HsQual _ (L _ [L _ HsPar {}]) _) -> x + HsQual l0 (L l1 [x@(L lx _)]) e -> HsQual l0 (L l1 [L lx (HsPar noAnn x)]) e + x -> x + -- | Enable all language extensions that we think should be enabled by -- default for ease of use. setDefaultExts :: DynFlags -> DynFlags -setDefaultExts flags = L.foldl' xopt_set flags autoExts +setDefaultExts flags = L.foldl' xopt_set (lang_set flags (Just Haskell2010)) autoExts where autoExts = allExts L.\\ manualExts allExts = [minBound .. maxBound] -- | Extensions that are not enabled automatically and should be activated --- by user. +-- by the user. manualExts :: [Extension] manualExts = [ Arrows, -- steals proc @@ -143,14 +276,19 @@ UnboxedSums, UnicodeSyntax, -- gives special meanings to operators like (→) TemplateHaskell, -- changes how $foo is parsed - TemplateHaskellQuotes, -- enables TH subset of quasi-quotes, this + TemplateHaskellQuotes, -- enables the TH subset of quasi-quotes, which -- apparently interferes with QuasiQuotes in -- weird ways ImportQualifiedPost, -- affects how Ormolu renders imports, so the - -- decision of enabling this style is left to the user + -- decision to enable this style is left to the user NegativeLiterals, -- with this, `- 1` and `-1` have differing AST LexicalNegation, -- implies NegativeLiterals - LinearTypes -- steals the (%) type operator in some cases + LinearTypes, -- steals the (%) type operator in some cases + OverloadedRecordDot, -- f.g parses differently + OverloadedRecordUpdate, -- qualified fields are not supported + OverloadedLabels, -- a#b is parsed differently + ExtendedLiterals, -- 1#Word32 is parsed differently + MultilineStrings -- """""" is parsed differently ] -- | Run a 'GHC.P' computation. @@ -162,37 +300,20 @@ -- | Module path FilePath -> -- | Module contents - String -> + Text -> -- | Parse result GHC.ParseResult a runParser parser flags filename input = GHC.unP parser parseState where location = mkRealSrcLoc (GHC.mkFastString filename) 1 1 - buffer = GHC.stringToStringBuffer input - parseState = GHC.mkPState flags buffer location - --- | Wrap GHC's 'Severity' to add 'Ord' instance. -newtype SeverityOrd = SeverityOrd Severity - -instance Eq SeverityOrd where - s1 == s2 = compare s1 s2 == EQ - -instance Ord SeverityOrd where - compare (SeverityOrd s1) (SeverityOrd s2) = - compare (f s1) (f s2) - where - f :: Severity -> Int - f SevOutput = 1 - f SevFatal = 2 - f SevInteractive = 3 - f SevDump = 4 - f SevInfo = 5 - f SevWarning = 6 - f SevError = 7 + buffer = textToStringBuffer input + parseState = GHC.initParserState (initParserOpts flags) buffer location ---------------------------------------------------------------------------- -- Helpers taken from HLint +-- | Detect pragmas in the given input and return them as a collection of +-- 'DynFlags'. parsePragmasIntoDynFlags :: -- | Pre-set 'DynFlags' DynFlags -> @@ -201,22 +322,70 @@ -- | File name (only for source location annotations) FilePath -> -- | Input for parser - String -> - IO (Either String ([GHC.Warn], DynFlags)) -parsePragmasIntoDynFlags flags extraOpts filepath str = - catchErrors $ do - let fileOpts = GHC.getOptions flags (GHC.stringToStringBuffer str) filepath + StringBuffer -> + IO (Either String (GHC.DriverMessages, DynFlags)) +parsePragmasIntoDynFlags flags extraOpts filepath input = + catchGhcErrors $ do + 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 -> throwIO (OrmoluUnrecognizedOpts (unLoc <$> unrecognizedOpts)) let flags'' = flags' `gopt_set` Opt_KeepRawTokenStream return $ Right (warnings, flags'') + +-- | Detect the collection of imports used in the given input. +parseImports :: + -- | Pre-set 'DynFlags' + DynFlags -> + -- | Whether the implicit Prelude is in effect + Choice "implicitPrelude" -> + -- | File name (only for source location annotations) + FilePath -> + -- | Input for the parser + StringBuffer -> + IO (Either String [LImportDecl GhcPs]) +parseImports flags implicitPrelude filepath input = + case GHC.unP GHC.parseHeader (GHC.initParserState popts input loc) of + GHC.PFailed pst -> + return $ Left (showOutputable (GHC.getPsErrorMessages pst)) + GHC.POk pst rdr_module -> + return $ + let (_warnings, errors) = GHC.getPsMessages pst + in if not (isEmptyMessages errors) + then Left (showOutputable (GHC.GhcPsMessage <$> errors)) + else + let hsmod = unLoc rdr_module + mmoduleName = hsmodName hsmod + main_loc = srcLocSpan (mkSrcLoc (GHC.mkFastString filepath) 1 1) + mod' = mmoduleName `orElse` L (GHC.noAnnSrcSpan main_loc) mAIN_NAME + explicitImports = hsmodImports hsmod + implicitImports = + GHC.mkPrelImports + (unLoc mod') + main_loc + (Choice.toBool implicitPrelude) + explicitImports + in Right (explicitImports ++ implicitImports) where - catchErrors act = - GHC.handleGhcException - reportErr - (GHC.handleSourceError reportErr act) + popts = initParserOpts flags + loc = mkRealSrcLoc (GHC.mkFastString filepath) 1 1 + +-- | Catch and report GHC errors. +catchGhcErrors :: (ExceptionMonad m) => m (Either String a) -> m (Either String a) +catchGhcErrors m = + GHC.handleGhcException + reportErr + (GHC.handleSourceError reportErr m) + where reportErr e = return $ Left (show e) diff --git a/src/Ormolu/Parser/Anns.hs b/src/Ormolu/Parser/Anns.hs deleted file mode 100644 --- a/src/Ormolu/Parser/Anns.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | Ormolu-specific representation of GHC annotations. -module Ormolu.Parser.Anns - ( Anns (..), - emptyAnns, - mkAnns, - lookupAnns, - ) -where - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import GHC.Parser.Annotation -import GHC.Parser.Lexer -import GHC.Types.SrcLoc - --- | Ormolu-specific representation of GHC annotations. -newtype Anns = Anns (Map RealSrcSpan [AnnKeywordId]) - deriving (Eq) - --- | Empty 'Anns'. -emptyAnns :: Anns -emptyAnns = Anns M.empty - --- | Create 'Anns' from 'PState'. -mkAnns :: - PState -> - Anns -mkAnns pstate = - Anns $ - M.fromListWith (++) (f <$> annotations pstate) - where - f ((rspn, kid), _) = (rspn, [kid]) - --- | Lookup 'AnnKeywordId's corresponding to a given 'SrcSpan'. -lookupAnns :: - -- | Span to lookup with - SrcSpan -> - -- | Collection of annotations - Anns -> - [AnnKeywordId] -lookupAnns (RealSrcSpan rspn _) (Anns m) = M.findWithDefault [] rspn m -lookupAnns (UnhelpfulSpan _) _ = [] diff --git a/src/Ormolu/Parser/CommentStream.hs b/src/Ormolu/Parser/CommentStream.hs --- a/src/Ormolu/Parser/CommentStream.hs +++ b/src/Ormolu/Parser/CommentStream.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} --- | Functions for working with comment stream. +-- | Functions for working with the comment stream. module Ormolu.Parser.CommentStream ( -- * Comment stream CommentStream (..), mkCommentStream, - showCommentStream, + HaddockText, -- * Comment + LComment, Comment (..), unComment, hasAtomsBefore, @@ -19,121 +20,241 @@ import Data.Char (isSpace) import Data.Data (Data) -import qualified Data.List as L +import Data.Generics.Schemes +import Data.List qualified as L import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (mapMaybe) -import qualified GHC.Parser.Annotation as GHC -import qualified GHC.Parser.Lexer as GHC +import Data.List.NonEmpty qualified as NE +import Data.Map.Lazy qualified as M +import Data.Maybe +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Data.Strict qualified as Strict +import GHC.Hs (HsModule (..)) +import GHC.Hs.Doc +import GHC.Hs.Extension +import GHC.Hs.ImpExp +import GHC.Parser.Annotation (EpAnnComments (..), getLocA) +import GHC.Parser.Annotation qualified as GHC import GHC.Types.SrcLoc import Ormolu.Parser.Pragma -import Ormolu.Parser.Shebang -import Ormolu.Processing.Common -import Ormolu.Utils (onTheSameLine, showOutputable) +import Ormolu.Utils (onTheSameLine) ---------------------------------------------------------------------------- -- Comment stream -- | A stream of 'RealLocated' 'Comment's in ascending order with respect to --- beginning of corresponding spans. -newtype CommentStream = CommentStream [RealLocated Comment] +-- the beginning of the corresponding spans. +newtype CommentStream = CommentStream [LComment] deriving (Eq, Data, Semigroup, Monoid) --- | Create 'CommentStream' from 'GHC.PState'. The pragmas and shebangs are --- removed from the 'CommentStream'. Shebangs are only extracted from the --- comments that come from the first argument. +-- | The source text of the Haddocks of a module, keyed by span. +-- +-- Haddocks are printed from the text the author wrote rather than +-- reconstructed from the 'GHC.Hs.Doc.HsDocString' GHC parsed out of it. +-- Reconstruction cannot preserve everything — an empty @-- |@ vanishes, and +-- a @{- | … -}@ cannot come back as anything but @--@ lines — and what it +-- loses, it loses from the AST as well, which is why Ormolu refuses to +-- format some modules it should be able to. +type HaddockText = M.Map RealSrcSpan Comment + +-- | Create a 'CommentStream' from an 'HsModule'. The pragmas are removed +-- from the 'CommentStream'. mkCommentStream :: -- | Original input - String -> - -- | Extra comments to include - [RealLocated String] -> - -- | Parser state to use for comment extraction - GHC.PState -> - -- | Stack header, shebangs, pragmas, and comment stream - ( Maybe (RealLocated Comment), - [Shebang], - [([RealLocated Comment], Pragma)], - CommentStream + Text -> + -- | Module to use for comment extraction + HsModule GhcPs -> + -- | Stack header, pragmas, comment stream, and Haddock source text + ( Maybe LComment, + [([LComment], Pragma)], + CommentStream, + HaddockText ) -mkCommentStream input extraComments pstate = +mkCommentStream input hsModule = ( mstackHeader, - shebangs, pragmas, - CommentStream comments + CommentStream comments, + haddockText ) where - (comments, pragmas) = extractPragmas input rawComments1 + -- The Haddocks are kept out of the comment stream, because they are + -- printed from the AST, but their text is kept so that the printer can + -- reproduce what the author wrote. + haddockText = + M.fromList + [ (spn, mkHaddockComment (L spn (sliceSpan input spn))) + | spn <- S.toList validHaddockCommentSpans + ] + + (comments, pragmas) = extractPragmas input headerEnd rawComments1 + + -- Where the file header stops and the module proper begins. Only + -- pragmas before this point are hoisted and normalized; GHC reads the + -- header and nothing else, so a pragma below it has no effect on + -- compilation and moving it to the top would give it one. + headerEnd = + listToMaybe . L.sort $ + [ realSrcSpanStart spn + | l <- + (getLocA <$> hsmodImports hsModule) + <> (getLocA <$> hsmodDecls hsModule), + Just spn <- [srcSpanToRealSrcSpan l] + ] (rawComments1, mstackHeader) = extractStackHeader rawComments0 + + -- We want to extract all comments except _valid_ Haddock comments rawComments0 = - L.sortOn (realSrcSpanStart . getRealSrcSpan) $ - otherExtraComments - ++ mapMaybe (liftMaybe . fmap unAnnotationComment) (GHC.comment_q pstate) - ++ concatMap - (mapMaybe (liftMaybe . fmap unAnnotationComment) . snd) - (GHC.annotations_comments pstate) - (shebangs, otherExtraComments) = extractShebangs extraComments + fmap (uncurry L) + . M.toAscList + . flip M.withoutKeys validHaddockCommentSpans + . M.fromList + . fmap (\(L l a) -> (l, a)) + $ allRawComments --- | Pretty-print a 'CommentStream'. -showCommentStream :: CommentStream -> String -showCommentStream (CommentStream xs) = - unlines $ - showComment <$> xs - where - showComment (L l str) = showOutputable l ++ " " ++ show str + -- All comments, including valid and invalid Haddock comments + allRawComments = + mapMaybe (unAnnotationComment input) $ + epAnnCommentsToList =<< listify (only @EpAnnComments) hsModule + where + epAnnCommentsToList = \case + EpaComments cs -> cs + EpaCommentsBalanced pcs fcs -> pcs <> fcs + -- All spans of valid Haddock comments + validHaddockCommentSpans = + S.fromList + . mapMaybe srcSpanToRealSrcSpan + . mconcat + [ fmap getLoc . listify (only @(LHsDoc GhcPs)), + fmap getLocA . listify isIEDocLike + ] + $ hsModule + where + isIEDocLike :: LIE GhcPs -> Bool + isIEDocLike = \case + L _ IEGroup {} -> True + L _ IEDoc {} -> True + L _ IEDocNamed {} -> True + _ -> False + only :: a -> Bool + only _ = True + ---------------------------------------------------------------------------- -- Comment +type LComment = RealLocated Comment + -- | A wrapper for a single comment. The 'Bool' indicates whether there were --- atoms before beginning of the comment in the original input. The --- 'NonEmpty' list inside contains lines of multiline comment @{- … -}@ or --- just single item\/line otherwise. -data Comment = Comment Bool (NonEmpty String) +-- atoms before the beginning of the comment in the original input. The +-- 'NonEmpty' list inside contains the lines of a multiline comment +-- @{- … -}@, or just a single item\/line otherwise. +data Comment = Comment Bool (NonEmpty Text) deriving (Eq, Show, Data) --- | Normalize comment string. Sometimes one multi-line comment is turned --- into several lines for subsequent outputting with correct indentation for --- each line. +-- | Normalize a comment string. Sometimes a single multi-line comment is +-- split into several lines so that it can later be output with correct +-- indentation on each line. mkComment :: -- | Lines of original input with their indices - [(Int, String)] -> + [(Int, Text)] -> -- | Raw comment string - RealLocated String -> + RealLocated Text -> -- | Remaining lines of original input and the constructed 'Comment' - ([(Int, String)], RealLocated Comment) + ([(Int, Text)], LComment) mkComment ls (L l s) = (ls', comment) where comment = - L l . Comment atomsBefore . removeConseqBlanks . fmap dropTrailing $ - if "{-" `L.isPrefixOf` s - then case NE.nonEmpty (lines s) of - Nothing -> s :| [] - Just (x :| xs) -> - let getIndent y = - if all isSpace y || y == endDisabling - then startIndent - else length (takeWhile isSpace y) - n = minimum (startIndent : fmap getIndent xs) - removeIndent y = - if y == endDisabling - then y - else drop n y - in x :| (removeIndent <$> xs) - else s :| [] + L l . Comment atomsBefore . removeConseqBlanks . fmap T.stripEnd $ + case NE.nonEmpty (T.lines s) of + Nothing -> s :| [] + Just (x :| xs) -> + let getIndent y = + if T.all isSpace y + then startIndent + else T.length (T.takeWhile isSpace y) + n = minimum (startIndent : fmap getIndent xs) + in x :| (escapeOpeningTrigger . T.drop n <$> xs) (atomsBefore, ls') = case dropWhile ((< commentLine) . fst) ls of [] -> (False, []) ((_, i) : ls'') -> - case take 2 (dropWhile isSpace i) of - "--" -> (False, ls'') - "{-" -> (False, ls'') - _ -> (True, ls'') - dropTrailing = L.dropWhileEnd isSpace + let lineStart = T.stripStart i + -- A pragma is code, not a comment, even though it opens the + -- same way. Without this a comment trailing @{-# UNPACK #-} + -- !Int@ looks as though nothing preceded it on the line. + startsWithComment = + "--" `T.isPrefixOf` lineStart + || ( "{-" `T.isPrefixOf` lineStart + && not ("{-#" `T.isPrefixOf` lineStart) + ) + in (not startsWithComment, ls'') + -- srcSpanStartCol counts columns starting from 1, so we subtract 1. + -- A multi-line run of @--@ lines reaches us as the source wrote it, so + -- it is dedented the same way a block comment is. startIndent = srcSpanStartCol l - 1 commentLine = srcSpanStartLine l +-- | Turn the source text of a Haddock into a 'Comment'. +-- +-- Only the indentation of the continuation lines is touched, so that the +-- comment can be re-indented along with the code it documents. Nothing is +-- re-prefixed and no Haddock triggers are escaped: the whole point is that +-- what the author wrote comes back out. +mkHaddockComment :: RealLocated Text -> Comment +mkHaddockComment (L l s) = + -- Blank lines are kept: inside a doc comment they are the author's + -- paragraph breaks, not the incidental spacing that 'removeConseqBlanks' + -- tidies up between ordinary comment lines. + Comment False . fmap T.stripEnd . spaceAfterTrigger $ + case NE.nonEmpty (T.lines s) of + Nothing -> s :| [] + Just (x :| xs) -> + let startIndent = srcSpanStartCol l - 1 + getIndent y = + if T.all isSpace y + then startIndent + else T.length (T.takeWhile isSpace y) + n = minimum (startIndent : fmap getIndent xs) + in x :| fmap (T.drop n) xs + +-- | Put a space between a Haddock's trigger and what follows it, so that +-- @-- |Foo@ comes out as @-- | Foo@. +-- +-- Named anchors are left alone: the name in @-- $section@ is part of the +-- anchor, and a space would make it a different one. +spaceAfterTrigger :: NonEmpty Text -> NonEmpty Text +spaceAfterTrigger (x :| xs) = + case go x of + Nothing -> x :| xs + -- The whole comment shifts right by one, not just the first line. + -- Haddock drops a leading space from every line of a doc string when + -- the first line has one, so padding the first line alone would take a + -- space away from all the others. + Just x' -> x' :| fmap indentContinuation xs + where + go t = do + (o, afterOpener) <- opener t + let (spaces, rest) = T.span (== ' ') afterOpener + (trg, body) <- trigger rest + if T.null body || " " `T.isPrefixOf` body + then Nothing + else Just (o <> spaces <> trg <> " " <> body) + indentContinuation t = case opener t of + Just (o, rest) -> o <> " " <> rest + Nothing -> " " <> t + opener t + | Just rest <- T.stripPrefix "--" t = Just ("--", rest) + | Just rest <- T.stripPrefix "{-" t = Just ("{-", rest) + | otherwise = Nothing + trigger t + | Just body <- T.stripPrefix "|" t = Just ("|", body) + | Just body <- T.stripPrefix "^" t = Just ("^", body) + | (stars, body) <- T.span (== '*') t, not (T.null stars) = Just (stars, body) + | otherwise = Nothing + -- | Get a collection of lines from a 'Comment'. -unComment :: Comment -> NonEmpty String +unComment :: Comment -> NonEmpty Text unComment (Comment _ xs) = xs -- | Check whether the 'Comment' had some non-whitespace atoms in front of @@ -143,16 +264,16 @@ -- | Is this comment multiline-style? isMultilineComment :: Comment -> Bool -isMultilineComment (Comment _ (x :| _)) = "{-" `L.isPrefixOf` x +isMultilineComment (Comment _ (x :| _)) = "{-" `T.isPrefixOf` x ---------------------------------------------------------------------------- -- Helpers --- | Detect and extract stack header if it is present. +-- | Detect and extract the stack header if it is present. extractStackHeader :: -- | Comment stream to analyze - [RealLocated String] -> - ([RealLocated String], Maybe (RealLocated Comment)) + [RealLocated Text] -> + ([RealLocated Text], Maybe LComment) extractStackHeader = \case [] -> ([], Nothing) (x : xs) -> @@ -162,61 +283,143 @@ else (x : xs, Nothing) where isStackHeader (Comment _ (x :| _)) = - "stack" `L.isPrefixOf` dropWhile isSpace (drop 2 x) + "stack" `T.isPrefixOf` T.stripStart (T.drop 2 x) -- | Extract pragmas and their associated comments. extractPragmas :: -- | Input - String -> + Text -> + -- | Where the file header ends, if the module has anything after it + Maybe RealSrcLoc -> -- | Comment stream to analyze - [RealLocated String] -> - ([RealLocated Comment], [([RealLocated Comment], Pragma)]) -extractPragmas input = go initialLs id id + [RealLocated Text] -> + ([LComment], [([LComment], Pragma)]) +extractPragmas input headerEnd = go initialLs id id where - initialLs = zip [1 ..] (lines input) + initialLs = zip [1 ..] (T.lines input) + + -- A pragma below the header is not a pragma as far as GHC is + -- concerned, so it stays in the comment stream and is printed where it + -- was written. Hoisting it would both give it an effect it did not + -- have and drag every comment above it to the top of the module. + inHeader x = case headerEnd of + Nothing -> True + Just end -> realSrcSpanStart (getRealSrcSpan x) < end + go ls csSoFar pragmasSoFar = \case [] -> (csSoFar [], pragmasSoFar []) (x : xs) -> case parsePragma (unRealSrcSpan x) of - Nothing -> + Just pragma + | inHeader x -> + let combined ys = (csSoFar ys, pragma) + go' ls' ys rest = go ls' id (pragmasSoFar . (combined ys :)) rest + in case xs of + [] -> go' ls [] xs + (y : ys) -> + let (ls', y') = mkComment ls y + in if onTheSameLine + (RealSrcSpan (getRealSrcSpan x) Strict.Nothing) + (RealSrcSpan (getRealSrcSpan y) Strict.Nothing) + then go' ls' [y'] ys + else go' ls [] xs + _ -> let (ls', x') = mkComment ls x in go ls' (csSoFar . (x' :)) pragmasSoFar xs - Just pragma -> - let combined ys = (csSoFar ys, pragma) - go' ls' ys rest = go ls' id (pragmasSoFar . (combined ys :)) rest - in case xs of - [] -> go' ls [] xs - (y : ys) -> - let (ls', y') = mkComment ls y - in if onTheSameLine - (RealSrcSpan (getRealSrcSpan x) Nothing) - (RealSrcSpan (getRealSrcSpan y) Nothing) - then go' ls' [y'] ys - else go' ls [] xs --- | Get a 'String' from 'GHC.AnnotationComment'. -unAnnotationComment :: GHC.AnnotationComment -> Maybe String -unAnnotationComment = \case - GHC.AnnDocCommentNext _ -> Nothing -- @-- |@ - GHC.AnnDocCommentPrev _ -> Nothing -- @-- ^@ - GHC.AnnDocCommentNamed _ -> Nothing -- @-- $@ - GHC.AnnDocSection _ _ -> Nothing -- @-- *@ - GHC.AnnDocOptions s -> Just s - GHC.AnnLineComment s -> Just s - GHC.AnnBlockComment s -> Just s +-- | Extract @'RealLocated' 'Text'@ from 'GHC.LEpaComment'. +unAnnotationComment :: Text -> GHC.LEpaComment -> Maybe (RealLocated Text) +unAnnotationComment input (L epaLoc (GHC.EpaComment eck _)) = + case eck of + -- A doc comment is taken from the source rather than rebuilt from the + -- 'HsDocString' GHC parsed out of it: rebuilding cannot preserve a + -- @{- | … -}@, nor an empty @-- |@, and losing either changes the AST. + -- A comment that GHC lexed as a doc comment but that did not become + -- part of the AST is not a Haddock at all. It still looks like one, so + -- its trigger is escaped: Ormolu may move it somewhere a Haddock would + -- be accepted, and it must not turn into one there. + GHC.EpaDocComment _ -> + withSpan $ \s -> + Just (escapeOpeningTrigger (normalizeSpacing (sliceSpan input s))) + GHC.EpaDocOptions s -> mkL (T.pack s) + GHC.EpaLineComment (T.pack -> s) -> mkL (normalizeSpacing s) + GHC.EpaBlockComment s -> mkL (T.pack s) + where + realSpan = case epaLoc of + GHC.EpaSpan (RealSrcSpan s _) -> Just s + _ -> Nothing + mkL = case realSpan of + Just s -> Just . L s + Nothing -> const Nothing + withSpan f = do + s <- realSpan + L s <$> f s -liftMaybe :: GenLocated l (Maybe a) -> Maybe (GenLocated l a) -liftMaybe = \case - L _ Nothing -> Nothing - L l (Just a) -> Just (L l a) +-- | Put a space after the dashes of a line comment when there is none. +-- +-- This is the one normalization that survives: @--foo@ becomes @-- foo@ and +-- @--|foo@ becomes @-- |foo@, which is what one expects of a formatter. +-- Everything else about a comment is left as it was written. +normalizeSpacing :: Text -> Text +normalizeSpacing s + | not ("--" `T.isPrefixOf` s) = s + | otherwise = case T.uncons (T.drop 2 s) of + Nothing -> s + Just (c, _) + | c == ' ' || c == '-' -> s + | otherwise -> "-- " <> T.drop 2 s +-- | Escape a Haddock trigger that opens a comment line, so that the line +-- cannot be read as a Haddock wherever it ends up. +-- +-- A line that does not open a comment is left alone: a @*@ in the middle of +-- a @{- … -}@ block is just a character, and escaping it there only +-- disfigures the text. +escapeOpeningTrigger :: Text -> Text +escapeOpeningTrigger t = + case T.stripPrefix "--" t of + Just rest -> "--" <> escapeAfterSpaces rest + Nothing -> case T.stripPrefix "{-" t of + Just rest -> "{-" <> escapeAfterSpaces rest + Nothing -> t + where + escapeAfterSpaces x = + let (spaces, rest) = T.span (== ' ') x + in spaces <> escapeHaddockTriggers rest + +-- | Extract the source text a span covers. +sliceSpan :: Text -> RealSrcSpan -> Text +sliceSpan input spn = + case spannedLines of + [] -> "" + [single] -> T.take (endCol - startCol) (T.drop (startCol - 1) single) + (firstLine : rest) -> + T.intercalate "\n" $ + T.drop (startCol - 1) firstLine : trimLast rest + where + startLine = srcSpanStartLine spn + endLine = srcSpanEndLine spn + startCol = srcSpanStartCol spn + endCol = srcSpanEndCol spn + spannedLines = + take (endLine - startLine + 1) (drop (startLine - 1) (T.lines input)) + trimLast xs = case reverse xs of + [] -> [] + (y : ys) -> reverse (T.take (endCol - 1) y : ys) + -- | Remove consecutive blank lines. -removeConseqBlanks :: NonEmpty String -> NonEmpty String -removeConseqBlanks (x :| xs) = x :| go (null x) id xs +removeConseqBlanks :: NonEmpty Text -> NonEmpty Text +removeConseqBlanks (x :| xs) = x :| go (T.null x) id xs where go seenBlank acc = \case [] -> acc [] (y : ys) -> - if seenBlank && null y + if seenBlank && T.null y then go True acc ys - else go (null y) (acc . (y :)) ys + else go (T.null y) (acc . (y :)) ys + +-- | Escape characters that can turn a line into a Haddock. +escapeHaddockTriggers :: Text -> Text +escapeHaddockTriggers string + | Just (h, _) <- T.uncons string, h `elem` ("|^*$" :: [Char]) = T.cons '\\' string + | otherwise = string diff --git a/src/Ormolu/Parser/Pragma.hs b/src/Ormolu/Parser/Pragma.hs --- a/src/Ormolu/Parser/Pragma.hs +++ b/src/Ormolu/Parser/Pragma.hs @@ -1,82 +1,71 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --- | A module for parsing of pragmas from comments. +-- | A module for parsing pragmas from comments. module Ormolu.Parser.Pragma ( Pragma (..), parsePragma, ) where -import Control.Monad -import Data.Char (isSpace, toLower) -import qualified Data.List as L -import qualified GHC.Data.EnumSet as ES -import GHC.Data.FastString (mkFastString, unpackFS) -import GHC.Data.StringBuffer -import qualified GHC.Parser.Lexer as L +import Data.Char (isSpace) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import GHC.Data.FastString (bytesFS, mkFastString) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.DynFlags (baseDynFlags) +import GHC.Parser.Lexer qualified as L import GHC.Types.SrcLoc -import GHC.Unit.Module (stringToUnitId) +import Ormolu.Utils (textToStringBuffer) -- | Ormolu's representation of pragmas. data Pragma = -- | Language pragma - PragmaLanguage [String] + PragmaLanguage [Text] | -- | GHC options pragma - PragmaOptionsGHC String + PragmaOptionsGHC Text | -- | Haddock options pragma - PragmaOptionsHaddock String + PragmaOptionsHaddock Text deriving (Show, Eq) -- | Extract a pragma from a comment if possible, or return 'Nothing' -- otherwise. parsePragma :: -- | Comment to try to parse - String -> + Text -> Maybe Pragma parsePragma input = do - inputNoPrefix <- L.stripPrefix "{-#" input - guard ("#-}" `L.isSuffixOf` input) - let contents = take (length inputNoPrefix - 3) inputNoPrefix - (pragmaName, cs) = (break isSpace . dropWhile isSpace) contents - case toLower <$> pragmaName of + contents <- T.stripSuffix "#-}" =<< T.stripPrefix "{-#" input + let (pragmaName, cs) = (T.break isSpace . T.dropWhile isSpace) contents + case T.toLower pragmaName of "language" -> PragmaLanguage <$> parseExtensions cs - "options_ghc" -> Just $ PragmaOptionsGHC (trimSpaces cs) - "options_haddock" -> Just $ PragmaOptionsHaddock (trimSpaces cs) + "options_ghc" -> Just $ PragmaOptionsGHC (T.strip cs) + "options_haddock" -> Just $ PragmaOptionsHaddock (T.strip cs) _ -> Nothing - where - trimSpaces :: String -> String - trimSpaces = L.dropWhileEnd isSpace . dropWhile isSpace -- | Assuming the input consists of a series of tokens from a language -- pragma, return the set of enabled extensions. -parseExtensions :: String -> Maybe [String] +parseExtensions :: Text -> Maybe [Text] parseExtensions str = tokenize str >>= go where go = \case - [L.ITconid ext] -> return [unpackFS ext] - (L.ITconid ext : L.ITcomma : xs) -> (unpackFS ext :) <$> go xs + [L.ITconid ext] -> return [fsToText ext] + (L.ITconid ext : L.ITcomma : xs) -> (fsToText ext :) <$> go xs _ -> Nothing + fsToText = T.decodeUtf8 . bytesFS -- | Tokenize a given input using GHC's lexer. -tokenize :: String -> Maybe [L.Token] +tokenize :: Text -> Maybe [L.Token] tokenize input = case L.unP pLexer parseState of L.PFailed {} -> Nothing L.POk _ x -> Just x where location = mkRealSrcLoc (mkFastString "") 1 1 - buffer = stringToStringBuffer input - parseState = L.mkPStatePure parserFlags buffer location - parserFlags = - L.mkParserFlags' - ES.empty - ES.empty - (stringToUnitId "") - True - True - True - True + buffer = textToStringBuffer input + parseState = L.initParserState parserOpts buffer location + parserOpts = initParserOpts baseDynFlags -- | Haskell lexer. pLexer :: L.P [L.Token] diff --git a/src/Ormolu/Parser/Result.hs b/src/Ormolu/Parser/Result.hs --- a/src/Ormolu/Parser/Result.hs +++ b/src/Ormolu/Parser/Result.hs @@ -1,54 +1,59 @@ -{-# LANGUAGE RecordWildCards #-} - --- | A type for result of parsing. +-- | A type for the result of parsing. module Ormolu.Parser.Result - ( ParseResult (..), - prettyPrintParseResult, + ( SourceSnippet (..), + ParseResult (..), + inputComments, ) where +import Data.List (sortOn) +import Data.Maybe (maybeToList) import Data.Text (Text) import GHC.Data.EnumSet (EnumSet) import GHC.Hs import GHC.LanguageExtensions.Type -import GHC.Types.SrcLoc -import Ormolu.Parser.Anns +import GHC.Types.SrcLoc (getLoc) +import Ormolu.Config (SourceType) +import Ormolu.Fixity (ModuleFixityMap) import Ormolu.Parser.CommentStream import Ormolu.Parser.Pragma (Pragma) -import Ormolu.Parser.Shebang (Shebang) +-- | Either a 'ParseResult', or a raw snippet. +data SourceSnippet = RawSnippet Text | ParsedSnippet ParseResult + -- | A collection of data that represents a parsed module in Ormolu. data ParseResult = ParseResult - { -- | 'ParsedSource' from GHC - prParsedSource :: HsModule, - -- | Ormolu-specfic representation of annotations - prAnns :: Anns, + { -- | Parsed module or signature + prParsedSource :: HsModule GhcPs, + -- | Whether this is a regular module or a signature file + prSourceType :: SourceType, -- | Stack header - prStackHeader :: Maybe (RealLocated Comment), - -- | Shebangs found in the input - prShebangs :: [Shebang], + prStackHeader :: Maybe LComment, -- | Pragmas and the associated comments - prPragmas :: [([RealLocated Comment], Pragma)], + prPragmas :: [([LComment], Pragma)], -- | Comment stream prCommentStream :: CommentStream, - -- | Whether or not record dot syntax is enabled - prUseRecordDot :: Bool, + -- | Source text of the module's Haddocks, keyed by span + prHaddockText :: HaddockText, -- | Enabled extensions prExtensions :: EnumSet Extension, - -- | Literal prefix - prLiteralPrefix :: Text, - -- | Literal suffix - prLiteralSuffix :: Text, - -- | Indentation level, can be non-zero in case of region formatting + -- | Fixity map for operators + prModuleFixityMap :: ModuleFixityMap, + -- | Indentation level; can be non-zero in the case of region formatting prIndent :: Int } --- | Pretty-print a 'ParseResult'. -prettyPrintParseResult :: ParseResult -> String -prettyPrintParseResult ParseResult {..} = - unlines - [ "parse result:", - " comment stream:", - showCommentStream prCommentStream - -- XXX extend as needed - ] +-- | All the comments a snippet started with, in source order. +-- +-- This is not simply the comment stream: the Stack header and the comments +-- that precede pragmas are lifted out of the stream while parsing, and are +-- emitted separately. Haddocks, on the other hand, are not included at all, +-- because GHC's parser makes them part of the AST. +inputComments :: ParseResult -> [LComment] +inputComments ParseResult {prStackHeader, prPragmas, prCommentStream} = + sortOn getLoc $ + maybeToList prStackHeader + <> concatMap fst prPragmas + <> streamComments + where + CommentStream streamComments = prCommentStream diff --git a/src/Ormolu/Parser/Shebang.hs b/src/Ormolu/Parser/Shebang.hs deleted file mode 100644 --- a/src/Ormolu/Parser/Shebang.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- | A module for dealing with shebangs. -module Ormolu.Parser.Shebang - ( Shebang (..), - extractShebangs, - isShebang, - ) -where - -import Data.Data (Data) -import qualified Data.List as L -import GHC.Types.SrcLoc - --- | A wrapper for a shebang. -newtype Shebang = Shebang (RealLocated String) - deriving (Eq, Data) - --- | Extract shebangs from the beginning of a comment stream. -extractShebangs :: [RealLocated String] -> ([Shebang], [RealLocated String]) -extractShebangs comments = (Shebang <$> shebangs, rest) - where - (shebangs, rest) = span (isShebang . unLoc) comments - --- | Return 'True' if given 'String' is a shebang. -isShebang :: String -> Bool -isShebang str = "#!" `L.isPrefixOf` str diff --git a/src/Ormolu/Printer.hs b/src/Ormolu/Printer.hs --- a/src/Ormolu/Printer.hs +++ b/src/Ormolu/Printer.hs @@ -1,38 +1,103 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -- | Pretty-printer for Haskell AST. +-- +-- Each snippet is rendered twice. Comments are attached to the elements the +-- printer enters, and the only way to know which elements those are is to +-- render once and see; the first pass therefore runs with no comments at +-- all and is kept only for the spans it visited. See 'render'. module Ormolu.Printer - ( printModule, + ( printSnippets, + printSnippetsWithPlacements, ) where +import Data.Choice (Choice) import Data.Text (Text) +import Data.Text qualified as T +import GHC.Types.SrcLoc (RealSrcSpan) +import Ormolu.Comments.Anchor +import Ormolu.Parser.CommentStream (CommentStream (..)) import Ormolu.Parser.Result import Ormolu.Printer.Combinators +import Ormolu.Printer.CommentPlacement import Ormolu.Printer.Meat.Module -import Ormolu.Printer.SpanStream -import Ormolu.Processing.Postprocess (postprocess) +import Ormolu.Processing.Common --- | Render a module. -printModule :: +-- | Render several source snippets. +printSnippets :: + -- | Whether to print out debug information during printing + Choice "debug" -> -- | Result of parsing - ParseResult -> + [SourceSnippet] -> -- | Resulting rendition Text -printModule ParseResult {..} = - prLiteralPrefix <> region <> prLiteralSuffix +printSnippets debug = T.concat . fmap fst . printSnippetsWithPlacements debug + +-- | Like 'printSnippets', but also return, for each snippet, the placement +-- of every comment it emitted. +-- +-- Snippets are rendered separately and their spans are relative to +-- themselves, so the placements stay grouped by snippet: anything that +-- compares them against the input has to work one snippet at a time. +printSnippetsWithPlacements :: + -- | Whether to print out debug information during printing + Choice "debug" -> + -- | Result of parsing + [SourceSnippet] -> + -- | For each snippet, its rendition and the comments it emitted + [(Text, [CommentPlacement])] +printSnippetsWithPlacements debug = fmap (renderSnippet debug) + +-- | Render one snippet. A snippet that could not be parsed is passed +-- through as it was. +renderSnippet :: + Choice "debug" -> + SourceSnippet -> + (Text, [CommentPlacement]) +renderSnippet debug = \case + ParsedSnippet r -> render debug r + RawSnippet r -> (r, []) + +-- | Render one parsed snippet, along with the placement of every comment it +-- emitted. +-- +-- This renders twice. Anchoring a comment to an element the printer never +-- enters would leave the comment stranded, and there is no way to know +-- which elements those are but to render once and see. The first pass is +-- given an empty 'AnchorMap', so it emits no comments and its output is +-- thrown away; what it is for is the spans it visited, which is what the +-- second pass attaches the comments to. +render :: + Choice "debug" -> + ParseResult -> + (Text, [CommentPlacement]) +render debug r@ParseResult {..} = + let (_, _, visited) = renderWith noComments + (rendered, placements, _) = renderWith (anchorMapFor r visited) + in (rendered, placements) where - region = - postprocess prIndent $ - runR - ( p_hsModule - prStackHeader - prShebangs - prPragmas - prParsedSource - ) - (mkSpanStream prParsedSource) - prCommentStream - prAnns - prUseRecordDot - prExtensions + renderWith anchorMap = + let (rendered, placements, visited) = + runR + ( p_hsModule + prStackHeader + prPragmas + prParsedSource + ) + anchorMap + prSourceType + prExtensions + prModuleFixityMap + debug + prHaddockText + in (reindent prIndent rendered, placements, visited) + +-- | Attach the comments of a snippet to the elements the printer enters. +anchorMapFor :: ParseResult -> [RealSrcSpan] -> AnchorMap +anchorMapFor ParseResult {..} visited = + mkAnchorMap (attachComments comments visited) + where + CommentStream comments = prCommentStream 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 @@ -1,17 +1,17 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | Printing combinators. The definitions here are presented in such an --- order so you can just go through the Haddocks and by the end of the file --- you should have a pretty good idea how to program rendering logic. +-- order that you can just read through the Haddocks, and by the end of the +-- file you should have a pretty good idea of how to program rendering logic. module Ormolu.Printer.Combinators ( -- * The 'R' monad R, runR, - getAnns, getEnclosingSpan, + getCommentsAnchoredWithin, + getCommentsBefore, isExtensionEnabled, -- * Combinators @@ -21,13 +21,18 @@ atom, space, newline, + newlineLiteral, inci, inciIf, - inciHalf, + askSourceType, + askModuleFixityMap, + askDebug, located, + locatedEmpty, located', - realLocated, switchLayout, + switchLayoutWithEnclosingComments, + enterLayout, Layout (..), vlayout, getLayout, @@ -37,6 +42,7 @@ -- ** Formatting lists sep, sepSemi, + sepSemi', canUseBraces, useBraces, dontUseBraces, @@ -47,7 +53,6 @@ backticks, banana, braces, - recordDotBraces, brackets, parens, parensHash, @@ -57,23 +62,33 @@ -- ** Literals comma, commaDel, - equals, -- ** Stateful markers - SpanMark (..), - spanMarkSpan, + LastEmitted (..), + lastEmittedSpan, HaddockStyle (..), - setSpanMark, - getSpanMark, + setLastEmitted, + getLastEmitted, + + -- ** Haddocks + lookupHaddockText, + + -- ** Placement + Placement (..), + placeHanging, ) where import Control.Monad import Data.List (intersperse) +import Data.List.NonEmpty qualified as NE import Data.Text (Text) +import GHC.Data.Strict qualified as Strict +import GHC.Parser.Annotation import GHC.Types.SrcLoc import Ormolu.Printer.Comments import Ormolu.Printer.Internal +import Ormolu.Utils (combineSrcSpans') ---------------------------------------------------------------------------- -- Basic @@ -87,57 +102,126 @@ R () inciIf b m = if b then inci m else m --- | Enter a 'Located' entity. This combinator handles outputting comments --- and sets layout (single-line vs multi-line) for the inner computation. +-- | Enter a 'GenLocated' entity. This combinator handles outputting comments +-- and sets the layout (single-line vs multi-line) for the inner computation. -- Roughly, the rule for using 'located' is that every time there is a -- 'Located' wrapper, it should be “discharged” with a corresponding -- 'located' invocation. located :: + (HasLoc l) => -- | Thing to enter - Located a -> - -- | How to render inner value + GenLocated l a -> + -- | How to render the inner value (a -> R ()) -> R () -located (L (UnhelpfulSpan _) a) f = f a -located (L (RealSrcSpan l _) a) f = realLocated (L l a) f +located (L l' a) f = case locA l' of + UnhelpfulSpan _ -> f a + RealSrcSpan l _ -> do + recordVisitedSpan l + spitPrecedingComments l + withEnclosingSpan l $ + switchLayout [RealSrcSpan l Strict.Nothing] (f a) + spitFollowingComments l --- | See 'located' -realLocated :: - -- | Thing to enter - RealLocated a -> - -- | How to render inner value - (a -> R ()) -> +-- | Give an empty bracketed construct something for a comment written +-- inside it to attach to. +-- +-- Brackets are rendered with 'txt', so an empty export or import list, an +-- empty @[]@ or a record with no fields contains no element at all. A +-- comment written between the brackets would be attached to whatever +-- encloses them and rendered outside them, so a zero-width element is +-- entered at the opening bracket instead. +locatedEmpty :: + -- | Span of the empty construct + SrcSpan -> R () -realLocated (L l a) f = do - spitPrecedingComments l - withEnclosingSpan l $ - switchLayout [RealSrcSpan l Nothing] (f a) - spitFollowingComments l +locatedEmpty l = + let loc = srcSpanStart l + in located (L (mkSrcSpan loc loc) ()) pure --- | A version of 'located' with arguments flipped. +-- | A version of 'located' with the arguments flipped. located' :: - -- | How to render inner value + (HasLoc l) => + -- | How to render the inner value (a -> R ()) -> -- | Thing to enter - Located a -> + GenLocated l a -> R () located' = flip located --- | Set layout according to combination of given 'SrcSpan's for a given. --- Use this only when you need to set layout based on e.g. combined span of --- several elements when there is no corresponding 'Located' wrapper --- provided by GHC AST. It is relatively rare that this one is needed. +-- | Set the layout according to the combination of the given 'SrcSpan's, +-- together with the spans of the comments that belong inside them. -- --- Given empty list this function will set layout to single line. +-- Comments count towards the layout: a construct that would fit on one line +-- has to be broken up anyway if a comment was written inside it, or the +-- comment would swallow whatever follows it on the line. +-- +-- 'located' calls this for you. Call it directly only when the layout has +-- to come from something the GHC AST has no 'Located' wrapper for, such as +-- the combined span of several elements; that is rare. +-- +-- Given an empty list and no comments, this function will set the layout to +-- single-line. switchLayout :: -- | Span that controls layout [SrcSpan] -> -- | Computation to run with changed layout R () -> R () -switchLayout spans' = enterLayout (spansLayout spans') +switchLayout spans' m = do + csSpans <- commentSpansIn (combineSrcSpans' <$> NE.nonEmpty spans') + enterLayout (spansLayout (spans' <> csSpans)) m --- | Which layout combined spans result in? +-- | Like 'switchLayout', but the comments are looked for in the enclosing +-- element rather than in the given spans. +-- +-- This is what a bracketed construct needs. In +-- +-- > ( -- c +-- > x +-- > ) +-- +-- the comment sits between the bracket and @x@, so it is inside neither of +-- them, and the parentheses would be put on one line despite it. Widening +-- the question to the enclosing element catches it. Do not reach for this +-- elsewhere: it is deliberately coarser than 'switchLayout', and applying +-- it where the enclosing element is large would let one comment break every +-- layout decision inside it. +switchLayoutWithEnclosingComments :: + -- | Span that controls layout + [SrcSpan] -> + -- | Computation to run with changed layout + R () -> + R () +switchLayoutWithEnclosingComments spans' m = do + enclosing <- getEnclosingSpan + csSpans <- commentSpansIn (flip RealSrcSpan Strict.Nothing <$> enclosing) + enterLayout (spansLayout (spans' <> csSpans)) m + +-- | The spans of the comments that belong inside the given region: both +-- attached to something in it and written inside it. +-- +-- Both halves are needed. Without the first, a comment anywhere in a +-- declaration would force every layout decision inside that declaration to +-- multi-line. Without the second, a comment trailing an element would force +-- that element itself to be broken up. +-- +-- Haddocks are not consulted here. They do not travel in the anchor map, +-- and their spans sit where the author wrote them rather than where they +-- will be printed, which is the wrong question; see +-- 'Ormolu.Printer.Meat.Common.multiLineIfDocumented'. +commentSpansIn :: Maybe SrcSpan -> R [SrcSpan] +commentSpansIn = \case + Just (RealSrcSpan region _) -> do + comments <- getCommentsAnchoredWithin region + pure + [ RealSrcSpan spn Strict.Nothing + | L spn _ <- comments, + region `containsSpan` spn + ] + _ -> pure [] + +-- | Which layout do the combined spans result in? spansLayout :: [SrcSpan] -> Layout spansLayout = \case [] -> SingleLine @@ -146,14 +230,14 @@ then SingleLine else MultiLine --- | Insert a space if enclosing layout is single-line, or newline if it's --- multiline. +-- | Insert a space if the enclosing layout is single-line, or a newline if +-- it is multi-line. -- -- > breakpoint = vlayout space newline breakpoint :: R () breakpoint = vlayout space newline --- | Similar to 'breakpoint' but outputs nothing in case of single-line +-- | Similar to 'breakpoint', but outputs nothing in the case of single-line -- layout. -- -- > breakpoint' = vlayout (return ()) newline @@ -163,7 +247,7 @@ ---------------------------------------------------------------------------- -- Formatting lists --- | Render a collection of elements inserting a separator between them. +-- | Render a collection of elements, inserting a separator between them. sep :: -- | Separator R () -> @@ -174,9 +258,9 @@ R () sep s f xs = sequence_ (intersperse s (f <$> xs)) --- | Render a collection of elements layout-sensitively using given printer, --- inserting semicolons if necessary and respecting 'useBraces' and --- 'dontUseBraces' combinators. +-- | Render a collection of elements layout-sensitively using the given +-- printer, inserting semicolons if necessary and respecting the 'useBraces' +-- and 'dontUseBraces' combinators. -- -- > useBraces $ sepSemi txt ["foo", "bar"] -- > == vlayout (txt "{ foo; bar }") (txt "foo\nbar") @@ -189,7 +273,25 @@ -- | Elements to render [a] -> R () -sepSemi f xs = vlayout singleLine multiLine +sepSemi = sepSemi' False + +-- | A version of 'sepSemi' that allows one 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 @@ -205,12 +307,15 @@ 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 --- | 'BracketStyle' controlling how closing bracket is rendered. +-- | 'BracketStyle' controlling how the closing bracket is rendered. data BracketStyle = -- | Normal N @@ -218,47 +323,31 @@ S deriving (Eq, Show) --- | Surround given entity by backticks. +-- | Surround the given entity with backticks. backticks :: R () -> R () backticks m = do txt "`" m txt "`" --- | Surround given entity by banana brackets (i.e., from arrow notation.) +-- | Surround the given entity with banana brackets (i.e. from arrow +-- notation). banana :: BracketStyle -> R () -> R () banana = brackets_ True "(|" "|)" --- | Surround given entity by curly braces @{@ and @}@. +-- | Surround the given entity with curly braces @{@ and @}@. braces :: BracketStyle -> R () -> R () braces = brackets_ False "{" "}" --- | Surround record update fields which use RecordDot plugin entity by --- curly braces @{@ and @}@. --- --- @since 0.1.3.1 -recordDotBraces :: R () -> R () -recordDotBraces m = sitcc (vlayout singleLine multiLine) - where - singleLine = do - txt "{" - m - txt "}" - multiLine = do - txt "{" - sitcc m - newline - txt "}" - --- | Surround given entity by square brackets @[@ and @]@. +-- | Surround the given entity with square brackets @[@ and @]@. brackets :: BracketStyle -> R () -> R () brackets = brackets_ False "[" "]" --- | Surround given entity by parentheses @(@ and @)@. +-- | Surround the given entity with parentheses @(@ and @)@. parens :: BracketStyle -> R () -> R () parens = brackets_ False "(" ")" --- | Surround given entity by @(# @ and @ #)@. +-- | Surround the given entity with @(# @ and @ #)@. parensHash :: BracketStyle -> R () -> R () parensHash = brackets_ True "(#" "#)" @@ -323,6 +412,31 @@ commaDel :: R () commaDel = comma >> breakpoint --- | Print @=@. Do not use @'txt' "="@. -equals :: R () -equals = interferingTxt "=" +---------------------------------------------------------------------------- +-- Placement + +-- | Expression placement. This marks the places where expressions that +-- support hanging forms may use them. +data Placement + = -- | Multi-line layout should cause + -- insertion of a newline and an + -- indentation bump + Normal + | -- | Expressions that have a hanging form + -- should use it and avoid bumping one level + -- of indentation + Hanging + deriving (Eq, Show) + +-- | Place a thing that may have a hanging form. This function handles how +-- to separate it from preceding expressions and whether to bump indentation +-- depending on what sort of expression we have. +placeHanging :: Placement -> R () -> R () +placeHanging placement m = + case placement of + Hanging -> do + space + m + Normal -> do + breakpoint + inci m diff --git a/src/Ormolu/Printer/CommentPlacement.hs b/src/Ormolu/Printer/CommentPlacement.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Printer/CommentPlacement.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | A record of where each comment ended up in the rendered output. +-- +-- The printer notes every comment as it emits it. Ormolu then checks that +-- record against the comments of the input, which is how it can promise +-- that formatting neither drops, duplicates, invents nor reorders a +-- comment; see "Ormolu.Comments.Invariants". +module Ormolu.Printer.CommentPlacement + ( CommentPlacement (..), + CommentSlot (..), + slotAnchor, + ) +where + +import GHC.Types.SrcLoc + +---------------------------------------------------------------------------- +-- Types + +-- | Where a comment ended up relative to the AST element it was attached +-- to. +-- +-- Only the distinctions a consumer can act on are kept: whether the comment +-- was attached to an element, and whether it rode along with a pragma. See +-- "Ormolu.Comments.Invariants", which is what reads this. +data CommentSlot + = -- | Attached to the element at this span + SlotAt RealSrcSpan + | -- | Hoisted into the module header along with a pragma. Pragmas are + -- sorted on purpose, so the order such a comment comes out in says + -- nothing. + SlotPragma + | -- | Attached to nothing: the Stack header, or a leftover flushed at the + -- end of the module by 'Ormolu.Printer.Comments.spitRemainingComments' + SlotFloating + deriving (Eq, Show) + +-- | The span of the AST element that a comment was attached to, if the +-- comment was attached to an element at all. +slotAnchor :: CommentSlot -> Maybe RealSrcSpan +slotAnchor = \case + SlotAt spn -> Just spn + SlotPragma -> Nothing + SlotFloating -> Nothing + +-- | A single placement decision: one comment and the slot it was rendered +-- in. +data CommentPlacement = CommentPlacement + { -- | Span of the comment in the input, which is what identifies it + cpSpan :: RealSrcSpan, + -- | Where the comment ended up + cpSlot :: CommentSlot + } + deriving (Eq, Show) diff --git a/src/Ormolu/Printer/Comments.hs b/src/Ormolu/Printer/Comments.hs --- a/src/Ormolu/Printer/Comments.hs +++ b/src/Ormolu/Printer/Comments.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --- | Helpers for formatting of comments. This is low-level code, use +-- | Helpers for formatting comments. This is low-level code; use -- "Ormolu.Printer.Combinators" unless you know what you are doing. module Ormolu.Printer.Comments ( spitPrecedingComments, @@ -9,159 +9,138 @@ spitRemainingComments, spitCommentNow, spitCommentPending, + CommentSlot (..), ) where import Control.Monad -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Maybe (listToMaybe) -import qualified Data.Text as T import GHC.Types.SrcLoc +import Ormolu.Comments.Anchor import Ormolu.Parser.CommentStream +import Ormolu.Printer.CommentPlacement import Ormolu.Printer.Internal ---------------------------------------------------------------------------- -- Top-level --- | Output all preceding comments for an element at given location. +-- | Output all preceding comments for an element at the given location. spitPrecedingComments :: -- | Span of the element to attach comments to RealSrcSpan -> R () spitPrecedingComments ref = do - gotSome <- handleCommentSeries (spitPrecedingComment ref) - when gotSome $ do - lastMark <- getSpanMark + comments <- withAnchorMap (claimBefore ref) + forM_ comments (spitPrecedingComment ref) + unless (null comments) $ do + lastEmitted <- getLastEmitted -- Insert a blank line between the preceding comments and the thing -- after them if there was a blank line in the input. - when (needsNewlineBefore ref lastMark) newline + when (needsNewlineBefore ref lastEmitted) newline --- | Output all comments following an element at given location. +-- | Output all comments following an element at the given location. spitFollowingComments :: -- | Span of the element to attach comments to RealSrcSpan -> R () spitFollowingComments ref = do - trimSpanStream ref - void $ handleCommentSeries (spitFollowingComment ref) + comments <- withAnchorMap (claimTrailing ref) + forM_ comments (spitFollowingComment ref) --- | Output all remaining comments in the comment stream. +-- | Output every comment that no element claimed. +-- +-- This is the safety net that keeps a misattached comment from being lost +-- outright. It also means misattachment is silent, which is why +-- "Ormolu.Comments.Invariants" exists. spitRemainingComments :: R () spitRemainingComments = do - -- Make sure we have a blank a line between the last definition and the + -- Make sure we have a blank line between the last definition and the -- trailing comments. newline - void $ handleCommentSeries spitRemainingComment + comments <- withAnchorMap claimRemaining + forM_ comments spitRemainingComment ---------------------------------------------------------------------------- -- Single-comment functions --- | Output a single preceding comment for an element at given location. +-- | Output a single preceding comment for an element at the given location. spitPrecedingComment :: - -- | Span of the element to attach comments to + -- | Span of the element the comment is attached to RealSrcSpan -> - -- | Are we done? - R Bool -spitPrecedingComment ref = do - mlastMark <- getSpanMark - let p (L l _) = realSrcSpanEnd l <= realSrcSpanStart ref - withPoppedComment p $ \l comment -> do - lineSpans <- thisLineSpans - let thisCommentLine = srcLocLine (realSrcSpanStart l) - needsNewline = - case listToMaybe lineSpans of - Nothing -> False - Just spn -> srcLocLine (realSrcSpanEnd spn) /= thisCommentLine - when (needsNewline || needsNewlineBefore l mlastMark) newline - spitCommentNow l comment - if theSameLinePre l ref - then space - else newline + -- | The comment to output + LComment -> + R () +spitPrecedingComment ref (L l comment) = do + lastEmitted <- getLastEmitted + lineSpans <- thisLineSpans + let thisCommentLine = srcLocLine (realSrcSpanStart l) + needsNewline = + case listToMaybe lineSpans of + Nothing -> False + Just spn -> srcLocLine (realSrcSpanEnd spn) /= thisCommentLine + sameLine = theSameLinePre l ref + when (needsNewline || needsNewlineBefore l lastEmitted) newline + spitCommentNow (SlotAt ref) l comment + if sameLine + then space + else newline --- | Output a comment that follows element at given location immediately on --- the same line, if there is any. +-- | Output a single comment that follows an element at the given location. spitFollowingComment :: - -- | AST element to attach comments to + -- | Span of the element the comment is attached to RealSrcSpan -> - -- | Are we done? - R Bool -spitFollowingComment ref = do - mlastMark <- getSpanMark - mnSpn <- nextEltSpan - -- Get first enclosing span that is not equal to reference span, i.e. it's - -- truly something enclosing the AST element. - meSpn <- getEnclosingSpan (/= ref) - withPoppedComment (commentFollowsElt ref mnSpn meSpn mlastMark) $ \l comment -> - if theSameLinePost l ref - then - if isMultilineComment comment - then space >> spitCommentNow l comment - else spitCommentPending OnTheSameLine l comment - else do - when (needsNewlineBefore l mlastMark) $ - registerPendingCommentLine OnNextLine "" - spitCommentPending OnNextLine l comment + -- | The comment to output + LComment -> + R () +spitFollowingComment ref (L l comment) = do + lastEmitted <- getLastEmitted + if theSameLinePost l ref + then + if isMultilineComment comment + then space >> spitCommentNow (SlotAt ref) l comment + else spitCommentPending (SlotAt ref) OnTheSameLine l comment + else do + -- A comment keeps the blank line the input had in front of it. When + -- nothing carrying a position has been emitted since, the element the + -- comment is attached to is what that blank line separated it from. + let lastEmitted' = case lastEmittedSpan lastEmitted of + Just _ -> lastEmitted + Nothing -> LastEmittedComment ref + when (needsNewlineBefore l lastEmitted') $ + registerPendingCommentLine OnNextLine "" + spitCommentPending (SlotAt ref) OnNextLine l comment --- | Output a single remaining comment from the comment stream. +-- | Output a single unclaimed comment. spitRemainingComment :: - -- | Are we done? - R Bool -spitRemainingComment = do - mlastMark <- getSpanMark - withPoppedComment (const True) $ \l comment -> do - when (needsNewlineBefore l mlastMark) newline - spitCommentNow l comment - newline + -- | The comment to output + LComment -> + R () +spitRemainingComment (L l comment) = do + lastEmitted <- getLastEmitted + when (needsNewlineBefore l lastEmitted) newline + spitCommentNow SlotFloating l comment + newline ---------------------------------------------------------------------------- -- Helpers --- | Output series of comments. -handleCommentSeries :: - -- | Given location of previous comment, output the next comment - -- returning 'True' if we're done - R Bool -> - -- | Whether we printed any comments - R Bool -handleCommentSeries f = go False - where - go gotSome = do - done <- f - if done - then return gotSome - else go True - --- | Try to pop a comment using given predicate and if there is a comment --- matching the predicate, print it out. -withPoppedComment :: - -- | Comment predicate - (RealLocated Comment -> Bool) -> - -- | Printing function - (RealSrcSpan -> Comment -> R ()) -> - -- | Are we done? - R Bool -withPoppedComment p f = do - r <- popComment p - case r of - Nothing -> return True - Just (L l comment) -> False <$ f l comment - --- | Determine if we need to insert a newline between current comment and --- last printed comment. +-- | Determine whether we need to insert a newline between the current +-- comment and the last printed comment. needsNewlineBefore :: -- | Current comment span RealSrcSpan -> - -- | Last printed comment span - Maybe SpanMark -> + -- | What was emitted last + LastEmitted -> Bool -needsNewlineBefore _ (Just (HaddockSpan _ _)) = True -needsNewlineBefore l mlastMark = - case spanMarkSpan <$> mlastMark of +needsNewlineBefore _ (LastEmittedHaddock _) = True +needsNewlineBefore l lastEmitted = + case lastEmittedSpan lastEmitted of Nothing -> False - Just lastMark -> - srcSpanStartLine l > srcSpanEndLine lastMark + 1 + Just lastSpn -> + srcSpanStartLine l > srcSpanEndLine lastSpn + 1 --- | Is the preceding comment and AST element are on the same line? +-- | Are the preceding comment and the AST element on the same line? theSameLinePre :: -- | Current comment span RealSrcSpan -> @@ -171,7 +150,7 @@ theSameLinePre l ref = srcSpanEndLine l == srcSpanStartLine ref --- | Is the following comment and AST element are on the same line? +-- | Are the following comment and the AST element on the same line? theSameLinePost :: -- | Current comment span RealSrcSpan -> @@ -181,106 +160,47 @@ theSameLinePost l ref = srcSpanStartLine l == srcSpanEndLine ref --- | Determine if given comment follows AST element. -commentFollowsElt :: - -- | Location of AST element - RealSrcSpan -> - -- | Location of next AST element - Maybe RealSrcSpan -> - -- | Location of enclosing AST element - Maybe RealSrcSpan -> - -- | Location of last comment in the series - Maybe SpanMark -> - -- | Comment to test - RealLocated Comment -> - Bool -commentFollowsElt ref mnSpn meSpn mlastMark (L l comment) = - -- A comment follows a AST element if all 4 conditions are satisfied: - goesAfter - && logicallyFollows - && noEltBetween - && (continuation || lastInEnclosing || supersedesParentElt) - where - -- 1) The comment starts after end of the AST element: - goesAfter = - realSrcSpanStart l >= realSrcSpanEnd ref - -- 2) The comment logically belongs to the element, four cases: - logicallyFollows = - theSameLinePost l ref -- a) it's on the same line - || continuation -- b) it's a continuation of a comment block - || lastInEnclosing -- c) it's the last element in the enclosing construct - - -- 3) There is no other AST element between this element and the comment: - noEltBetween = - case mnSpn of - Nothing -> True - Just nspn -> - realSrcSpanStart nspn >= realSrcSpanEnd l - -- 4) Less obvious: if column of comment is closer to the start of - -- enclosing element, it probably related to that parent element, not to - -- the current child element. This rule is important because otherwise - -- all comments would end up assigned to closest inner elements, and - -- parent elements won't have a chance to get any comments assigned to - -- them. This is not OK because comments will get indented according to - -- the AST elements they are attached to. - -- - -- Skip this rule if the comment is a continuation of a comment block. - supersedesParentElt = - case meSpn of - Nothing -> True - Just espn -> - let startColumn = srcLocCol . realSrcSpanStart - in startColumn espn > startColumn ref - || ( abs (startColumn espn - startColumn l) - >= abs (startColumn ref - startColumn l) - ) - continuation = - -- A comment is a continuation when it doesn't have non-whitespace - -- lexemes in front of it and goes right after the previous comment. - not (hasAtomsBefore comment) - && ( case mlastMark of - Just (HaddockSpan _ _) -> False - Just (CommentSpan spn) -> - srcSpanEndLine spn + 1 == srcSpanStartLine l - _ -> False - ) - lastInEnclosing = - case meSpn of - -- When there is no enclosing element, return false - Nothing -> False - -- When there is an enclosing element, - Just espn -> - let -- Make sure that the comment is inside the enclosing element - insideParent = realSrcSpanEnd l <= realSrcSpanEnd espn - -- And check if the next element is outside of the parent - nextOutsideParent = case mnSpn of - Nothing -> True - Just nspn -> realSrcSpanEnd espn < realSrcSpanStart nspn - in insideParent && nextOutsideParent - -- | Output a 'Comment' immediately. This is a low-level printing function. -spitCommentNow :: RealSrcSpan -> Comment -> R () -spitCommentNow spn comment = do +-- +-- Note that it records the placement as well as printing. Every path that +-- emits a comment has to go through this or 'spitCommentPending', or +-- "Ormolu.Comments.Invariants" will report the comment as dropped and +-- Ormolu will refuse to format the file. +spitCommentNow :: + -- | The slot the comment is being rendered in + CommentSlot -> + RealSrcSpan -> + Comment -> + R () +spitCommentNow slot spn comment = do + recordCommentPlacement CommentPlacement {cpSpan = spn, cpSlot = slot} sitcc . sequence_ . NE.intersperse newline - . fmap (txt . T.pack) + . fmap txt . unComment $ comment - setSpanMark (CommentSpan spn) + setLastEmitted (LastEmittedComment spn) --- | Output a 'Comment' at the end of correct line or after it depending on --- 'CommentPosition'. Used for comments that may potentially follow on the --- same line as something we just rendered, but not immediately after it. -spitCommentPending :: CommentPosition -> RealSrcSpan -> Comment -> R () -spitCommentPending position spn comment = do +-- | Output a 'Comment' at the end of the correct line, or after it, +-- depending on the 'CommentPosition'. Used for comments that may follow on +-- the same line as something we just rendered, but not immediately after it. +spitCommentPending :: + -- | The slot the comment is being rendered in + CommentSlot -> + CommentPosition -> + RealSrcSpan -> + Comment -> + R () +spitCommentPending slot position spn comment = do + recordCommentPlacement CommentPlacement {cpSpan = spn, cpSlot = slot} let wrapper = case position of OnTheSameLine -> sitcc OnNextLine -> id wrapper . sequence_ . NE.toList - . fmap (registerPendingCommentLine position . T.pack) + . fmap (registerPendingCommentLine position) . unComment $ comment - setSpanMark (CommentSpan spn) + setLastEmitted (LastEmittedComment spn) 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 @@ -1,9 +1,8 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} --- | In most cases import "Ormolu.Printer.Combinators" instead, these +-- | In most cases, import "Ormolu.Printer.Combinators" instead; these -- functions are the low-level building blocks and should not be used on -- their own. The 'R' monad is re-exported from "Ormolu.Printer.Combinators" -- as well. @@ -14,13 +13,14 @@ -- * Internal functions txt, - interferingTxt, atom, space, newline, - useRecordDot, + newlineLiteral, + askSourceType, + askModuleFixityMap, + askDebug, inci, - inciHalf, sitcc, Layout (..), enterLayout, @@ -35,53 +35,61 @@ -- * Special helpers for comment placement CommentPosition (..), registerPendingCommentLine, - trimSpanStream, - nextEltSpan, - popComment, + withAnchorMap, + getCommentsAnchoredWithin, + getCommentsBefore, getEnclosingSpan, withEnclosingSpan, thisLineSpans, -- * Stateful markers - SpanMark (..), - spanMarkSpan, + LastEmitted (..), + lastEmittedSpan, + setLastEmitted, + getLastEmitted, + + -- * Haddocks HaddockStyle (..), - setSpanMark, - getSpanMark, + lookupHaddockText, - -- * Annotations - getAnns, + -- * Recording comment placement + recordCommentPlacement, + recordVisitedSpan, -- * Extensions isExtensionEnabled, ) where +import Control.Monad import Control.Monad.Reader import Control.Monad.State.Strict import Data.Bool (bool) -import Data.Coerce +import Data.Choice (Choice) +import Data.List (find) +import Data.Map.Strict qualified as M import Data.Maybe (listToMaybe) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Builder import GHC.Data.EnumSet (EnumSet) -import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.EnumSet qualified as EnumSet import GHC.LanguageExtensions.Type -import GHC.Parser.Annotation import GHC.Types.SrcLoc import GHC.Utils.Outputable (Outputable) -import Ormolu.Parser.Anns +import Ormolu.Comments.Anchor (AnchorMap, commentsAnchoredWithin, commentsBefore) +import Ormolu.Config (SourceType (..)) +import Ormolu.Fixity (ModuleFixityMap) import Ormolu.Parser.CommentStream -import Ormolu.Printer.SpanStream +import Ormolu.Printer.CommentPlacement import Ormolu.Utils (showOutputable) ---------------------------------------------------------------------------- -- The 'R' monad -- | The 'R' monad hosts combinators that allow us to describe how to render --- AST. +-- the AST. newtype R a = R (ReaderT RC (State SC) a) deriving (Functor, Applicative, Monad) @@ -93,16 +101,20 @@ rcIndent :: !Int, -- | Current layout rcLayout :: Layout, - -- | Spans of enclosing elements of AST + -- | Spans of enclosing elements of the AST rcEnclosingSpans :: [RealSrcSpan], - -- | Collection of annotations - rcAnns :: Anns, -- | Whether the last expression in the layout can use braces rcCanUseBraces :: Bool, - -- | Whether the source could have used the record dot preprocessor - rcUseRecDot :: Bool, -- | Enabled extensions - rcExtensions :: EnumSet Extension + rcExtensions :: EnumSet Extension, + -- | Whether the source is a signature or a regular module + rcSourceType :: SourceType, + -- | Module fixity map + rcModuleFixityMap :: ModuleFixityMap, + -- | Whether to print out debug information during printing + rcDebug :: !(Choice "debug"), + -- | Source text of the module's Haddocks + rcHaddockText :: HaddockText } -- | State context of 'R'. @@ -113,22 +125,26 @@ scIndent :: !Int, -- | Rendered source code so far scBuilder :: Builder, - -- | Span stream - scSpanStream :: SpanStream, -- | Spans of atoms that have been printed on the current line so far scThisLineSpans :: [RealSrcSpan], - -- | Comment stream - scCommentStream :: CommentStream, - -- | Pending comment lines (in reverse order) to be inserted before next - -- newline, 'Int' is the indentation level + -- | Comments that have not been emitted yet, by the element they are + -- attached to + scAnchorMap :: AnchorMap, + -- | Pending comment lines (in reverse order) to be inserted before the + -- next newline scPendingComments :: ![(CommentPosition, Text)], -- | Whether to output a space before the next output scRequestedDelimiter :: !RequestedDelimiter, - -- | An auxiliary marker for keeping track of last output element - scSpanMark :: !(Maybe SpanMark) + -- | What was emitted last, used both for preserving blank lines from + -- the input and for recognizing runs of comments + scLastEmitted :: !LastEmitted, + -- | Comment placement decisions made so far, in reverse order + scCommentPlacements :: [CommentPlacement], + -- | Spans of the elements the printer has entered, in reverse order + scVisitedSpans :: [RealSrcSpan] } --- | Make sure next output is delimited by one of the following. +-- | Make sure the next output is delimited by one of the following. data RequestedDelimiter = -- | A space RequestedSpace @@ -144,17 +160,17 @@ -- | 'Layout' options. data Layout - = -- | Put everything on single line + = -- | Put everything on a single line SingleLine | -- | Use multiple lines MultiLine deriving (Eq, Show) --- | Modes for rendering of pending comments. +-- | Modes for rendering pending comments. data CommentPosition = -- | Put the comment on the same line OnTheSameLine - | -- | Put the comment on next line + | -- | Put the comment on the next line OnNextLine deriving (Eq, Show) @@ -162,42 +178,52 @@ runR :: -- | Monad to run R () -> - -- | Span stream - SpanStream -> - -- | Comment stream - CommentStream -> - -- | Annotations - Anns -> - -- | Use Record Dot Syntax - Bool -> + -- | Comments, attached to the elements they belong to + AnchorMap -> + -- | Whether the source is a signature or a regular module + SourceType -> -- | Enabled extensions EnumSet Extension -> - -- | Resulting rendition - Text -runR (R m) sstream cstream anns recDot extensions = - TL.toStrict . toLazyText . scBuilder $ execState (runReaderT m rc) sc + -- | Module fixity map + ModuleFixityMap -> + -- | Whether to print out debug information during printing + Choice "debug" -> + -- | Source text of the module's Haddocks + HaddockText -> + -- | The rendition, the comment placement decisions that were made along + -- the way, and the spans of the elements that were entered + (Text, [CommentPlacement], [RealSrcSpan]) +runR (R m) anchorMap sourceType extensions moduleFixityMap debug haddockText = + ( TL.toStrict . toLazyText . scBuilder $ finalSc, + reverse (scCommentPlacements finalSc), + reverse (scVisitedSpans finalSc) + ) where + finalSc = execState (runReaderT m rc) sc rc = RC { rcIndent = 0, rcLayout = MultiLine, rcEnclosingSpans = [], - rcAnns = anns, rcCanUseBraces = False, - rcUseRecDot = recDot, - rcExtensions = extensions + rcExtensions = extensions, + rcSourceType = sourceType, + rcModuleFixityMap = moduleFixityMap, + rcDebug = debug, + rcHaddockText = haddockText } sc = SC { scColumn = 0, scIndent = 0, scBuilder = mempty, - scSpanStream = sstream, scThisLineSpans = [], - scCommentStream = cstream, + scAnchorMap = anchorMap, scPendingComments = [], scRequestedDelimiter = VeryBeginning, - scSpanMark = Nothing + scLastEmitted = LastEmittedOther, + scCommentPlacements = [], + scVisitedSpans = [] } ---------------------------------------------------------------------------- @@ -208,12 +234,7 @@ data SpitType = -- | Simple opaque text that breaks comment series. SimpleText - | -- | Like 'SimpleText', but assume that when this text is inserted it - -- will separate an 'Atom' and its pending comments, so insert an extra - -- 'newline' in that case to force the pending comments and continue on - -- a fresh line. - InterferingText - | -- | An atom that typically have span information in the AST and can + | -- | An atom that typically has span information in the AST and can -- have comments attached to it. Atom | -- | Used for rendering comment lines. @@ -233,19 +254,11 @@ R () txt = spit SimpleText --- | Similar to 'txt' but the text inserted this way is assumed to break the --- “link” between the preceding atom and its pending comments. -interferingTxt :: - -- | 'Text' to output - Text -> - R () -interferingTxt = spit InterferingText - --- | Output 'Outputable' fragment of AST. This can be used to output numeric --- literals and similar. Everything that doesn't have inner structure but --- does have an 'Outputable' instance. +-- | Output an 'Outputable' fragment of the AST. This can be used to output +-- numeric literals and similar: anything that doesn't have inner structure +-- but does have an 'Outputable' instance. atom :: - Outputable a => + (Outputable a) => a -> R () atom = spit Atom . T.pack . showOutputable @@ -260,8 +273,6 @@ spit _ "" = return () spit stype text = do requestedDel <- R (gets scRequestedDelimiter) - pendingComments <- R (gets scPendingComments) - when (stype == InterferingText && not (null pendingComments)) newline case requestedDel of RequestedNewline -> do R . modify $ \sc -> @@ -275,7 +286,7 @@ R $ do i <- asks rcIndent c <- gets scColumn - closestEnclosing <- listToMaybe <$> asks rcEnclosingSpans + closestEnclosing <- asks (listToMaybe . rcEnclosingSpans) let indentedTxt = spaces <> text spaces = T.replicate spacesN " " spacesN = @@ -298,12 +309,12 @@ Just x -> x : xs _ -> xs, scRequestedDelimiter = RequestedNothing, - scSpanMark = + scLastEmitted = -- If there are pending comments, do not reset last comment -- location. if (stype == CommentPart) || (not . null . scPendingComments) sc - then scSpanMark sc - else Nothing + then scLastEmitted sc + else LastEmittedOther } -- | This primitive /does not/ necessarily output a space. It just ensures @@ -322,18 +333,25 @@ other -> other } --- | Output a newline. First time 'newline' is used after some non-'newline' --- output it gets inserted immediately. Second use of 'newline' does not --- output anything but makes sure that the next non-white space output will --- be prefixed by a newline. Using 'newline' more than twice in a row has no --- effect. Also, using 'newline' at the very beginning has no effect, this --- is to avoid leading whitespace. +-- | Output a newline. The first time 'newline' is used after some +-- non-'newline' output, it gets inserted immediately. The second use of +-- 'newline' does not output anything but makes sure that the next +-- non-whitespace output will be prefixed by a newline. Using 'newline' more +-- than twice in a row has no effect. Also, using 'newline' at the very +-- beginning has no effect; this is to avoid leading whitespace. -- -- Similarly to 'space', this design prevents trailing newlines and makes it -- hard to output more than one blank newline in a row. newline :: R () newline = do - indent <- R (gets scIndent) + lineIndent <- R (gets scIndent) + logicalIndent <- R (asks rcIndent) + -- A trailing comment block spills onto the lines below the code it + -- trails. Those lines take the indentation of the line the block started + -- on, unless the construct being printed is indented further, in which + -- case they follow it: dropping to the start of the line would put the + -- rest of a block comment outside the declaration it was written in. + let indent = max lineIndent logicalIndent cs <- reverse <$> R (gets scPendingComments) case cs of [] -> newlineRaw @@ -378,10 +396,32 @@ _ -> AfterNewline } --- | Return 'True' if we should print record dot syntax. -useRecordDot :: R Bool -useRecordDot = R (asks rcUseRecDot) +-- | Insert a literal newline without modifying the internal state of the +-- printer. This is to be used in exceptional cases, 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 +askSourceType = R (asks rcSourceType) + +-- | Retrieve the module fixity map. +askModuleFixityMap :: R ModuleFixityMap +askModuleFixityMap = R (asks rcModuleFixityMap) + +-- | Retrieve whether we should print out certain debug information while +-- printing. +askDebug :: R (Choice "debug") +askDebug = R (asks rcDebug) + inciBy :: Int -> R () -> R () inciBy step (R m) = R (local modRC m) where @@ -390,21 +430,16 @@ { rcIndent = rcIndent rc + step } --- | Increase indentation level by one indentation step for the inner --- computation. 'inci' should be used when a part of code must be more +-- | Increase the indentation level by one indentation step for the inner +-- computation. 'inci' should be used when a piece of code must be more -- indented relative to the parts outside of 'inci' in order for the output --- to be valid Haskell. When layout is single-line there is no obvious --- effect, but with multi-line layout correct indentation levels matter. +-- to be valid Haskell. With single-line layout there is no visible effect, +-- but with multi-line layout correct indentation levels matter. inci :: R () -> R () inci = inciBy indentStep --- | In rare cases, we have to indent by a positive amount smaller --- than 'indentStep'. -inciHalf :: R () -> R () -inciHalf = inciBy $ (indentStep `div` 2) `max` 1 - --- | Set indentation level for the inner computation equal to current --- column. This makes sure that the entire inner block is uniformly +-- | Set the indentation level for the inner computation equal to the +-- current column. This makes sure that the entire inner block is uniformly -- \"shifted\" to the right. sitcc :: R () -> R () sitcc (R m) = do @@ -417,7 +452,7 @@ } R (local modRC m) --- | Set 'Layout' for internal computation. +-- | Set the 'Layout' for the inner computation. enterLayout :: Layout -> R () -> R () enterLayout l (R m) = R (local modRC m) where @@ -426,7 +461,7 @@ { rcLayout = l } --- | Do one or another thing depending on current 'Layout'. +-- | Do one thing or another depending on the current 'Layout'. vlayout :: -- | Single line R a -> @@ -439,17 +474,17 @@ SingleLine -> sline MultiLine -> mline --- | Get current 'Layout'. +-- | Get the current 'Layout'. getLayout :: R Layout getLayout = R (asks rcLayout) ---------------------------------------------------------------------------- -- Special helpers for comment placement --- | Register a comment line for outputting. It will be inserted right --- before next newline. When the comment goes after something else on the --- same line, a space will be inserted between preceding text and the --- comment when necessary. +-- | Register a comment line for output. It will be inserted right before +-- the next newline. When the comment goes after something else on the same +-- line, a space will be inserted between the preceding text and the comment +-- when necessary. registerPendingCommentLine :: -- | Comment position CommentPosition -> @@ -462,54 +497,42 @@ { scPendingComments = (position, text) : scPendingComments sc } --- | Drop elements that begin before or at the same place as given --- 'SrcSpan'. -trimSpanStream :: - -- | Reference span - RealSrcSpan -> - R () -trimSpanStream ref = do - let leRef :: RealSrcSpan -> Bool - leRef x = realSrcSpanStart x <= realSrcSpanStart ref - R . modify $ \sc -> - sc - { scSpanStream = coerce (dropWhile leRef) (scSpanStream sc) - } +-- | Claim comments from the anchor map, storing what is left. +withAnchorMap :: (AnchorMap -> (a, AnchorMap)) -> R a +withAnchorMap f = R . state $ \sc -> + let (a, am) = f (scAnchorMap sc) + in (a, sc {scAnchorMap = am}) --- | Get location of next element in AST. -nextEltSpan :: R (Maybe RealSrcSpan) -nextEltSpan = listToMaybe . coerce <$> R (gets scSpanStream) +-- | Get the comments that will be printed before the element at the given +-- span. Like 'getCommentsAnchoredWithin', this only looks; it does not +-- claim. +getCommentsBefore :: RealSrcSpan -> R [LComment] +getCommentsBefore spn = withAnchorMap (\am -> (commentsBefore spn am, am)) --- | Pop a 'Comment' from the 'CommentStream' if given predicate is --- satisfied and there are comments in the stream. -popComment :: - (RealLocated Comment -> Bool) -> - R (Maybe (RealLocated Comment)) -popComment f = R $ do - CommentStream cstream <- gets scCommentStream - case cstream of - [] -> return Nothing - (x : xs) -> - if f x - then - Just x - <$ modify - ( \sc -> - sc - { scCommentStream = CommentStream xs - } - ) - else return Nothing +-- | Get the comments attached to the element at the given span, or to +-- anything inside it. +-- +-- This only looks; it does not claim. The layout decisions that ask this +-- run before the comments are emitted, and claiming here would leave +-- nothing for the printer to emit later. +getCommentsAnchoredWithin :: RealSrcSpan -> R [LComment] +getCommentsAnchoredWithin region = + withAnchorMap (\am -> (commentsAnchoredWithin region am, am)) --- | Get the first enclosing 'RealSrcSpan' that satisfies given predicate. -getEnclosingSpan :: +-- | Get the immediately enclosing 'RealSrcSpan'. +getEnclosingSpan :: R (Maybe RealSrcSpan) +getEnclosingSpan = getEnclosingSpanWhere (const True) + +-- | Get the first enclosing 'RealSrcSpan' that satisfies the given +-- predicate. +getEnclosingSpanWhere :: -- | Predicate to use (RealSrcSpan -> Bool) -> R (Maybe RealSrcSpan) -getEnclosingSpan f = - listToMaybe . filter f <$> R (asks rcEnclosingSpans) +getEnclosingSpanWhere f = + find f <$> R (asks rcEnclosingSpans) --- | Set 'RealSrcSpan' of enclosing span for the given computation. +-- | Set the 'RealSrcSpan' of the enclosing span for the given computation. withEnclosingSpan :: RealSrcSpan -> R () -> R () withEnclosingSpan spn (R m) = R (local modRC m) where @@ -525,23 +548,44 @@ ---------------------------------------------------------------------------- -- Stateful markers --- | An auxiliary marker for keeping track of last output element. -data SpanMark - = -- | Haddock comment - HaddockSpan HaddockStyle RealSrcSpan - | -- | Non-haddock comment - CommentSpan RealSrcSpan - | -- | A statement in a do-block and such span - StatementSpan RealSrcSpan +-- | What the printer emitted last, and where it came from in the input. +-- +-- This is about spacing, not about attachment: it is what lets a blank line +-- in the input be preserved in the output, and what lets a run of comment +-- lines be recognized as one. Statements are tracked for the first of those +-- reasons, Haddocks for the second. +data LastEmitted + = -- | Nothing yet, or ordinary code + LastEmittedOther + | -- | A comment occupying the given span of the input + LastEmittedComment RealSrcSpan + | -- | A Haddock occupying the given span of the input + LastEmittedHaddock RealSrcSpan + | -- | A statement of a layout block occupying the given span + LastEmittedStatement RealSrcSpan + deriving (Eq, Show) --- | Project 'RealSrcSpan' from 'SpanMark'. -spanMarkSpan :: SpanMark -> RealSrcSpan -spanMarkSpan = \case - HaddockSpan _ s -> s - CommentSpan s -> s - StatementSpan s -> s +-- | Where the last emitted thing came from in the input, if it came from +-- anywhere in particular. +lastEmittedSpan :: LastEmitted -> Maybe RealSrcSpan +lastEmittedSpan = \case + LastEmittedOther -> Nothing + LastEmittedComment s -> Just s + LastEmittedHaddock s -> Just s + LastEmittedStatement s -> Just s --- | Haddock string style. +-- | Record what was emitted last. +setLastEmitted :: LastEmitted -> R () +setLastEmitted lastEmitted = R . modify $ \sc -> + sc + { scLastEmitted = lastEmitted + } + +-- | Report what was emitted last. +getLastEmitted :: R LastEmitted +getLastEmitted = R (gets scLastEmitted) + +-- | Haddock string style, i.e. the trigger a Haddock is rendered with. data HaddockStyle = -- | @-- |@ Pipe @@ -552,28 +596,38 @@ | -- | @-- $@ Named String --- | Set span of last output comment. -setSpanMark :: - -- | Span mark to set - SpanMark -> - R () -setSpanMark spnMark = R . modify $ \sc -> - sc - { scSpanMark = Just spnMark - } - --- | Get span of last output comment. -getSpanMark :: R (Maybe SpanMark) -getSpanMark = R (gets scSpanMark) +-- | The source text of the Haddock at the given span, if it is one of the +-- module's Haddocks. See 'Ormolu.Parser.CommentStream.HaddockText'. +lookupHaddockText :: RealSrcSpan -> R (Maybe Comment) +lookupHaddockText spn = R (asks (M.lookup spn . rcHaddockText)) ---------------------------------------------------------------------------- --- Annotations +-- Recording comment placement --- | For a given span return 'AnnKeywordId's associated with it. -getAnns :: - SrcSpan -> - R [AnnKeywordId] -getAnns spn = lookupAnns spn <$> R (asks rcAnns) +-- | Record the fact that a comment was rendered in a particular slot. +-- +-- Every code path that emits a comment has to call this. What is recorded +-- here is what "Ormolu.Comments.Invariants" checks the input's comments +-- against, so a comment emitted without being recorded is reported as +-- dropped and Ormolu refuses to format the file. +recordCommentPlacement :: CommentPlacement -> R () +recordCommentPlacement placement = R . modify $ \sc -> + sc + { scCommentPlacements = placement : scCommentPlacements sc + } + +-- | Record that the printer entered the element with the given span. +-- +-- Not every span in the AST is entered: the printer renders plenty of +-- syntax with 'txt' rather than through 'Ormolu.Printer.Combinators.located', +-- so a @where@ clause, for instance, has a span but is never entered. A +-- comment can only be attached to an element that is entered, because +-- entering it is the only moment at which the comment could be emitted. +recordVisitedSpan :: RealSrcSpan -> R () +recordVisitedSpan spn = R . modify $ \sc -> + sc + { scVisitedSpans = spn : scVisitedSpans sc + } ---------------------------------------------------------------------------- -- Helpers for braces 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 @@ -1,5 +1,9 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} -- | Rendering of commonly useful bits. module Ormolu.Printer.Meat.Common @@ -7,27 +11,43 @@ p_hsmodName, p_ieWrappedName, p_rdrName, - doesNotNeedExtraParens, p_qualName, p_infixDefHelper, - p_hsDocString, + p_hsDoc, + p_hsDocInline, + multiLineIfDocumented, + switchLayoutDocumented, + hasLineHaddocks, p_hsDocName, p_sourceText, + p_namespaceSpec, + p_hsMultAnn, ) where import Control.Monad -import Data.List (isPrefixOf) -import qualified Data.Text as T +import Data.Choice (Choice, pattern Is, pattern Isn't, pattern With) +import Data.Choice qualified as Choice +import Data.Data (Data) +import Data.Generics.Schemes (listify) +import Data.List.NonEmpty qualified as NE +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Data.FastString +import GHC.Hs.Binds import GHC.Hs.Doc +import GHC.Hs.Extension (GhcPs) import GHC.Hs.ImpExp +import GHC.Hs.Type +import GHC.LanguageExtensions.Type (Extension (..)) import GHC.Parser.Annotation -import GHC.Types.Basic -import GHC.Types.Name (nameStableString) -import GHC.Types.Name.Occurrence (OccName (..)) +import GHC.Types.Name.Occurrence (OccName (..), occNameString) import GHC.Types.Name.Reader +import GHC.Types.SourceText import GHC.Types.SrcLoc -import GHC.Unit.Module.Name +import Language.Haskell.Syntax.Module.Name +import Ormolu.Config (SourceType (..)) +import Ormolu.Parser.CommentStream (Comment, isMultilineComment, unComment) import Ormolu.Printer.Combinators import Ormolu.Utils @@ -38,98 +58,105 @@ | -- | Top-level declarations Free +-- | Output the name of the module-like entity, preceded by the correct +-- prefix (@module@ or @signature@). p_hsmodName :: ModuleName -> R () p_hsmodName mname = do - txt "module" + sourceType <- askSourceType + txt $ case sourceType of + ModuleSource -> "module" + SignatureSource -> "signature" space atom mname -p_ieWrappedName :: IEWrappedName RdrName -> R () +p_ieWrappedName :: IEWrappedName GhcPs -> R () p_ieWrappedName = \case - IEName x -> p_rdrName x - IEPattern x -> do + IEName _ x -> p_rdrName x + IEDefault _ x -> do + txt "default" + space + p_rdrName x + IEPattern _ x -> do txt "pattern" space p_rdrName x - IEType x -> do + IEType _ x -> do txt "type" space p_rdrName x + IEData _ x -> do + txt "data" + space + p_rdrName x --- | Render a @'Located' 'RdrName'@. -p_rdrName :: Located RdrName -> R () -p_rdrName l@(L spn _) = located l $ \x -> do - ids <- getAnns spn - let backticksWrapper = - if AnnBackquote `elem` ids - then backticks - else id - parensWrapper = - if AnnOpenP `elem` ids - then parens N - else id - singleQuoteWrapper = - if AnnSimpleQuote `elem` ids - then \y -> do - txt "'" - y - else id - m = - case x of - Unqual occName -> - atom occName - Qual mname occName -> - p_qualName mname occName - Orig _ occName -> - -- This is used when GHC generates code that will be fed into - -- the renamer (e.g. from deriving clauses), but where we want - -- to say that something comes from given module which is not - -- specified in the source code, e.g. @Prelude.map@. - -- - -- My current understanding is that the provided module name - -- serves no purpose for us and can be safely ignored. - atom occName - Exact name -> - atom name - m' = backticksWrapper (singleQuoteWrapper m) - if doesNotNeedExtraParens x - then m' - else parensWrapper m' +-- | Render a @'LocatedN' 'RdrName'@. +p_rdrName :: LocatedN RdrName -> R () +p_rdrName l = located l $ \x -> do + unboxedSums <- isExtensionEnabled UnboxedSums + let wrapper EpAnn {anns} = case anns of + NameAnnQuote {nann_quoted} -> tickPrefix . wrapper nann_quoted + NameAnn {nann_adornment = NameParens {}} -> + parens N . handleUnboxedSumsAndHashInteraction + NameAnn {nann_adornment = NameBackquotes {}} -> backticks + -- whether the `->` identifier is parenthesized + NameAnnRArrow {nann_mopen = Just _} -> parens N + -- special case for unboxed unit tuples + NameAnnOnly {nann_adornment = NameParensHash {}} -> const $ txt "(# #)" + -- An empty list reaches the printer as a name, not as a list, so + -- this is the only place a comment written between its brackets can + -- be given something to attach to. + NameAnnOnly {nann_adornment = NameSquare open _} -> + const $ brackets N (locatedEmpty (getEpTokenSrcSpan open)) + _ -> id --- | Whether given name should not have parentheses around it. This is used --- to detect e.g. tuples for which annotations will indicate parentheses, --- but the parentheses are already part of the symbol, so no extra layer of --- parentheses should be added. It also detects the [] literal. -doesNotNeedExtraParens :: RdrName -> Bool -doesNotNeedExtraParens = \case - Exact name -> - let s = nameStableString name - in -- I'm not sure this "stable string" is stable enough, but it looks - -- like this is the most robust way to tell if we're looking at - -- exactly this piece of built-in syntax. - ("$ghc-prim$GHC.Tuple$" `isPrefixOf` s) - || ("$ghc-prim$GHC.Types$[]" `isPrefixOf` s) - _ -> False + -- When UnboxedSums is enabled, `(#` is a single lexeme, so we have to + -- insert spaces when we have a parenthesized operator starting with `#`. + handleUnboxedSumsAndHashInteraction + | unboxedSums, + -- Qualified names do not start with a `#`. + Unqual (occNameString -> '#' : _) <- x = + \y -> space *> y <* space + | otherwise = id + wrapper (getLoc l) $ case x of + Unqual occName -> + atom occName + Qual mname occName -> + p_qualName mname occName + Orig _ occName -> + -- This is used when GHC generates code that will be fed into + -- the renamer (e.g. from deriving clauses), but where we want + -- to say that something comes from a given module that is not + -- specified in the source code, e.g. @Prelude.map@. + -- + -- My current understanding is that the provided module name + -- serves no purpose for us and can be safely ignored. + atom occName + Exact name -> + atom name + where + tickPrefix y = txt "'" *> y + p_qualName :: ModuleName -> OccName -> R () p_qualName mname occName = do atom mname txt "." atom occName --- | A helper for formatting infix constructions in lhs of definitions. +-- | A helper for formatting infix constructions on the left-hand side 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 @@ -142,56 +169,198 @@ 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_hsDocString :: +-- +-- The author's own text is reused whenever it can be, so a @{- | … -}@ +-- comes back as a block comment and an empty @-- |@ survives; see +-- 'haddockAsWritten' for when it cannot be. Otherwise the Haddock is +-- rebuilt from its 'HsDocString'. +p_hsDoc :: -- | Haddock style HaddockStyle -> -- | Finish the doc string with a newline - Bool -> - -- | The doc string to render - LHsDocString -> + Choice "endNewline" -> + -- | The 'LHsDoc' to render + LHsDoc GhcPs -> R () -p_hsDocString hstyle needsNewline (L l str) = do - let isCommentSpan = \case - HaddockSpan _ _ -> True - CommentSpan _ -> True +p_hsDoc hstyle needsNewline = p_hsDocWith hstyle needsNewline (Isn't #mayShareLine) + +-- | 'p_hsDoc' for a Haddock inside a construct that may legitimately be laid +-- out on one line. +-- +-- A Haddock that comes back out as @{- | … -}@ is self-delimiting, so it +-- ends with a 'breakpoint' rather than a newline and can share the line: +-- @data A = A {- | a number -} Int Bool@ stays as written. One rendered as +-- @--@ lines still ends the line, since it owns the rest of it. +p_hsDocInline :: HaddockStyle -> LHsDoc GhcPs -> R () +p_hsDocInline hstyle = p_hsDocWith hstyle (With #endNewline) (Is #mayShareLine) + +-- | The worker behind 'p_hsDoc' and 'p_hsDocInline'. +p_hsDocWith :: + HaddockStyle -> + Choice "endNewline" -> + Choice "mayShareLine" -> + LHsDoc GhcPs -> + R () +p_hsDocWith hstyle needsNewline mayShareLine (L l str) = do + let goesAfterCommentOrHaddock = \case + LastEmittedHaddock _ -> True + LastEmittedComment _ -> True _ -> False - goesAfterComment <- maybe False isCommentSpan <$> getSpanMark + goesAfterComment <- goesAfterCommentOrHaddock <$> getLastEmitted -- Make sure the Haddock is separated by a newline from other comments. when goesAfterComment newline - forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do - if isFirst - then case hstyle of - Pipe -> txt "-- |" - Caret -> txt "-- ^" - Asterisk n -> txt ("-- " <> T.replicate n "*") - Named name -> p_hsDocName name - else newline >> txt "--" - space - unless (T.null x) (txt x) - when needsNewline newline + -- Print what the author wrote when we still have it. Rebuilding the + -- comment from the doc string cannot preserve a @{- | … -}@ or an empty + -- @-- |@, and what it loses it loses from the AST too. + asWritten <- haddockAsWritten hstyle (L l str) + case asWritten of + Just written -> do + let lns = unComment written + sitcc . sequence_ . NE.intersperse newline . fmap txt $ lns + Nothing -> do + let docStringLines = splitDocString $ hsDocString str + docPrefix = case hstyle of + Pipe -> "-- |" + Caret -> "-- ^" + Asterisk n -> "-- " <> T.replicate n "*" + Named name -> hsDocNameText name + forM_ (zip docStringLines (True : repeat False)) $ \(x, isFirst) -> do + if isFirst + then txt docPrefix + else newline >> txt "--" + space + unless (T.null x) (txt x) + -- A Haddock rendered as @--@ lines owns the rest of its line and has to + -- end it. One rendered as @{- | … -}@ is self-delimiting, so a space will + -- do when the surrounding layout is single-line. + when (Choice.isTrue needsNewline) $ + if Choice.isTrue mayShareLine && maybe False isMultilineComment asWritten + then breakpoint + else newline case l of UnhelpfulSpan _ -> -- It's often the case that the comment itself doesn't have a span - -- attached to it and instead its location can be obtained from + -- attached to it, and instead its location can be obtained from the -- nearest enclosing span. - getEnclosingSpan (const True) >>= mapM_ (setSpanMark . HaddockSpan hstyle) - RealSrcSpan spn _ -> setSpanMark (HaddockSpan hstyle spn) + getEnclosingSpan >>= mapM_ (setLastEmitted . LastEmittedHaddock) + RealSrcSpan spn _ -> setLastEmitted (LastEmittedHaddock spn) --- | Print anchor of named doc section. +-- | Lay the computation out on several lines if rendering the given +-- fragment of the syntax tree will emit a Haddock as @--@ lines. +-- +-- Such a Haddock takes whole lines: emitted inside a bracketed construct +-- that was put on one line, it swallows the rest of that line, closing +-- bracket and all. The author writes it in front of the construct, so its +-- span is outside the construct's and 'switchLayout' cannot see it; what +-- decides is where it will be /printed/, which is inside. Hence +-- @data A = A deriving (Eq)@ documented on the @Eq@ came out as +-- @deriving (-- \| B@, and a documented field of a one-line record as +-- @{-- \| …@, which does not parse at all. +-- +-- A Haddock that comes back out as @{- | … -}@ is self-delimiting and does +-- not force anything, so @data A = A {- | a number -} Int Bool@ is left +-- alone rather than being exploded over five lines. +multiLineIfDocumented :: (Data a) => a -> R () -> R () +multiLineIfDocumented x m = do + breaks <- hasLineHaddocks x + if breaks then enterLayout MultiLine m else m + +-- | 'switchLayout', except that the layout is multi-line regardless of the +-- spans when rendering the given fragment will emit a Haddock as @--@ +-- lines. +-- +-- Use this rather than 'multiLineIfDocumented' around a 'switchLayout': the +-- override has to be applied after the spans have had their say, or it is +-- immediately discarded. +switchLayoutDocumented :: + (Data a) => + -- | Fragment that decides whether documentation will be printed + a -> + -- | Span that controls layout otherwise + [SrcSpan] -> + -- | Computation to run with changed layout + R () -> + R () +switchLayoutDocumented x spans' = + switchLayout spans' . multiLineIfDocumented x + +-- | Does rendering this fragment emit a Haddock as @--@ lines? +-- +-- Every site this is asked about prints its Haddocks in 'Pipe' style, which +-- is what decides whether the author's own text can be reused. +hasLineHaddocks :: (Data a) => a -> R Bool +hasLineHaddocks x = case listify (const True :: LHsDoc GhcPs -> Bool) x of + -- A doc string that is not reachable as an 'LHsDoc' cannot be inspected, + -- so assume the worst and break. + [] -> pure (containsHaddocks x) + docs -> or <$> traverse rendersAsLines docs + where + rendersAsLines doc = + maybe True (not . isMultilineComment) <$> haddockAsWritten Pipe doc + +-- | The author's own text for a Haddock, when it can be reused. +-- +-- 'Nothing' means the Haddock has to be rebuilt from its 'HsDocString' as +-- @--@ lines: either its text was not kept, or it is about to be rendered +-- in a different style than it was written in. Ormolu moves a trailing +-- @-- ^ X@ in front of what it documents and writes it as @-- | X@, and +-- keeping the author's text there would leave a @^@ pointing at the wrong +-- thing. +haddockAsWritten :: HaddockStyle -> LHsDoc GhcPs -> R (Maybe Comment) +haddockAsWritten hstyle (L l _) = do + asWritten <- maybe (pure Nothing) lookupHaddockText (srcSpanToRealSrcSpan l) + pure (mfilter (writtenAs hstyle . NE.head . unComment) asWritten) + +-- | Was the Haddock written in the style it is about to be rendered in? +writtenAs :: HaddockStyle -> Text -> Bool +writtenAs hstyle firstLine = + case T.stripPrefix "--" opener of + Just rest -> hasTrigger (T.stripStart rest) + Nothing -> maybe False (hasTrigger . T.stripStart) (T.stripPrefix "{-" opener) + where + opener = T.stripStart firstLine + hasTrigger t = case hstyle of + Pipe -> "|" `T.isPrefixOf` t + Caret -> "^" `T.isPrefixOf` t + Asterisk n -> + T.replicate n "*" `T.isPrefixOf` t + && not (T.replicate (n + 1) "*" `T.isPrefixOf` t) + Named name -> ("$" <> T.pack name) `T.isPrefixOf` t + +-- | Print the anchor of a named doc section. Unlike 'p_hsDoc' this is a +-- bare anchor with no doc string attached, so there is no span to report. p_hsDocName :: String -> R () -p_hsDocName name = txt ("-- $" <> T.pack name) +p_hsDocName name = do + txt (hsDocNameText name) +-- | Render the anchor of a named doc section. +hsDocNameText :: String -> Text +hsDocNameText name = "-- $" <> T.pack name + p_sourceText :: SourceText -> R () p_sourceText = \case NoSourceText -> pure () - SourceText s -> space >> txt (T.pack s) + SourceText s -> atom @FastString s + +p_namespaceSpec :: NamespaceSpecifier -> R () +p_namespaceSpec = \case + NoNamespaceSpecifier -> pure () + TypeNamespaceSpecifier _ -> txt "type" *> space + DataNamespaceSpecifier _ -> txt "data" *> space + +p_hsMultAnn :: (mult -> R ()) -> HsMultAnnOf mult GhcPs -> R () +p_hsMultAnn p_mult = \case + HsUnannotated _ -> pure () + HsLinearAnn _ -> txt "%1" + HsExplicitMult _ mult -> txt "%" *> p_mult mult diff --git a/src/Ormolu/Printer/Meat/Declaration.hs b/src/Ormolu/Printer/Meat/Declaration.hs --- a/src/Ormolu/Printer/Meat/Declaration.hs +++ b/src/Ormolu/Printer/Meat/Declaration.hs @@ -1,5 +1,5 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} @@ -11,16 +11,15 @@ ) where +import Data.Choice (pattern Without) import Data.List (sort) import Data.List.NonEmpty (NonEmpty (..), (<|)) -import qualified Data.List.NonEmpty as NE -import GHC.Hs.Binds -import GHC.Hs.Decls -import GHC.Hs.Extension -import GHC.Hs.Pat +import Data.List.NonEmpty qualified as NE +import GHC.Hs import GHC.Types.Name.Occurrence (occNameFS) import GHC.Types.Name.Reader import GHC.Types.SrcLoc +import Ormolu.Config (SourceType (SignatureSource)) import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Declaration.Annotation @@ -50,32 +49,34 @@ p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R () p_hsDecls = p_hsDecls' Disregard --- | Like 'p_hsDecls' but respects user choices regarding grouping. If the +-- | Like 'p_hsDecls', but respects user choices regarding grouping. If the -- user omits newlines between declarations, we also omit them in most --- cases, except when said declarations have associated Haddocks. +-- cases, except when the declarations in question have associated Haddocks. -- --- Does some normalization (compress subsequent newlines into a single one) +-- Does some normalization (compresses consecutive newlines into a single +-- one). p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R () p_hsDeclsRespectGrouping = p_hsDecls' Respect p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R () -p_hsDecls' grouping style decls = +p_hsDecls' grouping style decls = do + isSig <- (== SignatureSource) <$> askSourceType sepSemi id $ -- Return a list of rendered declarations, adding a newline to separate -- groups. - case groupDecls decls of + case groupDecls isSig decls of [] -> [] (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs) where renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style) renderGroupWithPrev prev curr = -- We can omit a blank line when the user didn't add one, but we must - -- ensure we always add blank lines around documented declarations + -- ensure we always add blank lines around documented declarations. case grouping of Disregard -> breakpoint : renderGroup curr Respect -> - if separatedByBlankNE getLoc prev curr + if separatedByBlankNE getLocA prev curr || isDocumented prev || isDocumented curr then breakpoint : renderGroup curr @@ -90,53 +91,60 @@ isHaddock _ = False -- | Group relevant declarations together. -groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)] -groupDecls [] = [] -groupDecls (l@(L _ DocNext) : xs) = - -- If the first element is a doc string for next element, just include it - -- in the next block: - case groupDecls xs of +groupDecls :: + -- | Is the source a signature file? + Bool -> + -- | List of declarations + [LHsDecl GhcPs] -> + [NonEmpty (LHsDecl GhcPs)] +groupDecls _ [] = [] +groupDecls isSig (l@(L _ DocNext) : xs) = + -- If the first element is a doc string for the next element, just include + -- it in the next block: + case groupDecls isSig xs of [] -> [l :| []] (x : xs') -> (l <| x) : xs' -groupDecls (header : xs) = +groupDecls isSig (header : xs) = let (grp, rest) = flip span (zip (header : xs) xs) $ \(previous, current) -> let relevantToHdr = groupedDecls header current relevantToPrev = groupedDecls previous current - isDeclSeries = declSeries previous current + isDeclSeries = not isSig && declSeries previous current in isDeclSeries || relevantToHdr || relevantToPrev - in (header :| map snd grp) : groupDecls (map snd rest) + in (header :| map snd grp) : groupDecls isSig (map snd rest) p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R () p_hsDecl style = \case - TyClD NoExtField x -> p_tyClDecl style x - ValD NoExtField x -> p_valDecl x - SigD NoExtField x -> p_sigDecl x - InstD NoExtField x -> p_instDecl style x - DerivD NoExtField x -> p_standaloneDerivDecl x - DefD NoExtField x -> p_defaultDecl x - ForD NoExtField x -> p_foreignDecl x - WarningD NoExtField x -> p_warnDecls x - AnnD NoExtField x -> p_annDecl x - RuleD NoExtField x -> p_ruleDecls x - SpliceD NoExtField x -> p_spliceDecl x - DocD NoExtField docDecl -> + TyClD _ x -> p_tyClDecl style x + ValD _ x -> p_valDecl x + SigD _ x -> p_sigDecl x + InstD _ x -> p_instDecl style x + DerivD _ x -> p_standaloneDerivDecl x + DefD _ x -> p_defaultDecl x + ForD _ x -> p_foreignDecl x + WarningD _ x -> p_warnDecls x + AnnD _ x -> p_annDecl x + RuleD _ x -> p_ruleDecls x + SpliceD _ x -> p_spliceDecl x + DocD _ docDecl -> case docDecl of - DocCommentNext str -> p_hsDocString Pipe False (noLoc str) - DocCommentPrev str -> p_hsDocString Caret False (noLoc str) - DocCommentNamed name str -> p_hsDocString (Named name) False (noLoc str) - DocGroup n str -> p_hsDocString (Asterisk n) False (noLoc str) - RoleAnnotD NoExtField x -> p_roleAnnot x - KindSigD NoExtField s -> p_standaloneKindSig s + DocCommentNext str -> p_hsDoc Pipe (Without #endNewline) str + DocCommentPrev str -> p_hsDoc Caret (Without #endNewline) str + DocCommentNamed name str -> p_hsDoc (Named name) (Without #endNewline) str + DocGroup n str -> p_hsDoc (Asterisk n) (Without #endNewline) str + RoleAnnotD _ x -> p_roleAnnot x + KindSigD _ s -> p_standaloneKindSig s p_tyClDecl :: FamilyStyle -> TyClDecl GhcPs -> R () p_tyClDecl style = \case - FamDecl NoExtField x -> p_famDecl style x + FamDecl _ x -> p_famDecl style x SynDecl {..} -> p_synDecl tcdLName tcdFixity tcdTyVars tcdRhs DataDecl {..} -> p_dataDecl Associated tcdLName - (tyVarsToTyPats tcdTyVars) + (hsq_explicit tcdTyVars) + getLocA + (located' p_hsTyVarBndr) tcdFixity tcdDataDefn ClassDecl {..} -> @@ -154,16 +162,16 @@ p_instDecl :: FamilyStyle -> InstDecl GhcPs -> R () p_instDecl style = \case - ClsInstD NoExtField x -> p_clsInstDecl x - TyFamInstD NoExtField x -> p_tyFamInstDecl style x - DataFamInstD NoExtField x -> p_dataFamInstDecl style x + ClsInstD _ x -> p_clsInstDecl x + TyFamInstD _ x -> p_tyFamInstDecl style x + DataFamInstD _ x -> p_dataFamInstDecl style x --- | Determine if these declarations should be grouped together. +-- | Determine whether these declarations should be grouped together. groupedDecls :: LHsDecl GhcPs -> LHsDecl GhcPs -> Bool -groupedDecls (L l_x x') (L l_y y') = +groupedDecls (L (locA -> l_x) x') (L (locA -> l_y) y') = case (x', y') of (TypeSignature ns, FunctionBody ns') -> ns `intersects` ns' (TypeSignature ns, DefaultSignature ns') -> ns `intersects` ns' @@ -174,11 +182,11 @@ (x, DataDeclaration n) | Just ns <- isPragma x -> n `elem` ns (DataDeclaration n, x) | Just ns <- isPragma x -> - let f = occNameFS . rdrNameOcc in f n `elem` map f ns + let f = occNameFS . rdrNameOcc in f n `elem` map f ns (x, y) | Just ns <- isPragma x, Just ns' <- isPragma y -> - ns `intersects` ns' + ns `intersects` ns' (x, TypeSignature ns) | Just ns' <- isPragma x -> ns `intersects` ns' (TypeSignature ns, x) | Just ns' <- isPragma x -> ns `intersects` ns' (PatternSignature ns, Pattern n) -> n `elem` ns @@ -186,29 +194,30 @@ (KindSignature n, ClassDeclaration n') -> n == n' (KindSignature n, FamilyDeclaration n') -> n == n' (KindSignature n, TypeSynonym n') -> n == n' - -- Special case for TH splices, we look at locations + -- Special case for TH splices: we look at locations. (Splice, Splice) -> not (separatedByBlank id l_x l_y) - -- This looks only at Haddocks, normal comments are handled elsewhere + -- This looks only at Haddocks; normal comments are handled elsewhere. (DocNext, _) -> True (_, DocPrev) -> True _ -> False --- | Detect declaration series that should not have blanks between them. +-- | Detect a series of declarations that should not have blanks between +-- them. declSeries :: LHsDecl GhcPs -> LHsDecl GhcPs -> Bool declSeries (L _ x) (L _ y) = case (x, y) of - ( SigD NoExtField (TypeSig NoExtField _ _), - SigD NoExtField (TypeSig NoExtField _ _) + ( SigD _ (TypeSig _ _ _), + SigD _ (TypeSig _ _ _) ) -> True _ -> False -intersects :: Ord a => [a] -> [a] -> Bool +intersects :: (Ord a) => [a] -> [a] -> Bool intersects a b = go (sort a) (sort b) where - go :: Ord a => [a] -> [a] -> Bool + go :: (Ord a) => [a] -> [a] -> Bool go _ [] = False go [] _ = False go (x : xs) (y : ys) @@ -228,12 +237,12 @@ WarningPragma n -> Just n _ -> Nothing --- Declarations that do not refer to names +-- Declarations that do not refer to names. pattern Splice :: HsDecl GhcPs -pattern Splice <- SpliceD NoExtField (SpliceDecl NoExtField _ _) +pattern Splice <- SpliceD _ (SpliceDecl _ _ _) --- Declarations referring to a single name +-- Declarations referring to a single name. pattern InlinePragma, @@ -248,20 +257,26 @@ FamilyDeclaration, TypeSynonym :: RdrName -> HsDecl GhcPs -pattern InlinePragma n <- SigD NoExtField (InlineSig NoExtField (L _ n) _) -pattern SpecializePragma n <- SigD NoExtField (SpecSig NoExtField (L _ n) _ _) -pattern SCCPragma n <- SigD NoExtField (SCCFunSig NoExtField _ (L _ n) _) -pattern AnnTypePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (TypeAnnProvenance (L _ n)) _) -pattern AnnValuePragma n <- AnnD NoExtField (HsAnnotation NoExtField _ (ValueAnnProvenance (L _ n)) _) -pattern Pattern n <- ValD NoExtField (PatSynBind NoExtField (PSB _ (L _ n) _ _ _)) -pattern DataDeclaration n <- TyClD NoExtField (DataDecl NoExtField (L _ n) _ _ _) -pattern ClassDeclaration n <- TyClD NoExtField (ClassDecl _ _ (L _ n) _ _ _ _ _ _ _ _) -pattern KindSignature n <- KindSigD NoExtField (StandaloneKindSig NoExtField (L _ n) _) -pattern FamilyDeclaration n <- TyClD NoExtField (FamDecl NoExtField (FamilyDecl NoExtField _ (L _ n) _ _ _ _)) -pattern TypeSynonym n <- TyClD NoExtField (SynDecl NoExtField (L _ n) _ _ _) +pattern InlinePragma n <- SigD _ (InlineSig _ (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)) _) +pattern Pattern n <- ValD _ (PatSynBind _ (PSB _ (L _ n) _ _ _)) +pattern DataDeclaration n <- TyClD _ (DataDecl _ (L _ n) _ _ _) +pattern ClassDeclaration n <- TyClD _ (ClassDecl _ _ (L _ n) _ _ _ _ _ _ _ _) +pattern KindSignature n <- KindSigD _ (StandaloneKindSig _ (L _ n) _) +pattern FamilyDeclaration n <- TyClD _ (FamDecl _ (FamilyDecl _ _ _ (L _ n) _ _ _ _)) +pattern TypeSynonym n <- TyClD _ (SynDecl _ (L _ n) _ _ _) --- Declarations which can refer to multiple names +isSpecSig :: Sig GhcPs -> Maybe RdrName +isSpecSig = \case + SpecSig _ (L _ n) _ _ -> Just n + SpecSigE _ _ (deconstructExprFromSpecSigE -> (L _ n, _, _)) _ -> Just n + _ -> Nothing +-- Declarations that can refer to multiple names. + pattern TypeSignature, DefaultSignature, @@ -276,47 +291,51 @@ pattern WarningPragma n <- (warnSigRdrNames -> Just n) pattern DocNext, DocPrev :: HsDecl GhcPs -pattern DocNext <- (DocD NoExtField (DocCommentNext _)) -pattern DocPrev <- (DocD NoExtField (DocCommentPrev _)) +pattern DocNext <- (DocD _ (DocCommentNext _)) +pattern DocPrev <- (DocD _ (DocCommentPrev _)) sigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] -sigRdrNames (SigD NoExtField (TypeSig NoExtField ns _)) = Just $ map unLoc ns -sigRdrNames (SigD NoExtField (ClassOpSig NoExtField _ ns _)) = Just $ map unLoc ns -sigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns +sigRdrNames (SigD _ (TypeSig _ ns _)) = Just $ map unLoc ns +sigRdrNames (SigD _ (ClassOpSig _ _ ns _)) = Just $ map unLoc ns +sigRdrNames (SigD _ (PatSynSig _ ns _)) = Just $ map unLoc ns sigRdrNames _ = Nothing defSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] -defSigRdrNames (SigD NoExtField (ClassOpSig NoExtField True ns _)) = Just $ map unLoc ns +defSigRdrNames (SigD _ (ClassOpSig _ True ns _)) = Just $ map unLoc ns defSigRdrNames _ = Nothing funRdrNames :: HsDecl GhcPs -> Maybe [RdrName] -funRdrNames (ValD NoExtField (FunBind NoExtField (L _ n) _ _)) = Just [n] -funRdrNames (ValD NoExtField (PatBind NoExtField (L _ n) _ _)) = Just $ patBindNames n +funRdrNames (ValD _ (FunBind _ (L _ n) _)) = Just [n] +funRdrNames (ValD _ (PatBind _ (L _ n) _ _)) = Just $ patBindNames n funRdrNames _ = Nothing patSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] -patSigRdrNames (SigD NoExtField (PatSynSig NoExtField ns _)) = Just $ map unLoc ns +patSigRdrNames (SigD _ (PatSynSig _ ns _)) = Just $ map unLoc ns patSigRdrNames _ = Nothing warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] -warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $ - flip concatMap ws $ \(L _ (Warning NoExtField ns _)) -> map unLoc ns +warnSigRdrNames (WarningD _ (Warnings _ ws)) = Just $ + flip concatMap ws $ + \(L _ (Warning _ ns _)) -> map unLoc ns warnSigRdrNames _ = Nothing patBindNames :: Pat GhcPs -> [RdrName] -patBindNames (TuplePat NoExtField ps _) = concatMap (patBindNames . unLoc) ps -patBindNames (VarPat NoExtField (L _ n)) = [n] -patBindNames (WildPat NoExtField) = [] -patBindNames (LazyPat NoExtField (L _ p)) = patBindNames p -patBindNames (BangPat NoExtField (L _ p)) = patBindNames p -patBindNames (ParPat NoExtField (L _ p)) = patBindNames p -patBindNames (ListPat NoExtField ps) = concatMap (patBindNames . unLoc) ps -patBindNames (AsPat NoExtField (L _ n) (L _ p)) = n : patBindNames p -patBindNames (SumPat NoExtField (L _ p) _ _) = patBindNames p -patBindNames (ViewPat NoExtField _ (L _ p)) = patBindNames p -patBindNames (SplicePat NoExtField _) = [] -patBindNames (LitPat NoExtField _) = [] +patBindNames (TuplePat _ ps _) = concatMap (patBindNames . unLoc) ps +patBindNames (OrPat _ ps) = foldMap (patBindNames . unLoc) ps +patBindNames (VarPat _ (L _ n)) = [n] +patBindNames (WildPat _) = [] +patBindNames (LazyPat _ (L _ p)) = patBindNames p +patBindNames (BangPat _ (L _ p)) = patBindNames p +patBindNames (ParPat _ (L _ p)) = patBindNames p +patBindNames (ListPat _ ps) = concatMap (patBindNames . unLoc) ps +patBindNames (AsPat _ (L _ n) (L _ p)) = n : patBindNames p +patBindNames (SumPat _ (L _ p) _ _) = patBindNames p +patBindNames (ViewPat _ _ (L _ p)) = patBindNames p +patBindNames (SplicePat _ _) = [] +patBindNames (LitPat _ _) = [] patBindNames (SigPat _ (L _ p) _) = patBindNames p -patBindNames (NPat NoExtField _ _ _) = [] -patBindNames (NPlusKPat NoExtField (L _ n) _ _ _ _) = [n] -patBindNames (ConPat NoExtField _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d) +patBindNames (NPat _ _ _ _) = [] +patBindNames (NPlusKPat _ (L _ n) _ _ _ _) = [n] +patBindNames (ConPat _ _ d) = concatMap (patBindNames . unLoc) (hsConPatArgs d) +patBindNames (EmbTyPat _ _) = [] +patBindNames (InvisPat _ _) = [] diff --git a/src/Ormolu/Printer/Meat/Declaration/Annotation.hs b/src/Ormolu/Printer/Meat/Declaration/Annotation.hs --- a/src/Ormolu/Printer/Meat/Declaration/Annotation.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Annotation.hs @@ -6,20 +6,19 @@ ) where -import GHC.Hs.Decls -import GHC.Hs.Extension +import GHC.Hs import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Declaration.Value p_annDecl :: AnnDecl GhcPs -> R () -p_annDecl (HsAnnotation NoExtField _ annProv expr) = +p_annDecl (HsAnnotation _ annProv expr) = pragma "ANN" . inci $ do p_annProv annProv breakpoint located expr p_hsExpr -p_annProv :: AnnProvenance (IdP GhcPs) -> R () +p_annProv :: AnnProvenance GhcPs -> R () p_annProv = \case ValueAnnProvenance name -> p_rdrName name TypeAnnProvenance name -> txt "type" >> space >> p_rdrName name 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,15 +13,14 @@ 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) -import GHC.Core.Class -import GHC.Hs.Binds -import GHC.Hs.Decls -import GHC.Hs.Extension -import GHC.Hs.Type -import GHC.Types.Basic +import Data.Maybe +import GHC.Hs +import GHC.Types.Fixity import GHC.Types.Name.Reader import GHC.Types.SrcLoc import Ormolu.Printer.Combinators @@ -27,33 +29,32 @@ import Ormolu.Printer.Meat.Type p_classDecl :: - LHsContext GhcPs -> - Located RdrName -> + Maybe (LHsContext GhcPs) -> + LocatedN RdrName -> LHsQTyVars GhcPs -> LexicalFixity -> - [Located (FunDep (Located RdrName))] -> + [LHsFunDep GhcPs] -> [LSig GhcPs] -> LHsBinds GhcPs -> [LFamilyDecl GhcPs] -> [LTyFamDefltDecl GhcPs] -> - [LDocDecl] -> + [LDocDecl GhcPs] -> R () p_classDecl ctx name HsQTvs {..} fixity fdeps csigs cdefs cats catdefs cdocs = do - let variableSpans = getLoc <$> hsq_explicit - signatureSpans = getLoc name : variableSpans - dependencySpans = getLoc <$> fdeps - combinedSpans = getLoc ctx : (signatureSpans ++ dependencySpans) + let variableSpans = getLocA <$> hsq_explicit + signatureSpans = getLocA name : variableSpans + dependencySpans = getLocA <$> fdeps + combinedSpans = maybeToList (getLocA <$> ctx) ++ signatureSpans ++ dependencySpans -- GHC's AST does not necessarily store each kind of element in source -- location order. This happens because different declarations are stored -- in different lists. Consequently, to get all the declarations in proper -- order, they need to be manually sorted. - sigs = (getLoc &&& fmap (SigD NoExtField)) <$> csigs - vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cdefs - tyFams = (getLoc &&& fmap (TyClD NoExtField . FamDecl NoExtField)) <$> cats - docs = (getLoc &&& fmap (DocD NoExtField)) <$> cdocs + sigs = (getLocA &&& fmap (SigD NoExtField)) <$> csigs + vals = (getLocA &&& fmap (ValD NoExtField)) <$> toList cdefs + tyFams = (getLocA &&& fmap (TyClD NoExtField . FamDecl NoExtField)) <$> cats + docs = (getLocA &&& fmap (DocD NoExtField)) <$> cdocs tyFamDefs = - ( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField) - ) + (getLocA &&& fmap (InstD NoExtField . TyFamInstD NoExtField)) <$> catdefs allDecls = snd <$> sortBy (leftmost_smallest `on` fst) (sigs <> vals <> tyFams <> tyFamDefs <> docs) @@ -61,11 +62,11 @@ switchLayout combinedSpans $ do breakpoint inci $ do - p_classContext ctx + 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) @@ -73,7 +74,7 @@ breakpoint txt "where" unless (null allDecls) $ do - breakpoint -- Ensure whitespace is added after where clause. + breakpoint -- Ensure whitespace is added after the where clause. inci (p_hsDeclsRespectGrouping Associated allDecls) p_classContext :: LHsContext GhcPs -> R () @@ -83,15 +84,15 @@ txt "=>" breakpoint -p_classFundeps :: [Located (FunDep (Located RdrName))] -> R () +p_classFundeps :: [LHsFunDep GhcPs] -> R () p_classFundeps fdeps = unless (null fdeps) $ do breakpoint txt "|" space inci $ sep commaDel (sitcc . located' p_funDep) fdeps -p_funDep :: FunDep (Located RdrName) -> R () -p_funDep (before, after) = do +p_funDep :: FunDep GhcPs -> R () +p_funDep (FunDep _ before after) = do sep space p_rdrName before space txt "->" 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 @@ -1,21 +1,26 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} --- | Renedring of data type declarations. +-- | Rendering of data type declarations. module Ormolu.Printer.Meat.Declaration.Data ( p_dataDecl, ) where import Control.Monad -import Data.Maybe (isJust, maybeToList) -import GHC.Hs.Decls -import GHC.Hs.Extension -import GHC.Hs.Type -import GHC.Parser.Annotation -import GHC.Types.Basic +import Data.Choice (Choice, pattern Is, pattern Isn't, pattern With) +import Data.Choice qualified as Choice +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Maybe (isJust, isNothing, mapMaybe, maybeToList) +import GHC.Hs +import GHC.Types.Fixity import GHC.Types.ForeignCall import GHC.Types.Name.Reader import GHC.Types.SrcLoc @@ -28,172 +33,232 @@ -- | Whether to format as data family FamilyStyle -> -- | Type constructor - Located RdrName -> - -- | Type patterns - HsTyPats GhcPs -> + LocatedN RdrName -> + -- | Type variables + [tyVar] -> + -- | Get location information for type variables + (tyVar -> SrcSpan) -> + -- | How to print type variables + (tyVar -> R ()) -> -- | Lexical fixity LexicalFixity -> -- | Data definition HsDataDefn GhcPs -> R () -p_dataDecl style name tpats fixity HsDataDefn {..} = do - txt $ case dd_ND of - NewType -> "newtype" - DataType -> "data" +p_dataDecl style name tyVars getTyVarLoc p_tyVar fixity HsDataDefn {..} = do + txt $ case dd_cons of + NewTypeCon _ -> "newtype" + DataTypeCons False _ -> "data" + DataTypeCons True _ -> "type data" txt $ case style of Associated -> mempty Free -> " instance" - case unLoc <$> dd_cType of - Nothing -> pure () - Just (CType prag header (type_, _)) -> do - p_sourceText prag - case header of - Nothing -> pure () - Just (Header h _) -> space *> p_sourceText h - p_sourceText type_ - txt " #-}" - let constructorSpans = getLoc name : fmap lhsTypeArgSrcSpan tpats - switchLayout constructorSpans $ do + let constructorSpans = getLocA name : fmap getTyVarLoc tyVars + sigSpans = maybeToList . fmap getLocA $ dd_kindSig + contextSpans = maybeToList . fmap getLocA $ dd_ctxt + ctypeSpans = maybeToList . fmap getLocA $ dd_cType + declHeaderSpans = + constructorSpans ++ sigSpans ++ contextSpans ++ ctypeSpans + switchLayout declHeaderSpans . inci $ do + case unLoc <$> dd_cType of + Nothing -> pure () + Just (CType prag header (type_, _)) -> do + breakpoint + p_sourceText prag + case header of + Nothing -> pure () + Just (Header h _) -> space *> p_sourceText h + space + p_sourceText type_ + txt " #-}" breakpoint - inci $ + forM_ dd_ctxt p_lhsContext + switchLayout constructorSpans $ p_infixDefHelper - (isInfix fixity) - True + (Choice.fromBool (isInfix fixity)) + (Is #indentArgs) (p_rdrName name) - (p_lhsTypeArg <$> tpats) - case dd_kindSig of - Nothing -> return () - Just k -> do + (p_tyVar <$> tyVars) + forM_ dd_kindSig $ \k -> do space txt "::" - space - located k p_hsType - let gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons - unless (null dd_cons) $ - if gadt - then inci $ do - switchLayout constructorSpans $ do + breakpoint + inci $ located k p_hsType + let dd_cons' = case dd_cons of + NewTypeCon a -> [a] + DataTypeCons _ as -> as + gadt = isJust dd_kindSig || any (isGadt . unLoc) dd_cons' + case dd_cons' of + [] -> pure () + first_dd_cons : _ -> + if gadt + then inci $ do + switchLayout declHeaderSpans $ do + breakpoint + txt "where" breakpoint - txt "where" + sepSemi (located' (p_conDecl (Isn't #singleRecCon))) dd_cons' + else switchLayout (getLocA name : (getLocA <$> dd_cons')) . inci $ do + let singleRecCon = + case dd_cons' of + [L _ ConDeclH98 {con_args = RecCon {}}] -> Is #singleRecCon + _ -> Isn't #singleRecCon + compactLayoutAroundEquals = + onTheSameLine + (getLocA name) + (combineSrcSpans' (conDeclConsSpans (unLoc first_dd_cons))) + conDeclConsSpans = \case + ConDeclGADT {..} -> getLocA <$> con_names + ConDeclH98 {..} -> getLocA con_name :| [] + -- A constructor documented with @--@ lines cannot share a line + -- with anything. One documented with @{- | … -}@ can, so it is + -- laid out as though it were undocumented. + lineHaddocks <- consHaveLineHaddocks dd_cons' + if lineHaddocks + then newline + else + if Choice.isTrue singleRecCon && compactLayoutAroundEquals + then space + else breakpoint + txt "=" + space + layout <- getLayout + let s = + if layout == MultiLine || lineHaddocks + then newline >> txt "|" >> space + else space >> txt "|" >> space + sitcc' = + if lineHaddocks || Choice.isFalse singleRecCon + then sitcc + else id + sep s (sitcc' . located' (p_conDecl singleRecCon)) dd_cons' + unless (null dd_derivs) breakpoint + inci $ sep newline (located' p_hsDerivingClause) dd_derivs + +p_conDecl :: Choice "singleRecCon" -> ConDecl GhcPs -> R () +p_conDecl _ ConDeclGADT {..} = do + mapM_ (p_hsDoc Pipe (With #endNewline)) con_doc + switchLayoutDocumented documented conDeclSpn $ do + let c :| cs = con_names + p_rdrName c + unless (null cs) . inci $ do + commaDel + sep commaDel p_rdrName cs + space + txt "::" + breakpoint + inci . switchLayoutDocumented documented conSigSpans $ do + located con_outer_bndrs p_hsOuterTyVarBndrs + case unLoc con_outer_bndrs of + HsOuterImplicit {} -> pure () + HsOuterExplicit {} -> breakpoint + forM_ con_inner_bndrs $ \tele -> do + p_hsForAllTelescope tele breakpoint - sepSemi (located' (p_conDecl False)) dd_cons - else switchLayout (getLoc name : (getLoc <$> dd_cons)) . inci $ do - let singleConstRec = isSingleConstRec dd_cons - if singleConstRec - then space - else - if hasHaddocks dd_cons - then newline - else breakpoint - equals + forM_ con_mb_cxt $ \qs -> do + located qs p_hsContext space - layout <- getLayout - let s = - if layout == MultiLine || hasHaddocks dd_cons - then newline >> txt "|" >> space - else space >> txt "|" >> space - sitcc' = - if singleConstRec - then id - else sitcc - sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons - unless (null $ unLoc dd_derivs) breakpoint - inci . located dd_derivs $ \xs -> - sep newline (located' p_hsDerivingClause) xs + txt "=>" + breakpoint + switchLayoutDocumented documented conArgResSpans $ do + case con_g_args of + PrefixConGADT NoExtField xs -> + forM_ xs $ \x -> do + p_hsConDeclFieldWithDoc x + space + p_hsMultAnn (located' p_hsType) (cdf_multiplicity x) + space + txt "->" + breakpoint + RecConGADT _ x -> do + located x p_hsConDeclRecFields + space + txt "->" + breakpoint + located con_res_ty p_hsType + where + -- Every part of the signature shares one layout decision, so any + -- Haddock in any of them puts the whole of it on several lines. + documented = (con_g_args, con_res_ty) -p_conDecl :: - Bool -> - ConDecl GhcPs -> - R () -p_conDecl singleConstRec = \case - ConDeclGADT {..} -> do - mapM_ (p_hsDocString Pipe True) con_doc - let conDeclSpn = - fmap getLoc con_names - <> [getLoc con_forall] - <> fmap getLoc con_qvars - <> maybeToList (fmap getLoc con_mb_cxt) - <> conArgsSpans con_args - switchLayout conDeclSpn $ do - case con_names of - [] -> return () - (c : cs) -> do - p_rdrName c - unless (null cs) . inci $ do - commaDel - sep commaDel p_rdrName cs - inci $ do - space - txt "::" - let interArgBreak = - if hasDocStrings (unLoc con_res_ty) - then newline - else breakpoint - interArgBreak - conTy <- case con_args of - PrefixCon xs -> - let go (HsScaled a b) t = L (combineLocs t b) (HsFunTy NoExtField a b t) - in pure $ foldr go con_res_ty xs - RecCon r@(L l rs) -> - pure - . L (combineLocs r con_res_ty) - $ HsFunTy - NoExtField - (HsUnrestrictedArrow NormalSyntax) - (L l $ HsRecTy NoExtField rs) - con_res_ty - InfixCon _ _ -> notImplemented "InfixCon" -- NOTE(amesgen) should be unreachable - let qualTy = case con_mb_cxt of - Nothing -> conTy - Just qs -> - L (combineLocs qs conTy) $ - HsQualTy NoExtField qs conTy - let quantifiedTy = - if unLoc con_forall - then - L (combineLocs con_forall qualTy) $ - HsForAllTy NoExtField (mkHsForAllInvisTele con_qvars) qualTy - else qualTy - p_hsType (unLoc quantifiedTy) - ConDeclH98 {..} -> do - mapM_ (p_hsDocString Pipe True) con_doc - let conDeclWithContextSpn = - [getLoc con_forall] - <> fmap getLoc con_ex_tvs - <> maybeToList (fmap getLoc con_mb_cxt) - <> conDeclSpn - conDeclSpn = - getLoc con_name : conArgsSpans con_args - switchLayout conDeclWithContextSpn $ do - when (unLoc con_forall) $ do - p_forallBndrs ForAllInvis p_hsTyVarBndr con_ex_tvs + conDeclSpn = + fmap getLocA (NE.toList con_names) <> conSigSpans + conSigSpans = + [getLocA con_outer_bndrs] + <> maybeToList (fmap getLocA con_mb_cxt) + <> 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 xs -> do + renderConDoc + renderContext + switchLayoutDocumented xs conDeclSpn $ do + p_rdrName con_name + unless (null xs) breakpoint + inci . sitcc $ + sep breakpoint (sitcc . p_hsConDeclFieldWithDoc) xs + RecCon l -> do + renderConDoc + renderContext + switchLayout conDeclSpn $ do + p_rdrName con_name breakpoint - forM_ con_mb_cxt p_lhsContext - switchLayout conDeclSpn $ case con_args of - PrefixCon xs -> do - p_rdrName con_name - unless (null xs) breakpoint - inci . sitcc $ sep breakpoint (sitcc . located' p_hsTypePostDoc) (hsScaledThing <$> xs) - RecCon l -> do + inciIf (Choice.isFalse singleRecCon) (located l p_hsConDeclRecFields) + InfixCon l r -> do + -- Render these manually. + 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. + let putConDocOnTop = isNothing larg_doc && isNothing rarg_doc + + when putConDocOnTop renderConDoc + renderContext + switchLayout conDeclSpn $ do + -- The left arg Haddock can use pipe style only if the infix + -- constructor has docs. + if isJust con_doc + then do + mapM_ (p_hsDoc Pipe (With #endNewline)) larg_doc + p_hsConDeclField l + breakpoint + else do + p_hsConDeclField l + case larg_doc of + Just doc -> space >> p_hsDoc Caret (With #endNewline) doc + Nothing -> breakpoint + inci $ do + unless putConDocOnTop renderConDoc p_rdrName con_name - breakpoint - inciIf (not singleConstRec) (located l p_conDeclFields) - InfixCon (HsScaled _ x) (HsScaled _ y) -> do - located x p_hsType + case rarg_doc of + Just doc -> newline >> p_hsDoc Pipe (With #endNewline) doc + Nothing -> breakpoint + p_hsConDeclField r + where + renderConDoc = mapM_ (p_hsDoc Pipe (With #endNewline)) con_doc + renderContext = + switchLayout conNameWithContextSpn $ do + when con_forall $ do + p_forallBndrs ForAllInvis p_hsTyVarBndr con_ex_tvs breakpoint - inci $ do - p_rdrName con_name - space - located y p_hsType + forM_ con_mb_cxt p_lhsContext -conArgsSpans :: HsConDeclDetails GhcPs -> [SrcSpan] -conArgsSpans = \case - PrefixCon xs -> - getLoc . hsScaledThing <$> xs - RecCon l -> - [getLoc l] - InfixCon x y -> - getLoc . hsScaledThing <$> [x, y] + conNameWithContextSpn = + [getHasLoc $ acdh_forall con_ext] + <> fmap getLocA con_ex_tvs + <> maybeToList (fmap getLocA con_mb_cxt) + <> [conNameSpn] + conDeclSpn = conNameSpn : conArgsSpans + conNameSpn = getLocA con_name + conArgsSpans = case con_args of + PrefixCon xs -> getLocA . cdf_type <$> xs + RecCon l -> [getLocA l] + InfixCon x y -> getLocA . cdf_type <$> [x, y] p_lhsContext :: LHsContext GhcPs -> @@ -214,60 +279,65 @@ p_hsDerivingClause :: HsDerivingClause GhcPs -> R () -p_hsDerivingClause HsDerivingClause {..} = do +p_hsDerivingClause HsDerivingClause {..} = multiLineIfDocumented deriv_clause_tys $ do txt "deriving" - let derivingWhat = located deriv_clause_tys $ \case - [] -> txt "()" - xs -> - parens N $ - sep - commaDel - (sitcc . located' p_hsType . hsib_body) - xs + let derivingWhat = located deriv_clause_tys $ \tys -> + multiLineIfDocumented tys $ case tys of + DctSingle NoExtField sigTy -> parens N $ located sigTy p_hsSigType + DctMulti NoExtField sigTys -> + parens N $ + sep + commaDel + (sitcc . located' p_hsSigType) + sigTys space case deriv_clause_strategy of Nothing -> do breakpoint inci derivingWhat Just (L _ a) -> case a of - StockStrategy -> do + StockStrategy _ -> do txt "stock" breakpoint inci derivingWhat - AnyclassStrategy -> do + AnyclassStrategy _ -> do txt "anyclass" breakpoint inci derivingWhat - NewtypeStrategy -> do + NewtypeStrategy _ -> do txt "newtype" breakpoint inci derivingWhat - ViaStrategy HsIB {..} -> do + ViaStrategy (XViaStrategyPs _ sigTy) -> do breakpoint inci $ do derivingWhat breakpoint txt "via" space - located hsib_body p_hsType + located sigTy p_hsSigType ---------------------------------------------------------------------------- -- Helpers +-- | Do any of these constructors print a Haddock as @--@ lines where it +-- would share a line with the rest of the declaration? +-- +-- Only the constructor's own Haddock and the docs on its prefix arguments +-- count. A record constructor lays its fields out over several lines +-- anyway, so documenting one of them says nothing about how the @=@ and the +-- constructor name should be arranged. +consHaveLineHaddocks :: [LConDecl GhcPs] -> R Bool +consHaveLineHaddocks = fmap or . traverse (f . unLoc) + where + f ConDeclH98 {..} = + hasLineHaddocks $ + maybeToList con_doc <> case con_args of + PrefixCon xs -> mapMaybe cdf_doc xs + _ -> [] + f _ = pure False + isInfix :: LexicalFixity -> Bool isInfix = \case Infix -> True Prefix -> False - -isSingleConstRec :: [LConDecl GhcPs] -> Bool -isSingleConstRec [(L _ ConDeclH98 {..})] = - case con_args of - RecCon _ -> True - _ -> False -isSingleConstRec _ = False - -hasHaddocks :: [LConDecl GhcPs] -> Bool -hasHaddocks = any (f . unLoc) - where - f ConDeclH98 {..} = isJust con_doc - f _ = False diff --git a/src/Ormolu/Printer/Meat/Declaration/Default.hs b/src/Ormolu/Printer/Meat/Declaration/Default.hs --- a/src/Ormolu/Printer/Meat/Declaration/Default.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Default.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Ormolu.Printer.Meat.Declaration.Default @@ -6,14 +5,18 @@ ) where -import GHC.Hs.Decls -import GHC.Hs.Extension +import GHC.Data.Maybe (whenIsJust) +import GHC.Hs import Ormolu.Printer.Combinators +import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type p_defaultDecl :: DefaultDecl GhcPs -> R () -p_defaultDecl (DefaultDecl NoExtField ts) = do +p_defaultDecl (DefaultDecl _ mclass ts) = do txt "default" + whenIsJust mclass $ \c -> do + breakpoint + p_rdrName c breakpoint inci . parens N $ sep commaDel (sitcc . located' p_hsType) ts diff --git a/src/Ormolu/Printer/Meat/Declaration/Foreign.hs b/src/Ormolu/Printer/Meat/Declaration/Foreign.hs --- a/src/Ormolu/Printer/Meat/Declaration/Foreign.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Foreign.hs @@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Ormolu.Printer.Meat.Declaration.Foreign @@ -8,14 +7,14 @@ where import Control.Monad -import GHC.Hs.Decls -import GHC.Hs.Extension -import GHC.Hs.Type +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 @@ -26,19 +25,19 @@ p_foreignExport fd_fe p_foreignTypeSig fd --- | Printer for the last part of an import\/export, which is function name --- and type signature. +-- | Printer for the last part of an import\/export, which is the function +-- name and type signature. p_foreignTypeSig :: ForeignDecl GhcPs -> R () p_foreignTypeSig fd = do breakpoint inci . switchLayout - [ getLoc (fd_name fd), - (getLoc . hsib_body . fd_sig_ty) fd + [ getLocA (fd_name fd), + (getLocA . fd_sig_ty) fd ] $ do p_rdrName (fd_name fd) - p_typeAscription (HsWC NoExtField (fd_sig_ty fd)) + p_typeAscription (fd_sig_ty fd) -- | Printer for 'ForeignImport'. -- @@ -46,24 +45,29 @@ -- -- > foreign import callingConvention [safety] [identifier] -- --- We need to check whether the safety has a good source, span, as it +-- We need to check whether the safety has a good source span, as it -- defaults to 'PlaySafe' if you don't have anything in the source. -- --- We also layout the identifier using the 'SourceText', because printing --- with the other two fields of 'CImport' is very complicated. See the +-- We also lay out the identifier using the 'SourceText', because printing +-- it from the other two fields of 'CImport' is very complicated. See the -- 'Outputable' instance of 'ForeignImport' for details. -p_foreignImport :: ForeignImport -> R () -p_foreignImport (CImport cCallConv safety _ _ sourceText) = do +p_foreignImport :: ForeignImport GhcPs -> R () +p_foreignImport (CImport sourceText cCallConv safety _ _) = do txt "foreign import" space located cCallConv atom - -- Need to check for 'noLoc' for the 'safe' annotation - when (isGoodSrcSpan $ getLoc safety) (space >> atom safety) - located sourceText p_sourceText + -- Need to check for 'noLoc' for the 'safe' annotation. + when (isGoodSrcSpan $ getLocA safety) (space >> atom safety) + inci $ located sourceText $ \case + NoSourceText -> pure () + SourceText lit -> do + breakpoint + p_stringLit lit -p_foreignExport :: ForeignExport -> R () -p_foreignExport (CExport (L loc (CExportStatic _ _ cCallConv)) sourceText) = do +p_foreignExport :: ForeignExport GhcPs -> R () +p_foreignExport (CExport sourceText (L loc (CExportStatic _ _ cCallConv))) = do txt "foreign export" space located (L loc cCallConv) atom + space located sourceText p_sourceText diff --git a/src/Ormolu/Printer/Meat/Declaration/Instance.hs b/src/Ormolu/Printer/Meat/Declaration/Instance.hs --- a/src/Ormolu/Printer/Meat/Declaration/Instance.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Instance.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -16,9 +15,8 @@ import Data.Foldable import Data.Function (on) import Data.List (sortBy) -import GHC.Hs.Decls -import GHC.Hs.Extension -import GHC.Hs.Type +import Data.Maybe (maybeToList) +import GHC.Hs import GHC.Types.Basic import GHC.Types.SrcLoc import Ormolu.Printer.Combinators @@ -26,13 +24,17 @@ import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration import Ormolu.Printer.Meat.Declaration.Data import Ormolu.Printer.Meat.Declaration.TypeFamily +import Ormolu.Printer.Meat.Declaration.Warning import Ormolu.Printer.Meat.Type p_standaloneDerivDecl :: DerivDecl GhcPs -> R () -p_standaloneDerivDecl DerivDecl {..} = do - let typesAfterInstance = located (hsib_body (hswc_body deriv_type)) p_hsType +p_standaloneDerivDecl DerivDecl {deriv_ext = (mWarnTxt, _), ..} = do + let typesAfterInstance = located (hswc_body deriv_type) p_hsSigType instTypes toIndent = inci $ do txt "instance" + for_ mWarnTxt $ \warnTxt -> do + breakpoint + located warnTxt p_warningTxt breakpoint match_overlap_mode deriv_overlap_mode breakpoint inciIf toIndent typesAfterInstance @@ -42,52 +44,52 @@ Nothing -> instTypes False Just (L _ a) -> case a of - StockStrategy -> do + StockStrategy _ -> do txt "stock " instTypes False - AnyclassStrategy -> do + AnyclassStrategy _ -> do txt "anyclass " instTypes False - NewtypeStrategy -> do + NewtypeStrategy _ -> do txt "newtype " instTypes False - ViaStrategy HsIB {..} -> do + ViaStrategy (XViaStrategyPs _ sigTy) -> do txt "via" breakpoint - inci (located hsib_body p_hsType) + inci (located sigTy p_hsSigType) breakpoint instTypes True p_clsInstDecl :: ClsInstDecl GhcPs -> R () -p_clsInstDecl ClsInstDecl {..} = do +p_clsInstDecl ClsInstDecl {cid_ext = (mWarnTxt, _, _), ..} = do txt "instance" - let HsIB {..} = cid_poly_ty -- GHC's AST does not necessarily store each kind of element in source -- location order. This happens because different declarations are stored in -- different lists. Consequently, to get all the declarations in proper -- order, they need to be manually sorted. - let sigs = (getLoc &&& fmap (SigD NoExtField)) <$> cid_sigs - vals = (getLoc &&& fmap (ValD NoExtField)) <$> toList cid_binds + let sigs = (getLocA &&& fmap (SigD NoExtField)) <$> cid_sigs + vals = (getLocA &&& fmap (ValD NoExtField)) <$> toList cid_binds tyFamInsts = - ( getLoc &&& fmap (InstD NoExtField . TyFamInstD NoExtField) - ) + (getLocA &&& fmap (InstD NoExtField . TyFamInstD NoExtField)) <$> cid_tyfam_insts dataFamInsts = - ( getLoc &&& fmap (InstD NoExtField . DataFamInstD NoExtField) - ) + (getLocA &&& fmap (InstD NoExtField . DataFamInstD NoExtField)) <$> cid_datafam_insts allDecls = snd <$> sortBy (leftmost_smallest `on` fst) (sigs <> vals <> tyFamInsts <> dataFamInsts) - located hsib_body $ \x -> do + switchLayout (maybeToList (getLocA <$> mWarnTxt) <> [getLocA cid_poly_ty]) $ do + for_ mWarnTxt $ \warnTxt -> do + breakpoint + located warnTxt p_warningTxt breakpoint - inci $ do + located cid_poly_ty $ \sigTy -> inci $ do match_overlap_mode cid_overlap_mode breakpoint - p_hsType x + p_hsSigType sigTy unless (null allDecls) $ do breakpoint txt "where" unless (null allDecls) . inci $ do - -- Ensure whitespace is added after where clause. + -- Ensure whitespace is added after the where clause. breakpoint dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls @@ -100,10 +102,17 @@ inci (p_tyFamInstEqn tfid_eqn) p_dataFamInstDecl :: FamilyStyle -> DataFamInstDecl GhcPs -> R () -p_dataFamInstDecl style (DataFamInstDecl {dfid_eqn = HsIB {hsib_body = FamEqn {..}}}) = - p_dataDecl style feqn_tycon feqn_pats feqn_fixity feqn_rhs +p_dataFamInstDecl style (DataFamInstDecl {dfid_eqn = FamEqn {..}}) = + p_dataDecl + style + feqn_tycon + feqn_pats + lhsTypeArgSrcSpan + p_lhsTypeArg + feqn_fixity + feqn_rhs -match_overlap_mode :: Maybe (Located OverlapMode) -> R () -> R () +match_overlap_mode :: Maybe (LocatedP OverlapMode) -> R () -> R () match_overlap_mode overlap_mode layoutStrategy = case unLoc <$> overlap_mode of Just Overlappable {} -> do diff --git a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +-- | Printing of operator trees. +module Ormolu.Printer.Meat.Declaration.OpTree + ( p_exprOpTree, + exprOpTree, + p_cmdOpTree, + cmdOpTree, + p_tyOpTree, + tyOpTree, + getOpName, + getOpNameStr, + ) +where + +import Data.Functor ((<&>)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import GHC.Hs +import GHC.Types.Fixity +import GHC.Types.Name (occNameString) +import GHC.Types.Name.Reader (RdrName, rdrNameOcc) +import GHC.Types.SrcLoc +import Ormolu.Parser.CommentStream (LComment) +import Ormolu.Printer.Combinators +import Ormolu.Printer.Meat.Common (p_rdrName) +import Ormolu.Printer.Meat.Declaration.Value + ( IsApplicand (..), + cmdTopPlacement, + exprPlacement, + p_hsCmdTop, + p_hsExpr, + p_hsExpr', + ) +import Ormolu.Printer.Meat.Type (p_hsType) +import Ormolu.Printer.Operators + +-- | Extract the operator name of the specified 'HsExpr' if this expression +-- corresponds to an operator. +getOpName :: HsExpr GhcPs -> Maybe RdrName +getOpName = \case + HsVar _ (L _ a) -> Just a + _ -> Nothing + +-- | Convert an operator name to a 'String'. +getOpNameStr :: RdrName -> String +getOpNameStr = occNameString . rdrNameOcc + +-- | Decide whether the operands of an operator chain should be hanging. +opBranchPlacement :: + (HasLoc l) => + -- | Placer function for nodes + (ty -> Placement) -> + -- | First expression of the chain + OpTree (GenLocated l ty) op -> + -- | Last expression of the chain + OpTree (GenLocated l ty) op -> + Placement +opBranchPlacement placer firstExpr lastExpr + -- If the start of the first argument and the start of the last argument + -- are on the same line, and the last argument has a hanging form, use + -- hanging placement. + | isOneLineSpan + ( mkSrcSpan + (srcSpanStart (opTreeLoc firstExpr)) + (srcSpanStart (opTreeLoc lastExpr)) + ), + OpNode (L _ n) <- lastExpr = + placer n + | otherwise = Normal + +-- | Decide whether or not to use braces based on the layout and placement +-- of an expression in an infix operator application. +opBranchBraceStyle :: Placement -> R (R () -> R ()) +opBranchBraceStyle placement = + getLayout <&> \case + SingleLine -> useBraces + MultiLine -> case placement of + Hanging -> useBraces + Normal -> dontUseBraces + +-- | Convert a 'LHsExpr' containing an operator tree to the 'OpTree' +-- intermediate representation. +exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) +exprOpTree (L _ (OpApp _ x op y)) = BinaryOpBranches (exprOpTree x) op (exprOpTree y) +exprOpTree n = OpNode n + +-- | Print an operator tree where leaves are values. +p_exprOpTree :: + -- | Bracket style to use + BracketStyle -> + -- | N-ary 'OpTree' to render, enhanced with information regarding + -- operator fixity + OpTree (LHsExpr GhcPs) (OpInfo (LHsExpr GhcPs)) -> + R () +p_exprOpTree s (OpNode x) = located x (p_hsExpr' NotApplicand s) +p_exprOpTree s t@(OpBranches exprs@(firstExpr :| otherExprs) ops) = do + let placement = + opBranchPlacement + exprPlacement + firstExpr + (last otherExprs) + rightMostNode = \case + n@(OpNode _) -> n + OpBranches exprs'' _ -> rightMostNode (NE.last exprs'') + isDoBlock = \case + OpNode (L _ (HsDo _ ctx _)) -> case ctx of + DoExpr _ -> True + MDoExpr _ -> True + _ -> False + _ -> False + -- Whether we could place the operator in a trailing position, + -- followed by a breakpoint before the RHS + couldBeTrailing (prevExpr, opi) = + -- An operator with fixity InfixR 0, like seq, $, and the $ variants, + -- is required. + isHardSplitterOp (opiFixityApproximation opi) + -- The LHS must be single-line. + && isOneLineSpan (opTreeLoc prevExpr) + -- This can only happen when a breakpoint would have been added + -- anyway. + && placement == Normal + -- If the node just to the left of the operator (that is, the + -- rightmost node of the subtree prevExpr) is a do-block, then we + -- cannot 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 + -- A comment written on its own line in front of an operator forces the + -- operator onto a line of its own. In trailing position that line starts + -- at the indentation of the statement, and @$@ at the start of a line in + -- a @do@ block is read as a new statement rather than as a continuation. + -- The leading layout indents instead, so it keeps the meaning. + opsAreCommented <- + or <$> traverse (fmap (not . null) . leadingComments . opiOp) ops + -- If all operators at the current level match the conditions to be + -- trailing, and the chain is either a single operator or ends in a + -- hanging form, then put the operators in a trailing position. + let isTrailing = + (isSingleOperator || chainEndsInHangingForm) + && not opsAreCommented + && all couldBeTrailing (zip (NE.toList exprs) ops) + ub <- if isTrailing then return useBraces else opBranchBraceStyle placement + let p_x = ub $ p_exprOpTree s firstExpr + putOpsExprs prevExpr (opi : ops') (expr : exprs') = do + let isLast = null exprs' + ub' = if not isLast then ub else id + p_op = located (opiOp opi) p_hsExpr + p_y = ub' $ p_exprOpTree N expr + if isTrailing + then do + space + p_op + placeHanging + -- When we have a chain of trailing operators (staircase style), + -- the last operand, when multiline, is allowed to hang + -- (ex: do block, lambda...) + ( if isLast && (not . isOneLineSpan . opTreeLoc $ expr) + then opBranchPlacement exprPlacement prevExpr expr + else Normal + ) + $ do + p_y + putOpsExprs expr ops' exprs' + else do + placeHanging placement $ do + p_op + space + p_y + putOpsExprs expr ops' exprs' + putOpsExprs _ _ _ = pure () + switchLayout [opTreeLoc t] $ do + p_x + putOpsExprs firstExpr ops otherExprs + +-- | The comments that will be printed in front of a located thing. +leadingComments :: (HasLoc l) => GenLocated l a -> R [LComment] +leadingComments (L l _) = case locA l of + RealSrcSpan spn _ -> getCommentsBefore spn + _ -> pure [] + +-- | Convert a 'LHsCmdTop' containing an operator tree to the 'OpTree' +-- intermediate representation. +cmdOpTree :: LHsCmdTop GhcPs -> OpTree (LHsCmdTop GhcPs) (LHsExpr GhcPs) +cmdOpTree = \case + (L _ (HsCmdTop _ (L _ (HsCmdArrForm _ op Infix [x, y])))) -> + BinaryOpBranches (cmdOpTree x) op (cmdOpTree y) + n -> OpNode n + +-- | Print an operator tree where leaves are commands. +p_cmdOpTree :: + -- | Bracket style to use + BracketStyle -> + -- | N-ary OpTree to render, enhanced with information regarding operator + -- fixity + OpTree (LHsCmdTop GhcPs) (OpInfo (LHsExpr GhcPs)) -> + R () +p_cmdOpTree s (OpNode x) = located x (p_hsCmdTop s) +p_cmdOpTree s t@(OpBranches (firstExpr :| otherExprs) ops) = do + let placement = + opBranchPlacement + cmdTopPlacement + firstExpr + (last otherExprs) + ub <- opBranchBraceStyle placement + let p_x = ub $ p_cmdOpTree s firstExpr + putOpsExprs (opi : ops') (expr : exprs') = do + let ub' = if not (null exprs') then ub else id + p_op = located (opiOp opi) p_hsExpr + p_y = ub' $ p_cmdOpTree N expr + placeHanging placement $ do + p_op + space + p_y + putOpsExprs ops' exprs' + putOpsExprs _ _ = pure () + switchLayout [opTreeLoc t] $ do + p_x + putOpsExprs ops otherExprs + +-- | Check whether the given expression has a hanging form. Added for +-- symmetry with 'exprPlacement' and 'cmdTopPlacement', all of which are used +-- in the @p_xxxOpTree@ functions together with 'opBranchPlacement'. +tyOpPlacement :: HsType GhcPs -> Placement +tyOpPlacement = \case + _ -> Normal + +-- | Convert an 'LHsType' containing an operator tree to the 'OpTree' +-- intermediate representation. +tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (LocatedN RdrName) +tyOpTree (L _ (HsOpTy _ _ l op r)) = + BinaryOpBranches (tyOpTree l) op (tyOpTree r) +tyOpTree n = OpNode n + +-- | Print an operator tree where leaves are types. +p_tyOpTree :: + -- | N-ary 'OpTree' to render, enhanced with information regarding + -- operator fixity + OpTree (LHsType GhcPs) (OpInfo (LocatedN RdrName)) -> + R () +p_tyOpTree (OpNode n) = located n p_hsType +p_tyOpTree t@(OpBranches (firstExpr :| otherExprs) ops) = do + let placement = + opBranchPlacement + tyOpPlacement + firstExpr + (last otherExprs) + p_x = p_tyOpTree firstExpr + putOpsExprs (opi : ops') (expr : exprs') = do + let p_op = p_rdrName (opiOp opi) + p_y = p_tyOpTree expr + placeHanging + placement + $ do + p_op + space + p_y + putOpsExprs ops' exprs' + putOpsExprs _ _ = pure () + switchLayout [opTreeLoc t] $ do + ub <- opBranchBraceStyle placement + ub p_x + putOpsExprs ops otherExprs diff --git a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs-boot b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs-boot new file mode 100644 --- /dev/null +++ b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs-boot @@ -0,0 +1,33 @@ +module Ormolu.Printer.Meat.Declaration.OpTree + ( p_exprOpTree, + exprOpTree, + p_cmdOpTree, + cmdOpTree, + p_tyOpTree, + tyOpTree, + getOpName, + getOpNameStr, + ) +where + +import GHC.Hs +import GHC.Types.Name.Reader (RdrName) +import Ormolu.Printer.Combinators (BracketStyle, R) +import Ormolu.Printer.Operators (OpInfo, OpTree) + +exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) +p_exprOpTree :: + BracketStyle -> + OpTree (LHsExpr GhcPs) (OpInfo (LHsExpr GhcPs)) -> + R () +cmdOpTree :: LHsCmdTop GhcPs -> OpTree (LHsCmdTop GhcPs) (LHsExpr GhcPs) +p_cmdOpTree :: + BracketStyle -> + OpTree (LHsCmdTop GhcPs) (OpInfo (LHsExpr GhcPs)) -> + R () +tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (LocatedN RdrName) +p_tyOpTree :: + OpTree (LHsType GhcPs) (OpInfo (LocatedN RdrName)) -> + R () +getOpName :: HsExpr GhcPs -> Maybe RdrName +getOpNameStr :: RdrName -> String diff --git a/src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs b/src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs --- a/src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs +++ b/src/Ormolu/Printer/Meat/Declaration/RoleAnnotation.hs @@ -2,24 +2,22 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} --- | Rendering of Role annotation declarations. +-- | Rendering of role annotation declarations. module Ormolu.Printer.Meat.Declaration.RoleAnnotation ( p_roleAnnot, ) where import GHC.Core.Coercion.Axiom -import GHC.Hs.Decls -import GHC.Hs.Extension +import GHC.Hs hiding (anns) import GHC.Types.Name.Reader -import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common p_roleAnnot :: RoleAnnotDecl GhcPs -> R () -p_roleAnnot (RoleAnnotDecl NoExtField l_name anns) = p_roleAnnot' l_name anns +p_roleAnnot (RoleAnnotDecl _ l_name anns) = p_roleAnnot' l_name anns -p_roleAnnot' :: Located RdrName -> [Located (Maybe Role)] -> R () +p_roleAnnot' :: LocatedN RdrName -> [XRec GhcPs (Maybe Role)] -> R () p_roleAnnot' l_name anns = do txt "type role" breakpoint diff --git a/src/Ormolu/Printer/Meat/Declaration/Rule.hs b/src/Ormolu/Printer/Meat/Declaration/Rule.hs --- a/src/Ormolu/Printer/Meat/Declaration/Rule.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Rule.hs @@ -4,56 +4,56 @@ module Ormolu.Printer.Meat.Declaration.Rule ( p_ruleDecls, + p_ruleBndrs, ) where -import Control.Monad (unless) -import GHC.Hs.Decls -import GHC.Hs.Extension -import GHC.Hs.Lit -import GHC.Hs.Type +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 p_ruleDecls :: RuleDecls GhcPs -> R () -p_ruleDecls (HsRules NoExtField _ xs) = +p_ruleDecls (HsRules _ xs) = pragma "RULES" $ sep breakpoint (sitcc . located' p_ruleDecl) xs p_ruleDecl :: RuleDecl GhcPs -> R () -p_ruleDecl (HsRule NoExtField 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 space - equals + txt "=" inci $ do breakpoint located rhs p_hsExpr -p_ruleName :: (SourceText, RuleName) -> R () -p_ruleName (_, name) = atom $ (HsString NoSourceText name :: HsLit GhcPs) +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 - RuleBndr NoExtField x -> p_rdrName x - RuleBndrSig NoExtField x HsPS {..} -> parens N $ do + RuleBndr _ x -> p_rdrName x + RuleBndrSig _ x HsPS {..} -> parens N $ do p_rdrName x - p_typeAscription (HsWC NoExtField (HsIB NoExtField hsps_body)) + p_typeAscription (lhsTypeToSigType hsps_body) diff --git a/src/Ormolu/Printer/Meat/Declaration/Signature.hs b/src/Ormolu/Printer/Meat/Declaration/Signature.hs --- a/src/Ormolu/Printer/Meat/Declaration/Signature.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Signature.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} -- | Type signature declarations. module Ormolu.Printer.Meat.Declaration.Signature @@ -8,78 +9,78 @@ p_typeAscription, p_activation, p_standaloneKindSig, + deconstructExprFromSpecSigE, ) where import Control.Monad +import Data.Maybe (maybeToList) import GHC.Data.BooleanFormula -import GHC.Hs.Binds -import GHC.Hs.Decls -import GHC.Hs.Extension -import GHC.Hs.Type +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 p_sigDecl :: Sig GhcPs -> R () p_sigDecl = \case - TypeSig NoExtField names hswc -> p_typeSig True names hswc - PatSynSig NoExtField names hsib -> p_patSynSig names hsib - ClassOpSig NoExtField def names hsib -> p_classOpSig def names hsib - FixSig NoExtField sig -> p_fixSig sig - InlineSig NoExtField name inlinePragma -> p_inlineSig name inlinePragma - SpecSig NoExtField name ts inlinePragma -> p_specSig name ts inlinePragma - SpecInstSig NoExtField _ hsib -> p_specInstSig hsib - MinimalSig NoExtField _ booleanFormula -> p_minimalSig booleanFormula - CompleteMatchSig NoExtField _sourceText cs ty -> p_completeSig cs ty - SCCFunSig NoExtField _ name literal -> p_sccSig name literal - _ -> notImplemented "certain types of signature declarations" + TypeSig _ names hswc -> p_typeSig True names (hswc_body hswc) + PatSynSig _ names sigType -> p_patSynSig names sigType + 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 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 + SCCFunSig _ name literal -> p_sccSig name literal p_typeSig :: -- | Should the tail of the names be indented Bool -> -- | Names (before @::@) - [Located RdrName] -> + [LocatedN RdrName] -> -- | Type - LHsSigWcType GhcPs -> + LHsSigType GhcPs -> R () p_typeSig _ [] _ = return () -- should not happen though -p_typeSig indentTail (n : ns) hswc = do +p_typeSig indentTail (n : ns) sigType = do p_rdrName n if null ns - then p_typeAscription hswc + then p_typeAscription sigType else inciIf indentTail $ do commaDel sep commaDel p_rdrName ns - p_typeAscription hswc + p_typeAscription sigType p_typeAscription :: - LHsSigWcType GhcPs -> + LHsSigType GhcPs -> R () -p_typeAscription HsWC {..} = inci $ do +p_typeAscription sigType = inci $ do space txt "::" - let t = hsib_body hswc_body - if hasDocStrings (unLoc t) + if hasDocStrings (unLoc . sig_body . unLoc $ sigType) then newline else breakpoint - located t p_hsType + located sigType p_hsSigType p_patSynSig :: - [Located RdrName] -> - HsImplicitBndrs GhcPs (LHsType GhcPs) -> + [LocatedN RdrName] -> + LHsSigType GhcPs -> R () -p_patSynSig names hsib = do +p_patSynSig names sigType = do txt "pattern" - let body = - p_typeSig - False - names - HsWC {hswc_ext = NoExtField, hswc_body = hsib} + let body = p_typeSig False names sigType if length names > 1 then breakpoint >> inci body else space >> body @@ -88,19 +89,19 @@ -- | Whether this is a \"default\" signature Bool -> -- | Names (before @::@) - [Located RdrName] -> + [LocatedN RdrName] -> -- | Type - HsImplicitBndrs GhcPs (LHsType GhcPs) -> + LHsSigType GhcPs -> R () -p_classOpSig def names hsib = do +p_classOpSig def names sigType = do when def (txt "default" >> space) - p_typeSig True names HsWC {hswc_ext = NoExtField, hswc_body = hsib} + p_typeSig True names sigType p_fixSig :: FixitySig GhcPs -> R () p_fixSig = \case - FixitySig NoExtField names (Fixity _ n dir) -> do + FixitySig namespace names (Fixity n dir) -> do txt $ case dir of InfixL -> "infixl" InfixR -> "infixr" @@ -108,11 +109,12 @@ space atom n space + p_namespaceSpec namespace sitcc $ sep commaDel p_rdrName names p_inlineSig :: -- | Name - Located RdrName -> + LocatedN RdrName -> -- | Inline pragma specification InlinePragma -> R () @@ -123,41 +125,87 @@ ConLike -> txt "CONLIKE" FunLike -> return () space - p_activation inl_act + when (inl_act /= NeverActive) $ p_activation inl_act space p_rdrName name p_specSig :: - -- | Name - Located RdrName -> + -- | Rule binders + Maybe (RuleBndrs GhcPs) -> + -- | Expression to specialize + LHsExpr GhcPs -> -- | The types to specialize to [LHsSigType GhcPs] -> -- | For specialize inline InlinePragma -> R () -p_specSig name ts InlinePragma {..} = pragmaBraces $ do +p_specSig mRuleBndrs specExpr ts InlinePragma {..} = pragmaBraces $ do txt "SPECIALIZE" space p_inlineSpec inl_inline space - p_activation inl_act - space - p_rdrName name - space - txt "::" - breakpoint - inci $ sep commaDel (located' p_hsType . hsib_body) ts + case (inl_inline, inl_act) of + (NoInline _, NeverActive) -> return () + _ -> p_activation inl_act + inci $ do + space + forM_ mRuleBndrs $ \ruleBndrs -> do + p_ruleBndrs ruleBndrs + space + located specExpr p_hsExpr + case ts of + [] -> pure () + _ -> do + space + txt "::" + breakpoint + sep commaDel (located' p_hsSigType) ts +p_specSigE :: + -- | Rule binders + RuleBndrs GhcPs -> + -- | Expression to specialize + LHsExpr GhcPs -> + -- | For specialize inline + InlinePragma -> + R () +p_specSigE ruleBndrs expr = + p_specSig (Just ruleBndrs) specExpr (maybeToList sigTy) + where + (_, specExpr, sigTy) = deconstructExprFromSpecSigE expr + +-- | The 'LHsExpr' in a 'SpecSigE' can only be of a very specific form, +-- namely a variable applied to value/type-level arguments, optionally with a +-- type signature. +-- +-- https://github.com/ghc-proposals/ghc-proposals/blob/e2c683698323cec3e33625369ae2b5f585387c70/proposals/0493-specialise-expressions.rst#2proposed-change-specification +deconstructExprFromSpecSigE :: + (HasCallStack) => + LHsExpr GhcPs -> + (LocatedN RdrName, LHsExpr GhcPs, Maybe (LHsSigType GhcPs)) +deconstructExprFromSpecSigE = \case + L _ (ExprWithTySig _ e HsWC {hswc_body}) -> + (findVar e, e, Just hswc_body) + e -> (findVar e, e, Nothing) + where + findVar :: LHsExpr GhcPs -> LocatedN RdrName + findVar = \case + L _ (HsVar _ name) -> name + L _ (HsApp _ e _) -> findVar e + L _ (HsAppType _ e _) -> findVar e + _ -> error "unreachble" + p_inlineSpec :: InlineSpec -> R () p_inlineSpec = \case - Inline -> txt "INLINE" - Inlinable -> txt "INLINEABLE" - NoInline -> txt "NOINLINE" - NoUserInline -> return () + Inline _ -> txt "INLINE" + Inlinable _ -> txt "INLINEABLE" + NoInline _ -> txt "NOINLINE" + Opaque _ -> txt "OPAQUE" + NoUserInlinePrag -> return () p_activation :: Activation -> R () p_activation = \case - NeverActive -> return () + NeverActive -> txt "[~]" AlwaysActive -> return () ActiveBefore _ n -> do txt "[~" @@ -170,13 +218,13 @@ FinalActive -> notImplemented "FinalActive" -- NOTE(amesgen) is this unreachable or just not implemented? p_specInstSig :: LHsSigType GhcPs -> R () -p_specInstSig hsib = +p_specInstSig sigType = pragma "SPECIALIZE instance" . inci $ - located (hsib_body hsib) p_hsType + located sigType p_hsSigType p_minimalSig :: -- | Boolean formula - LBooleanFormula (Located RdrName) -> + LBooleanFormula GhcPs -> R () p_minimalSig = located' $ \booleanFormula -> @@ -184,7 +232,7 @@ p_booleanFormula :: -- | Boolean formula - BooleanFormula (Located RdrName) -> + BooleanFormula GhcPs -> R () p_booleanFormula = \case Var name -> p_rdrName name @@ -204,12 +252,12 @@ p_completeSig :: -- | Constructors\/patterns - Located [Located RdrName] -> + [LIdP GhcPs] -> -- | Type - Maybe (Located RdrName) -> + Maybe (LocatedN RdrName) -> R () -p_completeSig cs' mty = - located cs' $ \cs -> +p_completeSig cs mty = + switchLayout (getLocA <$> cs) $ pragma "COMPLETE" . inci $ do sep commaDel p_rdrName cs forM_ mty $ \ty -> do @@ -218,7 +266,7 @@ breakpoint inci (p_rdrName ty) -p_sccSig :: Located (IdP GhcPs) -> Maybe (Located StringLiteral) -> R () +p_sccSig :: LocatedN RdrName -> Maybe (XRec GhcPs StringLiteral) -> R () p_sccSig loc literal = pragma "SCC" . inci $ do p_rdrName loc forM_ literal $ \x -> do @@ -226,7 +274,7 @@ atom x p_standaloneKindSig :: StandaloneKindSig GhcPs -> R () -p_standaloneKindSig (StandaloneKindSig NoExtField name (HsIB NoExtField sig)) = do +p_standaloneKindSig (StandaloneKindSig _ name sigTy) = do txt "type" inci $ do space @@ -234,4 +282,4 @@ space txt "::" breakpoint - located sig p_hsType + located sigTy p_hsSigType diff --git a/src/Ormolu/Printer/Meat/Declaration/Signature.hs-boot b/src/Ormolu/Printer/Meat/Declaration/Signature.hs-boot new file mode 100644 --- /dev/null +++ b/src/Ormolu/Printer/Meat/Declaration/Signature.hs-boot @@ -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 () diff --git a/src/Ormolu/Printer/Meat/Declaration/Splice.hs b/src/Ormolu/Printer/Meat/Declaration/Splice.hs --- a/src/Ormolu/Printer/Meat/Declaration/Splice.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Splice.hs @@ -1,15 +1,12 @@ -{-# LANGUAGE LambdaCase #-} - module Ormolu.Printer.Meat.Declaration.Splice ( p_spliceDecl, ) where -import GHC.Hs.Decls -import GHC.Hs.Extension +import GHC.Hs import Ormolu.Printer.Combinators -import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice) +import Ormolu.Printer.Meat.Declaration.Value (p_hsUntypedSplice) p_spliceDecl :: SpliceDecl GhcPs -> R () -p_spliceDecl = \case - SpliceDecl NoExtField splice _explicit -> located splice p_hsSplice +p_spliceDecl (SpliceDecl NoExtField splice deco) = + located splice $ p_hsUntypedSplice deco diff --git a/src/Ormolu/Printer/Meat/Declaration/StringLiteral.hs b/src/Ormolu/Printer/Meat/Declaration/StringLiteral.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Printer/Meat/Declaration/StringLiteral.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Ormolu.Printer.Meat.Declaration.StringLiteral (p_stringLit) where + +import Control.Applicative (Alternative (..)) +import Control.Category ((>>>)) +import Control.Monad ((>=>)) +import Data.Semigroup (Min (..)) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Data.FastString +import GHC.Parser.CharClass (is_space) +import Ormolu.Printer.Combinators +import Ormolu.Utils + +-- | Print the source text of a string literal while indenting gaps and +-- newlines correctly. +p_stringLit :: FastString -> R () +p_stringLit src = case parseStringLiteral $ T.pack $ unpackFS src of + Nothing -> error $ "Internal Ormolu error: couldn't parse string literal: " <> show src + Just ParsedStringLiteral {..} -> sitcc do + txt startMarker + case stringLiteralKind of + RegularStringLiteral -> do + let singleLine = + txt $ intercalateMinimalStringGaps segments + multiLine = + sep breakpoint f (attachRelativePos segments) + where + f :: (RelativePos, Text) -> R () + f (pos, s) = case pos of + SinglePos -> txt s + FirstPos -> txt s *> txt "\\" + MiddlePos -> txt "\\" *> txt s *> txt "\\" + LastPos -> txt "\\" *> txt s + vlayout singleLine multiLine + MultilineStringLiteral -> + sep newlineLiteral txt segments + txt endMarker + +-- | The start/end marker of the literal, whether it is a regular or a +-- multiline literal, and the segments of the literal (separated by gaps for +-- a regular literal, and separated by newlines for a multiline literal). +data ParsedStringLiteral = ParsedStringLiteral + { startMarker, endMarker :: Text, + stringLiteralKind :: StringLiteralKind, + segments :: [Text] + } + deriving stock (Show, Eq) + +-- | A regular or a multiline string literal. +data StringLiteralKind = RegularStringLiteral | MultilineStringLiteral + deriving stock (Show, Eq) + +-- | Turn a string literal (as it exists in the source) into a more +-- structured form for printing. This should never return 'Nothing' for +-- literals that the GHC parser accepted. +parseStringLiteral :: Text -> Maybe ParsedStringLiteral +parseStringLiteral = \s -> do + psl <- + (stripStartEndMarker MultilineStringLiteral "\"\"\"" s) + <|> (stripStartEndMarker RegularStringLiteral "\"" s) + let splitSegments = case stringLiteralKind psl of + RegularStringLiteral -> splitGaps + MultilineStringLiteral -> splitMultilineString + pure psl {segments = concatMap splitSegments $ segments psl} + where + -- Remove the given marker from the start and the end (at the end, + -- optionally also remove a #). + stripStartEndMarker :: + StringLiteralKind -> Text -> Text -> Maybe ParsedStringLiteral + stripStartEndMarker stringLiteralKind marker s = do + let startMarker = marker + suffix <- T.stripPrefix startMarker s + let markerWithHash = marker <> "#" + (endMarker, infix_) <- + ((markerWithHash,) <$> T.stripSuffix markerWithHash suffix) + <|> ((marker,) <$> T.stripSuffix marker suffix) + pure ParsedStringLiteral {segments = [infix_], ..} + + -- Split a string on gaps (backslash-delimited whitespace). + -- + -- > splitGaps "bar\\ \\fo\\&o" == ["bar", "fo\\&o"] + splitGaps :: Text -> [Text] + splitGaps s = go $ T.breakOnAll "\\" s + where + go [] = [s] + go ((pre, suf) : bs) = case T.uncons suf of + Just ('\\', suf') + | (gap, T.uncons -> Just ('\\', rest)) <- T.span is_space suf', + -- If there is a space after the backslash, this is definitely a + -- string gap. Continue parsing gaps after the next backslash. + not $ T.null gap -> + pre : splitGaps rest + | otherwise -> + -- Check whether @suf@ starts with an escape sequence + -- involving another backslash. If so, it cannot 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 MultilineStrings GHC proposal and 'lexMultilineString' from + -- "GHC.Parser.String" for reference. + -- + -- https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0569-multiline-strings.rst#proposed-change-specification + splitMultilineString :: Text -> [Text] + splitMultilineString = + splitGaps + -- There is no reason to use gaps in multiline string literals just to + -- emulate multi-line strings, so we replace them with "\\ \\". + >>> intercalateMinimalStringGaps + >>> splitNewlines + >>> fmap expandLeadingTabs + >>> rmCommonWhitespacePrefixAndBlank + + -- See the definition of newlines on + -- . + splitNewlines :: Text -> [Text] + splitNewlines = T.splitOn "\r\n" >=> T.split isNewlineish + where + isNewlineish c = c == '\n' || c == '\r' || c == '\f' + + -- See GHC's 'lexMultilineString'. + expandLeadingTabs :: Text -> Text + expandLeadingTabs = T.concat . go 0 + where + go :: Int -> Text -> [Text] + go col s = case T.breakOn "\t" s of + (pre, T.uncons -> Just (_, suf)) -> + let col' = col + T.length pre + fill = 8 - (col' `mod` 8) + in pre : T.replicate fill " " : go (col' + fill) suf + _ -> [s] + + -- Don't touch the first line; remove common whitespace from all + -- remaining lines, and convert those consisting only of whitespace into + -- empty lines. + rmCommonWhitespacePrefixAndBlank :: [Text] -> [Text] + rmCommonWhitespacePrefixAndBlank = \case + [] -> [] + hd : tl -> hd : tl' + where + (leadingSpaces, tl') = unzip $ countLeadingAndBlank <$> tl + + commonWs :: Int + commonWs = maybe 0 getMin $ mconcat leadingSpaces + + countLeadingAndBlank :: Text -> (Maybe (Min Int), Text) + countLeadingAndBlank l + | T.all is_space l = (Nothing, "") + | otherwise = (Just $ Min leadingSpace, T.drop commonWs l) + where + leadingSpace = T.length $ T.takeWhile is_space l + +-- | Add minimal string gaps between string literal chunks. Such string gaps +-- /can/ be semantically meaningful (so we preserve them for simplicity); for +-- example: +-- +-- >>> "\65\ \0" == "\650" +-- False +intercalateMinimalStringGaps :: [Text] -> Text +intercalateMinimalStringGaps = T.intercalate "\\ \\" 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,9 +10,11 @@ ) where +import Data.Choice (pattern Is, pattern Isn't) import GHC.Hs.Extension import GHC.Hs.Type -import GHC.Types.Basic +import GHC.Parser.Annotation +import GHC.Types.Fixity import GHC.Types.Name.Reader import GHC.Types.SrcLoc import Ormolu.Printer.Combinators @@ -18,7 +23,7 @@ p_synDecl :: -- | Type constructor - Located RdrName -> + LocatedN RdrName -> -- | Fixity LexicalFixity -> -- | Type variables @@ -29,15 +34,19 @@ p_synDecl name fixity HsQTvs {..} t = do txt "type" space - switchLayout (getLoc name : map getLoc hsq_explicit) $ + 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) - space - equals - if hasDocStrings (unLoc t) - then newline - else breakpoint - inci (located t p_hsType) + inci $ do + space + txt "=" + if hasDocStrings (unLoc t) + then newline + else breakpoint + located t p_hsType 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,11 +13,11 @@ where import Control.Monad +import Data.Choice (pattern Is) +import Data.Choice qualified as Choice import Data.Maybe (isNothing) -import GHC.Hs.Decls -import GHC.Hs.Extension -import GHC.Hs.Type -import GHC.Types.Basic +import GHC.Hs +import GHC.Types.Fixity import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common @@ -29,12 +32,14 @@ txt $ case style of Associated -> mempty Free -> " family" - breakpoint - inci $ do - switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $ + let headerSpns = getLocA fdLName : (getLocA <$> hsq_explicit) + headerAndSigSpns = getLocA fdResultSig : headerSpns + inci . switchLayout headerAndSigSpns $ do + 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 @@ -46,7 +51,7 @@ case mmeqs of Nothing -> return () Just meqs -> do - inci $ do + inci . switchLayout headerAndSigSpns $ do breakpoint txt "where" case meqs of @@ -55,10 +60,10 @@ txt ".." Just eqs -> do newline - sep newline (located' (inci . p_tyFamInstEqn)) eqs + inci (sep newline (located' p_tyFamInstEqn) eqs) p_familyResultSigL :: - Located (FamilyResultSig GhcPs) -> + LFamilyResultSig GhcPs -> Maybe (R ()) p_familyResultSigL (L _ a) = case a of NoSig NoExtField -> Nothing @@ -67,12 +72,12 @@ breakpoint located k p_hsType TyVarSig NoExtField bndr -> Just $ do - equals + txt "=" breakpoint located bndr p_hsTyVarBndr p_injectivityAnn :: InjectivityAnn GhcPs -> R () -p_injectivityAnn (InjectivityAnn a bs) = do +p_injectivityAnn (InjectivityAnn _ a bs) = do txt "|" space p_rdrName a @@ -82,24 +87,28 @@ sep space p_rdrName bs p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R () -p_tyFamInstEqn HsIB {hsib_body = FamEqn {..}} = do +p_tyFamInstEqn FamEqn {..} = do case feqn_bndrs of - Nothing -> return () - Just bndrs -> do + HsOuterImplicit NoExtField -> return () + HsOuterExplicit _ bndrs -> do p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs breakpoint - inciIf (not $ null feqn_bndrs) $ do - let famLhsSpn = getLoc feqn_tycon : fmap lhsTypeArgSrcSpan feqn_pats + let atLeastOneBndr = case feqn_bndrs of + HsOuterImplicit NoExtField -> False + HsOuterExplicit _ bndrs -> not $ null bndrs + inciIf atLeastOneBndr $ do + 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) - space - equals - breakpoint - inci (located feqn_rhs p_hsType) + inci $ do + space + txt "=" + breakpoint + located feqn_rhs p_hsType ---------------------------------------------------------------------------- -- Helpers 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 @@ -1,1389 +1,1429 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Ormolu.Printer.Meat.Declaration.Value - ( p_valDecl, - p_pat, - p_hsExpr, - p_hsSplice, - p_stringLit, - ) -where - -import Control.Monad -import Data.Bool (bool) -import Data.Char (isPunctuation, isSymbol) -import Data.Data hiding (Infix, Prefix) -import Data.Function (on) -import Data.Functor ((<&>)) -import Data.Generics.Schemes (everything) -import Data.List (intersperse, sortBy) -import Data.List.NonEmpty (NonEmpty (..), (<|)) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (isJust) -import Data.Text (Text) -import qualified Data.Text as Text -import GHC.Data.Bag (bagToList) -import GHC.Hs.Binds -import GHC.Hs.Expr -import GHC.Hs.Extension -import GHC.Hs.Lit -import GHC.Hs.Pat -import GHC.Hs.Type -import GHC.LanguageExtensions.Type (Extension (NegativeLiterals)) -import GHC.Parser.Annotation -import GHC.Parser.CharClass (is_space) -import GHC.Types.Basic -import GHC.Types.Name.Occurrence (occNameString) -import GHC.Types.Name.Reader -import GHC.Types.SrcLoc -import Ormolu.Printer.Combinators -import Ormolu.Printer.Internal -import Ormolu.Printer.Meat.Common -import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration -import Ormolu.Printer.Meat.Declaration.Signature -import Ormolu.Printer.Meat.Type -import Ormolu.Printer.Operators -import Ormolu.Utils - --- | Style of a group of equations. -data MatchGroupStyle - = Function (Located RdrName) - | PatternBind - | Case - | Lambda - | LambdaCase - --- | Style of equations in a group. -data GroupStyle - = EqualSign - | RightArrow - --- | Expression placement. This marks the places where expressions that --- implement handing forms may use them. -data Placement - = -- | Multi-line layout should cause - -- insertion of a newline and indentation - -- bump - Normal - | -- | Expressions that have hanging form - -- should use it and avoid bumping one level - -- of indentation - Hanging - deriving (Eq, Show) - -p_valDecl :: HsBindLR GhcPs GhcPs -> R () -p_valDecl = \case - FunBind NoExtField funId funMatches _ -> p_funBind funId funMatches - PatBind NoExtField pat grhss _ -> p_match PatternBind False NoSrcStrict [pat] grhss - VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker - AbsBinds {} -> notImplemented "AbsBinds" -- introduced by the type checker - PatSynBind NoExtField psb -> p_patSynBind psb - -p_funBind :: - Located RdrName -> - MatchGroup GhcPs (LHsExpr GhcPs) -> - R () -p_funBind name = p_matchGroup (Function name) - -p_matchGroup :: - MatchGroupStyle -> - MatchGroup GhcPs (LHsExpr GhcPs) -> - R () -p_matchGroup = p_matchGroup' exprPlacement p_hsExpr - -p_matchGroup' :: - Data body => - -- | How to get body placement - (body -> Placement) -> - -- | How to print body - (body -> R ()) -> - -- | Style of this group of equations - MatchGroupStyle -> - -- | Match group - MatchGroup GhcPs (Located body) -> - R () -p_matchGroup' placer render style MG {..} = do - let ob = case style of - Case -> id - LambdaCase -> id - _ -> dontUseBraces - -- 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 - ob $ sepSemi (located' (ub . p_Match)) (unLoc mg_alts) - where - p_Match m@Match {..} = - p_match' - placer - render - (adjustMatchGroupStyle m style) - (isInfixMatch m) - (matchStrictness m) - m_pats - m_grhss - --- | Function id obtained through pattern matching on 'FunBind' should not --- be used to print the actual equations because the different ‘RdrNames’ --- used in the equations may have different “decorations” (such as backticks --- and paretheses) associated with them. It is necessary to use per-equation --- names obtained from 'm_ctxt' of 'Match'. This function replaces function --- name inside of 'Function' accordingly. -adjustMatchGroupStyle :: - Match GhcPs body -> - MatchGroupStyle -> - MatchGroupStyle -adjustMatchGroupStyle m = \case - Function _ -> (Function . mc_fun . m_ctxt) m - style -> style - -matchStrictness :: Match id body -> SrcStrictness -matchStrictness match = - case m_ctxt match of - FunRhs {mc_strictness = s} -> s - _ -> NoSrcStrict - -p_match :: - -- | Style of the group - MatchGroupStyle -> - -- | Is this an infix match? - Bool -> - -- | Strictness prefix (FunBind) - SrcStrictness -> - -- | Argument patterns - [LPat GhcPs] -> - -- | Equations - GRHSs GhcPs (LHsExpr GhcPs) -> - R () -p_match = p_match' exprPlacement p_hsExpr - -p_match' :: - Data body => - -- | How to get body placement - (body -> Placement) -> - -- | How to print body - (body -> R ()) -> - -- | Style of this group of equations - MatchGroupStyle -> - -- | Is this an infix match? - Bool -> - -- | Strictness prefix (FunBind) - SrcStrictness -> - -- | Argument patterns - [LPat GhcPs] -> - -- | Equations - GRHSs GhcPs (Located body) -> - R () -p_match' placer render style isInfix strictness m_pats GRHSs {..} = do - -- Normally, since patterns may be placed in a multi-line layout, it is - -- necessary to bump indentation for the pattern group so it's more - -- indented than function name. This in turn means that indentation for - -- the body should also be bumped. Normally this would mean that bodies - -- would start with two indentation steps applied, which is ugly, so we - -- need to be a bit more clever here and bump indentation level only when - -- pattern group is multiline. - case strictness of - NoSrcStrict -> return () - SrcStrict -> txt "!" - SrcLazy -> txt "~" - indentBody <- case NE.nonEmpty m_pats of - Nothing -> - False <$ case style of - Function name -> p_rdrName name - _ -> return () - Just ne_pats -> do - let combinedSpans = case style of - Function name -> combineSrcSpans (getLoc name) patSpans - _ -> patSpans - patSpans = combineSrcSpans' (getLoc <$> ne_pats) - indentBody = not (isOneLineSpan combinedSpans) - switchLayout [combinedSpans] $ do - let stdCase = sep breakpoint (located' p_pat) m_pats - case style of - Function name -> - p_infixDefHelper - isInfix - indentBody - (p_rdrName name) - (located' p_pat <$> m_pats) - PatternBind -> stdCase - Case -> stdCase - Lambda -> do - let needsSpace = case unLoc (NE.head ne_pats) of - LazyPat _ _ -> True - BangPat _ _ -> True - SplicePat _ _ -> True - _ -> False - txt "\\" - when needsSpace space - sitcc stdCase - LambdaCase -> stdCase - return indentBody - let -- Calculate position of end of patterns. This is useful when we decide - -- about putting certain constructions in hanging positions. - endOfPats = case NE.nonEmpty m_pats of - Nothing -> case style of - Function name -> Just (getLoc name) - _ -> Nothing - Just pats -> (Just . getLoc . NE.last) pats - isCase = \case - Case -> True - LambdaCase -> True - _ -> False - hasGuards = withGuards grhssGRHSs - grhssSpan = - combineSrcSpans' $ - getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs - patGrhssSpan = - maybe - grhssSpan - (combineSrcSpans grhssSpan . srcLocSpan . srcSpanEnd) - endOfPats - placement = - case endOfPats of - Nothing -> blockPlacement placer grhssGRHSs - Just spn -> - if onTheSameLine spn grhssSpan - then blockPlacement placer grhssGRHSs - else Normal - p_body = do - let groupStyle = - if isCase style && hasGuards - then RightArrow - else EqualSign - sep newline (located' (p_grhs' placer render groupStyle)) grhssGRHSs - p_where = do - let whereIsEmpty = eqEmptyLocalBinds (unLoc grhssLocalBinds) - unless (eqEmptyLocalBinds (unLoc grhssLocalBinds)) $ do - breakpoint - txt "where" - unless whereIsEmpty breakpoint - inci $ located grhssLocalBinds p_hsLocalBinds - inciIf indentBody $ do - unless (length grhssGRHSs > 1) $ - case style of - Function _ | hasGuards -> return () - Function _ -> space >> inci equals - PatternBind -> space >> inci equals - s | isCase s && hasGuards -> return () - _ -> space >> txt "->" - switchLayout [patGrhssSpan] $ - placeHanging placement p_body - inci p_where - -p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R () -p_grhs = p_grhs' exprPlacement p_hsExpr - -p_grhs' :: - Data body => - -- | How to get body placement - (body -> Placement) -> - -- | How to print body - (body -> R ()) -> - GroupStyle -> - GRHS GhcPs (Located body) -> - R () -p_grhs' placer render style (GRHS NoExtField guards body) = - case guards of - [] -> p_body - xs -> do - txt "|" - space - sitcc (sep commaDel (sitcc . located' p_stmt) xs) - space - inci $ case style of - EqualSign -> equals - RightArrow -> txt "->" - placeHanging placement p_body - where - placement = - case endOfGuards of - Nothing -> placer (unLoc body) - Just spn -> - if onTheSameLine spn (getLoc body) - then placer (unLoc body) - else Normal - endOfGuards = - case NE.nonEmpty guards of - Nothing -> Nothing - Just gs -> (Just . getLoc . NE.last) gs - p_body = located body render - -p_hsCmd :: HsCmd GhcPs -> R () -p_hsCmd = p_hsCmd' N - -p_hsCmd' :: BracketStyle -> HsCmd GhcPs -> R () -p_hsCmd' s = \case - HsCmdArrApp NoExtField body input arrType rightToLeft -> do - let (l, r) = if rightToLeft then (body, input) else (input, body) - located l p_hsExpr - breakpoint - inci $ do - case (arrType, rightToLeft) of - (HsFirstOrderApp, True) -> txt "-<" - (HsHigherOrderApp, True) -> txt "-<<" - (HsFirstOrderApp, False) -> txt ">-" - (HsHigherOrderApp, False) -> txt ">>-" - placeHanging (exprPlacement (unLoc input)) $ - located r p_hsExpr - HsCmdArrForm NoExtField form Prefix _ cmds -> banana s $ do - located form p_hsExpr - unless (null cmds) $ do - breakpoint - inci (sequence_ (intersperse breakpoint (located' p_hsCmdTop <$> cmds))) - HsCmdArrForm NoExtField form Infix _ [left, right] -> do - located left p_hsCmdTop - case unLoc left of - HsCmdTop NoExtField (L _ HsCmdPar {}) -> space - _ -> breakpoint - located form p_hsExpr - placeHanging (cmdTopPlacement (unLoc right)) $ - located right p_hsCmdTop - HsCmdArrForm NoExtField _ Infix _ _ -> notImplemented "HsCmdArrForm" - HsCmdApp NoExtField cmd expr -> do - located cmd (p_hsCmd' s) - space - located expr p_hsExpr - HsCmdLam NoExtField mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup - HsCmdPar NoExtField c -> parens N (located c p_hsCmd) - HsCmdCase NoExtField e mgroup -> - p_case cmdPlacement p_hsCmd e mgroup - HsCmdLamCase NoExtField mgroup -> - p_lamcase cmdPlacement p_hsCmd mgroup - HsCmdIf NoExtField _ if' then' else' -> - p_if cmdPlacement p_hsCmd if' then' else' - HsCmdLet NoExtField localBinds c -> - p_let p_hsCmd localBinds c - HsCmdDo NoExtField es -> do - txt "do" - newline - inci . located es $ - sitcc . sep newline (sitcc . withSpacing (p_stmt' cmdPlacement (p_hsCmd' S))) - -p_hsCmdTop :: HsCmdTop GhcPs -> R () -p_hsCmdTop (HsCmdTop NoExtField cmd) = located cmd p_hsCmd - --- | Render an expression preserving blank lines between such consecutive --- expressions found in the original source code. -withSpacing :: - -- | Rendering function - (a -> R ()) -> - -- | Entity to render - Located a -> - R () -withSpacing f l = located l $ \x -> do - case getLoc l of - 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 () - f x - -- In some cases the (f x) expression may insert a new mark. We want - -- to be careful not to override comment marks. - getSpanMark >>= \case - Just (HaddockSpan _ _) -> return () - Just (CommentSpan _) -> return () - _ -> setSpanMark (StatementSpan currentSpn) - -p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R () -p_stmt = p_stmt' exprPlacement p_hsExpr - -p_stmt' :: - Data body => - -- | Placer - (body -> Placement) -> - -- | Render - (body -> R ()) -> - -- | Statement to render - Stmt GhcPs (Located body) -> - R () -p_stmt' placer render = \case - LastStmt NoExtField body _ _ -> located body render - BindStmt NoExtField p f@(L l x) -> do - located p p_pat - space - txt "<-" - let loc = getLoc p - placement - | isOneLineSpan (mkSrcSpan (srcSpanEnd loc) (srcSpanStart l)) = placer x - | otherwise = Normal - switchLayout [loc, l] $ - placeHanging placement (located f render) - ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer - BodyStmt NoExtField body _ _ -> located body render - LetStmt NoExtField binds -> do - txt "let" - space - sitcc $ located binds p_hsLocalBinds - ParStmt {} -> - -- 'ParStmt' should always be eliminated in 'gatherStmt' already, such - -- that it never occurs in 'p_stmt''. Consequently, handling it here - -- would be redundant. - notImplemented "ParStmt" - TransStmt {..} -> - -- 'TransStmt' only needs to account for render printing itself, since - -- pretty printing of relevant statements (e.g., in 'trS_stmts') is - -- handled through 'gatherStmt'. - case (trS_form, trS_by) of - (ThenForm, Nothing) -> do - txt "then" - breakpoint - inci $ located trS_using p_hsExpr - (ThenForm, Just e) -> do - txt "then" - breakpoint - inci $ located trS_using p_hsExpr - breakpoint - txt "by" - breakpoint - inci $ located e p_hsExpr - (GroupForm, Nothing) -> do - txt "then group using" - breakpoint - inci $ located trS_using p_hsExpr - (GroupForm, Just e) -> do - txt "then group by" - breakpoint - inci $ located e p_hsExpr - breakpoint - txt "using" - breakpoint - inci $ located trS_using p_hsExpr - RecStmt {..} -> do - txt "rec" - space - sitcc $ sepSemi (withSpacing (p_stmt' placer render)) recS_stmts - -gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]] -gatherStmt (L _ (ParStmt NoExtField block _ _)) = - foldr ((<>) . gatherStmtBlock) [] block -gatherStmt (L s stmt@TransStmt {..}) = - foldr liftAppend [] ((gatherStmt <$> trS_stmts) <> pure [[L s stmt]]) -gatherStmt stmt = [[stmt]] - -gatherStmtBlock :: ParStmtBlock GhcPs GhcPs -> [[ExprLStmt GhcPs]] -gatherStmtBlock (ParStmtBlock _ stmts _ _) = - foldr (liftAppend . gatherStmt) [] stmts - -p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R () -p_hsLocalBinds = \case - HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do - -- When in a single-line layout, there is a chance that the inner - -- elements will also contain semicolons and they will confuse the - -- parser. so we request braces around every element except the last. - br <- layoutToBraces <$> getLayout - let items = - let injectLeft (L l x) = L l (Left x) - injectRight (L l x) = L l (Right x) - in (injectLeft <$> bagToList bag) ++ (injectRight <$> lsigs) - positionToBracing = \case - SinglePos -> id - FirstPos -> br - MiddlePos -> br - LastPos -> id - p_item' (p, item) = - positionToBracing p $ - withSpacing (either p_valDecl p_sigDecl) item - binds = sortBy (leftmost_smallest `on` getLoc) items - sitcc $ sepSemi p_item' (attachRelativePos binds) - HsValBinds NoExtField _ -> notImplemented "HsValBinds" - HsIPBinds NoExtField (IPBinds NoExtField xs) -> - -- Second argument of IPBind is always Left before type-checking. - let p_ipBind (IPBind NoExtField (Left name) expr) = do - atom name - space - equals - breakpoint - useBraces $ inci $ located expr p_hsExpr - p_ipBind (IPBind NoExtField (Right _) _) = - -- Should only occur after the type checker - notImplemented "IPBind _ (Right _) _" - in sepSemi (located' p_ipBind) xs - EmptyLocalBinds NoExtField -> return () - -p_hsRecField :: - HsRecField' RdrName (LHsExpr GhcPs) -> - R () -p_hsRecField HsRecField {..} = do - p_rdrName hsRecFieldLbl - unless hsRecPun $ do - space - equals - let placement = - if onTheSameLine (getLoc hsRecFieldLbl) (getLoc hsRecFieldArg) - then exprPlacement (unLoc hsRecFieldArg) - else Normal - placeHanging placement (located hsRecFieldArg p_hsExpr) - -p_hsExpr :: HsExpr GhcPs -> R () -p_hsExpr = p_hsExpr' N - -p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R () -p_hsExpr' s = \case - HsVar NoExtField name -> p_rdrName name - HsUnboundVar NoExtField occ -> atom occ - HsConLikeOut NoExtField _ -> notImplemented "HsConLikeOut" - HsRecFld NoExtField x -> - case x of - Unambiguous NoExtField name -> p_rdrName name - Ambiguous NoExtField name -> p_rdrName name - HsOverLabel NoExtField _ v -> do - txt "#" - atom v - HsIPVar NoExtField (HsIPName name) -> do - txt "?" - atom name - HsOverLit NoExtField v -> atom (ol_val v) - HsLit NoExtField lit -> - case lit of - HsString (SourceText stxt) _ -> p_stringLit stxt - HsStringPrim (SourceText stxt) _ -> p_stringLit stxt - r -> atom r - HsLam NoExtField mgroup -> - p_matchGroup Lambda mgroup - HsLamCase NoExtField mgroup -> - p_lamcase exprPlacement p_hsExpr mgroup - HsApp NoExtField f x -> do - let -- In order to format function applications with multiple parameters - -- nicer, traverse the AST to gather the function and all the - -- parameters together. - gatherArgs f' knownArgs = - case f' of - L _ (HsApp _ l r) -> gatherArgs l (r <| knownArgs) - _ -> (f', knownArgs) - (func, args) = gatherArgs f (x :| []) - -- We need to handle the last argument specially if it is a - -- hanging construct, so separate it from the rest. - (initp, lastp) = (NE.init args, NE.last args) - initSpan = - combineSrcSpans' $ - getLoc f :| [(srcLocSpan . srcSpanStart . getLoc) lastp] - -- Hang the last argument only if the initial arguments span one - -- line. - placement = - if isOneLineSpan initSpan - then exprPlacement (unLoc lastp) - else Normal - -- If the last argument is not hanging, just separate every argument as - -- usual. If it is hanging, print the initial arguments and hang the - -- last one. Also, use braces around the every argument except the last - -- one. - case placement of - Normal -> do - let -- Usually we want to bump indentation for arguments for the - -- sake of readability. However: - -- When the function is itself a multi line do-block or a case - -- expression, we can't indent by indentStep or more. - -- When we are on the other hand *in* a do block, we have to - -- indent by at least 1. - -- Thus, we indent by half of indentStep when the function is - -- a multi line do block or case expression. - indentArg - | isOneLineSpan (getLoc func) = inci - | otherwise = case unLoc func of - HsDo {} -> inciHalf - HsCase {} -> inciHalf - HsLamCase {} -> inciHalf - _ -> inci - ub <- - getLayout <&> \case - SingleLine -> useBraces - MultiLine -> id - ub $ do - located func (p_hsExpr' s) - breakpoint - indentArg $ sep breakpoint (located' p_hsExpr) initp - indentArg $ do - unless (null initp) breakpoint - located lastp p_hsExpr - Hanging -> do - useBraces . switchLayout [initSpan] $ do - located func (p_hsExpr' s) - breakpoint - sep breakpoint (located' p_hsExpr) initp - placeHanging placement $ - located lastp p_hsExpr - HsAppType NoExtField e a -> do - located e p_hsExpr - breakpoint - inci $ do - txt "@" - -- Insert a space when the type is represented as a TH splice to avoid - -- gluing @ and $ together. - case unLoc (hswc_body a) of - HsSpliceTy {} -> space - _ -> return () - located (hswc_body a) p_hsType - OpApp NoExtField x op y -> do - let opTree = OpBranch (exprOpTree x) op (exprOpTree y) - p_exprOpTree s (reassociateOpTree getOpName opTree) - NegApp NoExtField e NoExtField -> do - negativeLiterals <- isExtensionEnabled NegativeLiterals - let isLiteral = case unLoc e of - HsLit {} -> True - HsOverLit {} -> True - _ -> False - txt "-" - -- If NegativeLiterals is enabled, we have to insert a space before - -- negated literals, as `- 1` and `-1` have differing AST. - when (negativeLiterals && isLiteral) space - located e p_hsExpr - HsPar NoExtField e -> - parens s (located e (dontUseBraces . p_hsExpr)) - SectionL NoExtField x op -> do - located x p_hsExpr - breakpoint - inci (located op p_hsExpr) - SectionR NoExtField op x -> do - located op p_hsExpr - useRecordDot' <- useRecordDot - let isRecordDot' = isRecordDot (unLoc op) (getLoc x) - unless (useRecordDot' && isRecordDot') breakpoint - inci (located x p_hsExpr) - ExplicitTuple NoExtField args boxity -> - let isSection = any (isMissing . unLoc) args - isMissing = \case - Missing NoExtField -> True - _ -> False - p_arg = \case - Present NoExtField x -> located x p_hsExpr - Missing NoExtField -> pure () - p_larg = sitcc . located' p_arg - parens' = - case boxity of - Boxed -> parens - Unboxed -> parensHash - in if isSection - then - switchLayout [] . parens' s $ - sep comma p_larg args - else - switchLayout (getLoc <$> args) . parens' s $ - sep commaDel p_larg args - ExplicitSum NoExtField tag arity e -> - p_unboxedSum N tag arity (located e p_hsExpr) - HsCase NoExtField e mgroup -> - p_case exprPlacement p_hsExpr e mgroup - HsIf NoExtField if' then' else' -> - p_if exprPlacement p_hsExpr if' then' else' - HsMultiIf NoExtField guards -> do - txt "if" - breakpoint - inci . inci $ sep newline (located' (p_grhs RightArrow)) guards - HsLet NoExtField localBinds e -> - p_let p_hsExpr localBinds e - HsDo NoExtField ctx es -> do - let doBody moduleName header = do - forM_ moduleName $ \m -> atom m *> txt "." - txt header - breakpoint - ub <- layoutToBraces <$> getLayout - inci $ - sepSemi - (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S))) - (unLoc es) - compBody = brackets N . located es $ \xs -> do - let p_parBody = - sep - (breakpoint >> txt "|" >> space) - p_seqBody - p_seqBody = - sitcc - . sep - commaDel - (located' (sitcc . p_stmt)) - stmts = init xs - yield = last xs - lists = foldr (liftAppend . gatherStmt) [] stmts - located yield p_stmt - breakpoint - txt "|" - space - p_parBody lists - case ctx of - DoExpr moduleName -> doBody moduleName "do" - MDoExpr moduleName -> doBody moduleName "mdo" - ListComp -> compBody - MonadComp -> compBody - ArrowExpr -> notImplemented "ArrowExpr" - GhciStmtCtxt -> notImplemented "GhciStmtCtxt" - PatGuard _ -> notImplemented "PatGuard" - ParStmtCtxt _ -> notImplemented "ParStmtCtxt" - TransStmtCtxt _ -> notImplemented "TransStmtCtxt" - ExplicitList _ _ xs -> - brackets s $ - sep commaDel (sitcc . located' p_hsExpr) xs - RecordCon {..} -> do - located rcon_con_name atom - breakpoint - let HsRecFields {..} = rcon_flds - updName f = - (f :: HsRecField GhcPs (LHsExpr GhcPs)) - { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of - FieldOcc _ n -> n - } - fields = located' (p_hsRecField . updName) <$> rec_flds - dotdot = - case rec_dotdot of - Just {} -> [txt ".."] - Nothing -> [] - inci . braces N $ - sep commaDel sitcc (fields <> dotdot) - RecordUpd {..} -> do - located rupd_expr p_hsExpr - useRecordDot' <- useRecordDot - let mrs sp = case getLoc sp of - RealSrcSpan r _ -> Just r - _ -> Nothing - let isPluginForm = - ((1 +) . srcSpanEndCol <$> mrs rupd_expr) - == (srcSpanStartCol <$> mrs (head rupd_flds)) - && onTheSameLine (getLoc rupd_expr) (getLoc $ head rupd_flds) - unless (useRecordDot' && isPluginForm) breakpoint - let updName f = - (f :: HsRecUpdField GhcPs) - { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of - Ambiguous _ n -> n - Unambiguous _ n -> n - } - updBraces = - if useRecordDot' && isPluginForm - then recordDotBraces - else inci . braces N - updBraces $ - sep - commaDel - (sitcc . located' (p_hsRecField . updName)) - rupd_flds - ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do - located x p_hsExpr - space - txt "::" - breakpoint - inci $ located hsib_body p_hsType - ArithSeq NoExtField _ x -> - case x of - From from -> brackets s $ do - located from p_hsExpr - breakpoint - txt ".." - FromThen from next -> brackets s $ do - sep commaDel (located' p_hsExpr) [from, next] - breakpoint - txt ".." - FromTo from to -> brackets s $ do - located from p_hsExpr - breakpoint - txt ".." - space - located to p_hsExpr - FromThenTo from next to -> brackets s $ do - sep commaDel (located' p_hsExpr) [from, next] - breakpoint - txt ".." - space - located to p_hsExpr - HsBracket NoExtField x -> p_hsBracket x - HsRnBracketOut {} -> notImplemented "HsRnBracketOut" - HsTcBracketOut {} -> notImplemented "HsTcBracketOut" - HsSpliceE NoExtField splice -> p_hsSplice splice - HsProc NoExtField p e -> do - txt "proc" - located p $ \x -> do - breakpoint - inci (p_pat x) - breakpoint - txt "->" - placeHanging (cmdTopPlacement (unLoc e)) $ - located e p_hsCmdTop - HsStatic _ e -> do - txt "static" - breakpoint - inci (located e p_hsExpr) - HsTick {} -> notImplemented "HsTick" - HsBinTick {} -> notImplemented "HsBinTick" - HsPragE NoExtField prag x -> case prag of - HsPragSCC NoExtField _ name -> do - txt "{-# SCC " - atom name - txt " #-}" - breakpoint - located x p_hsExpr - HsPragTick {} -> notImplemented "HsTickPragma" - -p_patSynBind :: PatSynBind GhcPs GhcPs -> R () -p_patSynBind PSB {..} = do - let rhs = do - space - case psb_dir of - Unidirectional -> do - txt "<-" - breakpoint - located psb_def p_pat - ImplicitBidirectional -> do - equals - breakpoint - located psb_def p_pat - ExplicitBidirectional mgroup -> do - txt "<-" - breakpoint - located psb_def p_pat - breakpoint - txt "where" - breakpoint - inci (p_matchGroup (Function psb_id) mgroup) - txt "pattern" - case psb_args of - PrefixCon xs -> do - space - p_rdrName psb_id - inci $ do - switchLayout (getLoc <$> xs) $ do - unless (null xs) breakpoint - sitcc (sep breakpoint p_rdrName xs) - rhs - RecCon xs -> do - space - p_rdrName psb_id - inci $ do - switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do - unless (null xs) breakpoint - braces N $ - sep commaDel (p_rdrName . recordPatSynPatVar) xs - rhs - InfixCon l r -> do - switchLayout [getLoc l, getLoc r] $ do - space - p_rdrName l - breakpoint - inci $ do - p_rdrName psb_id - space - p_rdrName r - inci rhs - -p_case :: - Data body => - -- | Placer - (body -> Placement) -> - -- | Render - (body -> R ()) -> - -- | Expression - LHsExpr GhcPs -> - -- | Match group - MatchGroup GhcPs (Located body) -> - R () -p_case placer render e mgroup = do - txt "case" - space - located e p_hsExpr - space - txt "of" - breakpoint - inci (p_matchGroup' placer render Case mgroup) - -p_lamcase :: - Data body => - -- | Placer - (body -> Placement) -> - -- | Render - (body -> R ()) -> - -- | Expression - MatchGroup GhcPs (Located body) -> - R () -p_lamcase placer render mgroup = do - txt "\\case" - breakpoint - inci (p_matchGroup' placer render LambdaCase mgroup) - -p_if :: - Data body => - -- | Placer - (body -> Placement) -> - -- | Render - (body -> R ()) -> - -- | If - LHsExpr GhcPs -> - -- | Then - Located body -> - -- | Else - Located body -> - R () -p_if placer render if' then' else' = do - txt "if" - space - located if' p_hsExpr - breakpoint - inci $ do - txt "then" - space - located then' $ \x -> - placeHanging (placer x) (render x) - breakpoint - txt "else" - space - located else' $ \x -> - placeHanging (placer x) (render x) - -p_let :: - Data body => - -- | Render - (body -> R ()) -> - Located (HsLocalBindsLR GhcPs GhcPs) -> - Located body -> - R () -p_let render localBinds e = sitcc $ do - txt "let" - space - dontUseBraces $ sitcc (located localBinds p_hsLocalBinds) - vlayout space (newline >> txt " ") - txt "in" - space - sitcc (located e render) - -p_pat :: Pat GhcPs -> R () -p_pat = \case - WildPat NoExtField -> txt "_" - VarPat NoExtField name -> p_rdrName name - LazyPat NoExtField pat -> do - txt "~" - located pat p_pat - AsPat NoExtField name pat -> do - p_rdrName name - txt "@" - located pat p_pat - ParPat NoExtField pat -> - located pat (parens S . p_pat) - BangPat NoExtField pat -> do - txt "!" - located pat p_pat - ListPat NoExtField pats -> - brackets S $ sep commaDel (located' p_pat) pats - TuplePat NoExtField pats boxing -> do - let parens' = - case boxing of - Boxed -> parens S - Unboxed -> parensHash S - parens' $ sep commaDel (sitcc . located' p_pat) pats - SumPat NoExtField pat tag arity -> - p_unboxedSum S tag arity (located pat p_pat) - ConPat NoExtField pat details -> - case details of - PrefixCon xs -> sitcc $ do - p_rdrName pat - unless (null xs) $ do - breakpoint - inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs - RecCon (HsRecFields fields dotdot) -> do - p_rdrName pat - breakpoint - let f = \case - Nothing -> txt ".." - Just x -> located x p_pat_hsRecField - inci . braces N . sep commaDel f $ - case dotdot of - Nothing -> Just <$> fields - Just (L _ n) -> (Just <$> take n fields) ++ [Nothing] - InfixCon l r -> do - switchLayout [getLoc l, getLoc r] $ do - located l p_pat - breakpoint - inci $ do - p_rdrName pat - space - located r p_pat - ViewPat NoExtField expr pat -> sitcc $ do - located expr p_hsExpr - space - txt "->" - breakpoint - inci (located pat p_pat) - SplicePat NoExtField splice -> p_hsSplice splice - LitPat NoExtField p -> atom p - NPat NoExtField v (isJust -> isNegated) NoExtField -> do - when isNegated $ do - txt "-" - negativeLiterals <- isExtensionEnabled NegativeLiterals - when negativeLiterals space - located v (atom . ol_val) - NPlusKPat NoExtField n k _ _ _ -> sitcc $ do - p_rdrName n - breakpoint - inci $ do - txt "+" - space - located k (atom . ol_val) - SigPat NoExtField pat HsPS {..} -> do - located pat p_pat - p_typeAscription (HsWC NoExtField (HsIB NoExtField hsps_body)) - -p_pat_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R () -p_pat_hsRecField HsRecField {..} = do - located hsRecFieldLbl $ \x -> - p_rdrName (rdrNameFieldOcc x) - unless hsRecPun $ do - space - equals - breakpoint - inci (located hsRecFieldArg p_pat) - -p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R () -p_unboxedSum s tag arity m = do - let before = tag - 1 - after = arity - before - 1 - args = replicate before Nothing <> [Just m] <> replicate after Nothing - f x = - case x :: Maybe (R ()) of - Nothing -> - space - Just m' -> do - space - m' - space - parensHash s $ sep (txt "|") f args - -p_hsSplice :: HsSplice GhcPs -> R () -p_hsSplice = \case - HsTypedSplice NoExtField deco _ expr -> p_hsSpliceTH True expr deco - HsUntypedSplice NoExtField deco _ expr -> p_hsSpliceTH False expr deco - HsQuasiQuote NoExtField _ quoterName srcSpan str -> do - txt "[" - p_rdrName (L srcSpan quoterName) - txt "|" - -- QuasiQuoters often rely on precise custom strings. We cannot do any - -- formatting here without potentially breaking someone's code. - atom str - txt "|]" - HsSpliced {} -> notImplemented "HsSpliced" - -p_hsSpliceTH :: - -- | Typed splice? - Bool -> - -- | Splice expression - LHsExpr GhcPs -> - -- | Splice decoration - SpliceDecoration -> - R () -p_hsSpliceTH isTyped expr = \case - DollarSplice -> do - txt decoSymbol - located expr (sitcc . p_hsExpr) - BareSplice -> - located expr (sitcc . p_hsExpr) - where - decoSymbol = if isTyped then "$$" else "$" - -p_hsBracket :: HsBracket GhcPs -> R () -p_hsBracket = \case - ExpBr NoExtField expr -> do - anns <- getEnclosingAnns - let name = case anns of - AnnOpenEQ : _ -> "" - _ -> "e" - quote name (located expr p_hsExpr) - PatBr NoExtField pat -> located pat (quote "p" . p_pat) - DecBrL NoExtField decls -> quote "d" (handleStarIsType decls (p_hsDecls Free decls)) - DecBrG NoExtField _ -> notImplemented "DecBrG" -- result of renamer - TypBr NoExtField ty -> quote "t" (located ty (handleStarIsType ty . p_hsType)) - VarBr NoExtField isSingleQuote name -> do - txt (bool "''" "'" isSingleQuote) - -- HACK As you can see we use 'noLoc' here to be able to pass name into - -- 'p_rdrName' since the latter expects a "located" thing. The problem - -- is that 'VarBr' doesn't provide us with location of the name. This in - -- turn makes it impossible to detect if there are parentheses around - -- it, etc. So we have to add parentheses manually assuming they are - -- necessary for all operators. - let isOperator = - all - (\i -> isPunctuation i || isSymbol i) - (showOutputable (rdrNameOcc name)) - && not (doesNotNeedExtraParens name) - wrapper = if isOperator then parens N else id - wrapper $ p_rdrName (noLoc name) - TExpBr NoExtField expr -> do - txt "[||" - breakpoint' - located expr p_hsExpr - breakpoint' - txt "||]" - where - quote :: Text -> R () -> R () - quote name body = do - txt "[" - txt name - txt "|" - breakpoint' - inci $ do - dontUseBraces body - breakpoint' - txt "|]" - -- With StarIsType, type and declaration brackets might end with a *, - -- so we have to insert a space in the end to prevent the (mis)parsing - -- of an (*|) operator. - -- The detection is a bit overcautious, as it adds the spaces as soon as - -- HsStarTy is anywhere in the type/declaration. - handleStarIsType :: Data a => a -> R () -> R () - handleStarIsType a p - | containsHsStarTy a = space *> p <* space - | otherwise = p - where - containsHsStarTy = everything (||) $ \b -> case cast @_ @(HsType GhcPs) b of - Just HsStarTy {} -> True - _ -> False - --- Print the source text of a string literal while indenting --- gaps correctly. - -p_stringLit :: String -> R () -p_stringLit src = - let s = splitGaps src - singleLine = - txt $ Text.pack (mconcat s) - multiLine = - sitcc $ sep breakpoint (txt . Text.pack) (backslashes s) - in vlayout singleLine multiLine - where - -- Split a string on gaps (backslash delimited whitespaces) - -- - -- > splitGaps "bar\\ \\fo\\&o" == ["bar", "fo\\&o"] - splitGaps :: String -> [String] - splitGaps "" = [] - splitGaps s = - let -- A backslash and a whitespace starts a "gap" - p (Just '\\', _, _) = True - p (_, '\\', Just c) | ghcSpace c = False - p _ = True - in case span p (zipPrevNext s) of - (l, r) -> - let -- drop the initial '\', any amount of 'ghcSpace', and another '\' - r' = drop 1 . dropWhile ghcSpace . drop 1 $ map orig r - in map orig l : splitGaps r' - -- GHC's definition of whitespaces in strings - -- See: https://gitlab.haskell.org/ghc/ghc/blob/86753475/compiler/parser/Lexer.x#L1653 - ghcSpace :: Char -> Bool - ghcSpace c = c <= '\x7f' && is_space c - -- Add backslashes to the inner side of the strings - -- - -- > backslashes ["a", "b", "c"] == ["a\\", "\\b\\", "\\c"] - backslashes :: [String] -> [String] - backslashes (x : y : xs) = (x ++ "\\") : backslashes (('\\' : y) : xs) - backslashes xs = xs - -- Attaches previous and next items to each list element - zipPrevNext :: [a] -> [(Maybe a, a, Maybe a)] - zipPrevNext xs = - let z = - zip - (zip (Nothing : map Just xs) xs) - (map Just (tail xs) ++ repeat Nothing) - in map (\((p, x), n) -> (p, x, n)) z - orig (_, x, _) = x - ----------------------------------------------------------------------------- --- Helpers - --- | Return the wrapping function controlling the use of braces according to --- the current layout. -layoutToBraces :: Layout -> R () -> R () -layoutToBraces = \case - SingleLine -> useBraces - MultiLine -> id - --- | Append each element in both lists with semigroups. If one list is shorter --- than the other, return the rest of the longer list unchanged. -liftAppend :: Semigroup a => [a] -> [a] -> [a] -liftAppend [] [] = [] -liftAppend [] (y : ys) = y : ys -liftAppend (x : xs) [] = x : xs -liftAppend (x : xs) (y : ys) = x <> y : liftAppend xs ys - -getGRHSSpan :: GRHS GhcPs (Located body) -> SrcSpan -getGRHSSpan (GRHS NoExtField guards body) = - combineSrcSpans' $ getLoc body :| map getLoc guards - --- | Place a thing that may have a hanging form. This function handles how --- to separate it from preceding expressions and whether to bump indentation --- depending on what sort of expression we have. -placeHanging :: Placement -> R () -> R () -placeHanging placement m = - case placement of - Hanging -> do - space - m - Normal -> do - breakpoint - inci m - --- | Check if given block contains single expression which has a hanging --- form. -blockPlacement :: - (body -> Placement) -> - [LGRHS GhcPs (Located body)] -> - Placement -blockPlacement placer [L _ (GRHS NoExtField _ (L _ x))] = placer x -blockPlacement _ _ = Normal - --- | Check if given command has a hanging form. -cmdPlacement :: HsCmd GhcPs -> Placement -cmdPlacement = \case - HsCmdLam NoExtField _ -> Hanging - HsCmdCase NoExtField _ _ -> Hanging - HsCmdLamCase NoExtField _ -> Hanging - HsCmdDo NoExtField _ -> Hanging - _ -> Normal - -cmdTopPlacement :: HsCmdTop GhcPs -> Placement -cmdTopPlacement (HsCmdTop NoExtField (L _ x)) = cmdPlacement x - --- | Check if given expression has a hanging form. -exprPlacement :: HsExpr GhcPs -> Placement -exprPlacement = \case - -- Only hang lambdas with single line parameter lists - HsLam NoExtField mg -> case mg of - MG _ (L _ [L _ (Match NoExtField _ (x : xs) _)]) _ - | isOneLineSpan (combineSrcSpans' $ fmap getLoc (x :| xs)) -> - Hanging - _ -> Normal - HsLamCase NoExtField _ -> Hanging - HsCase NoExtField _ _ -> Hanging - HsDo NoExtField (DoExpr _) _ -> Hanging - HsDo NoExtField (MDoExpr _) _ -> Hanging - OpApp NoExtField _ op y -> - case (fmap getOpNameStr . getOpName . unLoc) op of - Just "$" -> exprPlacement (unLoc y) - _ -> Normal - HsApp NoExtField _ y -> exprPlacement (unLoc y) - HsProc NoExtField p _ -> - -- Indentation breaks if pattern is longer than one line and left - -- hanging. Consequently, only apply hanging when it is safe. - if isOneLineSpan (getLoc p) - then Hanging - else Normal - _ -> Normal - -withGuards :: [LGRHS GhcPs (Located body)] -> Bool -withGuards = any (checkOne . unLoc) - where - checkOne :: GRHS GhcPs (Located body) -> Bool - checkOne (GRHS NoExtField [] _) = False - checkOne _ = True - -exprOpTree :: LHsExpr GhcPs -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -exprOpTree (L _ (OpApp NoExtField x op y)) = OpBranch (exprOpTree x) op (exprOpTree y) -exprOpTree n = OpNode n - -getOpName :: HsExpr GhcPs -> Maybe RdrName -getOpName = \case - HsVar NoExtField (L _ a) -> Just a - _ -> Nothing - -getOpNameStr :: RdrName -> String -getOpNameStr = occNameString . rdrNameOcc - -p_exprOpTree :: - -- | Bracket style to use - BracketStyle -> - OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> - R () -p_exprOpTree s (OpNode x) = located x (p_hsExpr' s) -p_exprOpTree s (OpBranch x op y) = do - -- If the beginning of the first argument and the second argument are on - -- the same line, and the second argument has a hanging form, use hanging - -- placement. - let placement = - if isOneLineSpan - (mkSrcSpan (srcSpanStart (opTreeLoc x)) (srcSpanStart (opTreeLoc y))) - then case y of - OpNode (L _ n) -> exprPlacement n - _ -> Normal - else Normal - -- Distinguish holes used in infix notation. - -- eg. '1 _foo 2' and '1 `_foo` 2' - opWrapper = case unLoc op of - HsUnboundVar NoExtField _ -> backticks - _ -> id - layout <- getLayout - let ub = case layout of - SingleLine -> useBraces - MultiLine -> case placement of - Hanging -> useBraces - Normal -> dontUseBraces - opNameStr = (fmap getOpNameStr . getOpName . unLoc) op - gotDollar = opNameStr == Just "$" - gotColon = opNameStr == Just ":" - gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y) - lhs = - switchLayout [opTreeLoc x] $ - p_exprOpTree s x - p_op = located op (opWrapper . p_hsExpr) - p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y) - isSection = case (opTreeLoc x, getLoc op) of - (RealSrcSpan treeSpan _, RealSrcSpan opSpan _) -> - srcSpanEndCol treeSpan /= srcSpanStartCol opSpan - _ -> False - isDoBlock = \case - OpNode (L _ HsDo {}) -> True - _ -> False - useRecordDot' <- useRecordDot - if - | gotColon -> do - lhs - space - p_op - case placement of - Hanging -> do - space - p_y - Normal -> do - breakpoint - inciIf (isDoBlock y) p_y - | gotDollar - && isOneLineSpan (opTreeLoc x) - && placement == Normal -> do - useBraces lhs - space - p_op - breakpoint - inci p_y - | useRecordDot' && gotRecordDot -> do - lhs - when isSection space - p_op - p_y - | otherwise -> do - ub lhs - placeHanging placement $ do - p_op - space - p_y - --- | Return 'True' if given expression is a record-dot operator expression. -isRecordDot :: - -- | Operator expression - HsExpr GhcPs -> - -- | Span of the expression on the right-hand side of the operator - SrcSpan -> - Bool -isRecordDot op (RealSrcSpan ySpan _) = case op of - HsVar NoExtField (L (RealSrcSpan opSpan _) opName) -> - (getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan) - _ -> False -isRecordDot _ _ = False - --- | Get annotations for the enclosing element. -getEnclosingAnns :: R [AnnKeywordId] -getEnclosingAnns = do - e <- getEnclosingSpan (const True) - case e of - Nothing -> return [] - Just e' -> getAnns (RealSrcSpan e' Nothing) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Ormolu.Printer.Meat.Declaration.Value + ( p_valDecl, + p_pat, + p_hsExpr, + p_hsUntypedSplice, + IsApplicand (..), + p_hsExpr', + p_hsCmdTop, + exprPlacement, + cmdTopPlacement, + ) +where + +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 ((<&>)) +import Data.Generics.Schemes (everything) +import Data.List (intersperse, sortBy, unsnoc) +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.List.NonEmpty qualified as NE +import Data.Maybe +import Data.Text (Text) +import GHC.Data.Strict qualified as Strict +import GHC.Hs +import GHC.LanguageExtensions.Type (Extension (NegativeLiterals)) +import GHC.Types.Basic +import GHC.Types.Fixity +import GHC.Types.Name.Reader +import GHC.Types.SourceText +import GHC.Types.SrcLoc +import Language.Haskell.Syntax.Basic +import Ormolu.Printer.Combinators +import Ormolu.Printer.Meat.Common +import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration +import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.OpTree +import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Signature +import Ormolu.Printer.Meat.Declaration.StringLiteral +import Ormolu.Printer.Meat.Type +import Ormolu.Printer.Operators +import Ormolu.Utils + +-- | Style of a group of equations. +data MatchGroupStyle + = Function (LocatedN RdrName) + | PatternBind + | Case + | Lambda + | LambdaCase + +-- | Style of equations in a group. +data GroupStyle + = EqualSign + | RightArrow + +p_valDecl :: HsBind GhcPs -> R () +p_valDecl = \case + FunBind _ funId funMatches -> p_funBind funId funMatches + PatBind _ pat multAnn grhss -> + p_match PatternBind False multAnn NoSrcStrict [pat] grhss + VarBind {} -> notImplemented "VarBinds" -- introduced by the type checker + PatSynBind _ psb -> p_patSynBind psb + +p_funBind :: + LocatedN RdrName -> + MatchGroup GhcPs (LHsExpr GhcPs) -> + R () +p_funBind name = p_matchGroup (Function name) + +p_matchGroup :: + MatchGroupStyle -> + MatchGroup GhcPs (LHsExpr GhcPs) -> + R () +p_matchGroup = p_matchGroup' exprPlacement p_hsExpr + +p_matchGroup' :: + ( Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO, + Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA + ) => + -- | How to get body placement + (body -> Placement) -> + -- | How to print body + (body -> R ()) -> + -- | Style of this group of equations + MatchGroupStyle -> + -- | Match group + MatchGroup GhcPs (LocatedA body) -> + R () +p_matchGroup' placer render style mg@MG {..} = do + -- 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 {..} = + p_match' + placer + render + (adjustMatchGroupStyle m style) + (isInfixMatch m) + (HsUnannotated EpPatBind) + (matchStrictness m) + -- We use the spans of the individual patterns. + (unLoc m_pats) + m_grhss + +-- | The 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 parentheses) associated with them. It is necessary to use +-- the per-equation names obtained from the 'm_ctxt' of a 'Match'. This +-- function replaces the function name inside 'Function' accordingly. +adjustMatchGroupStyle :: + Match GhcPs body -> + MatchGroupStyle -> + MatchGroupStyle +adjustMatchGroupStyle m = \case + Function _ | FunRhs {mc_fun = f} <- m_ctxt m -> Function f + style -> style + +matchStrictness :: Match id body -> SrcStrictness +matchStrictness = \case + Match {m_ctxt = FunRhs {mc_strictness = s}} -> s + _ -> NoSrcStrict + +p_match :: + -- | Style of the group + MatchGroupStyle -> + -- | Is this an infix match? + Bool -> + -- | Multiplicity annotation + HsMultAnn GhcPs -> + -- | Strictness prefix (FunBind) + SrcStrictness -> + -- | Argument patterns + [LPat GhcPs] -> + -- | Equations + GRHSs GhcPs (LHsExpr GhcPs) -> + R () +p_match = p_match' exprPlacement p_hsExpr + +p_match' :: + (Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO) => + -- | How to get body placement + (body -> Placement) -> + -- | How to print body + (body -> R ()) -> + -- | Style of this group of equations + MatchGroupStyle -> + -- | Is this an infix match? + Bool -> + -- | Multiplicity annotation + HsMultAnn GhcPs -> + -- | Strictness prefix (FunBind) + SrcStrictness -> + -- | Argument patterns + [LPat GhcPs] -> + -- | Equations + GRHSs GhcPs (LocatedA body) -> + R () +p_match' placer render style isInfix multAnn strictness m_pats GRHSs {..} = do + -- Normally, since patterns may be placed in a multi-line layout, it is + -- necessary to bump indentation for the pattern group so that it's more + -- indented than the function name. This in turn means that indentation for + -- the body should also be bumped. Normally this would mean that bodies + -- would start with two indentation steps applied, which is ugly, so we + -- need to be a bit more clever here and bump the indentation level only + -- when the pattern group is multiline. + p_hsMultAnn (located' p_hsType) multAnn + case multAnn of + 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 + Function name -> p_rdrName name + _ -> return () + Just ne_pats@(head_pat :| tail_pats) -> do + let combinedSpans = case style of + Function name -> combineSrcSpans (getLocA name) patSpans + _ -> patSpans + patSpans = combineSrcSpans' (getLocA <$> ne_pats) + containsOrPat = everything (||) $ \b -> case cast @_ @(Pat GhcPs) b of + Just OrPat {} -> True + _ -> False + indentBody = + not (isOneLineSpan combinedSpans) + && not (isCase style && containsOrPat ne_pats) + switchLayout [combinedSpans] $ do + let stdCase = sep breakpoint (located' p_pat) m_pats + case style of + Function name -> + p_infixDefHelper + (Choice.fromBool isInfix) + (Choice.fromBool indentBody) + (p_rdrName name) + (located' p_pat <$> m_pats) + PatternBind -> stdCase + Case -> stdCase + Lambda -> do + let needsSpace = case unLoc head_pat of + LazyPat _ _ -> True + BangPat _ _ -> True + SplicePat _ _ -> True + InvisPat _ _ -> True + _ -> False + txt "\\" + when needsSpace space + sitcc stdCase + LambdaCase -> do + located' p_pat head_pat + unless (null tail_pats) $ do + breakpoint + -- When we have multiple patterns (with `\cases`) across multiple + -- lines, we have to indent all but the first pattern. + inci $ sep breakpoint (located' p_pat) tail_pats + return indentBody + let -- Calculate the position of the end of the patterns. This is useful + -- when we decide whether to put certain constructions in hanging + -- positions. + endOfPats = case NE.nonEmpty m_pats of + Nothing -> case style of + Function name -> Just (getLocA name) + _ -> Nothing + Just pats -> (Just . getLocA . NE.last) pats + hasGuards = withGuards grhssGRHSs + grhssSpan = + combineSrcSpans' $ + getGRHSSpan . unLoc <$> grhssGRHSs + patGrhssSpan = + maybe + grhssSpan + (combineSrcSpans grhssSpan . srcLocSpan . srcSpanEnd) + endOfPats + placement = + case endOfPats of + Just spn + | any guardNeedsLineBreak grhssGRHSs + || not (onTheSameLine spn grhssSpan) -> + Normal + _ -> blockPlacement placer grhssGRHSs + guardNeedsLineBreak :: XRec GhcPs (GRHS GhcPs body) -> Bool + guardNeedsLineBreak (L _ (GRHS _ guardLStmts _)) = case guardLStmts of + [] -> False + [g] -> not . isOneLineSpan . getLocA $ g + _ -> True + p_body = do + let groupStyle = + if isCase style && hasGuards + then RightArrow + else EqualSign + sep + 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 + located (L localBindsWhereSpan ()) $ \_ -> txt "where" + breakpoint + inci $ p_hsLocalBinds grhssLocalBinds + inciIf indentBody $ do + unless (length grhssGRHSs > 1) $ + case style of + Function _ | hasGuards -> return () + Function _ -> space >> inci (txt "=") + PatternBind | hasGuards -> return () + PatternBind -> space >> inci (txt "=") + s | isCase s && hasGuards -> return () + _ -> space >> txt "->" + switchLayout [patGrhssSpan] $ + placeHanging placement p_body + inci p_where + +p_grhs :: GroupStyle -> GRHS GhcPs (LHsExpr GhcPs) -> R () +p_grhs = p_grhs' Normal exprPlacement p_hsExpr + +p_grhs' :: + -- | Placement of the parent RHS construct + Placement -> + -- | How to get body placement + (body -> Placement) -> + -- | How to print body + (body -> R ()) -> + GroupStyle -> + GRHS GhcPs (LocatedA body) -> + R () +p_grhs' parentPlacement placer render style (GRHS _ guards body) = + case guards of + [] -> p_body + xs -> do + txt "|" + space + sitcc (sep commaDel (sitcc . located' p_stmt) xs) + space + inci $ case style of + EqualSign -> txt "=" + RightArrow -> txt "->" + -- If we have a sequence of guards and it is placed in the normal way, + -- then we indent one level more for readability. Otherwise (all + -- guards are on the same line) we do not need to indent, as it would + -- look like double indentation without a good reason. + inciIf (parentPlacement == Normal) (placeHanging placement p_body) + where + placement = + case endOfGuards of + Nothing -> placer (unLoc body) + Just spn -> + if onTheSameLine spn (getLocA body) + then placer (unLoc body) + else Normal + endOfGuards = + case NE.nonEmpty guards of + Nothing -> Nothing + Just gs -> (Just . getLocA . NE.last) gs + p_body = located body render + +p_hsCmd :: HsCmd GhcPs -> R () +p_hsCmd = p_hsCmd' NotApplicand N + +p_hsCmd' :: IsApplicand -> BracketStyle -> HsCmd GhcPs -> R () +p_hsCmd' isApp s = \case + HsCmdArrApp _ body input arrType rightToLeft -> do + let (l, r) = if rightToLeft then (body, input) else (input, body) + located l $ p_hsExpr' NotApplicand s + breakpoint + inci $ do + case (arrType, rightToLeft) of + (HsFirstOrderApp, True) -> txt "-<" + (HsHigherOrderApp, True) -> txt "-<<" + (HsFirstOrderApp, False) -> txt ">-" + (HsHigherOrderApp, False) -> txt ">>-" + placeHanging (exprPlacement (unLoc input)) $ + located r p_hsExpr + HsCmdArrForm _ form Prefix cmds -> banana s $ do + located form p_hsExpr + unless (null cmds) $ do + breakpoint + inci (sequence_ (intersperse breakpoint (located' (p_hsCmdTop N) <$> cmds))) + HsCmdArrForm _ form Infix [left, right] -> do + modFixityMap <- askModuleFixityMap + debug <- askDebug + let opTree = BinaryOpBranches (cmdOpTree left) form (cmdOpTree right) + p_cmdOpTree + s + (reassociateOpTree debug (getOpName . unLoc) modFixityMap opTree) + HsCmdArrForm _ _ Infix _ -> notImplemented "HsCmdArrForm" + HsCmdApp _ cmd expr -> do + located cmd (p_hsCmd' Applicand s) + breakpoint + inci $ located expr p_hsExpr + HsCmdLam _ variant mgroup -> p_lam isApp s variant cmdPlacement p_hsCmd mgroup + HsCmdPar _ c -> parens N (located c p_hsCmd) + HsCmdCase _ e mgroup -> + p_case isApp s cmdPlacement p_hsCmd e mgroup + HsCmdIf anns _ if' then' else' -> + p_if cmdPlacement p_hsCmd anns if' then' else' + HsCmdLet _ localBinds c -> + p_let p_hsCmd localBinds c + HsCmdDo _ es -> do + txt "do" + p_stmts S isApp cmdPlacement (p_hsCmd' NotApplicand) es + +-- | Print a top-level command. +p_hsCmdTop :: BracketStyle -> HsCmdTop GhcPs -> R () +p_hsCmdTop s (HsCmdTop _ cmd) = located cmd (p_hsCmd' NotApplicand s) + +-- | Render an expression preserving blank lines between such consecutive +-- expressions found in the original source code. +withSpacing :: + -- | Rendering function + (a -> R ()) -> + -- | Entity to render + LocatedAn ann a -> + R () +withSpacing f l = located l $ \x -> do + case getLocA l of + UnhelpfulSpan _ -> f x + RealSrcSpan currentSpn _ -> do + (lastEmittedSpan <$> getLastEmitted) >>= \case + -- We deal with blank lines between statements here. The last thing + -- emitted may be a statement (the usual case) or a comment: 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 lastSpn -> + when (srcSpanStartLine currentSpn > srcSpanEndLine lastSpn + 1) newline + Nothing -> return () + f x + -- In some cases the (f x) expression may record something else. We + -- want to be careful not to override comments. + getLastEmitted >>= \case + LastEmittedHaddock _ -> return () + LastEmittedComment _ -> return () + _ -> setLastEmitted (LastEmittedStatement currentSpn) + +p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R () +p_stmt = p_stmt' N exprPlacement (p_hsExpr' NotApplicand) + +p_stmt' :: + ( Anno [LStmt GhcPs (XRec GhcPs body)] ~ SrcSpanAnnLW, + Anno (Stmt GhcPs (XRec GhcPs body)) ~ SrcSpanAnnA, + Anno body ~ SrcSpanAnnA + ) => + BracketStyle -> + -- | Placer + (body -> Placement) -> + -- | Render + (BracketStyle -> body -> R ()) -> + -- | Statement to render + Stmt GhcPs (XRec GhcPs body) -> + R () +p_stmt' s placer render = \case + LastStmt _ body _ _ -> located body (render s) + BindStmt _ p f@(getLocA -> l) -> do + located p p_pat + space + txt "<-" + let loc = getLocA p + placement + | isOneLineSpan (mkSrcSpan (srcSpanEnd loc) (srcSpanStart l)) = placer (unLoc f) + | otherwise = Normal + switchLayout [loc, l] $ + placeHanging placement (located f (render N)) + BodyStmt _ body _ _ -> located body (render s) + LetStmt _ binds -> do + txt "let" + space + sitcc $ p_hsLocalBinds binds + ParStmt {} -> + -- 'ParStmt' should always be eliminated in 'gatherStmts' already, so + -- that it never occurs in 'p_stmt''. Consequently, handling it here + -- would be redundant. + notImplemented "ParStmt" + TransStmt {..} -> + -- 'TransStmt' only needs to account for printing itself, since + -- pretty-printing of the relevant statements (e.g. in 'trS_stmts') is + -- handled through 'gatherStmts'. + case (trS_form, trS_by) of + (ThenForm, Nothing) -> do + txt "then" + breakpoint + inci $ located trS_using p_hsExpr + (ThenForm, Just e) -> do + txt "then" + breakpoint + inci $ located trS_using p_hsExpr + breakpoint + txt "by" + breakpoint + inci $ located e p_hsExpr + (GroupForm, Nothing) -> do + txt "then group using" + breakpoint + inci $ located trS_using p_hsExpr + (GroupForm, Just e) -> do + txt "then group by" + breakpoint + inci $ located e p_hsExpr + breakpoint + txt "using" + breakpoint + inci $ located trS_using p_hsExpr + RecStmt {..} -> do + txt "rec" + space + sitcc . located recS_stmts $ sepSemi (withSpacing (p_stmt' s placer render)) + +p_stmts :: + ( Anno [LStmt GhcPs (XRec GhcPs body)] ~ SrcSpanAnnLW, + Anno (Stmt GhcPs (XRec GhcPs body)) ~ SrcSpanAnnA, + Anno body ~ SrcSpanAnnA + ) => + BracketStyle -> + IsApplicand -> + -- | Placer + (body -> Placement) -> + -- | Render + (BracketStyle -> body -> R ()) -> + -- | Statements to render + XRec GhcPs [LStmt GhcPs (XRec GhcPs body)] -> + R () +p_stmts s isApp placer render es = do + breakpoint + ub <- layoutToBraces <$> getLayout + let p_stmtExt (relPos, stmt) = + ub' $ withSpacing (p_stmt' s placer render) stmt + where + -- We need to set brace usage information for all but the last + -- statement (e.g. in the case of nested do blocks). + ub' = case relPos of + FirstPos -> ub + MiddlePos -> ub + LastPos -> id + SinglePos -> id + inciApplicand isApp . located es $ + sepSemi p_stmtExt . attachRelativePos + +p_hsLocalBinds :: HsLocalBinds GhcPs -> R () +p_hsLocalBinds = \case + HsValBinds epAnn (ValBinds _ binds lsigs) -> pseudoLocated epAnn $ do + -- When in a single-line layout, there is a chance that the inner + -- elements will also contain semicolons that will confuse the parser, + -- so we request braces around every element except the last. + br <- layoutToBraces <$> getLayout + let items = + let injectLeft (L l x) = L l (Left x) + injectRight (L l x) = L l (Right x) + in (injectLeft <$> binds) ++ (injectRight <$> lsigs) + positionToBracing = \case + SinglePos -> id + FirstPos -> br + MiddlePos -> br + LastPos -> id + p_item' (p, item) = + positionToBracing p $ + withSpacing (either p_valDecl p_sigDecl) item + items' = sortBy (leftmost_smallest `on` getLocA) items + sitcc $ sepSemi p_item' (attachRelativePos items') + HsValBinds _ _ -> notImplemented "HsValBinds" + HsIPBinds epAnn (IPBinds _ xs) -> pseudoLocated epAnn $ do + let p_ipBind (IPBind _ (L _ name) expr) = do + atom @HsIPName name + space + txt "=" + breakpoint + useBraces $ inci $ located expr p_hsExpr + sepSemi (located' p_ipBind) xs + EmptyLocalBinds _ -> return () + where + -- HsLocalBinds is no longer wrapped in a Located (see the call sites + -- of p_hsLocalBinds). Hence, we introduce a manual Located, as we + -- depend on the layout being set correctly. + pseudoLocated = \case + EpAnn {anns = AnnList {al_anchor}} + | -- Excluding cases where there are no bindings. + not $ isZeroWidthSpan (locA al_anchor) -> + located (L al_anchor ()) . const + _ -> id + +p_dotFieldOcc :: DotFieldOcc GhcPs -> R () +p_dotFieldOcc = + p_rdrName . fmap (mkVarUnqual . field_label) . dfoLabel + +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 + +p_hsFieldBind :: + (lhs ~ GenLocated l a, HasLoc l) => + (lhs -> R ()) -> + HsFieldBind lhs (LHsExpr GhcPs) -> + R () +p_hsFieldBind p_lhs HsFieldBind {..} = do + p_lhs hfbLHS + unless hfbPun $ do + space + txt "=" + let placement = + if onTheSameLine (getLocA hfbLHS) (getLocA hfbRHS) + then exprPlacement (unLoc hfbRHS) + else Normal + placeHanging placement (located hfbRHS p_hsExpr) + +p_hsExpr :: HsExpr GhcPs -> R () +p_hsExpr = p_hsExpr' NotApplicand N + +-- | An applicand is the left-hand side of a function application, i.e. @f@ +-- in @f a@. We need to track this in order to add extra indentation in cases +-- like +-- +-- > foo = +-- > do +-- > succ +-- > 1 +data IsApplicand = Applicand | NotApplicand + +inciApplicand :: IsApplicand -> R () -> R () +inciApplicand = \case + Applicand -> inci . inci + NotApplicand -> inci + +-- | Adjust bracing as needed for certain cases, e.g. those 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 + HsOverLabel sourceText _ -> do + txt "#" + p_sourceText sourceText + HsIPVar _ (HsIPName name) -> do + txt "?" + atom name + HsOverLit _ v -> atom (ol_val v) + HsLit _ lit -> + case lit of + HsString (SourceText stxt) _ -> p_stringLit stxt + HsStringPrim (SourceText stxt) _ -> p_stringLit stxt + HsMultilineString (SourceText stxt) _ -> p_stringLit stxt + r -> atom r + HsLam _ variant mgroup -> + p_lam isApp s variant exprPlacement p_hsExpr mgroup + HsApp _ f x -> do + let -- In order to format function applications with multiple parameters + -- more nicely, traverse the AST to gather the function and all the + -- parameters together. + gatherArgs f' knownArgs = + case f' of + L _ (HsApp _ l r) -> gatherArgs l (r <| knownArgs) + _ -> (f', knownArgs) + (func, args) = gatherArgs f (x :| []) + -- We need to handle the last argument specially if it is a + -- hanging construct, so separate it from the rest. + (initp, lastp) = (NE.init args, NE.last args) + initSpan = + combineSrcSpans' $ + getLocA f :| [(srcLocSpan . srcSpanStart . getLocA) lastp] + -- Hang the last argument only if the initial arguments span one + -- line. + placement = + if isOneLineSpan initSpan + then exprPlacement (unLoc lastp) + else Normal + -- If the last argument is not hanging, just separate every argument as + -- usual. If it is hanging, print the initial arguments and hang the + -- last one. Also, use braces around every argument except the last one. + case placement of + Normal -> do + ub <- + getLayout <&> \case + SingleLine -> useBraces + MultiLine -> id + ub $ do + located func (p_hsExpr' Applicand s) + breakpoint + inci $ sep breakpoint (located' p_hsExpr) initp + inci $ do + unless (null initp) breakpoint + located lastp p_hsExpr + Hanging -> do + useBraces . switchLayout [initSpan] $ do + located func (p_hsExpr' Applicand s) + breakpoint + sep breakpoint (located' p_hsExpr) initp + placeHanging placement $ + located lastp p_hsExpr + HsAppType _ e a -> do + located e p_hsExpr + breakpoint + inci $ do + txt "@" + located (hswc_body a) p_hsType + OpApp _ x op y -> do + modFixityMap <- askModuleFixityMap + debug <- askDebug + let opTree = BinaryOpBranches (exprOpTree x) op (exprOpTree y) + p_exprOpTree + s + (reassociateOpTree debug (getOpName . unLoc) modFixityMap opTree) + NegApp _ e _ -> do + negativeLiterals <- isExtensionEnabled NegativeLiterals + let isLiteral = case unLoc e of + HsLit {} -> True + HsOverLit {} -> True + _ -> False + txt "-" + -- If NegativeLiterals is enabled, we have to insert a space before + -- negated literals, as `- 1` and `-1` have differing ASTs. + when (negativeLiterals && isLiteral) space + located e p_hsExpr + HsPar _ e -> + switchLayoutWithEnclosingComments [locA e] $ + parens s (located e (dontUseBraces . p_hsExpr)) + SectionL _ x op -> do + located x p_hsExpr + breakpoint + inci (located op p_hsExpr) + SectionR _ op x -> do + located op p_hsExpr + breakpoint + inci (located x p_hsExpr) + ExplicitTuple _ args boxity -> do + let isSection = any isMissing args + isMissing = \case + Missing _ -> True + _ -> False + p_arg = + sitcc . \case + Present _ x -> located x p_hsExpr + Missing _ -> pure () + parens' = + case boxity of + Boxed -> parens + Unboxed -> parensHash + enclSpan <- + fmap (flip RealSrcSpan Strict.Nothing) . maybeToList + <$> getEnclosingSpan + if isSection + then + switchLayout [] . parens' s $ + sep comma p_arg args + else + switchLayout enclSpan . parens' s $ + sep commaDel p_arg args + ExplicitSum _ tag arity e -> + p_unboxedSum N tag arity (located e p_hsExpr) + HsCase _ 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)) (NE.toList guards) + HsLet _ localBinds e -> + p_let p_hsExpr localBinds e + HsDo _ doFlavor es -> do + let doBody moduleName header = do + forM_ moduleName $ \m -> atom m *> txt "." + txt header + p_stmts S isApp exprPlacement (p_hsExpr' NotApplicand) es + case doFlavor of + DoExpr moduleName -> doBody moduleName "do" + MDoExpr moduleName -> doBody moduleName "mdo" + ListComp -> p_listComp s es + MonadComp -> p_listComp s es + GhciStmtCtxt -> notImplemented "GhciStmtCtxt" + ExplicitList _ xs -> + brackets s $ + sep commaDel (sitcc . located' p_hsExpr) xs + RecordCon {..} -> do + p_rdrName rcon_con + breakpoint + let HsRecFields {..} = rcon_flds + p_lhs = located' $ p_rdrName . foLabel + fields = located' (p_hsFieldBind p_lhs) <$> rec_flds + dotdot = case rec_dotdot of + Just {} -> [txt ".."] + Nothing -> [] + inci . braces N $ + sep commaDel sitcc (fields <> dotdot) + RecordUpd {..} -> do + located rupd_expr p_hsExpr + breakpoint + let p_recFields p_lbl = + sep commaDel (sitcc . located' (p_hsFieldBind p_lbl)) + p_fieldLabelStrings (FieldLabelStrings flss) = + p_dotFieldOccs $ unLoc <$> flss + inci . braces N $ case rupd_flds of + RegularRecUpdFields {..} -> + p_recFields (located' p_fieldOcc) recUpdFields + OverloadedRecUpdFields {..} -> + p_recFields (located' p_fieldLabelStrings) olRecUpdFields + HsGetField {..} -> do + located gf_expr p_hsExpr + txt "." + located gf_field p_dotFieldOcc + HsProjection {..} -> parens N $ do + txt "." + p_dotFieldOccs proj_flds + ExprWithTySig _ x HsWC {hswc_body} -> sitcc $ do + located x p_hsExpr + space + txt "::" + breakpoint + inci $ located hswc_body p_hsSigType + ArithSeq _ _ x -> + case x of + From from -> brackets s $ do + located from p_hsExpr + breakpoint + txt ".." + FromThen from next -> brackets s $ do + sep commaDel (located' p_hsExpr) [from, next] + breakpoint + txt ".." + FromTo from to -> brackets s $ do + located from p_hsExpr + breakpoint + txt ".." + space + located to p_hsExpr + FromThenTo from next to -> brackets s $ do + sep commaDel (located' p_hsExpr) [from, next] + breakpoint + txt ".." + space + located to p_hsExpr + HsTypedBracket _ expr -> do + txt "[||" + breakpoint' + located expr p_hsExpr + breakpoint' + txt "||]" + HsUntypedBracket _ x -> p_hsQuote x + HsTypedSplice _ (HsTypedSpliceExpr _ expr) -> p_hsSpliceTH True expr DollarSplice + HsUntypedSplice _ untySplice -> p_hsUntypedSplice DollarSplice untySplice + HsProc _ p e -> do + txt "proc" + located p $ \x -> do + breakpoint + inci (p_pat x) + breakpoint + txt "->" + placeHanging (cmdTopPlacement (unLoc e)) $ + located e (p_hsCmdTop N) + HsStatic _ e -> do + txt "static" + breakpoint + inci (located e p_hsExpr) + HsPragE _ prag x -> case prag of + HsPragSCC _ name -> do + txt "{-# SCC " + atom name + txt " #-}" + breakpoint + let inciIfS = case s of N -> id; S -> inci + inciIfS $ located x p_hsExpr + HsEmbTy _ HsWC {hswc_body} -> do + txt "type" + space + located hswc_body p_hsType + HsHole holeKind -> case holeKind of + HoleVar name -> p_rdrName name + HoleError -> error "parse error" + -- similar to HsForAllTy + HsForAll _ tele e -> do + p_hsForAllTelescope tele + breakpoint + located e p_hsExpr + -- similar to HsQualTy + HsQual _ qs e -> do + located qs $ p_hsContext' p_hsExpr + space + txt "=>" + breakpoint + located e p_hsExpr + -- similar to HsFunTy + HsFunArr _ multAnn x y -> do + located x p_hsExpr + space + p_hsMultAnn (located' p_hsExpr) multAnn + space + txt "->" + breakpoint + case unLoc y of + HsFunArr {} -> p_hsExpr (unLoc y) + _ -> located y p_hsExpr + +-- | Print a list comprehension. +-- +-- The 'BracketStyle' should be 'N' except in a do-block, where it must be 'S' +-- or else it's a parse error. +p_listComp :: BracketStyle -> XRec GhcPs [ExprLStmt GhcPs] -> R () +p_listComp s es = sitcc (vlayout singleLine multiLine) + where + singleLine = do + txt "[" + body + txt "]" + multiLine = do + txt "[" >> space + (if s == S then sitcc else id) $ do + body + newline + txt "]" + + body = located es p_body + p_body xs = do + let (stmts, yield) = + case unsnoc xs of + Nothing -> error $ "list comprehension unexpectedly had no expressions" + Just (ys, y) -> (ys, y) + sitcc $ located yield p_stmt + breakpoint + txt "|" + space + p_bodyParallels (gatherStmts stmts) + + -- Print the list of list comprehension sections, e.g. + -- [ "| x <- xs, y <- ys, let z = x <> y", "| a <- f z" ] + p_bodyParallels = sep (breakpoint >> txt "|" >> space) (sitcc . p_bodyParallelStmts) + + -- Print a list comprehension section within a pipe, e.g. + -- [ "x <- xs", "y <- ys", "let z = x <> y" ] + p_bodyParallelStmts = sep commaDel (located' (sitcc . p_stmt)) + +-- | Gather the set of statements in a list comprehension. +-- +-- For example, this code: +-- +-- @ +-- [ a + b + c + d +-- | a <- as, let b = a + a +-- | c <- cs +-- | d <- ds, then sort by f +-- ] +-- @ +-- +-- is parsed as roughly: +-- +-- @ +-- [ ParStmt +-- [ ParStmtBlock +-- [ BindStmt [| a <- as |] +-- , LetStmt [| let b = a + a |] +-- ] +-- , ParStmtBlock +-- [ BindStmt [| c <- cs |] +-- ] +-- , ParStmtBlock +-- [ TransStmt +-- [ BindStmt [| d <- ds |] +-- ] +-- [| then sort by f |] +-- ] +-- ] +-- , LastStmt [| a + b + c + d |] +-- ] +-- @ +-- +-- The final expression is parsed out in p_body, and the rest is passed +-- to this function. This function takes the tree above as input and +-- normalizes it into: +-- +-- @ +-- [ [ BindStmt [| a <- as |] +-- , LetStmt [| let b = a + a |] +-- ] +-- , [ BindStmt [| c <- cs |] +-- ] +-- , [ BindStmt [| d <- ds |] +-- , TransStmt [] [| then sortWith by f |] +-- ] +-- ] +-- @ +-- +-- Notes: +-- * The number of elements in the outer list is the number of pipes in +-- the comprehension, i.e. 1 unless -XParallelListComp is enabled. +gatherStmts :: [ExprLStmt GhcPs] -> [[ExprLStmt GhcPs]] +gatherStmts = \case + -- When -XParallelListComp is enabled and the list comprehension has + -- multiple pipes, the input will have exactly 1 element, and it + -- will be a ParStmt. + [L _ (ParStmt _ blocks _ _)] -> + [ concatMap collectNonParStmts stmts + | ParStmtBlock _ stmts _ _ <- NE.toList blocks + ] + -- Otherwise, the list will not contain any ParStmt. + stmts -> + [ concatMap collectNonParStmts stmts + ] + where + collectNonParStmts = \case + L _ ParStmt {} -> unexpected "ParStmt" + stmt@(L _ TransStmt {trS_stmts}) -> concatMap collectNonParStmts trS_stmts ++ [stmt] + stmt -> [stmt] + + unexpected label = error $ "Unexpected " <> label <> "! Please file a bug." + +p_patSynBind :: PatSynBind GhcPs GhcPs -> R () +p_patSynBind PSB {..} = do + let rhs conSpans = do + space + let pattern_def_spans = [getLocA psb_id, getLocA psb_def] ++ conSpans + case psb_dir of + Unidirectional -> + switchLayout pattern_def_spans $ do + txt "<-" + breakpoint + located psb_def p_pat + ImplicitBidirectional -> + switchLayout pattern_def_spans $ do + txt "=" + breakpoint + located psb_def p_pat + ExplicitBidirectional mgroup -> do + switchLayout pattern_def_spans $ do + txt "<-" + breakpoint + located psb_def p_pat + breakpoint + txt "where" + breakpoint + inci (p_matchGroup (Function psb_id) mgroup) + txt "pattern" + case psb_args of + PrefixCon xs -> do + space + p_rdrName psb_id + inci $ do + let conSpans = getLocA <$> xs + switchLayout conSpans $ do + unless (null xs) breakpoint + sitcc (sep breakpoint p_rdrName xs) + rhs conSpans + RecCon xs -> do + space + p_rdrName psb_id + inci $ do + let conSpans = getLocA . recordPatSynPatVar <$> xs + switchLayout conSpans $ do + unless (null xs) breakpoint + braces N $ + sep commaDel (p_rdrName . recordPatSynPatVar) xs + rhs conSpans + InfixCon l r -> do + let conSpans = [getLocA l, getLocA r] + switchLayout conSpans $ do + space + p_rdrName l + breakpoint + inci $ do + p_rdrName psb_id + space + p_rdrName r + inci (rhs conSpans) + +p_case :: + ( Anno (GRHS GhcPs (LocatedA body)) ~ EpAnnCO, + Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA + ) => + IsApplicand -> + BracketStyle -> + -- | Placer + (body -> Placement) -> + -- | Render + (body -> R ()) -> + -- | Expression + LHsExpr GhcPs -> + -- | Match group + MatchGroup GhcPs (LocatedA body) -> + R () +p_case isApp s placer render e mgroup = do + txt "case" + space + located e p_hsExpr + space + txt "of" + breakpoint + 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 + (body -> Placement) -> + -- | Render + (body -> R ()) -> + -- | Expression + MatchGroup GhcPs (LocatedA body) -> + R () +p_lam isApp s variant placer render mgroup = do + let mCaseTxt = case variant of + LamSingle -> Nothing + LamCase -> Just "\\case" + LamCases -> Just "\\cases" + mgs = if isJust mCaseTxt then LambdaCase else Lambda + pMatchGroup = p_matchGroup' placer render mgs mgroup + case mCaseTxt of + Nothing -> pMatchGroup + Just caseTxt -> do + txt caseTxt + breakpoint + adjustBracing isApp s (inciApplicand isApp pMatchGroup) + +p_if :: + -- | Placer + (body -> Placement) -> + -- | Render + (body -> R ()) -> + -- | Annotations + AnnsIf -> + -- | If + LHsExpr GhcPs -> + -- | Then + LocatedA body -> + -- | Else + LocatedA body -> + R () +p_if placer render anns if' then' else' = do + txt "if" + space + located if' p_hsExpr + breakpoint + -- A comment between the @then@ or @else@ keyword and its branch means the + -- branch cannot hang; it has to start on its own line. + commentSpans <- + getEnclosingSpan >>= \case + Nothing -> pure [] + Just enclosing -> fmap getLoc <$> getCommentsAnchoredWithin enclosing + let (thenSpan, elseSpan) = (locA aiThen, locA aiElse) + where + AnnsIf {aiThen, aiElse} = anns + + locatedToken tokenSpan token = + located (L tokenSpan ()) $ \_ -> txt token + + betweenSpans spanA spanB s = spanA < s && s < spanB + + placeHangingLocated tokenSpan bodyLoc@(L _ body) = do + let bodySpan = getLocA bodyLoc + hasComments = fromMaybe False $ do + tokenRealSpan <- srcSpanToRealSrcSpan tokenSpan + bodyRealSpan <- srcSpanToRealSrcSpan bodySpan + pure $ any (betweenSpans tokenRealSpan bodyRealSpan) commentSpans + placement = if hasComments then Normal else placer body + switchLayout [tokenSpan, bodySpan] $ + placeHanging placement (located bodyLoc render) + inci $ do + locatedToken thenSpan "then" + space + placeHangingLocated thenSpan then' + breakpoint + locatedToken elseSpan "else" + space + placeHangingLocated elseSpan else' + +p_let :: + -- | Render + (body -> R ()) -> + HsLocalBinds GhcPs -> + LocatedA body -> + R () +p_let render localBinds e = sitcc $ do + txt "let" + space + dontUseBraces $ sitcc (p_hsLocalBinds localBinds) + vlayout space (newline >> txt " ") + txt "in" + space + sitcc (located e render) + +p_pat :: Pat GhcPs -> R () +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' inAsPat) + AsPat _ name pat -> do + p_rdrName name + txt "@" + located pat (p_pat' True) + ParPat _ pat -> + located pat (parens S . p_pat' inAsPat) + BangPat _ pat -> do + txt "!" + located pat (p_pat' inAsPat) + ListPat _ 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' 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' inAsPat)) + ConPat _ pat details -> + case details of + PrefixCon xs -> sitcc $ do + p_rdrName pat + unless (null xs) breakpoint + inci . sitcc $ sep breakpoint (sitcc . located' (p_pat' inAsPat)) xs + RecCon (HsRecFields _ fields dotdot) -> do + p_rdrName pat + breakpoint + let f = \case + Nothing -> txt ".." + Just x -> located x p_pat_hsFieldBind + inci . braces N . 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' inAsPat) + breakpoint + inci $ do + p_rdrName pat + space + located r (p_pat' inAsPat) + ViewPat _ expr pat -> sitcc $ do + located expr p_hsExpr + space + txt "->" + breakpoint + inci (located pat (p_pat' inAsPat)) + SplicePat _ splice -> p_hsUntypedSplice DollarSplice splice + LitPat _ p -> atom p + NPat _ v (isJust -> isNegated) _ -> do + when isNegated $ do + txt "-" + negativeLiterals <- isExtensionEnabled NegativeLiterals + when negativeLiterals space + located v (atom . ol_val) + NPlusKPat _ n k _ _ _ -> sitcc $ do + p_rdrName n + breakpoint + inci $ do + txt "+" + space + located k (atom . ol_val) + SigPat _ pat HsPS {..} -> do + located pat (p_pat' inAsPat) + p_typeAscription (lhsTypeToSigType hsps_body) + EmbTyPat _ (HsTP _ ty) -> do + txt "type" + space + located ty p_hsType + InvisPat _ tyPat -> p_tyPat tyPat + +p_tyPat :: HsTyPat GhcPs -> R () +p_tyPat (HsTP _ ty) = txt "@" *> located ty p_hsType + +p_pat_hsFieldBind :: HsRecField GhcPs (LPat GhcPs) -> R () +p_pat_hsFieldBind HsFieldBind {..} = do + located hfbLHS p_fieldOcc + unless hfbPun $ do + space + txt "=" + breakpoint + inci (located hfbRHS p_pat) + +p_unboxedSum :: BracketStyle -> ConTag -> Arity -> R () -> R () +p_unboxedSum s tag arity m = do + let before = tag - 1 + after = arity - before - 1 + args = replicate before Nothing <> [Just m] <> replicate after Nothing + f x = + case x :: Maybe (R ()) of + Nothing -> + space + Just m' -> do + space + m' + space + parensHash s $ sep (txt "|") f args + +p_hsUntypedSplice :: SpliceDecoration -> HsUntypedSplice GhcPs -> R () +p_hsUntypedSplice deco = \case + HsUntypedSpliceExpr _ expr -> p_hsSpliceTH False expr deco + HsQuasiQuote _ quoterName str -> do + txt "[" + p_rdrName quoterName + txt "|" + -- QuasiQuoters often rely on precise custom strings. We cannot do any + -- formatting here without potentially breaking someone's code. + atom str + txt "|]" + +p_hsSpliceTH :: + -- | Typed splice? + Bool -> + -- | Splice expression + LHsExpr GhcPs -> + -- | Splice decoration + SpliceDecoration -> + R () +p_hsSpliceTH isTyped expr = \case + DollarSplice -> do + txt decoSymbol + located expr (sitcc . p_hsExpr) + BareSplice -> + located expr (sitcc . p_hsExpr) + where + decoSymbol = if isTyped then "$$" else "$" + +p_hsQuote :: HsQuote GhcPs -> R () +p_hsQuote = \case + ExpBr (bracketAnn, _) expr -> do + let name = case bracketAnn of + BracketNoE {} -> "" + BracketHasE {} -> "e" + quote name (located expr p_hsExpr) + PatBr _ pat -> located pat (quote "p" . p_pat) + DecBrL _ decls -> quote "d" (handleStarIsType decls (p_hsDecls Free decls)) + DecBrG _ _ -> notImplemented "DecBrG" -- result of renamer + TypBr _ ty -> quote "t" (located ty (handleStarIsType ty . p_hsType)) + VarBr _ isSingleQuote name -> do + txt (bool "''" "'" isSingleQuote) + p_rdrName name + where + quote :: Text -> R () -> R () + quote name body = do + txt "[" + txt name + txt "|" + breakpoint' + inci $ do + dontUseBraces body + breakpoint' + txt "|]" + -- With StarIsType, type and declaration brackets might end with a *, + -- so we have to insert a space at the end to prevent the (mis)parsing + -- of an (*|) operator. + -- The detection is a bit overcautious, as it adds the spaces as soon as + -- an HsStarTy appears anywhere in the type/declaration. + handleStarIsType :: (Data a) => a -> R () -> R () + handleStarIsType a p + | containsHsStarTy a = space *> p <* space + | otherwise = p + where + containsHsStarTy = everything (||) $ \b -> case cast @_ @(HsType GhcPs) b of + Just HsStarTy {} -> True + _ -> False + +---------------------------------------------------------------------------- +-- Helpers + +-- | Return the wrapping function controlling the use of braces according to +-- the current layout. +layoutToBraces :: Layout -> R () -> R () +layoutToBraces = \case + SingleLine -> useBraces + MultiLine -> id + +getGRHSSpan :: GRHS GhcPs (LocatedA body) -> SrcSpan +getGRHSSpan (GRHS _ guards body) = + combineSrcSpans' $ getLocA body :| map getLocA guards + +-- | Determine the placement of a given block. +blockPlacement :: + (body -> Placement) -> + NonEmpty (LGRHS GhcPs (LocatedA body)) -> + Placement +blockPlacement placer (L _ (GRHS _ _ (L _ x)) :| []) = placer x +blockPlacement _ _ = Normal + +-- | Determine the placement of a given command. +cmdPlacement :: HsCmd GhcPs -> Placement +cmdPlacement = \case + HsCmdLam {} -> Hanging + HsCmdCase {} -> Hanging + HsCmdDo {} -> Hanging + _ -> Normal + +-- | Determine the placement of a top-level command. +cmdTopPlacement :: HsCmdTop GhcPs -> Placement +cmdTopPlacement (HsCmdTop _ (L _ x)) = cmdPlacement x + +-- | Check whether the given expression has a hanging form. +exprPlacement :: HsExpr GhcPs -> Placement +exprPlacement = \case + -- Only hang lambdas with single-line parameter lists. + HsLam _ variant mg -> case variant of + LamSingle -> case mg of + MG _ (L _ [L _ (Match _ _ (L _ (x : xs)) _)]) + | isOneLineSpan (combineSrcSpans' $ fmap getLocA (x :| xs)) -> + Hanging + _ -> Normal + LamCase -> Hanging + LamCases -> Hanging + HsCase _ _ _ -> Hanging + HsDo _ (DoExpr _) _ -> Hanging + HsDo _ (MDoExpr _) _ -> Hanging + OpApp _ _ op y -> + case (fmap getOpNameStr . getOpName . unLoc) op of + Just "$" -> exprPlacement (unLoc y) + _ -> Normal + HsApp _ _ y -> exprPlacement (unLoc y) + HsProc _ p _ -> + -- Indentation breaks if the pattern is longer than one line and left + -- hanging. Consequently, only apply hanging when it is safe. + if isOneLineSpan (getLocA p) + then Hanging + else Normal + _ -> Normal + +-- | Return 'True' if any of the RHS expressions has guards. +withGuards :: NonEmpty (LGRHS GhcPs body) -> Bool +withGuards = any (checkOne . unLoc) + where + checkOne (GRHS _ [] _) = False + checkOne _ = True diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot b/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot @@ -2,19 +2,25 @@ ( p_valDecl, p_pat, p_hsExpr, - p_hsSplice, - p_stringLit, + p_hsUntypedSplice, + p_hsExpr', + p_hsCmdTop, + exprPlacement, + cmdTopPlacement, ) where -import GHC.Hs.Binds -import GHC.Hs.Expr -import GHC.Hs.Extension -import GHC.Hs.Pat +import GHC.Hs import Ormolu.Printer.Combinators p_valDecl :: HsBindLR GhcPs GhcPs -> R () p_pat :: Pat GhcPs -> R () p_hsExpr :: HsExpr GhcPs -> R () -p_hsSplice :: HsSplice GhcPs -> R () -p_stringLit :: String -> R () +p_hsUntypedSplice :: SpliceDecoration -> HsUntypedSplice GhcPs -> R () + +data IsApplicand + +p_hsExpr' :: IsApplicand -> BracketStyle -> HsExpr GhcPs -> R () +p_hsCmdTop :: BracketStyle -> HsCmdTop GhcPs -> R () +exprPlacement :: HsExpr GhcPs -> Placement +cmdTopPlacement :: HsCmdTop GhcPs -> Placement diff --git a/src/Ormolu/Printer/Meat/Declaration/Warning.hs b/src/Ormolu/Printer/Meat/Declaration/Warning.hs --- a/src/Ormolu/Printer/Meat/Declaration/Warning.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Warning.hs @@ -1,50 +1,54 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Ormolu.Printer.Meat.Declaration.Warning ( p_warnDecls, - p_moduleWarning, + p_warningTxt, ) where import Data.Foldable import Data.Text (Text) -import GHC.Hs.Decls -import GHC.Hs.Extension -import GHC.Types.Basic -import GHC.Types.Name.Reader +import Data.Text qualified as T +import GHC.Hs +import GHC.Types.SourceText import GHC.Types.SrcLoc +import GHC.Unit.Module.Warnings import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common +import Ormolu.Utils p_warnDecls :: WarnDecls GhcPs -> R () -p_warnDecls (Warnings NoExtField _ warnings) = +p_warnDecls (Warnings _ warnings) = traverse_ (located' p_warnDecl) warnings p_warnDecl :: WarnDecl GhcPs -> R () -p_warnDecl (Warning NoExtField functions warningTxt) = - p_topLevelWarning functions warningTxt - -p_moduleWarning :: WarningTxt -> R () -p_moduleWarning wtxt = do - let (pragmaText, lits) = warningText wtxt - inci $ pragma pragmaText $ inci $ p_lits lits - -p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R () -p_topLevelWarning fnames wtxt = do +p_warnDecl (Warning (namespace, _) fnames wtxt) = do let (pragmaText, lits) = warningText wtxt - switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $ + switchLayout (fmap getLocA fnames ++ fmap getLocA lits) $ pragma pragmaText . inci $ do + p_namespaceSpec namespace sep commaDel p_rdrName fnames breakpoint p_lits lits -warningText :: WarningTxt -> (Text, [Located StringLiteral]) +p_warningTxt :: WarningTxt GhcPs -> R () +p_warningTxt wtxt = do + let (pragmaText, lits) = warningText wtxt + inci $ pragma pragmaText $ inci $ p_lits lits + +warningText :: WarningTxt GhcPs -> (Text, [LocatedE StringLiteral]) warningText = \case - WarningTxt _ lits -> ("WARNING", lits) - DeprecatedTxt _ lits -> ("DEPRECATED", lits) + WarningTxt mcat _ lits -> ("WARNING" <> T.pack cat, fmap hsDocString <$> lits) + where + cat = case unLoc <$> mcat of + Just InWarningCategory {..} -> + " in " <> show (showOutputable @WarningCategory (unLoc iwc_wc)) + Nothing -> "" + DeprecatedTxt _ lits -> ("DEPRECATED", fmap hsDocString <$> lits) -p_lits :: [Located StringLiteral] -> R () +p_lits :: [LocatedE StringLiteral] -> R () p_lits = \case [l] -> atom l ls -> brackets N $ sep commaDel atom ls 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 @@ -1,36 +1,43 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -- | Rendering of import and export lists. module Ormolu.Printer.Meat.ImportExport ( p_hsmodExports, p_hsmodImport, + enterMultilineLayoutIfContainsDocEntries, ) where import Control.Monad -import GHC.Hs.Extension -import GHC.Hs.ImpExp +import Data.Choice (pattern Without) +import Data.Foldable (for_, traverse_) +import GHC.Hs import GHC.LanguageExtensions.Type +import GHC.Types.PkgQual import GHC.Types.SrcLoc -import GHC.Unit.Types import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common +import Ormolu.Printer.Meat.Declaration.Warning import Ormolu.Utils (RelativePos (..), attachRelativePos) p_hsmodExports :: [LIE GhcPs] -> R () -p_hsmodExports [] = do - txt "(" - breakpoint' - txt ")" p_hsmodExports xs = - parens N $ do - layout <- getLayout - sep - breakpoint - (\(p, l) -> sitcc (located l (p_lie layout p))) - (attachRelativePos xs) + enterMultilineLayoutIfContainsDocEntries xs $ + parens N $ do + layout <- getLayout + sep + breakpoint + (\(p, l) -> sitcc (located (addDocSrcSpan l) (p_lie layout p))) + (attachRelativePos xs) + where + -- In order to correctly set the layout when a doc comment is present. + addDocSrcSpan lie@(L l ie) = case ieExportDoc ie of + Nothing -> lie + Just (L l' _) -> L (l <> noAnnSrcSpan l') ie p_hsmodImport :: ImportDecl GhcPs -> R () p_hsmodImport ImportDecl {..} = do @@ -41,16 +48,24 @@ space when ideclSafe (txt "safe") space + case ideclLevelSpec of + LevelStylePre l -> p_declLevel l + _ -> return () + space when (isImportDeclQualified ideclQualified && not useQualifiedPost) (txt "qualified") space case ideclPkgQual of - Nothing -> return () - Just slit -> atom slit + NoRawPkgQual -> return () + RawPkgQual slit -> atom slit space inci $ do located ideclName atom + space + case ideclLevelSpec of + LevelStylePost l -> p_declLevel l + _ -> return () when (isImportDeclQualified ideclQualified && useQualifiedPost) (space >> txt "qualified") @@ -62,49 +77,61 @@ space located l atom space - case ideclHiding of - Nothing -> return () - Just (hiding, _) -> - when hiding (txt "hiding") - case ideclHiding of + case ideclImportList of Nothing -> return () - Just (_, L _ xs) -> do + Just (hiding, L listLoc xs) -> do + case hiding of + Exactly -> pure () + EverythingBut -> txt "hiding" breakpoint parens N $ do layout <- getLayout + when (null xs) $ locatedEmpty (locA listLoc) sep breakpoint (\(p, l) -> sitcc (located l (p_lie layout p))) (attachRelativePos xs) - newline +p_declLevel :: ImportDeclLevel -> R () +p_declLevel = \case + ImportDeclSplice -> txt "splice" + ImportDeclQuote -> txt "quote" + p_lie :: Layout -> RelativePos -> IE GhcPs -> R () p_lie encLayout relativePos = \case - IEVar NoExtField l1 -> do + IEVar mwarn l1 exportDoc -> do + for_ mwarn $ \warnTxt -> do + located warnTxt p_warningTxt + breakpoint located l1 p_ieWrappedName p_comma - IEThingAbs NoExtField l1 -> do + p_exportDoc exportDoc + IEThingAbs _ l1 exportDoc -> do located l1 p_ieWrappedName p_comma - IEThingAll NoExtField l1 -> do + p_exportDoc exportDoc + IEThingAll _ l1 exportDoc -> do located l1 p_ieWrappedName space txt "(..)" p_comma - IEThingWith NoExtField l1 w xs _ -> sitcc $ do - located l1 p_ieWrappedName - breakpoint - inci $ do - let names :: [R ()] - names = located' p_ieWrappedName <$> xs - parens N . sep commaDel sitcc $ - case w of - NoIEWildcard -> names - IEWildcard n -> - let (before, after) = splitAt n names - in before ++ [txt ".."] ++ after - p_comma - IEModuleContents NoExtField l1 -> do + p_exportDoc exportDoc + IEThingWith _ l1 w xs exportDoc -> do + sitcc $ do + located l1 p_ieWrappedName + breakpoint + inci $ do + let names :: [R ()] + names = located' p_ieWrappedName <$> xs + parens N . sep commaDel sitcc $ + case w of + NoIEWildcard -> names + IEWildcard n -> + let (before, after) = splitAt n names + in before ++ [txt ".."] ++ after + p_comma + p_exportDoc exportDoc + IEModuleContents _ l1 -> do located l1 p_hsmodName p_comma IEGroup NoExtField n str -> do @@ -113,9 +140,9 @@ FirstPos -> return () MiddlePos -> newline LastPos -> newline - p_hsDocString (Asterisk n) False (noLoc str) + p_hsDoc (Asterisk n) (Without #endNewline) str IEDoc NoExtField str -> - p_hsDocString Pipe False (noLoc str) + p_hsDoc Pipe (Without #endNewline) str IEDocNamed NoExtField str -> p_hsDocName str where p_comma = @@ -127,3 +154,36 @@ MiddlePos -> comma LastPos -> return () MultiLine -> comma + + -- This is used to support `@since` annotations for (re)exported items. It + -- /must/ use caret style comments, see + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12098 and + -- https://github.com/haskell/haddock/issues/1629#issuecomment-1931354411. + p_exportDoc :: Maybe (ExportDoc GhcPs) -> R () + p_exportDoc = traverse_ $ \exportDoc -> do + breakpoint + p_hsDoc Caret (Without #endNewline) exportDoc + +ieExportDoc :: IE GhcPs -> Maybe (ExportDoc GhcPs) +ieExportDoc = \case + IEVar _ _ doc -> doc + IEThingAbs _ _ doc -> doc + IEThingAll _ _ doc -> doc + IEThingWith _ _ _ _ doc -> doc + IEModuleContents {} -> Nothing + IEGroup {} -> Nothing + IEDoc {} -> Nothing + IEDocNamed {} -> Nothing + +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 @@ -1,5 +1,6 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -- | Rendering of modules. @@ -9,13 +10,11 @@ where import Control.Monad -import qualified Data.Text as T -import GHC.Hs +import Data.Choice (pattern With) +import GHC.Hs hiding (comment) import GHC.Types.SrcLoc -import Ormolu.Imports (normalizeImports) import Ormolu.Parser.CommentStream import Ormolu.Parser.Pragma -import Ormolu.Parser.Shebang import Ormolu.Printer.Combinators import Ormolu.Printer.Comments import Ormolu.Printer.Meat.Common @@ -24,53 +23,56 @@ import Ormolu.Printer.Meat.ImportExport import Ormolu.Printer.Meat.Pragma --- | Render a module. +-- | Render a module-like entity (either a regular module or a Backpack +-- signature). p_hsModule :: -- | Stack header - Maybe (RealLocated Comment) -> - -- | Shebangs - [Shebang] -> + Maybe LComment -> -- | Pragmas and the associated comments - [([RealLocated Comment], Pragma)] -> + [([LComment], Pragma)] -> -- | AST to print - HsModule -> + HsModule GhcPs -> R () -p_hsModule mstackHeader shebangs pragmas HsModule {..} = do - let deprecSpan = maybe [] (\(L s _) -> [s]) hsmodDeprecMessage - exportSpans = maybe [] (\(L s _) -> [s]) hsmodExports - switchLayout (deprecSpan <> exportSpans) $ do - forM_ shebangs $ \(Shebang x) -> - realLocated x $ \shebang -> do - txt (T.pack shebang) +p_hsModule mstackHeader pragmas HsModule {..} = do + let XModulePs {..} = hsmodExt + deprecSpan = maybe [] (pure . getLocA) hsmodDeprecMessage + exportSpans = maybe [] (pure . getLocA) hsmodExports + switchLayout (deprecSpan <> exportSpans) $ + enterMultilineLayoutIfContainsDocEntries (maybe [] unLoc hsmodExports) $ do + forM_ mstackHeader $ \(L spn comment) -> do + spitCommentNow SlotFloating spn comment newline - forM_ mstackHeader $ \(L spn comment) -> do - spitCommentNow spn comment newline - newline - p_pragmas pragmas - newline - case hsmodName of - Nothing -> return () - Just hsmodName' -> do - located hsmodName' $ \name -> do - forM_ hsmodHaddockModHeader (p_hsDocString Pipe True) - p_hsmodName name - breakpoint - forM_ hsmodDeprecMessage $ \w -> do - located' p_moduleWarning w + p_pragmas pragmas + newline + case hsmodName of + Nothing -> return () + Just hsmodName' -> do + located hsmodName' $ \name -> do + forM_ hsmodHaddockModHeader (p_hsDoc Pipe (With #endNewline)) + p_hsmodName name breakpoint - case hsmodExports of - Nothing -> return () - Just l -> do - located l $ \exports -> do - inci (p_hsmodExports exports) + forM_ hsmodDeprecMessage $ \w -> do + located' p_warningTxt w breakpoint - txt "where" + case hsmodExports of + Nothing -> return () + Just l -> do + located l $ \exports -> do + when (null exports) $ locatedEmpty (locA l) + inci (p_hsmodExports exports) + breakpoint + txt "where" + newline + newline + -- The newline goes here rather than at the end of 'p_hsmodImport' so + -- that a comment trailing an import is emitted while the printer is + -- still on the import's line. + forM_ hsmodImports $ \x -> do + located' p_hsmodImport x newline - newline - forM_ (normalizeImports hsmodImports) (located' p_hsmodImport) - newline - switchLayout (getLoc <$> hsmodDecls) $ do - p_hsDecls Free hsmodDecls newline - spitRemainingComments + switchLayout (getLocA <$> hsmodDecls) $ do + p_hsDecls Free hsmodDecls + newline + spitRemainingComments diff --git a/src/Ormolu/Printer/Meat/Pragma.hs b/src/Ormolu/Printer/Meat/Pragma.hs --- a/src/Ormolu/Printer/Meat/Pragma.hs +++ b/src/Ormolu/Printer/Meat/Pragma.hs @@ -10,13 +10,16 @@ import Control.Monad import Data.Char (isUpper) -import qualified Data.List as L -import Data.Maybe (listToMaybe) -import qualified Data.Text as T +import Data.List qualified as L +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Driver.Flags (Language) import GHC.Types.SrcLoc import Ormolu.Parser.CommentStream import Ormolu.Parser.Pragma (Pragma (..)) -import Ormolu.Printer.Combinators +import Ormolu.Printer.Combinators hiding (Placement (..)) import Ormolu.Printer.Comments -- | Pragma classification. @@ -38,7 +41,9 @@ -- -- See also: data LanguagePragmaClass - = -- | All other extensions + = -- | A pack of extensions like @GHC2021@ or @Haskell2010@ + ExtensionPack + | -- | All other extensions Normal | -- | Extensions starting with "No" Disabling @@ -47,22 +52,28 @@ deriving (Eq, Ord) -- | Print a collection of 'Pragma's with their associated comments. -p_pragmas :: [([RealLocated Comment], Pragma)] -> R () +p_pragmas :: [([LComment], Pragma)] -> R () p_pragmas ps = do let prepare = L.sortOn snd . L.nub . concatMap analyze analyze = \case + -- @{-# LANGUAGE A, B #-}@ becomes one pragma per extension, but the + -- comment written above it was written once. It goes to the first + -- extension only; giving it to each of them printed it as many + -- times as there were extensions. (cs, PragmaLanguage xs) -> - let f x = (cs, (Language (classifyLanguagePragma x), x)) - in f <$> xs + let f x = (Language (classifyLanguagePragma x), x) + in case xs of + [] -> [] + (y : ys) -> (cs, f y) : ((mempty,) . f <$> ys) (cs, PragmaOptionsGHC x) -> [(cs, (OptionsGHC, x))] (cs, PragmaOptionsHaddock x) -> [(cs, (OptionsHaddock, x))] forM_ (prepare ps) $ \(cs, (pragmaTy, x)) -> p_pragma cs pragmaTy x -p_pragma :: [RealLocated Comment] -> PragmaTy -> String -> R () +p_pragma :: [LComment] -> PragmaTy -> Text -> R () p_pragma comments ty x = do forM_ comments $ \(L l comment) -> do - spitCommentNow l comment + spitCommentNow SlotPragma l comment newline txt "{-# " txt $ case ty of @@ -70,22 +81,28 @@ OptionsGHC -> "OPTIONS_GHC" OptionsHaddock -> "OPTIONS_HADDOCK" space - txt (T.pack x) + txt x txt " #-}" newline -- | Classify a 'LanguagePragma'. -classifyLanguagePragma :: String -> LanguagePragmaClass +classifyLanguagePragma :: Text -> LanguagePragmaClass classifyLanguagePragma = \case + str | str `Set.member` extensionPacks -> ExtensionPack "ImplicitPrelude" -> Final "CUSKs" -> Final str -> - case splitAt 2 str of + case T.splitAt 2 str of ("No", rest) -> - case listToMaybe rest of + case T.uncons rest of Nothing -> Normal - Just x -> + Just (x, _) -> if isUpper x then Disabling else Normal _ -> Normal + +-- | Extension packs, like @GHC2021@ and @Haskell2010@. +extensionPacks :: Set Text +extensionPacks = + Set.fromList $ T.pack . show <$> [minBound :: Language .. maxBound] diff --git a/src/Ormolu/Printer/Meat/Type.hs b/src/Ormolu/Printer/Meat/Type.hs --- a/src/Ormolu/Printer/Meat/Type.hs +++ b/src/Ormolu/Printer/Meat/Type.hs @@ -1,67 +1,63 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} -- | Rendering of types. module Ormolu.Printer.Meat.Type ( p_hsType, - p_hsTypePostDoc, hasDocStrings, p_hsContext, + p_hsContext', p_hsTyVarBndr, ForAllVisibility (..), p_forallBndrs, - p_conDeclFields, + p_hsConDeclRecFields, + p_hsConDeclField, + p_hsConDeclFieldWithDoc, p_lhsTypeArg, - tyVarsToTypes, - tyVarsToTyPats, + p_hsSigType, + p_hsForAllTelescope, + p_hsOuterTyVarBndrs, + lhsTypeToSigType, ) where -import Data.Data (Data) -import GHC.Hs.Decls -import GHC.Hs.Extension -import GHC.Hs.Type -import GHC.Types.Basic hiding (isPromoted) -import GHC.Types.Name.Reader +import Control.Monad +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 Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common -import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit) +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.Operators import Ormolu.Utils p_hsType :: HsType GhcPs -> R () -p_hsType t = p_hsType' (hasDocStrings t) PipeStyle t - -p_hsTypePostDoc :: HsType GhcPs -> R () -p_hsTypePostDoc t = p_hsType' (hasDocStrings t) CaretStyle t - --- | How to render Haddocks associated with a type. -data TypeDocStyle - = PipeStyle - | CaretStyle +p_hsType t = p_hsType' (hasDocStrings t) t -p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R () -p_hsType' multilineArgs docStyle = \case - HsForAllTy NoExtField tele t -> do - case tele of - HsForAllInvis NoExtField bndrs -> p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs - HsForAllVis NoExtField bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs +p_hsType' :: Bool -> HsType GhcPs -> R () +p_hsType' multilineArgs = \case + HsForAllTy _ tele t -> do + p_hsForAllTelescope tele interArgBreak - p_hsTypeR (unLoc t) - HsQualTy NoExtField qs t -> do + located t p_hsType + HsQualTy _ qs t -> do located qs p_hsContext space txt "=>" interArgBreak case unLoc t of HsQualTy {} -> p_hsTypeR (unLoc t) - HsFunTy {} -> p_hsTypeR (unLoc t) + HsFunTy {} -> located t p_hsType _ -> located t p_hsTypeR - HsTyVar NoExtField p n -> do + HsTyVar _ p n -> do case p of IsPromoted -> do txt "'" @@ -70,16 +66,16 @@ _ -> return () NotPromoted -> return () p_rdrName n - HsAppTy NoExtField f x -> do + HsAppTy _ f x -> do let -- In order to format type applications with multiple parameters - -- nicer, traverse the AST to gather the function and all the + -- more nicely, traverse the AST to gather the function and all the -- parameters together. gatherArgs f' knownArgs = case f' of L _ (HsAppTy _ l r) -> gatherArgs l (r : knownArgs) _ -> (f', knownArgs) (func, args) = gatherArgs f [x] - switchLayout (getLoc f : fmap getLoc args) . sitcc $ do + switchLayout (getLocA f : fmap getLocA args) . sitcc $ do located func p_hsType breakpoint inci $ @@ -93,113 +89,109 @@ inci $ do txt "@" located kd p_hsType - HsFunTy NoExtField arrow x y@(L _ y') -> do + HsFunTy _ multAnn x y -> do located x p_hsType space - case arrow of - HsUnrestrictedArrow _ -> txt "->" - HsLinearArrow _ -> txt "%1 ->" - HsExplicitMult _ mult -> do - txt "%" - p_hsTypeR (unLoc mult) - space - txt "->" + p_hsMultAnn (located' p_hsTypeR) multAnn + space + txt "->" interArgBreak - case y' of - HsFunTy {} -> p_hsTypeR y' + case unLoc y of + HsFunTy {} -> p_hsTypeR (unLoc y) _ -> located y p_hsTypeR - HsListTy NoExtField t -> + HsListTy _ t -> located t (brackets N . p_hsType) - HsTupleTy NoExtField tsort xs -> + HsTupleTy _ tsort xs -> let parens' = case tsort of HsUnboxedTuple -> parensHash N - HsBoxedTuple -> parens N - HsConstraintTuple -> parens N HsBoxedOrConstraintTuple -> parens N in parens' $ sep commaDel (sitcc . located' p_hsType) xs - HsSumTy NoExtField xs -> + HsSumTy _ xs -> parensHash N $ - sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs - HsOpTy NoExtField x op y -> - sitcc $ - let opTree = OpBranch (tyOpTree x) op (tyOpTree y) - in p_tyOpTree (reassociateOpTree Just opTree) - HsParTy NoExtField t -> - parens N (located t p_hsType) - HsIParamTy NoExtField n t -> sitcc $ do + sep (space >> txt "|" >> breakpoint) (sitcc . located' p_hsType) xs + HsOpTy _ _ x op y -> do + modFixityMap <- askModuleFixityMap + debug <- askDebug + let opTree = BinaryOpBranches (tyOpTree x) op (tyOpTree y) + p_tyOpTree + (reassociateOpTree debug (Just . unLoc) modFixityMap opTree) + HsParTy _ t -> + switchLayoutWithEnclosingComments [locA t] $ + parens N (located t p_hsType) + HsIParamTy _ n t -> sitcc $ do located n atom space txt "::" breakpoint inci (located t p_hsType) - HsStarTy NoExtField _ -> txt "*" - HsKindSig NoExtField t k -> sitcc $ do + HsStarTy _ _ -> txt "*" + HsKindSig _ t k -> sitcc $ do located t p_hsType space txt "::" breakpoint inci (located k p_hsType) - HsSpliceTy NoExtField splice -> p_hsSplice splice - HsDocTy NoExtField t str -> - case docStyle of - PipeStyle -> do - p_hsDocString Pipe True str - located t p_hsType - CaretStyle -> do - located t p_hsType - newline - p_hsDocString Caret False str - HsBangTy NoExtField (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 () + HsSpliceTy _ splice -> p_hsUntypedSplice DollarSplice splice + HsDocTy _ t str -> do + p_hsDocInline Pipe str located t p_hsType - HsRecTy NoExtField fields -> - p_conDeclFields fields - HsExplicitListTy NoExtField p xs -> do + HsExplicitListTy _ p xs -> do case p of IsPromoted -> txt "'" NotPromoted -> return () brackets N $ do - -- If both this list itself and the first element is promoted, - -- we need to put a space in between or it fails to parse. + -- If this list is promoted and the first element starts with a single + -- quote, we need to put a space in between or it fails to parse. case (p, xs) of - (IsPromoted, L _ t : _) | isPromoted t -> space + (IsPromoted, L _ t : _) | startsWithSingleQuote t -> space _ -> return () sep commaDel (sitcc . located' p_hsType) xs - HsExplicitTupleTy NoExtField xs -> do - txt "'" + HsExplicitTupleTy _ p xs -> do + case p of + IsPromoted -> txt "'" + NotPromoted -> return () parens N $ do - case xs of - L _ t : _ | isPromoted t -> space + -- If this tuple is promoted and the first element starts with a single + -- quote, we need to put a space in between or it fails to parse. + case (p, xs) of + (IsPromoted, L _ t : _) | startsWithSingleQuote t -> space _ -> return () sep commaDel (located' p_hsType) xs - HsTyLit NoExtField t -> + HsTyLit _ t -> case t of HsStrTy (SourceText s) _ -> p_stringLit s a -> atom a - HsWildCardTy NoExtField -> txt "_" - XHsType (NHsCoreTy t) -> atom t + HsWildCardTy _ -> txt "_" + 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 - isPromoted = \case - HsAppTy _ (L _ f) _ -> isPromoted f + startsWithSingleQuote = \case + HsAppTy _ (L _ f) _ -> startsWithSingleQuote f HsTyVar _ IsPromoted _ -> True HsExplicitTupleTy {} -> True HsExplicitListTy {} -> True + HsTyLit _ HsCharTy {} -> True _ -> False interArgBreak = if multilineArgs then newline else breakpoint - p_hsTypeR = p_hsType' multilineArgs docStyle + p_hsTypeR = p_hsType' multilineArgs --- | Return 'True' if at least one argument in 'HsType' has a doc string +-- | Return 'True' if at least one argument in the 'HsType' has a doc string -- attached to it. hasDocStrings :: HsType GhcPs -> Bool hasDocStrings = \case @@ -210,41 +202,66 @@ _ -> False p_hsContext :: HsContext GhcPs -> R () -p_hsContext = \case +p_hsContext = p_hsContext' p_hsType + +p_hsContext' :: (HasLoc (Anno a)) => (a -> R ()) -> [XRec GhcPs a] -> R () +p_hsContext' f = \case [] -> txt "()" - [x] -> located x p_hsType - xs -> parens N $ sep commaDel (sitcc . located' p_hsType) xs + [x] -> located x f + xs -> parens N $ sep commaDel (sitcc . located' f) xs -class IsInferredTyVarBndr flag where +class IsTyVarBndrFlag flag where isInferred :: flag -> Bool + p_tyVarBndrFlag :: flag -> R () + p_tyVarBndrFlag _ = pure () -instance IsInferredTyVarBndr () where +instance IsTyVarBndrFlag () where isInferred () = False -instance IsInferredTyVarBndr Specificity where +instance IsTyVarBndrFlag Specificity where isInferred = \case InferredSpec -> True SpecifiedSpec -> False -p_hsTyVarBndr :: IsInferredTyVarBndr flag => HsTyVarBndr flag GhcPs -> R () -p_hsTyVarBndr = \case - UserTyVar NoExtField flag x -> - (if isInferred flag then braces N else id) $ p_rdrName x - KindedTyVar NoExtField flag l k -> (if isInferred flag then braces else parens) N $ do - located l atom - space - txt "::" - breakpoint - inci (located k p_hsType) +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 -> do + space + txt "::" + breakpoint + inci (located k p_hsType) + HsBndrNoKind _ -> pure () + data ForAllVisibility = ForAllInvis | ForAllVis -- | Render several @forall@-ed variables. -p_forallBndrs :: Data a => ForAllVisibility -> (a -> R ()) -> [Located a] -> R () +p_forallBndrs :: + (HasLoc l) => + ForAllVisibility -> + (a -> R ()) -> + [GenLocated l a] -> + R () p_forallBndrs ForAllInvis _ [] = txt "forall." p_forallBndrs ForAllVis _ [] = txt "forall ->" p_forallBndrs vis p tyvars = - switchLayout (getLoc <$> tyvars) $ do + switchLayout (locA <$> tyvars) $ do txt "forall" breakpoint inci $ do @@ -253,65 +270,80 @@ ForAllInvis -> txt "." ForAllVis -> space >> txt "->" -p_conDeclFields :: [LConDeclField GhcPs] -> R () -p_conDeclFields xs = - braces N $ sep commaDel (sitcc . located' p_conDeclField) xs +p_hsConDeclRecFields :: [LHsConDeclRecField GhcPs] -> R () +p_hsConDeclRecFields xs = + multiLineIfDocumented xs . braces N $ do + when (null xs) $ + getEnclosingSpan >>= mapM_ (locatedEmpty . flip RealSrcSpan Strict.Nothing) + sep commaDel (sitcc . located' p_hsConDeclRecField) xs -p_conDeclField :: ConDeclField GhcPs -> R () -p_conDeclField ConDeclField {..} = do - mapM_ (p_hsDocString Pipe True) cd_fld_doc +p_hsConDeclRecField :: HsConDeclRecField GhcPs -> R () +p_hsConDeclRecField HsConDeclRecField {..} = do + mapM_ (p_hsDocInline Pipe) (cdf_doc cdrf_spec) sitcc $ sep commaDel - (located' (p_rdrName . rdrNameFieldOcc)) - cd_fld_names + (located' (p_rdrName . foLabel)) + cdrf_names space + p_hsMultAnn (located' p_hsType) (cdf_multiplicity cdrf_spec) + space txt "::" breakpoint - sitcc . inci $ p_hsType (unLoc cd_fld_type) + sitcc . inci $ p_hsConDeclField cdrf_spec -tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (Located RdrName) -tyOpTree (L _ (HsOpTy NoExtField l op r)) = - OpBranch (tyOpTree l) op (tyOpTree r) -tyOpTree n = OpNode n +-- | 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_tyOpTree :: OpTree (LHsType GhcPs) (Located RdrName) -> R () -p_tyOpTree (OpNode n) = located n p_hsType -p_tyOpTree (OpBranch l op r) = do - switchLayout [opTreeLoc l] $ - p_tyOpTree l - breakpoint - inci . switchLayout [opTreeLoc r] $ do - p_rdrName op - space - p_tyOpTree r +p_hsConDeclFieldWithDoc :: HsConDeclField GhcPs -> R () +p_hsConDeclFieldWithDoc cdf = do + mapM_ (p_hsDocInline Pipe) (cdf_doc cdf) + p_hsConDeclField cdf p_lhsTypeArg :: LHsTypeArg GhcPs -> R () p_lhsTypeArg = \case - HsValArg ty -> located ty p_hsType - -- first argument is the SrcSpan of the @, - -- but the @ always has to be directly before the type argument + HsValArg NoExtField ty -> located ty p_hsType + -- The first argument is the SrcSpan of the @, but the @ always has to be + -- directly before the type argument. HsTypeArg _ ty -> txt "@" *> located ty p_hsType -- NOTE(amesgen) is this unreachable or just not implemented? HsArgPar _ -> notImplemented "HsArgPar" ----------------------------------------------------------------------------- --- Conversion functions +p_hsSigType :: HsSigType GhcPs -> R () +p_hsSigType HsSig {..} = do + p_hsOuterTyVarBndrs sig_bndrs + case sig_bndrs of + HsOuterImplicit {} -> pure () + HsOuterExplicit {} -> breakpoint + located sig_body p_hsType -tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs] -tyVarsToTypes HsQTvs {..} = fmap tyVarToType <$> hsq_explicit +p_hsForAllTelescope :: HsForAllTelescope GhcPs -> R () +p_hsForAllTelescope = \case + HsForAllInvis _ bndrs -> p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs + HsForAllVis _ bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs -tyVarToType :: HsTyVarBndr () GhcPs -> HsType GhcPs -tyVarToType = \case - UserTyVar NoExtField () tvar -> HsTyVar NoExtField NotPromoted tvar - KindedTyVar NoExtField () tvar kind -> - -- Note: we always add parentheses because for whatever reason GHC does - -- not use HsParTy for left-hand sides of declarations. Please see - -- . This is fine as - -- long as 'tyVarToType' does not get applied to right-hand sides of - -- declarations. - HsParTy NoExtField . noLoc $ - HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind +p_hsOuterTyVarBndrs :: + HsOuterTyVarBndrs Specificity GhcPs -> + R () +p_hsOuterTyVarBndrs = \case + HsOuterImplicit _ -> pure () + HsOuterExplicit _ bndrs -> p_hsForAllTelescope $ mkHsForAllInvisTele noAnn bndrs -tyVarsToTyPats :: LHsQTyVars GhcPs -> HsTyPats GhcPs -tyVarsToTyPats HsQTvs {..} = HsValArg . fmap tyVarToType <$> hsq_explicit +---------------------------------------------------------------------------- +-- Conversion functions + +lhsTypeToSigType :: LHsType GhcPs -> LHsSigType GhcPs +lhsTypeToSigType ty = + L (getLoc ty) . HsSig NoExtField (HsOuterImplicit NoExtField) $ ty 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 @@ -1,179 +1,372 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternSynonyms #-} -- | This module helps handle operator chains composed of different -- operators that may have different precedence and fixities. module Ormolu.Printer.Operators ( OpTree (..), + pattern BinaryOpBranches, + OpInfo (..), opTreeLoc, reassociateOpTree, + isHardSplitterOp, ) where -import Data.Function (on) -import qualified Data.List as L -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, mapMaybe) -import GHC.Types.Basic -import GHC.Types.Name.Occurrence (occNameString) +import Data.Choice (Choice) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import GHC.Parser.Annotation import GHC.Types.Name.Reader import GHC.Types.SrcLoc -import Ormolu.Utils (unSrcSpan) +import Ormolu.Fixity +import Ormolu.Utils --- | Intermediate representation of operator trees. It has two type --- parameters: @ty@ is the type of sub-expressions, while @op@ is the type --- of operators. +-- | Intermediate representation of operator trees, where a branching is not +-- just a binary branching (with a left node, a right node, and an operator, +-- as in the GHC AST), but rather an n-ary branching, with n + 1 nodes and n +-- operators (n >= 1). +-- +-- This representation allows us to put all the operators with the same +-- precedence level as direct siblings in this tree, to better represent the +-- idea of a chain of operators. data OpTree ty op - = OpNode ty - | OpBranch - (OpTree ty op) - op - (OpTree ty op) + = -- | A node which is not an operator application + OpNode ty + | -- | A subtree of operator application(s); the invariant is: @length + -- exprs == length ops + 1@. @OpBranches [x, y, z] [op1, op2]@ + -- represents the expression @x op1 y op2 z@. + OpBranches (NonEmpty (OpTree ty op)) [op] + deriving (Eq, Show) --- | Return combined 'SrcSpan's of all elements in this 'OpTree'. -opTreeLoc :: OpTree (Located a) b -> SrcSpan -opTreeLoc (OpNode (L l _)) = l -opTreeLoc (OpBranch l _ r) = combineSrcSpans (opTreeLoc l) (opTreeLoc r) +pattern BinaryOpBranches :: OpTree ty op -> op -> OpTree ty op -> OpTree ty op +pattern BinaryOpBranches x op y = OpBranches (x :| [y]) [op] --- | Re-associate an 'OpTree' taking into account automagically inferred --- relative precedence of operators. Users are expected to first construct --- an initial 'OpTree', then re-associate it using this function before --- printing. +-- | Wrapper for an operator, carrying information about its name and +-- fixity. +data OpInfo op = OpInfo + { -- | The actual operator + opiOp :: op, + -- | Its name, if available. We use 'Maybe RdrName' here instead of + -- 'RdrName' because the name-fetching function passed to + -- 'reassociateOpTree' returns a 'Maybe' + opiName :: Maybe RdrName, + -- | Information about the fixity direction and precedence level of the + -- operator + opiFixityApproximation :: FixityApproximation + } + deriving (Eq) + +-- | Compare the precedence level of two operators. 'OpInfo' is required +-- (and not just 'FixityInfo') because operator names are used in the case +-- of equality. +compareOp :: OpInfo op -> OpInfo op -> Maybe Ordering +compareOp + (OpInfo _ mName1 FixityApproximation {faMinPrecedence = min1, faMaxPrecedence = max1}) + (OpInfo _ mName2 FixityApproximation {faMinPrecedence = min2, faMaxPrecedence = max2}) = + if + -- Only declare two precedence levels as equal when + -- * either both precedence levels are precise + -- (fiMinPrecedence == fiMaxPrecedence) and match + -- * or when the precedence levels are imprecise but when the + -- operator names match + | min1 == min2 + && max1 == max2 + && (min1 == max1 || sameSymbol) -> + Just EQ + | max1 < min2 -> Just LT + | max2 < min1 -> Just GT + | otherwise -> Nothing + where + sameSymbol = case (mName1, mName2) of + (Just n1, Just n2) -> n1 == n2 + _ -> False + +-- | Return the combined 'SrcSpan's of all elements in this 'OpTree'. +opTreeLoc :: (HasLoc l) => OpTree (GenLocated l a) b -> SrcSpan +opTreeLoc (OpNode n) = getHasLoc n +opTreeLoc (OpBranches exprs _) = + combineSrcSpans' . fmap opTreeLoc $ exprs + +-- | Re-associate an 'OpTree' taking into account the precedence of +-- operators. +-- Users are expected to first construct an initial 'OpTree', then +-- re-associate it using this function before printing. reassociateOpTree :: + -- | Whether to print debug info regarding fixity inference + Choice "debug" -> -- | How to get name of an operator (op -> Maybe RdrName) -> + -- | Fixity Map + ModuleFixityMap -> -- | Original 'OpTree' - OpTree (Located ty) (Located op) -> - -- | Re-associated 'OpTree' - OpTree (Located ty) (Located op) -reassociateOpTree getOpName opTree = - reassociateOpTreeWith - (buildFixityMap getOpName normOpTree) - (getOpName . unLoc) - normOpTree - where - normOpTree = normalizeOpTree opTree + OpTree ty op -> + -- | Re-associated 'OpTree', with added context and info around operators + OpTree ty (OpInfo op) +reassociateOpTree debug getOpName modFixityMap = + reassociateFlatOpTree + . makeFlatOpTree + . addFixityInfo debug modFixityMap getOpName --- | Re-associate an 'OpTree' given the map with operator fixities. -reassociateOpTreeWith :: - forall ty op. +-- | Wrap every operator of the tree with 'OpInfo' to carry the information +-- about its fixity (extracted from the specified fixity map). +addFixityInfo :: + -- | Whether to print debug info regarding fixity inference + Choice "debug" -> -- | Fixity map for operators - Map String Fixity -> + ModuleFixityMap -> -- | How to get the name of an operator (op -> Maybe RdrName) -> - -- | Original 'OpTree' + -- | 'OpTree' OpTree ty op -> - -- | Re-associated 'OpTree' - OpTree ty op -reassociateOpTreeWith fixityMap getOpName = go + -- | 'OpTree', with fixity info wrapped around each operator + OpTree ty (OpInfo op) +addFixityInfo _ _ _ (OpNode n) = OpNode n +addFixityInfo debug modFixityMap getOpName (OpBranches exprs ops) = + OpBranches + (addFixityInfo debug modFixityMap getOpName <$> exprs) + (toOpInfo <$> ops) where - fixityOf :: op -> Fixity - fixityOf op = fromMaybe defaultFixity $ do - s <- occNameString . rdrNameOcc <$> getOpName op - M.lookup s fixityMap - -- Here, left branch is already associated and the root alongside with - -- the right branch is right-associated. This function picks up one item - -- from the right and inserts it correctly to the left. - -- - -- Also, we are using the 'compareFixity' function which tells if the - -- expression should associate to right. - go :: OpTree ty op -> OpTree ty op - -- base cases - go t@(OpNode _) = t - go t@(OpBranch (OpNode _) _ (OpNode _)) = t - -- shift one operator to the left at the beginning - go (OpBranch l@(OpNode _) op (OpBranch l' op' r')) = - go (OpBranch (OpBranch l op l') op' r') - -- at the last operator, place the operator and don't recurse - go (OpBranch (OpBranch l op r) op' r'@(OpNode _)) = - if snd $ compareFixity (fixityOf op) (fixityOf op') - then OpBranch l op (go $ OpBranch r op' r') - else OpBranch (OpBranch l op r) op' r' - -- else, shift one operator to left and recurse. - go (OpBranch (OpBranch l op r) op' (OpBranch l' op'' r')) = - if snd $ compareFixity (fixityOf op) (fixityOf op') - then go $ OpBranch (OpBranch l op (go $ OpBranch r op' l')) op'' r' - else go $ OpBranch (OpBranch (OpBranch l op r) op' l') op'' r' + toOpInfo o = OpInfo o mrdrName fixityApproximation + where + mrdrName = getOpName o + fixityApproximation = case mrdrName of + Nothing -> defaultFixityApproximation + Just rdrName -> inferFixity debug rdrName modFixityMap --- | A score assigned to an operator. -data Score - = -- | The operator was placed at the beginning of a line - AtBeginning Int - | -- | The operator was placed at the end of a line - AtEnd - | -- | The operator was placed in between arguments on a single line - InBetween - deriving (Eq, Ord) +-- | Given an 'OpTree' of any shape, produce a flat 'OpTree' where every +-- node and operator is directly connected to the root. +makeFlatOpTree :: OpTree ty op -> OpTree ty op +makeFlatOpTree (OpNode n) = OpNode n +makeFlatOpTree (OpBranches exprs ops) = + OpBranches rExprs rOps + where + makeFlatOpTree' expr = case makeFlatOpTree expr of + OpNode n -> (NE.singleton (OpNode n), []) + OpBranches noptExprs noptOps -> (noptExprs, noptOps) + flattenedSubTrees = makeFlatOpTree' <$> exprs + rExprs = fst =<< flattenedSubTrees + rOps = concat $ interleave (snd <$> NE.toList flattenedSubTrees) (pure <$> ops) + interleave (x : xs) (y : ys) = x : y : interleave xs ys + interleave [] ys = ys + interleave xs [] = xs --- | Build a map of inferred 'Fixity's from an 'OpTree'. -buildFixityMap :: - forall ty op. - -- | How to get the name of an operator - (op -> Maybe RdrName) -> - -- | Operator tree - OpTree (Located ty) (Located op) -> - -- | Fixity map - Map String Fixity -buildFixityMap getOpName opTree = - addOverrides - . M.fromList - . concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns) - . zip [2 ..] - . L.groupBy ((==) `on` snd) - . selectScores - $ score opTree +-- | Starting from a flat 'OpTree' (i.e. an n-ary tree of depth 1, without +-- regard for operator fixities), build an 'OpTree' with proper sub-trees +-- (according to the fixity info carried by the nodes). +-- +-- We have two complementary ways to build the proper sub-trees: +-- +-- * if we can find a set of operators "minOps" at the current level where +-- forall (op1, op2) \in minOps x minOps, op1 `equal` op2 +-- forall (op1, op2) \in minOps x (opsOfCurrentLevel \ minOps), +-- op1 `lessThan` op2 +-- then we can build a subtree with the exprs and ops located "between" +-- each element of minOps. +-- For example, if minOps = {op0, op2, op5}, +-- and if [...] means "extract a subtree", then +-- currentLevel = +-- [ex0 op0 ex1 op1 ex2 op2 ex3 op3 ex4 op4 ex5 op5 ex6 op6 ex7] +-- will become +-- [ex0 op0 [ex1 op1 ex2] op2 [ex3 op3 ex4 op4 ex5] op5 [ex6 op6 ex7]] +-- * if we can find a set of operators "maxOps" at the current level where +-- forall (op1, op2) \in maxOps x maxOps, op1 `equal` op2 +-- forall (op1, op2) \in maxOps x (opsOfCurrentLevel \ maxOps), +-- op1 `greaterThan` op2 +-- then we can build a subtree with every contiguous range of elements +-- from maxOps (and the exprs on their sides) +-- For example, if maxOps = {op0, op1, op4}, +-- and if [...] means "extract a subtree", then +-- currentLevel = +-- [ex0 op0 ex1 op1 ex2 op2 ex3 op3 ex4 op4 ex5 op5 ex6 op6 ex7] +-- will become +-- [[ex0 op0 ex1 op1 ex2] op2 ex3 op3 [ex4 op4 ex5] op5 ex6 op6 ex7] +-- +-- We also recursively apply the same logic to every sub-tree built during +-- the process. The two principles do not overlap, and both are required, +-- because we are comparing precedence level ranges. In the case where we +-- cannot find a non-empty set {min,max}Ops with one approach or the other, +-- we finally try to split the tree on “hard splitters”, if there are any. +reassociateFlatOpTree :: + -- | Flat 'OpTree', with fixity info wrapped around each operator + OpTree ty (OpInfo op) -> + -- | Re-associated 'OpTree', with fixity info wrapped around each operator + OpTree ty (OpInfo op) +reassociateFlatOpTree tree@(OpNode _) = tree +reassociateFlatOpTree tree@(OpBranches noptExprs noptOps) = + case indexOfMinMaxPrecOps noptOps of + (Just minIndices, _) -> splitTree noptExprs noptOps minIndices + (_, Just maxIndices) -> groupTree noptExprs noptOps maxIndices + _ -> case indicesOfHardSplitter of + [] -> tree + indices -> splitTree noptExprs noptOps indices where - addOverrides :: Map String Fixity -> Map String Fixity - addOverrides m = - M.fromList - [ ("$", fixity 0 InfixR), - (":", fixity 1 InfixR), - (".", fixity 100 InfixL) - ] - `M.union` m - fixity = Fixity NoSourceText - score :: OpTree (Located ty) (Located op) -> [(String, Score)] - score (OpNode _) = [] - score (OpBranch l o r) = fromMaybe (score r) $ do - -- If we fail to get any of these, 'defaultFixity' will be used by - -- 'reassociateOpTreeWith'. - le <- srcSpanEndLine <$> unSrcSpan (opTreeLoc l) -- left end - ob <- srcSpanStartLine <$> unSrcSpan (getLoc o) -- operator begin - oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end - rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin - oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column - opName <- occNameString . rdrNameOcc <$> getOpName (unLoc o) - let s - | le < ob = AtBeginning oc - | oe < rb = AtEnd - | otherwise = InBetween - return $ (opName, s) : score r - selectScores :: [(String, Score)] -> [(String, Score)] - selectScores = - L.sortOn snd - . mapMaybe - ( \case - [] -> Nothing - xs@((n, _) : _) -> Just (n, selectScore $ map snd xs) - ) - . L.groupBy ((==) `on` fst) - . L.sort - selectScore :: [Score] -> Score - selectScore xs = - case filter (/= InBetween) xs of - [] -> InBetween - xs' -> maximum xs' + indicesOfHardSplitter = + 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 + go :: + -- Remaining operators to look up + [OpInfo op] -> + -- Index of the next operator + Int -> + -- representative of the current minOps set, if there is one, + -- or representative of the lowest precedence level encountered + -- so far otherwise + OpInfo op -> + -- indices of the elements of the candidate minOps set, + -- if there is any + Maybe [Int] -> + -- representative of the current maxOps set, if there is one, or + -- representative of the highest precedence level encountered + -- so far otherwise + OpInfo op -> + -- indices of the elements of the candidate maxOps set, + -- if there is any + Maybe [Int] -> + -- (indices of minOps elements, indices of maxOps elements) + (Maybe [Int], Maybe [Int]) + go [] _ _ minRes _ maxRes = (reverse <$> minRes, reverse <$> maxRes) + go (o : os) i minOpi minRes maxOpi maxRes = + let (minOpi', minRes') = case compareOp o minOpi of + Just EQ -> (minOpi, (:) i <$> minRes) + Just LT -> (o, Just [i]) + Just GT -> (minOpi, minRes) + Nothing -> (combine minOpi o, Nothing) + (maxOpi', maxRes') = case compareOp o maxOpi of + Just EQ -> (maxOpi, (:) i <$> maxRes) + Just LT -> (maxOpi, maxRes) + Just GT -> (o, Just [i]) + Nothing -> (combine maxOpi o, Nothing) + -- Merge two potential {min/max}Ops representatives for + -- which the comparison gave 'OpUnknown' into a representative + -- of the {lowest/highest} precedence level encountered so far + combine (OpInfo x _ fix1) (OpInfo _ _ fix2) = + OpInfo x Nothing (fix1 <> fix2) + in go os (i + 1) minOpi' minRes' maxOpi' maxRes' + -- If indices = [0, 2, 5], transform + -- [ex0 op0 ex1 op1 ex2 op2 ex3 op3 ex4 op4 ex5 op5 ex6 op6 ex7] + -- into + -- [ex0 op0 [ex1 op1 ex2] op2 [ex3 op3 ex4 op4 ex5] op5 [ex6 op6 ex7]] + splitTree nExprs nOps indices = go (NE.toList nExprs) nOps indices 0 [] [] [] [] + where + go :: + -- Remaining exprs to look up + [OpTree ty (OpInfo op)] -> + -- Remaining ops to look up + [OpInfo op] -> + -- Remaining list of indices of operators on which to split + -- (sorted) + [Int] -> + -- Index of the next expr/op + Int -> + -- Bag for exprs for the subtree we are building + [OpTree ty (OpInfo op)] -> + -- Bag for ops for the subtree we are building + [OpInfo op] -> + -- Bag for exprs of the result tree + [OpTree ty (OpInfo op)] -> + -- Bag for ops of the result tree + [OpInfo op] -> + -- Result tree + OpTree ty (OpInfo op) + go [] _ _ _ subExprs subOps resExprs resOps = + -- No expr left to process. + -- Because we are in a "splitting" logic, there is at least one + -- expr in the subExprs bag, so we build a subtree (if necessary) + -- from the sub-bags, add the node/subtree to the result bag, and + -- then emit the result tree. + let resExpr = buildFromSub (NE.fromList subExprs) subOps + in OpBranches (NE.reverse (resExpr :| resExprs)) (reverse resOps) + go (x : xs) (o : os) (idx : idxs) i subExprs subOps resExprs resOps + | i == idx = + -- The op we are looking at is one on which we need to split. + -- So we build a subtree from the sub-bags and the current + -- expr, append it to the result exprs, and continue with + -- cleared sub-bags. + let resExpr = buildFromSub (x :| subExprs) subOps + in go xs os idxs (i + 1) [] [] (resExpr : resExprs) (o : resOps) + go (x : xs) ops idxs i subExprs subOps resExprs resOps = + -- Either there is no op left, or the op we are looking at is not + -- one on which we need to split. So we just add both the current + -- expr and the current op (if there is any) to the sub-bags. + let (ops', subOps') = moveOneIfPossible ops subOps + in go xs ops' idxs (i + 1) (x : subExprs) subOps' resExprs resOps ----------------------------------------------------------------------------- --- Helpers + -- If indices = [0, 1, 4], transform + -- [ex0 op0 ex1 op1 ex2 op2 ex3 op3 ex4 op4 ex5 op5 ex6 op6 ex7] + -- into + -- [[ex0 op0 ex1 op1 ex2] op2 ex3 op3 [ex4 op4 ex5] op5 ex6 op6 ex7] + groupTree nExprs nOps indices = go (NE.toList nExprs) nOps indices 0 [] [] [] [] + where + go :: + -- remaining exprs to look up + [OpTree ty (OpInfo op)] -> + -- remaining ops to look up + [OpInfo op] -> + -- remaining list of indices of operators on which to group + -- (sorted) + [Int] -> + -- index of the next expr/op + Int -> + -- bag for exprs for the subtree we are building + [OpTree ty (OpInfo op)] -> + -- bag for ops for the subtree we are building + [OpInfo op] -> + -- bag for exprs of the result tree + [OpTree ty (OpInfo op)] -> + -- bag for ops of the result tree + [OpInfo op] -> + -- result tree + OpTree ty (OpInfo op) + go [] _ _ _ subExprs subOps resExprs resOps = + -- No expr left to process. + -- Because we are in a "grouping" logic, the subExprs bag might be + -- empty. If it is not, we build a subtree (if necessary) from the + -- sub-bags and add the resulting node/subtree to the result bag. + -- In any case, we then emit the result tree. + let resExprs' = case NE.nonEmpty subExprs of + Nothing -> NE.fromList resExprs + Just subExprs' -> buildFromSub subExprs' subOps :| resExprs + in OpBranches (NE.reverse resExprs') (reverse resOps) + go (x : xs) (o : os) (idx : idxs) i subExprs subOps resExprs resOps + | i == idx = + -- The op we are looking at is one on which we need to group. + -- So we just add the current expr and op to the sub-bags. + go xs os idxs (i + 1) (x : subExprs) (o : subOps) resExprs resOps + go (x : xs) ops idxs i subExprs@(_ : _) subOps resExprs resOps = + -- Either there is no op left, or the op we are looking at is not + -- one on which we need to split, but in any case the sub-bags are + -- not empty. So we finalize the started group using sub-bags and + -- the current expr, to form a subtree which is then added to the + -- result bag. + let (ops', resOps') = moveOneIfPossible ops resOps + resExpr = buildFromSub (x :| subExprs) subOps + in go xs ops' idxs (i + 1) [] [] (resExpr : resExprs) resOps' + go (x : xs) ops idxs i [] subOps resExprs resOps = + -- Either there is no op left, or the op we are looking at is not + -- one on which we need to split, but the sub-bags are empty. So + -- we just add both the current expr and the current op (if there + -- is any) to the result bags. + let (ops', resOps') = moveOneIfPossible ops resOps + in go xs ops' idxs (i + 1) [] subOps (x : resExprs) resOps' --- | Convert an 'OpTree' to with all operators having the same fixity and --- associativity (left infix). -normalizeOpTree :: OpTree ty op -> OpTree ty op -normalizeOpTree (OpNode n) = - OpNode n -normalizeOpTree (OpBranch (OpNode l) lop r) = - OpBranch (OpNode l) lop (normalizeOpTree r) -normalizeOpTree (OpBranch (OpBranch l' lop' r') lop r) = - normalizeOpTree (OpBranch l' lop' (OpBranch r' lop r)) + moveOneIfPossible [] bs = ([], bs) + moveOneIfPossible (a : as) bs = (as, a : bs) + + buildFromSub subExprs subOps = reassociateFlatOpTree $ case subExprs of + -- Do not build a subtree when the potential subtree would have + -- 1 expr(s) and 0 op(s) + x :| [] -> x + _ -> OpBranches (NE.reverse subExprs) (reverse subOps) + +-- | Indicate whether an operator has @'InfixR' 0@ fixity. We special-case +-- this class of operators because, like ('$'), they often have a specific +-- “separator” use case, and we sometimes format them differently from other +-- operators. +isHardSplitterOp :: FixityApproximation -> Bool +isHardSplitterOp = (== FixityApproximation (Just InfixR) 0 0) diff --git a/src/Ormolu/Printer/SpanStream.hs b/src/Ormolu/Printer/SpanStream.hs deleted file mode 100644 --- a/src/Ormolu/Printer/SpanStream.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | Build span stream from AST. -module Ormolu.Printer.SpanStream - ( SpanStream (..), - mkSpanStream, - ) -where - -import Data.DList (DList) -import qualified Data.DList as D -import Data.Data (Data) -import Data.Generics (everything, ext2Q) -import Data.List (sortOn) -import Data.Typeable (cast) -import GHC.Types.SrcLoc - --- | A stream of 'RealSrcSpan's in ascending order. This allows us to tell --- e.g. whether there is another \"located\" element of AST between current --- element and comment we're considering for printing. -newtype SpanStream = SpanStream [RealSrcSpan] - deriving (Eq, Show, Data, Semigroup, Monoid) - --- | Create 'SpanStream' from a data structure containing \"located\" --- elements. -mkSpanStream :: - Data a => - -- | Data structure to inspect (AST) - a -> - SpanStream -mkSpanStream a = - SpanStream - . sortOn realSrcSpanStart - . D.toList - $ everything mappend (const mempty `ext2Q` queryLocated) a - where - queryLocated :: - (Data e0) => - GenLocated e0 e1 -> - DList RealSrcSpan - queryLocated (L mspn _) = - case cast mspn :: Maybe SrcSpan of - Nothing -> mempty - Just (UnhelpfulSpan _) -> mempty - Just (RealSrcSpan spn _) -> D.singleton spn diff --git a/src/Ormolu/Processing/Common.hs b/src/Ormolu/Processing/Common.hs --- a/src/Ormolu/Processing/Common.hs +++ b/src/Ormolu/Processing/Common.hs @@ -1,27 +1,57 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} --- | Common definitions for pre- and post- processing. +-- | Common definitions for pre- and post-processing. module Ormolu.Processing.Common - ( OrmoluState (..), - startDisabling, - endDisabling, + ( removeIndentation, + reindent, + linesInRegion, + intSetToRegions, ) where -import Data.String (IsString (..)) +import Data.Char (isSpace) +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet +import Data.Text (Text) +import Data.Text qualified as T +import Ormolu.Config --- | Ormolu state. -data OrmoluState - = -- | Enabled - OrmoluEnabled - | -- | Disabled - OrmoluDisabled - deriving (Eq, Show) +-- | Remove indentation from a given 'Text'. Return the input with indentation +-- removed and the detected indentation level. +removeIndentation :: Text -> (Text, Int) +removeIndentation (T.lines -> xs) = (T.unlines (T.drop n <$> xs), n) + where + n = minimum (getIndent <$> xs) + getIndent y = + if T.all isSpace y + then 0 + else T.length (T.takeWhile isSpace y) --- | Marker for the beginning of the region where Ormolu should be disabled. -startDisabling :: IsString s => s -startDisabling = "{- ORMOLU_DISABLE_START" +-- | Add indentation to a 'Text'. +reindent :: Int -> Text -> Text +reindent i = T.unlines . fmap (T.replicate i " " <>) . T.lines --- | Marker for the end of the region where Ormolu should be disabled. -endDisabling :: IsString s => s -endDisabling = "ORMOLU_DISABLE_END -}" +-- | All lines in the region specified by 'RegionDeltas'. +linesInRegion :: RegionDeltas -> Text -> Text +linesInRegion RegionDeltas {..} (T.lines -> ls) = T.unlines middle + where + (_, nonPrefix) = splitAt regionPrefixLength ls + middle = take (length nonPrefix - regionSuffixLength) nonPrefix + +-- | Convert a set of line indices into disjoint 'RegionDeltas'. +intSetToRegions :: + -- | Total number of lines + Int -> + IntSet -> + [RegionDeltas] +intSetToRegions total (IntSet.toAscList -> indices) = + regionIndicesToDeltas total <$> go Nothing indices + where + go Nothing [] = [] + go (Just (a, b)) [] = [RegionIndices (Just a) (Just b)] + go Nothing (i : is) = go (Just (i, i)) is + go (Just (a, b)) (i : is) + | b + 1 == i = go (Just (a, i)) is + | otherwise = RegionIndices (Just a) (Just b) : go (Just (i, i)) is diff --git a/src/Ormolu/Processing/Cpp.hs b/src/Ormolu/Processing/Cpp.hs --- a/src/Ormolu/Processing/Cpp.hs +++ b/src/Ormolu/Processing/Cpp.hs @@ -2,69 +2,73 @@ -- | Support for CPP. module Ormolu.Processing.Cpp - ( State (..), - processLine, - unmaskLine, + ( cppLines, + eraseCppLines, ) where -import Control.Monad -import Data.Char (isSpace) -import qualified Data.List as L +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet import Data.Maybe (isJust) -import Data.String import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T -- | State of the CPP processor. data State = -- | Outside of CPP directives Outside - | -- | In a conditional expression - InConditional - | -- | In a continuation (after @\\@) + | -- | In a conditional expression, with a positive nesting count + InConditional Int + | -- | In a continuation (after @\\@), but not in a conditional expression InContinuation deriving (Eq, Show) --- | Automatically mask the line when needed and update the 'State'. -processLine :: String -> State -> (String, State) -processLine line state - | for "define " = (masked, state') - | for "include " = (masked, state') - | for "undef " = (masked, state') - | for "ifdef " = (masked, InConditional) - | for "ifndef " = (masked, InConditional) - | for "if " = (masked, InConditional) - | for "else" = (masked, InConditional) - | for "elif" = (masked, InConditional) - | for "endif" = (masked, state') - | otherwise = - case state of - Outside -> (line, Outside) - InConditional -> (masked, InConditional) - InContinuation -> (masked, state') +-- | Return an 'IntSet' containing all lines which are affected by CPP. +cppLines :: Text -> IntSet +cppLines input = IntSet.fromAscList $ go Outside (T.lines input `zip` [1 ..]) where - for directive = isJust $ do - s <- dropWhile isSpace <$> L.stripPrefix "#" line - void (L.stripPrefix directive s) - masked = maskLine line - state' = - if "\\" `L.isSuffixOf` line - then InContinuation - else Outside - --- | Mask the given line. -maskLine :: String -> String -maskLine x = maskPrefix ++ x - --- | If the given line is masked, unmask it. Otherwise return the line --- unchanged. -unmaskLine :: Text -> Text -unmaskLine x = - case T.stripPrefix maskPrefix (T.stripStart x) of - Nothing -> x - Just x' -> x' + go _ [] = [] + go state ((line, i) : ls) + | any for ["define ", "include ", "undef "] = + i : go contState ls + | any for ["ifdef ", "ifndef ", "if "] = + let state' = case state of + InConditional nc -> InConditional (nc + 1) + _ -> InConditional 1 + in i : go state' ls + | for "endif" = + let state' = case state of + InConditional nc | nc > 1 -> InConditional (nc - 1) + _ -> Outside + in i : go state' ls + | otherwise = + let is = case state of + Outside -> [] + _ -> [i] + state' = case state of + InContinuation -> contState + _ -> state + in is <> go state' ls + where + for directive = isJust $ do + s <- T.stripStart <$> T.stripPrefix "#" line + T.stripPrefix directive s + contState = + if "\\" `T.isSuffixOf` line && not inConditional + then InContinuation + else Outside + where + inConditional = case state of + InConditional {} -> True + _ -> False --- | Mask prefix for CPP. -maskPrefix :: IsString s => s -maskPrefix = "-- ORMOLU_CPP_MASK" +-- | Replace all lines affected by CPP with blank lines. +eraseCppLines :: Text -> Text +eraseCppLines input = + T.unlines . fmap eraseCpp $ T.lines input `zip` [1 ..] + where + linesToErase = cppLines input + eraseCpp (x, i) = + if i `IntSet.member` linesToErase + then "\n" + else x diff --git a/src/Ormolu/Processing/Postprocess.hs b/src/Ormolu/Processing/Postprocess.hs deleted file mode 100644 --- a/src/Ormolu/Processing/Postprocess.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - --- | Postprocessing for the results of printing. -module Ormolu.Processing.Postprocess - ( postprocess, - ) -where - -import Data.Text (Text) -import qualified Data.Text as T -import Ormolu.Processing.Common -import qualified Ormolu.Processing.Cpp as Cpp - --- | Postprocess output of the formatter. -postprocess :: - -- | Desired indentation level - Int -> - -- | Input to process - Text -> - Text -postprocess indent = - T.unlines - . fmap indentLine - . fmap Cpp.unmaskLine - . filter (not . magicComment) - . T.lines - where - magicComment (T.stripStart -> x) = - x == startDisabling || x == endDisabling - indentLine x = T.replicate indent " " <> x 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,5 +1,6 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | Preprocessing for input source code. @@ -9,141 +10,174 @@ where import Control.Monad +import Data.Array as A +import Data.Bifunctor (bimap) import Data.Char (isSpace) -import qualified Data.List as L -import Data.Maybe (isJust, maybeToList) -import GHC.Data.FastString -import GHC.Types.SrcLoc +import Data.Choice (Choice) +import Data.Choice qualified as Choice +import Data.Function ((&)) +import Data.IntMap (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet +import Data.List qualified as L +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Text qualified as T import Ormolu.Config (RegionDeltas (..)) -import Ormolu.Parser.Shebang (isShebang) import Ormolu.Processing.Common -import qualified Ormolu.Processing.Cpp as Cpp +import Ormolu.Processing.Cpp --- | Transform given input possibly returning comments extracted from it. --- This handles LINE pragmas, CPP, shebangs, and the magic comments for --- enabling\/disabling of Ormolu. +-- | Preprocess the specified region of the input into raw snippets +-- and subregions to be formatted. preprocess :: - -- | File name, just to use in the spans - FilePath -> - -- | Input to process - String -> - -- | Region deltas + -- | Whether CPP is enabled + Choice "cppEnabled" -> RegionDeltas -> - -- | Literal prefix, pre-processed input, literal suffix, extra comments - (String, String, String, [RealLocated String]) -preprocess path input RegionDeltas {..} = - go 1 OrmoluEnabled Cpp.Outside id id regionLines + Text -> + [Either Text RegionDeltas] +preprocess cppEnabled region rawInput = rawSnippetsAndRegionsToFormat where - (prefixLines, otherLines) = splitAt regionPrefixLength (lines input) - (regionLines, suffixLines) = - let regionLength = length otherLines - regionSuffixLength - in splitAt regionLength otherLines - go !n ormoluState cppState inputSoFar csSoFar = \case - [] -> - let input' = unlines (inputSoFar []) - in ( unlines prefixLines, - case ormoluState of - OrmoluEnabled -> input' - OrmoluDisabled -> input' ++ endDisabling, - unlines suffixLines, - csSoFar [] - ) - (x : xs) -> - let (x', ormoluState', cppState', cs) = - processLine path n ormoluState cppState x - in go - (n + 1) - ormoluState' - cppState' - (inputSoFar . (x' :)) - (csSoFar . (maybeToList cs ++)) - xs + (linesNotToFormat', replacementLines) = + linesNotToFormat cppEnabled region rawInput + regionsToFormat = + intSetToRegions rawLineLength $ + IntSet.fromAscList [1 .. rawLineLength] IntSet.\\ linesNotToFormat' + regionsNotToFormat = intSetToRegions rawLineLength linesNotToFormat' + -- We want to interleave the regionsToFormat and regionsNotToFormat. + -- If the first non-formattable region starts at the first line, it is + -- the first interleaved region, otherwise, we start with the first + -- region to format. + interleave' = case regionsNotToFormat of + r : _ | regionPrefixLength r == 0 -> interleave + _ -> flip interleave + rawSnippets = flip linesInRegion updatedInput <$> regionsNotToFormat + where + updatedInput = T.unlines . fmap updateLine . zip [1 ..] . T.lines $ rawInput + updateLine (i, line) = IntMap.findWithDefault line i replacementLines + rawSnippetsAndRegionsToFormat = + interleave' (Left <$> rawSnippets) (Right <$> regionsToFormat) + >>= patchSeparatingBlankLines + & dropWhile isBlankRawSnippet + & L.dropWhileEnd isBlankRawSnippet + -- For every formattable region, we want to ensure that it is separated by + -- a blank line from the preceding/succeeding raw snippets if it + -- starts/ends with a blank line. + -- Empty formattable regions are replaced by a blank line instead. + -- Extraneous raw snippets at the start/end are dropped afterwards. + patchSeparatingBlankLines = \case + Right r@RegionDeltas {..} -> + if T.all isSpace (linesInRegion r rawInput) + then [blankRawSnippet] + else + [blankRawSnippet | isBlankLine regionPrefixLength] + <> [Right r] + <> [blankRawSnippet | isBlankLine (rawLineLength - regionSuffixLength - 1)] + Left r -> [Left r] + where + blankRawSnippet = Left "\n" + isBlankLine i = isJust . mfilter (T.all isSpace) $ rawLines !!? i + isBlankRawSnippet = \case + Left r | T.all isSpace r -> True + _ -> False --- | Transform a given line possibly returning a comment extracted from it. -processLine :: - -- | File name, just to use in the spans - FilePath -> - -- | Line number of this line - Int -> - -- | Whether Ormolu is currently enabled - OrmoluState -> - -- | CPP state - Cpp.State -> - -- | The actual line - String -> - -- | Adjusted line and possibly a comment extracted from it - (String, OrmoluState, Cpp.State, Maybe (RealLocated String)) -processLine path n ormoluState Cpp.Outside line - | "{-# LINE" `L.isPrefixOf` line = - let (pragma, res) = getPragma line - size = length pragma - ss = mkRealSrcSpan (mkRealSrcLoc' 1) (mkRealSrcLoc' (size + 1)) - in (res, ormoluState, Cpp.Outside, Just (L ss pragma)) - | isOrmoluEnable line = - case ormoluState of - OrmoluEnabled -> - (enableMarker, OrmoluEnabled, Cpp.Outside, Nothing) - OrmoluDisabled -> - (endDisabling ++ enableMarker, OrmoluEnabled, Cpp.Outside, Nothing) - | isOrmoluDisable line = - case ormoluState of - OrmoluEnabled -> - (disableMarker ++ startDisabling, OrmoluDisabled, Cpp.Outside, Nothing) - OrmoluDisabled -> - (disableMarker, OrmoluDisabled, Cpp.Outside, Nothing) - | isShebang line = - let ss = mkRealSrcSpan (mkRealSrcLoc' 1) (mkRealSrcLoc' (length line)) - in ("", ormoluState, Cpp.Outside, Just (L ss line)) - | otherwise = - let (line', cppState') = Cpp.processLine line Cpp.Outside - in (line', ormoluState, cppState', Nothing) + rawLines = A.listArray (0, length rawLines' - 1) rawLines' + where + rawLines' = T.lines rawInput + rawLineLength = length rawLines + + interleave [] bs = bs + interleave (a : as) bs = a : interleave bs as + + xs !!? i = if A.bounds xs `A.inRange` i then Just $ xs A.! i else Nothing + +-- | All lines we are not supposed to format, and a set of replacements +-- for specific lines. +linesNotToFormat :: + -- | Whether CPP is enabled + Choice "cppEnabled" -> + RegionDeltas -> + Text -> + (IntSet, IntMap Text) +linesNotToFormat cppEnabled region@RegionDeltas {..} input = + (unconsidered <> magicDisabled <> otherDisabled, lineUpdates) where - mkRealSrcLoc' = mkRealSrcLoc (mkFastString path) n -processLine _ _ ormoluState cppState line = - let (line', cppState') = Cpp.processLine line cppState - in (line', ormoluState, cppState', Nothing) + unconsidered = + IntSet.fromAscList $ + [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 | Choice.isTrue cppEnabled] --- | Take a line pragma and output its replacement (where line pragma is --- replaced with spaces) and the contents of the pragma itself. -getPragma :: - -- | Pragma line to analyze - String -> - -- | Contents of the pragma and its replacement line - (String, String) -getPragma [] = error "Ormolu.Preprocess.getPragma: input must not be empty" -getPragma s@(x : xs) - | "#-}" `L.isPrefixOf` s = ("#-}", " " ++ drop 3 s) - | otherwise = - let (prag, remline) = getPragma xs - in (x : prag, ' ' : remline) +-- | Ormolu state. +data OrmoluState + = -- | Enabled + OrmoluEnabled + | -- | Disabled + OrmoluDisabled + deriving (Eq, Show) --- | Canonical enable marker. -enableMarker :: String -enableMarker = "{- ORMOLU_ENABLE -}" +-- | All lines which are disabled by Ormolu's magic comments, +-- as well as normalizing replacements. +magicDisabledLines :: Text -> (IntSet, IntMap Text) +magicDisabledLines input = + bimap IntSet.fromAscList IntMap.fromAscList . mconcat $ + go OrmoluEnabled (T.lines input `zip` [1 ..]) + where + go _ [] = [] + go state ((line, i) : ls) + | Just rest <- isMagicComment ormoluDisable line, + state == OrmoluEnabled = + ([i], [(i, magicComment ormoluDisable <> rest)]) : go OrmoluDisabled ls + | Just rest <- isMagicComment ormoluEnable line, + state == OrmoluDisabled = + ([i], [(i, magicComment ormoluEnable <> rest)]) : go OrmoluEnabled ls + | otherwise = iIfDisabled : go state ls + where + iIfDisabled = case state of + OrmoluDisabled -> ([i], []) + OrmoluEnabled -> ([], []) --- | Canonical disable marker. -disableMarker :: String -disableMarker = "{- ORMOLU_DISABLE -}" +-- | All lines which satisfy a predicate. +linesFiltered :: (Text -> Bool) -> Text -> IntSet +linesFiltered p = + IntSet.fromAscList . fmap snd . filter (p . fst) . (`zip` [1 ..]) . T.lines --- | Return 'True' if the given string is an enabling marker. -isOrmoluEnable :: String -> Bool -isOrmoluEnable = magicComment "ORMOLU_ENABLE" +-- | Lines which contain a shebang. +shebangLines :: Text -> IntSet +shebangLines = linesFiltered ("#!" `T.isPrefixOf`) --- | Return 'True' if the given string is a disabling marker. -isOrmoluDisable :: String -> Bool -isOrmoluDisable = magicComment "ORMOLU_DISABLE" +-- | Lines which contain a LINE pragma. +linePragmaLines :: Text -> IntSet +linePragmaLines = linesFiltered ("{-# LINE" `T.isPrefixOf`) --- | Construct a function for whitespace-insensitive matching of string. -magicComment :: +-- | Inner text of a magic enabling marker. +ormoluEnable :: Text +ormoluEnable = "ORMOLU_ENABLE" + +-- | Inner text of a magic disabling marker. +ormoluDisable :: Text +ormoluDisable = "ORMOLU_DISABLE" + +-- | Create a magic comment with the given inner text. +magicComment :: Text -> Text +magicComment t = "{- " <> t <> " -}" + +-- | Construct a function for whitespace-insensitive matching of a string. +isMagicComment :: -- | What to expect - String -> + Text -> -- | String to test - String -> - -- | Whether or not the two strings watch - Bool -magicComment expected s0 = isJust $ do - let trim = dropWhile isSpace - s1 <- trim <$> L.stripPrefix "{-" (trim s0) - s2 <- trim <$> L.stripPrefix expected s1 - s3 <- L.stripPrefix "-}" s2 - guard (all isSpace s3) + Text -> + -- | If the two strings match, we return the rest of the line. + Maybe Text +isMagicComment expected s0 = do + s1 <- T.stripStart <$> T.stripPrefix "{-" (T.stripStart s0) + s2 <- T.stripStart <$> T.stripPrefix expected s1 + T.stripPrefix "-}" s2 diff --git a/src/Ormolu/Terminal.hs b/src/Ormolu/Terminal.hs --- a/src/Ormolu/Terminal.hs +++ b/src/Ormolu/Terminal.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} --- | An abstraction for colorful output in terminal. +-- | An abstraction for colorful output in the terminal. module Ormolu.Terminal - ( -- * The 'Term' monad + ( -- * The 'Term' abstraction Term, ColorMode (..), runTerm, + runTermPure, -- * Styling bold, @@ -17,109 +17,114 @@ -- * Printing put, - putS, - putSrcSpan, + putShow, + putOutputable, newline, ) where -import Control.Monad.Reader +import Control.Applicative (Const (..)) +import Control.Monad (forM_) +import Data.Foldable (toList) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq import Data.Text (Text) -import qualified Data.Text.IO as T -import GHC.Types.SrcLoc +import Data.Text qualified as T +import Data.Text.IO.Utf8 qualified as T.Utf8 +import GHC.Utils.Outputable (Outputable) import Ormolu.Utils (showOutputable) import System.Console.ANSI -import System.IO (Handle, hFlush, hPutStr) +import System.IO (Handle, hFlush) ---------------------------------------------------------------------------- --- The 'Term' monad +-- The 'Term' abstraction --- | Terminal monad. -newtype Term a = Term (ReaderT RC IO a) - deriving (Functor, Applicative, Monad) +type Term = TermOutput () --- | Reader context of 'Term'. -data RC = RC - { -- | Whether to use colors - rcUseColor :: Bool, - -- | Handle to print to - rcHandle :: Handle - } +newtype TermOutput a = TermOutput (Const (Seq TermOutputNode) a) + deriving (Semigroup, Monoid, Functor, Applicative) +data TermOutputNode + = OutputText Text + | WithColor Color Term + | WithBold Term + +singleTerm :: TermOutputNode -> Term +singleTerm = TermOutput . Const . Seq.singleton + -- | Whether to use colors and other features of ANSI terminals. data ColorMode = Never | Always | Auto deriving (Eq, Show) --- | Run 'Term' monad. +-- | Run the 'Term' monad. runTerm :: - -- | Monad to run - Term a -> + Term -> -- | Color mode ColorMode -> -- | Handle to print to Handle -> - IO a -runTerm (Term m) colorMode rcHandle = do - rcUseColor <- case colorMode of + IO () +runTerm term0 colorMode handle = do + useSGR <- case colorMode of Never -> return False Always -> return True - Auto -> hSupportsANSI rcHandle - x <- runReaderT m RC {..} - hFlush rcHandle - return x + Auto -> hSupportsANSI handle + runTerm' useSGR term0 + hFlush handle + where + runTerm' useSGR = go + where + go (TermOutput (Const nodes)) = + forM_ nodes $ \case + OutputText s -> T.Utf8.hPutStr handle s + WithColor color term -> withSGR [SetColor Foreground Dull color] (go term) + WithBold term -> withSGR [SetConsoleIntensity BoldIntensity] (go term) + withSGR sgrs m + | useSGR = hSetSGR handle sgrs >> m >> hSetSGR handle [Reset] + | otherwise = m + +runTermPure :: Term -> Text +runTermPure (TermOutput (Const nodes)) = + T.concat . toList . flip fmap nodes $ \case + OutputText s -> s + WithColor _ term -> runTermPure term + WithBold term -> runTermPure term + ---------------------------------------------------------------------------- -- Styling --- | Make the inner computation output bold text. -bold :: Term a -> Term a -bold = withSGR [SetConsoleIntensity BoldIntensity] - --- | Make the inner computation output cyan text. -cyan :: Term a -> Term a -cyan = withSGR [SetColor Foreground Dull Cyan] +-- | Make the output bold text. +bold :: Term -> Term +bold = singleTerm . WithBold --- | Make the inner computation output green text. -green :: Term a -> Term a -green = withSGR [SetColor Foreground Dull Green] +-- | Make the output cyan text. +cyan :: Term -> Term +cyan = singleTerm . WithColor Cyan --- | Make the inner computation output red text. -red :: Term a -> Term a -red = withSGR [SetColor Foreground Dull Red] +-- | Make the output green text. +green :: Term -> Term +green = singleTerm . WithColor Green --- | Alter 'SGR' for inner computation. -withSGR :: [SGR] -> Term a -> Term a -withSGR sgrs (Term m) = Term $ do - RC {..} <- ask - if rcUseColor - then do - liftIO $ hSetSGR rcHandle sgrs - x <- m - liftIO $ hSetSGR rcHandle [Reset] - return x - else m +-- | Make the output red text. +red :: Term -> Term +red = singleTerm . WithColor Red ---------------------------------------------------------------------------- -- Printing -- | Output 'Text'. -put :: Text -> Term () -put txt = Term $ do - RC {..} <- ask - liftIO $ T.hPutStr rcHandle txt +put :: Text -> Term +put = singleTerm . OutputText --- | Output 'String'. -putS :: String -> Term () -putS str = Term $ do - RC {..} <- ask - liftIO $ hPutStr rcHandle str +-- | Output a 'Show' value. +putShow :: (Show a) => a -> Term +putShow = put . T.pack . show --- | Output a 'GHC.SrcSpan'. -putSrcSpan :: SrcSpan -> Term () -putSrcSpan = putS . showOutputable +-- | Output an 'Outputable' value. +putOutputable :: (Outputable a) => a -> Term +putOutputable = put . T.pack . showOutputable -- | Output a newline. -newline :: Term () -newline = Term $ do - RC {..} <- ask - liftIO $ T.hPutStr rcHandle "\n" +newline :: Term +newline = put "\n" diff --git a/src/Ormolu/Terminal/QualifiedDo.hs b/src/Ormolu/Terminal/QualifiedDo.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Terminal/QualifiedDo.hs @@ -0,0 +1,7 @@ +module Ormolu.Terminal.QualifiedDo ((>>)) where + +import Ormolu.Terminal +import Prelude hiding ((>>)) + +(>>) :: Term -> Term -> Term +(>>) = (<>) diff --git a/src/Ormolu/Utils.hs b/src/Ormolu/Utils.hs --- a/src/Ormolu/Utils.hs +++ b/src/Ormolu/Utils.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -- | Random utilities used by the code. module Ormolu.Utils @@ -9,27 +8,39 @@ combineSrcSpans', notImplemented, showOutputable, + containsHaddocks, splitDocString, - unSrcSpan, incSpanLine, separatedByBlank, separatedByBlankNE, onTheSameLine, - removeIndentation, + textToStringBuffer, + ghcModuleNameToCabal, ) where -import Data.Char (isSpace) +import Data.Data (Data) +import Data.Generics.Schemes (listify) import Data.List (dropWhileEnd) import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T +import Data.Text.Foreign qualified as TFFI +import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName qualified as ModuleName +import Foreign (pokeElemOff, withForeignPtr) +import GHC.Data.Strict qualified as Strict +import GHC.Data.StringBuffer (StringBuffer (..)) +import GHC.Driver.Ppr import GHC.DynFlags (baseDynFlags) -import GHC.Hs +import GHC.ForeignPtr (mallocPlainForeignPtrBytes) +import GHC.Hs hiding (ModuleName) +import GHC.IO.Unsafe (unsafePerformIO) import GHC.Types.SrcLoc -import qualified GHC.Utils.Outputable as GHC +import GHC.Utils.Outputable (Outputable (..)) +import Language.Haskell.Syntax.Module.Name qualified as GHC -- | Relative positions in a list. data RelativePos @@ -39,7 +50,7 @@ | LastPos deriving (Eq, Show) --- | Attach 'RelativePos'es to elements of a given list. +-- | Attach 'RelativePos'es to the elements of the given list. attachRelativePos :: [a] -> [(RelativePos, a)] attachRelativePos = \case [] -> [] @@ -58,10 +69,20 @@ notImplemented :: String -> a notImplemented msg = error $ "not implemented yet: " ++ msg --- | Pretty-print an 'GHC.Outputable' thing. -showOutputable :: GHC.Outputable o => o -> String -showOutputable = GHC.showSDoc baseDynFlags . GHC.ppr +-- | Pretty-print a 'GHC.Outputable' thing. +showOutputable :: (Outputable o) => o -> String +showOutputable = showSDoc baseDynFlags . ppr +-- | Does this fragment of the syntax tree carry a Haddock anywhere inside +-- it? +-- +-- Unlike the span of a Haddock, which sits wherever the author wrote it, +-- this answers the question the printer actually has: will rendering this +-- fragment emit documentation? +containsHaddocks :: (Data a) => a -> Bool +containsHaddocks = + not . null . listify (const True :: HsDocString -> Bool) + -- | Split and normalize a doc string. The result is a list of lines that -- make up the comment. splitDocString :: HsDocString -> [Text] @@ -76,9 +97,9 @@ . dropWhileEnd T.null . fmap (T.stripEnd . T.pack) . lines - $ unpackHDS docStr - -- We cannot have the first character to be a dollar because in that - -- case it'll be a parse error (apparently collides with named docs + $ renderHsDocString docStr + -- We cannot let the first character be a dollar, because in that case + -- it would be a parse error (apparently it collides with the named docs -- syntax @-- $name@ somehow). escapeLeadingDollar txt = case T.uncons txt of @@ -99,13 +120,7 @@ then dropSpace <$> xs else xs --- | Get 'RealSrcSpan' out of 'SrcSpan' if the span is “helpful”. -unSrcSpan :: SrcSpan -> Maybe RealSrcSpan -unSrcSpan = \case - RealSrcSpan r _ -> Just r - UnhelpfulSpan _ -> Nothing - --- | Increment line number in a 'SrcSpan'. +-- | Increment the line number in a 'SrcSpan'. incSpanLine :: Int -> SrcSpan -> SrcSpan incSpanLine i = \case RealSrcSpan s _ -> @@ -116,33 +131,41 @@ line = srcLocLine x col = srcLocCol x in mkRealSrcLoc file (line + i) col - in RealSrcSpan (mkRealSrcSpan (incLine start) (incLine end)) Nothing + in RealSrcSpan (mkRealSrcSpan (incLine start) (incLine end)) Strict.Nothing UnhelpfulSpan x -> UnhelpfulSpan x -- | Do two declarations have a blank between them? separatedByBlank :: (a -> SrcSpan) -> a -> a -> Bool separatedByBlank loc a b = fromMaybe False $ do - endA <- srcSpanEndLine <$> unSrcSpan (loc a) - startB <- srcSpanStartLine <$> unSrcSpan (loc b) + endA <- srcSpanEndLine <$> srcSpanToRealSrcSpan (loc a) + startB <- srcSpanStartLine <$> srcSpanToRealSrcSpan (loc b) pure (startB - endA >= 2) -- | Do two declaration groups have a blank between them? separatedByBlankNE :: (a -> SrcSpan) -> NonEmpty a -> NonEmpty a -> Bool separatedByBlankNE loc a b = separatedByBlank loc (NE.last a) (NE.head b) --- | Return 'True' if one span ends on the same line the second one starts. +-- | Return 'True' if one span ends on the same line where the second one +-- starts. onTheSameLine :: SrcSpan -> SrcSpan -> Bool onTheSameLine a b = isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b)) --- | Remove indentation from a given 'String'. Return the input with --- indentation removed and the detected indentation level. -removeIndentation :: String -> (String, Int) -removeIndentation (lines -> xs) = (unlines (drop n <$> xs), n) +-- | Convert 'Text' to a 'StringBuffer' by making a copy. +textToStringBuffer :: Text -> StringBuffer +textToStringBuffer txt = unsafePerformIO $ do + buf <- mallocPlainForeignPtrBytes (len + 3) + withForeignPtr buf $ \ptr -> do + TFFI.unsafeCopyToPtr txt ptr + -- The last three bytes have to be zero for easier decoding. + pokeElemOff ptr len 0 + pokeElemOff ptr (len + 1) 0 + pokeElemOff ptr (len + 2) 0 + pure StringBuffer {buf, len, cur = 0} where - n = minimum (getIndent <$> xs) - getIndent y = - if all isSpace y - then 0 - else length (takeWhile isSpace y) + len = TFFI.lengthWord8 txt + +-- | Convert GHC's 'ModuleName' into the one used by Cabal. +ghcModuleNameToCabal :: GHC.ModuleName -> ModuleName +ghcModuleNameToCabal = ModuleName.fromString . GHC.moduleNameString diff --git a/src/Ormolu/Utils/Cabal.hs b/src/Ormolu/Utils/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Utils/Cabal.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Ormolu.Utils.Cabal + ( CabalSearchResult (..), + CabalInfo (..), + Extension (..), + getCabalInfoForSourceFile, + findCabalFile, + parseCabalInfo, + ) +where + +import Control.Exception +import Control.Monad.IO.Class +import Data.ByteString qualified as B +import Data.Map.Lazy (Map) +import Data.Map.Lazy qualified as M +import Data.Maybe (maybeToList) +import Data.Set (Set) +import Data.Set qualified as Set +import Distribution.ModuleName qualified as ModuleName +import Distribution.PackageDescription +import Distribution.PackageDescription.Parsec +import Distribution.Types.CondTree qualified as CT +import Distribution.Utils.Path (getSymbolicPath) +import Language.Haskell.Extension +import Ormolu.Config +import Ormolu.Exception +import Ormolu.Fixity +import Ormolu.Utils.IO (Cache, findClosestFileSatisfying, newCache, withCache) +import System.Directory +import System.FilePath +import System.IO.Unsafe (unsafePerformIO) + +-- | The result of searching for a @.cabal@ file. +-- +-- @since 0.5.3.0 +data CabalSearchResult + = -- | Cabal file could not be found + CabalNotFound + | -- | Cabal file was found, but it did not mention the source file in + -- question + CabalDidNotMention CabalInfo + | -- | Cabal file was found and it mentions the source file in question + CabalFound CabalInfo + deriving (Eq, Show) + +-- | Cabal information of interest to Ormolu. +data CabalInfo = CabalInfo + { -- | Package name + ciPackageName :: !PackageName, + -- | Extension and language settings in the form of 'DynOption's + ciDynOpts :: ![DynOption], + -- | Direct dependencies + ciDependencies :: !(Set PackageName), + -- | Absolute path to the cabal file + ciCabalFilePath :: !FilePath + } + deriving (Eq, Show) + +-- | Locate a @.cabal@ file corresponding to the given Haskell source file +-- and obtain 'CabalInfo' from it. +getCabalInfoForSourceFile :: + (MonadIO m) => + -- | Haskell source file + FilePath -> + -- | Extracted cabal info, if any + m CabalSearchResult +getCabalInfoForSourceFile sourceFile = + liftIO (findCabalFile sourceFile) >>= \case + Just cabalFile -> do + (mentioned, cabalInfo) <- parseCabalInfo cabalFile sourceFile + return + ( if mentioned + then CabalFound cabalInfo + else CabalDidNotMention cabalInfo + ) + Nothing -> return CabalNotFound + +-- | Find the path to an appropriate @.cabal@ file for a Haskell source +-- file, if available. +findCabalFile :: + (MonadIO m) => + -- | Path to a Haskell source file in a project with a @.cabal@ file + FilePath -> + -- | Absolute path to the @.cabal@ file, if available + m (Maybe FilePath) +findCabalFile = findClosestFileSatisfying $ \x -> + takeExtension x == ".cabal" + +-- | Parsed cabal file information to be shared across multiple source files. +data CachedCabalFile = CachedCabalFile + { -- | Parsed generic package description. + genericPackageDescription :: GenericPackageDescription, + -- | Map from Haskell source file paths (without any extensions) to the + -- corresponding 'DynOption's and dependencies. + extensionsAndDeps :: Map FilePath ([DynOption], [PackageName]) + } + deriving (Show) + +-- | Cache ref that stores 'CachedCabalFile' per Cabal file. +cacheRef :: Cache FilePath CachedCabalFile +cacheRef = unsafePerformIO newCache +{-# NOINLINE cacheRef #-} + +-- | Parse 'CabalInfo' from a @.cabal@ file at the given 'FilePath'. +parseCabalInfo :: + (MonadIO m) => + -- | Location of the .cabal file + FilePath -> + -- | Location of the source file we are formatting + FilePath -> + -- | Indication if the source file was mentioned in the Cabal file and the + -- extracted 'CabalInfo' + m (Bool, CabalInfo) +parseCabalInfo cabalFileAsGiven sourceFileAsGiven = liftIO $ do + cabalFile <- makeAbsolute cabalFileAsGiven + sourceFileAbs <- makeAbsolute sourceFileAsGiven + CachedCabalFile {..} <- withCache cacheRef cabalFile $ do + cabalFileBs <- B.readFile cabalFile + genericPackageDescription <- + whenLeft (snd . runParseResult $ parseGenericPackageDescription cabalFileBs) $ + throwIO . OrmoluCabalFileParsingFailed cabalFile . snd + let extensionsAndDeps = + getExtensionAndDepsMap cabalFile genericPackageDescription + pure CachedCabalFile {..} + let (dynOpts, dependencies, mentioned) = + case M.lookup (dropExtensions sourceFileAbs) extensionsAndDeps of + Nothing -> ([], Set.toList defaultDependencies, False) + Just (dynOpts', dependencies') -> (dynOpts', dependencies', True) + pdesc = packageDescription genericPackageDescription + return + ( mentioned, + CabalInfo + { ciPackageName = pkgName (package pdesc), + ciDynOpts = dynOpts, + ciDependencies = Set.fromList dependencies, + ciCabalFilePath = cabalFile + } + ) + where + whenLeft :: (Applicative f) => Either e a -> (e -> f a) -> f a + whenLeft eitha ma = either ma pure eitha + +-- | Get a map from Haskell source file paths (without any extensions) to +-- the corresponding 'DynOption's and dependencies. +getExtensionAndDepsMap :: + -- | Path to the cabal file + FilePath -> + -- | Parsed generic package description + GenericPackageDescription -> + Map FilePath ([DynOption], [PackageName]) +getExtensionAndDepsMap cabalFile GenericPackageDescription {..} = + M.unions . concat $ + [ buildMap extractFromLibrary <$> lib ++ sublibs, + buildMap extractFromExecutable . snd <$> condExecutables, + buildMap extractFromTestSuite . snd <$> condTestSuites, + buildMap extractFromBenchmark . snd <$> condBenchmarks + ] + where + lib = maybeToList condLibrary + sublibs = snd <$> condSubLibraries + + buildMap f a = M.fromList ((,extsAndDeps) <$> files) + where + (mergedA, _) = CT.ignoreConditions a + (files, extsAndDeps) = f mergedA + + extractFromBuildInfo extraModules BuildInfo {..} = (,(exts, deps)) $ do + m <- extraModules ++ (ModuleName.toFilePath <$> otherModules) + normalise . (takeDirectory cabalFile ) <$> prependSrcDirs (dropExtensions m) + where + prependSrcDirs f + | null hsSourceDirs = [f] + | otherwise = ( f) . getSymbolicPath <$> hsSourceDirs + deps = depPkgName <$> targetBuildDepends + exts = maybe [] langExt defaultLanguage ++ fmap extToDynOption defaultExtensions + langExt = + pure . DynOption . ("-X" <>) . \case + UnknownLanguage lan -> lan + lan -> show lan + extToDynOption = + DynOption . \case + EnableExtension e -> "-X" ++ show e + DisableExtension e -> "-XNo" ++ show e + UnknownExtension e -> "-X" ++ e + + extractFromLibrary Library {..} = + extractFromBuildInfo (ModuleName.toFilePath <$> exposedModules) libBuildInfo + extractFromExecutable Executable {..} = + extractFromBuildInfo [getSymbolicPath modulePath] buildInfo + extractFromTestSuite TestSuite {..} = + extractFromBuildInfo mainPath testBuildInfo + where + mainPath = case testInterface of + TestSuiteExeV10 _ p -> [getSymbolicPath p] + TestSuiteLibV09 _ p -> [ModuleName.toFilePath p] + TestSuiteUnsupported {} -> [] + extractFromBenchmark Benchmark {..} = + extractFromBuildInfo mainPath benchmarkBuildInfo + where + mainPath = case benchmarkInterface of + BenchmarkExeV10 _ p -> [getSymbolicPath p] + BenchmarkUnsupported {} -> [] diff --git a/src/Ormolu/Utils/Fixity.hs b/src/Ormolu/Utils/Fixity.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Utils/Fixity.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE LambdaCase #-} + +module Ormolu.Utils.Fixity + ( getDotOrmoluForSourceFile, + parseFixityDeclarationStr, + parseModuleReexportDeclarationStr, + ) +where + +import Control.Exception (throwIO) +import Control.Monad.IO.Class +import Data.Bifunctor (first) +import Data.List.NonEmpty (NonEmpty) +import Data.Text qualified as T +import Data.Text.IO.Utf8 qualified as T.Utf8 +import Distribution.ModuleName (ModuleName) +import Distribution.Types.PackageName (PackageName) +import Ormolu.Exception +import Ormolu.Fixity +import Ormolu.Fixity.Parser +import Ormolu.Utils.IO (Cache, findClosestFileSatisfying, newCache, withCache) +import System.Directory +import System.IO.Unsafe (unsafePerformIO) +import Text.Megaparsec (errorBundlePretty) + +-- | Attempt to locate and parse an @.ormolu@ file. If it does not exist, +-- the default fixity map and module re-exports are returned. This function +-- maintains a cache of fixity overrides and module re-exports keyed by +-- @.ormolu@ file path. +getDotOrmoluForSourceFile :: + (MonadIO m) => + -- | 'CabalInfo' already obtained for this source file + FilePath -> + m (FixityOverrides, ModuleReexports) +getDotOrmoluForSourceFile sourceFile = + liftIO (findDotOrmoluFile sourceFile) >>= \case + Just dotOrmoluFile -> liftIO $ withCache cacheRef dotOrmoluFile $ do + dotOrmoluRelative <- makeRelativeToCurrentDirectory dotOrmoluFile + contents <- T.Utf8.readFile dotOrmoluFile + case parseDotOrmolu dotOrmoluRelative contents of + Left errorBundle -> + throwIO (OrmoluFixityOverridesParseError errorBundle) + Right x -> return x + Nothing -> return (defaultFixityOverrides, defaultModuleReexports) + +-- | Find the path to an appropriate @.ormolu@ file for a Haskell source +-- file, if available. +findDotOrmoluFile :: + (MonadIO m) => + -- | Path to a Haskell source file + FilePath -> + -- | Absolute path to the closest @.ormolu@ file, if available + m (Maybe FilePath) +findDotOrmoluFile = findClosestFileSatisfying $ \x -> + x == ".ormolu" + +-- | Cache ref that maps names of @.ormolu@ files to their contents. +cacheRef :: Cache FilePath (FixityOverrides, ModuleReexports) +cacheRef = unsafePerformIO newCache +{-# NOINLINE cacheRef #-} + +-- | A wrapper around 'parseFixityDeclaration' for parsing individual fixity +-- definitions. +parseFixityDeclarationStr :: + -- | Input to parse + String -> + -- | Parse result + Either String [(OpName, FixityInfo)] +parseFixityDeclarationStr = + first errorBundlePretty . parseFixityDeclaration . T.pack + +-- | A wrapper around 'parseModuleReexportDeclaration' for parsing an +-- individual module re-export. +parseModuleReexportDeclarationStr :: + -- | Input to parse + String -> + -- | Parse result + Either String (ModuleName, NonEmpty (Maybe PackageName, ModuleName)) +parseModuleReexportDeclarationStr = + first errorBundlePretty . parseModuleReexportDeclaration . T.pack diff --git a/src/Ormolu/Utils/IO.hs b/src/Ormolu/Utils/IO.hs new file mode 100644 --- /dev/null +++ b/src/Ormolu/Utils/IO.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +module Ormolu.Utils.IO + ( findClosestFileSatisfying, + Cache, + newCache, + withCache, + ) +where + +import Control.Exception (catch, throwIO) +import Control.Monad.IO.Class +import Data.IORef +import Data.Map.Lazy (Map) +import Data.Map.Lazy qualified as M +import System.Directory +import System.FilePath +import System.IO.Error (isDoesNotExistError, isPermissionError) + +-- | Find the path to the closest file higher in the file hierarchy that +-- satisfies a given predicate. +findClosestFileSatisfying :: + (MonadIO m) => + -- | The predicate that determines what we are looking for + (FilePath -> Bool) -> + -- | Path to the starting point for the search + FilePath -> + -- | Absolute path to the found file if available + m (Maybe FilePath) +findClosestFileSatisfying isRightFile rootOfSearch = liftIO $ do + parentDir <- takeDirectory <$> makeAbsolute rootOfSearch + 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 + 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)) + +newCache :: (Ord k) => IO (Cache k v) +newCache = do + var <- newIORef mempty + pure (Cache var) + +-- | Execute an 'IO' action but only if the given key is not found in the +-- cache. +withCache :: (Ord k) => Cache k v -> k -> IO v -> IO v +withCache (Cache cacheVar) k action = do + cache <- readIORef cacheVar + case M.lookup k cache of + Just v -> pure v + Nothing -> do + v <- action + atomicModifyIORef cacheVar ((,()) . M.insert k v) + pure v diff --git a/tests/Ormolu/CabalInfoSpec.hs b/tests/Ormolu/CabalInfoSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Ormolu/CabalInfoSpec.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE RecordWildCards #-} + +module Ormolu.CabalInfoSpec (spec) where + +import Data.Set qualified as Set +import Distribution.Types.PackageName (unPackageName) +import Ormolu.Config (DynOption (..)) +import Ormolu.Utils.Cabal +import System.Directory +import System.FilePath +import System.IO.Temp (withSystemTempDirectory) +import Test.Hspec + +spec :: Spec +spec = do + describe "findCabalFile" $ do + let findsOrmoluCabal start expectedCabalFile = do + Just absolute <- findCabalFile start + absolute `shouldSatisfy` isAbsolute + makeRelativeToCurrentDirectory absolute `shouldReturn` expectedCabalFile + it "returns correct absolute path" $ + findsOrmoluCabal "src/Ormolu/Config.hs" "ormolu.cabal" + it "finds correct path even when it starts from nonsense" $ + findsOrmoluCabal "a/b/c/d/e" "ormolu.cabal" + it "returns Nothing when it cannot find a cabal file" $ + findCabalFile "/foo.hs" `shouldReturn` Nothing + it "does not consider directories as .cabal files" $ + withSystemTempDirectory "" $ + \dir -> do + createDirectory $ dir ".cabal" + cabalFile <- findCabalFile (dir "foo/bar.hs") + cabalFile `shouldBe` Nothing + describe "parseCabalInfo" $ do + it "extracts correct cabal info from ormolu.cabal for src/Ormolu/Config.hs" $ do + (mentioned, CabalInfo {..}) <- parseCabalInfo "ormolu.cabal" "src/Ormolu/Config.hs" + mentioned `shouldBe` True + unPackageName ciPackageName `shouldBe` "ormolu" + ciDynOpts `shouldBe` [DynOption "-XGHC2021"] + Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "Diff", "MemoTrie", "ansi-terminal", "array", "base", "binary", "bytestring", "choice", "containers", "directory", "file-embed", "filepath", "ghc-lib-parser", "megaparsec", "mtl", "syb", "text"] + ciCabalFilePath `shouldSatisfy` isAbsolute + makeRelativeToCurrentDirectory ciCabalFilePath `shouldReturn` "ormolu.cabal" + it "extracts correct cabal info from ormolu.cabal for tests/Ormolu/PrinterSpec.hs" $ do + (mentioned, CabalInfo {..}) <- parseCabalInfo "ormolu.cabal" "tests/Ormolu/PrinterSpec.hs" + mentioned `shouldBe` True + unPackageName ciPackageName `shouldBe` "ormolu" + ciDynOpts `shouldBe` [DynOption "-XGHC2021"] + Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["Cabal-syntax", "QuickCheck", "base", "choice", "containers", "directory", "filepath", "ghc-lib-parser", "hspec", "hspec-megaparsec", "megaparsec", "ormolu", "path", "path-io", "temporary", "text"] + ciCabalFilePath `shouldSatisfy` isAbsolute + makeRelativeToCurrentDirectory ciCabalFilePath `shouldReturn` "ormolu.cabal" + it "handles correctly files that are not mentioned in ormolu.cabal" $ do + (mentioned, CabalInfo {..}) <- parseCabalInfo "ormolu.cabal" "src/FooBob.hs" + mentioned `shouldBe` False + unPackageName ciPackageName `shouldBe` "ormolu" + ciDynOpts `shouldBe` [] + Set.map unPackageName ciDependencies `shouldBe` Set.fromList ["base"] + ciCabalFilePath `shouldSatisfy` isAbsolute + makeRelativeToCurrentDirectory ciCabalFilePath `shouldReturn` "ormolu.cabal" + it "handles `hs-source-dirs: .`" $ do + (_, CabalInfo {..}) <- parseTestCabalInfo "Foo.hs" + ciDynOpts `shouldContain` [DynOption "-XImportQualifiedPost"] + it "handles empty hs-source-dirs" $ do + (_, CabalInfo {..}) <- parseTestCabalInfo "Bar.hs" + ciDynOpts `shouldContain` [DynOption "-XImportQualifiedPost"] + where + parseTestCabalInfo f = + parseCabalInfo "data/cabal-tests/test.cabal" ("data/cabal-tests" f) diff --git a/tests/Ormolu/Comments/AnchorSpec.hs b/tests/Ormolu/Comments/AnchorSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Ormolu/Comments/AnchorSpec.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Tests for the containment tree and the positional attachment rules. +module Ormolu.Comments.AnchorSpec (spec) where + +import Data.List.NonEmpty (NonEmpty (..)) +import GHC.Data.FastString (fsLit) +import GHC.Types.SrcLoc +import Ormolu.Comments.Anchor +import Ormolu.Comments.Tree +import Ormolu.Parser.CommentStream +import Test.Hspec + +spec :: Spec +spec = do + describe "mkSpanForest" $ do + it "nests spans by containment" $ + mkSpanForest [spn 1 1 9 9, spn 2 1 3 9, spn 2 3 2 8] + `shouldBe` [ SpanTree + (spn 1 1 9 9) + [SpanTree (spn 2 1 3 9) [SpanTree (spn 2 3 2 8) []]] + ] + it "keeps siblings in ascending order" $ + fmap stSpan (mkSpanForest [spn 5 1 5 9, spn 1 1 1 9, spn 3 1 3 9]) + `shouldBe` [spn 1 1 1 9, spn 3 1 3 9, spn 5 1 5 9] + it "treats a repeated span as one element" $ + -- Several AST nodes routinely share a span; the comment can only be + -- owned once. + countNodes (mkSpanForest [spn 1 1 9 9, spn 1 1 9 9, spn 1 1 9 9]) + `shouldBe` 1 + it "drops spans that overlap without being contained" $ + countNodes (mkSpanForest [spn 1 1 5 9, spn 3 1 7 9]) `shouldBe` 1 + it "keeps zero-width spans" $ + -- The printer enters a zero-width span at each end of an empty list, + -- deliberately, so that a comment written inside the brackets has + -- something to attach to. + mkSpanForest [spn 1 1 1 1, spn 2 1 2 9] + `shouldBe` [SpanTree (spn 1 1 1 1) [], SpanTree (spn 2 1 2 9) []] + + describe "anchorFor" $ do + let forest = mkSpanForest [block, stmt1, stmt2] + block = spn 1 1 5 10 + stmt1 = spn 2 3 2 9 + stmt2 = spn 4 3 4 9 + + it "puts a comment between two elements before the later one" $ + anchorFor forest (ownLine 3 3 3 12) `shouldBe` AnchorBefore stmt2 + it "attaches a comment that trails code to the element it trails" $ + anchorFor forest (trailing 2 12 2 20) `shouldBe` AnchorTrailing stmt1 + it "does not treat a comment as trailing when no code precedes it" $ + -- Same line as the end of stmt1, but alone on its line, so it belongs + -- to what comes after. + anchorFor forest (ownLine 2 12 2 20) `shouldBe` AnchorBefore stmt2 + it "attaches a comment after the last element to that element" $ + anchorFor forest (ownLine 5 3 5 9) `shouldBe` AnchorTrailing stmt2 + it "gives a comment inside a childless element to that element" $ + anchorFor (mkSpanForest [spn 1 1 3 3]) (ownLine 2 3 2 9) + `shouldBe` AnchorInside (spn 1 1 3 3) + it "leaves a comment outside everything to the module" $ + -- Not trailing the last top-level element: there is nothing it could + -- trail without being rendered before syntax that preceded it. + anchorFor forest (ownLine 9 1 9 9) `shouldBe` AnchorModule + it "leaves a comment to the module when there are no elements at all" $ + anchorFor [] (ownLine 1 1 1 9) `shouldBe` AnchorModule + + -- @f x = -- c@ re-parsed: the comment now falls inside the right-hand + -- side, which opened on that line and has nothing of its own before the + -- comment. Without looking one level up it would move onto its own + -- line, and formatting would not be idempotent. + it "attaches a comment inside an element that opened on its line to the code before it" $ + let rhs = spn 2 11 3 9 + body = spn 3 3 3 9 + in anchorFor + (mkSpanForest [block, stmt1, rhs, body]) + (trailing 2 14 2 20) + `shouldBe` AnchorTrailing stmt1 + it "still lets an element starting on the comment's line lead it" $ + -- The @{-a-}@ of @x = ({-a-} b, c)@ belongs to @b@, not to the @x@ + -- one level up. + let tuple = spn 2 11 2 30 + b = spn 2 18 2 19 + in anchorFor + (mkSpanForest [block, stmt1, tuple, b]) + (trailing 2 12 2 17) + `shouldBe` AnchorBefore b + it "does not carry a comment out of a list of items" $ + -- @xs ++ [ -- why?@: the comment introduces the items, so carrying it + -- up to trail @xs@ would drag it out of the brackets. + let list = spn 2 11 4 9 + itemA = spn 3 3 3 9 + itemB = spn 4 3 4 9 + in anchorFor + (mkSpanForest [block, stmt1, list, itemA, itemB]) + (trailing 2 14 2 20) + `shouldBe` AnchorBefore itemA + it "does not carry a block comment up a level" $ + -- A block comment renders where it stands, so trailing an element one + -- level up would push it ahead of the tokens that opened the element + -- it was written inside. + let rhs = spn 2 11 3 9 + body = spn 3 3 3 9 + in anchorFor + (mkSpanForest [block, stmt1, rhs, body]) + (blockTrailing 2 14 2 20) + `shouldBe` AnchorBefore body + + it "does not depend on the order the elements are given in" $ + -- This is the whole point: reordering imports or reassociating an + -- operator tree must not change who owns a comment. + anchorFor (mkSpanForest [stmt2, block, stmt1]) (ownLine 3 3 3 12) + `shouldBe` AnchorBefore stmt2 + + describe "attachComments" $ + it "attaches every comment exactly once" $ do + let comments = [ownLine 3 3 3 12, trailing 4 12 4 20] + anchors = attachComments comments [spn 1 1 5 10, spn 2 3 2 9, spn 4 3 4 9] + length anchors `shouldBe` 2 + fmap snd anchors + `shouldBe` [AnchorBefore (spn 4 3 4 9), AnchorTrailing (spn 4 3 4 9)] + +---------------------------------------------------------------------------- +-- Helpers + +spn :: Int -> Int -> Int -> Int -> RealSrcSpan +spn l1 c1 l2 c2 = + mkRealSrcSpan + (mkRealSrcLoc (fsLit "") l1 c1) + (mkRealSrcLoc (fsLit "") l2 c2) + +-- | A comment with code in front of it on the same line. +trailing :: Int -> Int -> Int -> Int -> LComment +trailing l1 c1 l2 c2 = L (spn l1 c1 l2 c2) (Comment True ("-- x" :| [])) + +-- | A block comment with code in front of it on the same line. +blockTrailing :: Int -> Int -> Int -> Int -> LComment +blockTrailing l1 c1 l2 c2 = L (spn l1 c1 l2 c2) (Comment True ("{- x -}" :| [])) + +-- | A comment that is alone on its line. +ownLine :: Int -> Int -> Int -> Int -> LComment +ownLine l1 c1 l2 c2 = L (spn l1 c1 l2 c2) (Comment False ("-- x" :| [])) diff --git a/tests/Ormolu/Diff/TextSpec.hs b/tests/Ormolu/Diff/TextSpec.hs --- a/tests/Ormolu/Diff/TextSpec.hs +++ b/tests/Ormolu/Diff/TextSpec.hs @@ -2,14 +2,11 @@ module Ormolu.Diff.TextSpec (spec) where -import Data.Text (Text) -import qualified Data.Text.IO as T +import Data.Text.IO.Utf8 qualified as T.Utf8 import Ormolu.Diff.Text import Ormolu.Terminal import Path -import Path.IO -import qualified System.FilePath as FP -import System.IO (hClose) +import System.FilePath qualified as FP import Test.Hspec spec :: Spec @@ -24,8 +21,10 @@ stdTest "two-hunks" "main-and-baz" "main-and-baz-v2" stdTest "trimming" "spaced" "spaced-v2" stdTest "trailing-blank-line" "no-trailing-blank-line" "with-trailing-blank-line" + stdTest "trimming-trailing-both-eof" "applicative-before" "applicative-after" + stdTest "trimming-trailing-both-out-of-margin" "longer" "longer-v2" --- | Test diff printig. +-- | Test diff printing. stdTest :: -- | Name of the test case String -> @@ -37,25 +36,16 @@ stdTest name pathA pathB = it name $ do inputA <- parseRelFile (FP.addExtension pathA "hs") - >>= T.readFile . toFilePath . (diffInputsDir ) + >>= T.Utf8.readFile . toFilePath . (diffInputsDir ) inputB <- parseRelFile (FP.addExtension pathB "hs") - >>= T.readFile . toFilePath . (diffInputsDir ) + >>= T.Utf8.readFile . toFilePath . (diffInputsDir ) let expectedDiffPath = FP.addExtension name "txt" expectedDiffText <- parseRelFile expectedDiffPath - >>= T.readFile . toFilePath . (diffOutputsDir ) - let Just actualDiff = diffText inputA inputB "TEST" - actualDiffText <- printDiff actualDiff - actualDiffText `shouldBe` expectedDiffText - --- | Print to a 'Text' value. -printDiff :: TextDiff -> IO Text -printDiff diff = - withSystemTempFile "ormolu-diff-test" $ \path h -> do - runTerm (printTextDiff diff) Never h - hClose h - T.readFile (toFilePath path) + >>= T.Utf8.readFile . toFilePath . (diffOutputsDir ) + Just actualDiff <- pure $ diffText inputA inputB "TEST" + runTermPure (printTextDiff actualDiff) `shouldBe` expectedDiffText diffTestsDir :: Path Rel Dir diffTestsDir = $(mkRelDir "data/diff-tests") diff --git a/tests/Ormolu/Fixity/ParserSpec.hs b/tests/Ormolu/Fixity/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Ormolu/Fixity/ParserSpec.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Ormolu.Fixity.ParserSpec (spec) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Ormolu.Fixity +import Ormolu.Fixity.Parser +import Test.Hspec +import Test.Hspec.Megaparsec +import Text.Megaparsec.Error (ErrorFancy (..)) + +spec :: Spec +spec = do + describe "parseDotOrmolu" $ do + it "parses the empty input without choking" $ + parseDotOrmolu "" "" + `shouldParse` (FixityOverrides Map.empty, ModuleReexports Map.empty) + it "parses a collection of fixity declarations" $ + -- The example is taken from base. + parseDotOrmolu + "" + ( T.unlines + [ "infixr 9 .", + "infixr 5 ++", + "infixl 4 <$", + "infixl 1 >>, >>=", + "infixr 1 =<<", + "infixr 0 $, $!", + "infixl 4 <*>, <*, *>, <**>" + ] + ) + `shouldParse` ( exampleFixityOverrides, + ModuleReexports Map.empty + ) + it "accepts fractional operator precedences" $ + parseDotOrmolu + "" + ( T.unlines + [ "infixr 3 >~<", + "infixr 3.3 |~|", + "infixr 3.7 <~>" + ] + ) + `shouldParse` ( fractionalFixityOverrides, + ModuleReexports Map.empty + ) + it "combines conflicting fixity declarations correctly" $ + parseDotOrmolu + "" + ( T.unlines + [ "infixr 9 ., ^", + "infixr 7 ., $", + "infixr 9 ^ ", + "infixl 7 $" + ] + ) + `shouldParse` ( FixityOverrides + ( Map.fromList + [ ("$", FixityInfo InfixL 7), + (".", FixityInfo InfixR 7), + ("^", FixityInfo InfixR 9) + ] + ), + ModuleReexports Map.empty + ) + it "handles CRLF line endings correctly" $ + parseDotOrmolu "" + `shouldSucceedOn` unlinesCrlf + [ "infixr 9 .", + "infixr 5 ++" + ] + it "parses inputs without a trailing newline" $ + parseDotOrmolu "" + `shouldSucceedOn` T.intercalate + "\n" + [ "infixr 9 .", + "infixr 5 ++" + ] + it "fails with correct parse error (keyword wrong second line)" $ + parseDotOrmolu "" "infixr 5 .\nfoobar 5 $" + `shouldFailWith` err + 11 + ( mconcat + [ utok 'f', + etoks "infix", + etoks "infixl", + etoks "infixr", + etoks "module", + eeof + ] + ) + it "parses module re-exports and combines them correctly" $ + parseDotOrmolu + "" + ( T.unlines + [ "module Control.Lens exports Control.Lens.Lens", + "module Control.Lens exports \"lens\" Control.Lens.At", + "module Text.Megaparsec exports Control.Monad.Combinators" + ] + ) + `shouldParse` (FixityOverrides Map.empty, exampleModuleReexports) + it "parses fixity declarations + module re-export declarations with blanks" $ + parseDotOrmolu + "" + ( T.unlines + [ "module Control.Lens exports Control.Lens.Lens", + "", + "infixr 5 ++", + "infixl 4 <$", + "", + "", + "module Control.Lens exports \"lens\" Control.Lens.At", + "infixr 9 .", + "module Text.Megaparsec exports Control.Monad.Combinators", + "infixl 1 >>, >>=", + "infixr 1 =<<", + "", + "infixr 0 $, $!", + "infixl 4 <*>, <*, *>, <**>" + ] + ) + `shouldParse` (exampleFixityOverrides, exampleModuleReexports) + describe "parseFixtiyDeclaration" $ do + it "parses a simple infixr declaration" $ + parseFixityDeclaration "infixr 5 $" + `shouldParse` [("$", FixityInfo InfixR 5)] + it "parses a simple infixl declaration" $ + parseFixityDeclaration "infixl 5 $" + `shouldParse` [("$", FixityInfo InfixL 5)] + it "parses a simple infix declaration" $ + parseFixityDeclaration "infix 5 $" + `shouldParse` [("$", FixityInfo InfixN 5)] + it "parses a declaration for a ticked identifier" $ + parseFixityDeclaration "infixl 5 `foo`" + `shouldParse` [("foo", FixityInfo InfixL 5)] + it "parses a declaration for a ticked identifier (constructor case)" $ + parseFixityDeclaration "infixl 5 `Foo`" + `shouldParse` [("Foo", FixityInfo InfixL 5)] + it "parses a multi-operator declaration" $ + parseFixityDeclaration "infixl 5 $, ., `Foo`, `bar`" + `shouldParse` [ ("$", FixityInfo InfixL 5), + (".", FixityInfo InfixL 5), + ("Foo", FixityInfo InfixL 5), + ("bar", FixityInfo InfixL 5) + ] + it "parses a declaration with a unicode operator" $ + parseFixityDeclaration "infixr 5 ×" + `shouldParse` [("×", FixityInfo InfixR 5)] + it "fails with correct parse error (keyword wrong)" $ + parseFixityDeclaration "foobar 5 $" + `shouldFailWith` err + 0 + ( mconcat + [ utoks "foobar", + etoks "infix", + etoks "infixl", + etoks "infixr" + ] + ) + it "fails with correct parse error (missing operator)" $ + parseFixityDeclaration "infixr 5 " + `shouldFailWith` err + 9 + ( mconcat + [ ueof, + etok '`', + elabel "operator character" + ] + ) + it "fails with correct parse error (trailing comma)" $ + parseFixityDeclaration "infixr 5 ., " + `shouldFailWith` err + 12 + ( mconcat + [ ueof, + etok '`', + elabel "operator character" + ] + ) + it "fails with correct parse error (precedence greater than 9)" $ + parseFixityDeclaration "infixl 10 $" + `shouldFailWith` errFancy + 7 + (fancy (ErrorFail "precedence should not be greater than 9")) + describe "parseModuleReexportDeclaration" $ do + it "parses a re-export declaration" $ + parseModuleReexportDeclaration "module Control.Lens exports Control.Lens.Lens" + `shouldParse` ( "Control.Lens", + (Nothing, "Control.Lens.Lens") :| [] + ) + it "parses a re-export declaration (explicit package)" $ + parseModuleReexportDeclaration "module Control.Lens exports \"lens\" Control.Lens.Lens" + `shouldParse` ( "Control.Lens", + (Just "lens", "Control.Lens.Lens") :| [] + ) + it "fails with correct parse error (keyword wrong)" $ + parseModuleReexportDeclaration "foo Control.Lens exports Control.Lens.Lens" + `shouldFailWith` err + 0 + ( mconcat + [ utoks "foo Co", + etoks "module" + ] + ) + it "fails with correct parse error (module syntax)" $ + parseModuleReexportDeclaration "module control.Lens exports Control.Lens.Lens" + `shouldFailWith` err + 7 + ( mconcat + [ utok 'c', + elabel "module name" + ] + ) + it "fails with correct parse error (typo: export instead exports)" $ + parseModuleReexportDeclaration "module Control.Lens export Control.Lens.Lens" + `shouldFailWith` err + 20 + ( mconcat + [ utoks "export ", + etoks "exports" + ] + ) + +exampleFixityOverrides :: FixityOverrides +exampleFixityOverrides = + FixityOverrides + ( Map.fromList + [ ("$", FixityInfo InfixR 0), + ("$!", FixityInfo InfixR 0), + ("*>", FixityInfo InfixL 4), + ("++", FixityInfo InfixR 5), + (".", FixityInfo InfixR 9), + ("<$", FixityInfo InfixL 4), + ("<*", FixityInfo InfixL 4), + ("<**>", FixityInfo InfixL 4), + ("<*>", FixityInfo InfixL 4), + ("=<<", FixityInfo InfixR 1), + (">>", FixityInfo InfixL 1), + (">>=", FixityInfo InfixL 1) + ] + ) + +fractionalFixityOverrides :: FixityOverrides +fractionalFixityOverrides = + FixityOverrides + ( Map.fromList + [ (">~<", FixityInfo InfixR 3), + ("|~|", FixityInfo InfixR 3.3), + ("<~>", FixityInfo InfixR 3.7) + ] + ) + +exampleModuleReexports :: ModuleReexports +exampleModuleReexports = + ModuleReexports . Map.fromList $ + [ ( "Control.Lens", + (Nothing, "Control.Lens.Lens") :| [(Just "lens", "Control.Lens.At")] + ), + ( "Text.Megaparsec", + (Nothing, "Control.Monad.Combinators") :| [] + ) + ] + +unlinesCrlf :: [Text] -> Text +unlinesCrlf = T.concat . fmap (<> "\r\n") diff --git a/tests/Ormolu/Fixity/PrinterSpec.hs b/tests/Ormolu/Fixity/PrinterSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Ormolu/Fixity/PrinterSpec.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ormolu.Fixity.PrinterSpec (spec) where + +import Data.List (intercalate) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Distribution.ModuleName (ModuleName) +import Distribution.ModuleName qualified as ModuleName +import Distribution.Types.PackageName (PackageName, mkPackageName) +import Ormolu.Fixity +import Ormolu.Fixity.Parser +import Ormolu.Fixity.Printer +import Test.Hspec +import Test.Hspec.Megaparsec +import Test.QuickCheck + +instance Arbitrary FixityOverrides where + arbitrary = + FixityOverrides . Map.fromList + <$> listOf ((,) <$> genOperator <*> genFixityInfo) + where + genOperator = + OpName . T.pack <$> oneof [genNormalOperator, genIdentifier] + genNormalOperator = + listOf1 (scaleDown arbitrary `suchThat` isOperatorConstituent) + genIdentifier = do + x <- arbitrary `suchThat` isIdentifierFirstChar + xs <- listOf1 (scaleDown arbitrary `suchThat` isIdentifierConstituent) + return (x : xs) + genFixityInfo = do + fiDirection <- + elements + [ InfixL, + InfixR, + InfixN + ] + precedenceWholePart <- fromIntegral <$> chooseInt (0, 9) + precedenceFractionalPart <- + if precedenceWholePart < 9.0 + then (* 0.1) . fromIntegral <$> chooseInt (0, 1) + else return 0 + let fiPrecedence = precedenceWholePart + precedenceFractionalPart + return FixityInfo {..} + +instance Arbitrary ModuleReexports where + arbitrary = ModuleReexports . Map.fromListWith combine <$> listOf genReexport + where + combine x y = NE.sort (x <> y) + genReexport = do + exportingModule <- arbitrary + exports <- NE.sort . NE.fromList . getNonEmpty <$> scaleDown arbitrary + return (exportingModule, exports) + +instance Arbitrary PackageName where + arbitrary = + mkPackageName + <$> listOf1 (scaleDown arbitrary `suchThat` isPackageNameConstituent) + +instance Arbitrary ModuleName where + arbitrary = + ModuleName.fromString . intercalate "." <$> scaleDown (listOf1 genSegment) + where + genSegment = do + x <- arbitrary `suchThat` isModuleSegmentFirstChar + xs <- listOf (arbitrary `suchThat` isModuleSegmentConstituent) + return (x : xs) + +scaleDown :: Gen a -> Gen a +scaleDown = scale (`div` 4) + +spec :: Spec +spec = do + describe "parseFixityOverrides & printFixityOverrides" $ + it "arbitrary fixity maps are printed and parsed back correctly" $ + property $ \fixityOverrides moduleReexports -> + parseDotOrmolu "" (printDotOrmolu fixityOverrides moduleReexports) + `shouldParse` (fixityOverrides, moduleReexports) diff --git a/tests/Ormolu/FixitySpec.hs b/tests/Ormolu/FixitySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Ormolu/FixitySpec.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Ormolu.FixitySpec (spec) where + +import Data.Choice (pattern Without) +import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text qualified as T +import Distribution.ModuleName (ModuleName) +import Distribution.Types.PackageName (PackageName) +import GHC.Types.Name (OccName) +import GHC.Types.Name.Occurrence (mkVarOcc) +import GHC.Types.Name.Reader +import Language.Haskell.Syntax.ImpExp (ImportListInterpretation (..)) +import Language.Haskell.Syntax.Module.Name (mkModuleName) +import Ormolu.Fixity +import Ormolu.Fixity.Imports +import Ormolu.Fixity.Internal +import Ormolu.Utils (showOutputable) +import Test.Hspec + +instance Show RdrName where + show = showOutputable + +spec :: Spec +spec = do + it "gives the correct fixity info for (:) (built-in)" $ + checkFixities + [] + [] + [(unqual ":", FixityApproximation (Just InfixR) 5 5)] + it "does not know operators from base if base is not a dependency" $ + checkFixities + [] + [] + [ (unqual "$", defaultFixityApproximation), + (unqual "+", defaultFixityApproximation), + (unqual "++", defaultFixityApproximation) + ] + it "does not know operators from base if Prelude is not imported" $ + checkFixities + [] + [] + [ (unqual "$", defaultFixityApproximation), + (unqual "+", defaultFixityApproximation), + (unqual "++", defaultFixityApproximation) + ] + it "infers fixities of operators from base correctly" $ + checkFixities + ["base"] + [import_ "Prelude"] + [ (unqual "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", FixityApproximation (Just InfixL) 6 6), + (unqual "++", FixityApproximation (Just InfixR) 5 5) + ] + it "does not know (>>>) when Control.Category is not imported" $ + checkFixities + ["base"] + [import_ "Prelude"] + [ (unqual ">>>", defaultFixityApproximation) + ] + it "infer correct fixity for (>>>) when Control.Category is imported" $ + checkFixities + ["base"] + [ import_ "Prelude", + import_ "Control.Category" + ] + [ (unqual ">>>", FixityApproximation (Just InfixR) 1 1) + ] + it "handles 'as' imports correctly" $ + checkFixities + ["base"] + [ import_ "Control.Category" & as_ "Foo" + ] + [ (unqual ">>>", FixityApproximation (Just InfixR) 1 1), + (qual "Foo" ">>>", FixityApproximation (Just InfixR) 1 1), + (qual "Bar" ">>>", defaultFixityApproximation) + ] + it "handles 'qualified' imports correctly" $ + checkFixities + ["base"] + [import_ "Control.Category" & qualified_] + [ (unqual ">>>", defaultFixityApproximation), + (qual "Control.Category" ">>>", FixityApproximation (Just InfixR) 1 1) + ] + it "handles 'qualified as' imports correctly" $ + checkFixities + ["base"] + [import_ "Control.Category" & qualified_ & as_ "Foo"] + [ (unqual ">>>", defaultFixityApproximation), + (qual "Control.Category" ">>>", defaultFixityApproximation), + (qual "Foo" ">>>", FixityApproximation (Just InfixR) 1 1) + ] + it "handles explicit import lists correctly" $ + checkFixities + ["base"] + [import_ "Prelude" & exactly_ ["$"]] + [ (unqual "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", defaultFixityApproximation) + ] + it "handles hiding import lists correctly" $ + checkFixities + ["base"] + [import_ "Prelude" & hiding_ ["$"]] + [ (unqual "$", defaultFixityApproximation), + (unqual "+", FixityApproximation (Just InfixL) 6 6), + (unqual "++", FixityApproximation (Just InfixR) 5 5) + ] + it "handles qualified imports with explicit import lists correctly" $ + checkFixities + ["base"] + [import_ "Prelude" & qualified_ & exactly_ ["$"]] + [ (unqual "$", defaultFixityApproximation), + (qual "Prelude" "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", defaultFixityApproximation), + (qual "Prelude" "+", defaultFixityApproximation) + ] + it "handles qualified import with hiding correctly" $ + checkFixities + ["base"] + [import_ "Prelude" & qualified_ & hiding_ ["$"]] + [ (unqual "$", defaultFixityApproximation), + (qual "Prelude" "$", defaultFixityApproximation), + (unqual "+", defaultFixityApproximation), + (qual "Prelude" "+", FixityApproximation (Just InfixL) 6 6) + ] + it "handles qualified import and explicit import lists correctly (1)" $ + checkFixities + ["base"] + [ import_ "Prelude" & qualified_, + import_ "Prelude" & exactly_ ["$"] + ] + [ (unqual "$", FixityApproximation (Just InfixR) 0 0), + (qual "Prelude" "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", defaultFixityApproximation), + (qual "Prelude" "+", FixityApproximation (Just InfixL) 6 6) + ] + it "handles qualified import and explicit import lists correctly (2)" $ + checkFixities + ["base"] + [ import_ "Prelude" & exactly_ ["$"], + import_ "Prelude" & qualified_ + ] + [ (unqual "$", FixityApproximation (Just InfixR) 0 0), + (qual "Prelude" "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", defaultFixityApproximation), + (qual "Prelude" "+", FixityApproximation (Just InfixL) 6 6) + ] + it "handles qualified import and hiding import correctly (1)" $ + checkFixities + ["base"] + [ import_ "Prelude" & qualified_, + import_ "Prelude" & hiding_ ["$"] + ] + [ (unqual "$", defaultFixityApproximation), + (qual "Prelude" "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", FixityApproximation (Just InfixL) 6 6), + (qual "Prelude" "+", FixityApproximation (Just InfixL) 6 6) + ] + it "handles qualified import and hiding import correctly (2)" $ + checkFixities + ["base"] + [ import_ "Prelude" & hiding_ ["$"], + import_ "Prelude" & qualified_ + ] + [ (unqual "$", defaultFixityApproximation), + (qual "Prelude" "$", FixityApproximation (Just InfixR) 0 0), + (unqual "+", FixityApproximation (Just InfixL) 6 6), + (qual "Prelude" "+", FixityApproximation (Just InfixL) 6 6) + ] + it "works for several imports from different packages" $ + checkFixities + ["base", "esqueleto"] + [ import_ "Prelude", + import_ "Database.Esqueleto.Experimental" & qualified_ & as_ "E" + ] + [ (unqual "$", FixityApproximation (Just InfixR) 0 0), + (qual "E" "++.", FixityApproximation (Just InfixR) 5 5), + (qual "E" "on", FixityApproximation (Just InfixN) 9 9) + ] + it "merges approximations in case of a conflict" $ + checkFixities + ["fclabels", "persistent"] + [ import_ "Data.Label.Monadic", + import_ "Database.Persist" + ] + [ (unqual "=.", FixityApproximation (Just InfixR) 2 3) + ] + it "correctly handles package-qualified imports (1)" $ + checkFixities + ["esqueleto"] + [package_ "esqueleto" $ import_ "Database.Esqueleto.Experimental"] + [(unqual "++.", FixityApproximation (Just InfixR) 5 5)] + it "correctly handles package-qualified imports (2)" $ + checkFixities + ["esqueleto"] + [package_ "bob" $ import_ "Database.Esqueleto.Experimental"] + [(unqual "++.", defaultFixityApproximation)] + it "re-exports baked into the database: Control.Lens brings <+~ into scope" $ + checkFixities + ["lens"] + [import_ "Control.Lens"] + [(unqual "<+~", FixityApproximation (Just InfixR) 4 4)] + it "re-exports baked into the database: Control.Lens qualified" $ + checkFixities + ["lens"] + [import_ "Control.Lens" & qualified_] + [ (unqual "<+~", defaultFixityApproximation), + (qual "Control.Lens" "<+~", FixityApproximation (Just InfixR) 4 4) + ] + it "re-exports baked into the database: Control.Lens qualified as" $ + checkFixities + ["lens"] + [import_ "Control.Lens" & qualified_ & as_ "L"] + [ (unqual "<+~", 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.singleton + "Foo" + ((Nothing, "Control.Lens") :| []) + checkFixities + ["lens"] + ( applyModuleReexports + reexports + [import_ "Foo"] + ) + [ (unqual "<+~", FixityApproximation (Just InfixR) 4 4) + ] + +-- | Build a fixity map using the Hoogle database and then check the fixity +-- of the specified subset of operators. +checkFixities :: + -- | List of dependencies + [PackageName] -> + -- | Imports + [FixityImport] -> + -- | Associative list representing a subset of the resulting fixity map + -- that should be checked. + [(RdrName, FixityApproximation)] -> + Expectation +checkFixities dependencies fixityImports expectedResult = + actualResult `shouldBe` expectedResult + where + actualResult = + fmap + (\(k, _) -> (k, inferFixity (Without #debug) k resultMap)) + expectedResult + resultMap = + moduleFixityMap + (packageFixityMap (Set.fromList dependencies)) + fixityImports + +qual :: String -> OpName -> RdrName +qual moduleName opName = mkRdrQual (mkModuleName moduleName) (opNameToOccName opName) + +unqual :: OpName -> RdrName +unqual = mkRdrUnqual . opNameToOccName + +opNameToOccName :: OpName -> OccName +opNameToOccName = mkVarOcc . T.unpack . unOpName + +-- | Explicitly specify the package. +package_ :: PackageName -> FixityImport -> FixityImport +package_ packageName fixityImport = + fixityImport + { fimportPackage = Just packageName + } + +-- | Construct a simple 'FixityImport'. +import_ :: ModuleName -> FixityImport +import_ moduleName = + FixityImport + { fimportPackage = Nothing, + fimportModule = moduleName, + fimportQualified = UnqualifiedAndQualified moduleName, + fimportList = Nothing + } + +-- | Add an alias for an import. +as_ :: ModuleName -> FixityImport -> FixityImport +as_ moduleName fixityImport = + fixityImport + { fimportQualified = case fimportQualified fixityImport of + UnqualifiedAndQualified _ -> UnqualifiedAndQualified moduleName + OnlyQualified _ -> OnlyQualified moduleName + } + +-- | Qualified imports. +qualified_ :: FixityImport -> FixityImport +qualified_ fixityImport = + fixityImport + { fimportQualified = case fimportQualified fixityImport of + UnqualifiedAndQualified m -> OnlyQualified m + OnlyQualified m -> OnlyQualified m + } + +-- | Exact import lists. +exactly_ :: [OpName] -> FixityImport -> FixityImport +exactly_ opNames fixityImports = + fixityImports + { fimportList = Just (Exactly, opNames) + } + +-- | Hiding. +hiding_ :: [OpName] -> FixityImport -> FixityImport +hiding_ opNames fixityImports = + fixityImports + { fimportList = Just (EverythingBut, opNames) + } diff --git a/tests/Ormolu/OpTreeSpec.hs b/tests/Ormolu/OpTreeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Ormolu/OpTreeSpec.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Ormolu.OpTreeSpec (spec) where + +import Data.Choice (pattern Without) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Types.Name (mkOccName, varName) +import GHC.Types.Name.Reader (mkRdrUnqual) +import Ormolu.Fixity +import Ormolu.Fixity.Internal +import Ormolu.Printer.Operators +import Test.Hspec + +n :: Text -> OpTree Text OpName +n = OpNode + +-- | Check that the input tree is actually reassociated as expected. +checkReassociate :: + -- | Fixity map used for the reassociation + [(OpName, FixityInfo)] -> + -- | Input tree + OpTree Text OpName -> + -- | Expected output tree + OpTree Text OpName -> + Expectation +checkReassociate fixities inputTree expectedOutputTree = + removeOpInfo actualOutputTree `shouldBe` expectedOutputTree + where + removeOpInfo (OpNode x) = OpNode x + removeOpInfo (OpBranches exprs ops) = + OpBranches (removeOpInfo <$> exprs) (opiOp <$> ops) + actualOutputTree = reassociateOpTree (Without #debug) convertName modFixityMap inputTree + modFixityMap = ModuleFixityMap (Map.map Given (Map.fromList fixities)) + convertName = Just . mkRdrUnqual . mkOccName varName . T.unpack . unOpName + +spec :: Spec +spec = do + it "flattens a tree correctly" $ do + let inputTree = + OpBranches + [ OpBranches + [OpBranches [n "a", n "b"] ["+"], n "c"] + ["+"], + n "d" + ] + ["+"] + outputTree = + OpBranches [n "a", n "b", n "c", n "d"] ["+", "+", "+"] + fixities = [("+", FixityInfo InfixL 5)] + checkReassociate fixities inputTree outputTree + + it "uses 'minOps' strategy by default" $ do + let inputTree = + OpBranches + [n "a", n "b", n "c", n "d", n "e", n "f"] + ["*", "*", "+", "*", "-"] + outputTree = + OpBranches + [ OpBranches [n "a", n "b", n "c"] ["*", "*"], + OpBranches [n "d", n "e"] ["*"], + n "f" + ] + ["+", "-"] + fixities = + [ ("+", FixityInfo InfixL 5), + ("*", FixityInfo InfixL 7), + ("-", FixityInfo InfixL 5) + ] + checkReassociate fixities inputTree outputTree + + it "uses 'maxOps' strategy if 'minOps' strategy fails" $ do + let inputTree = + OpBranches + [n "a", n "b", n "c", n "d", n "e", n "f"] + ["*", "*", "+", "*", "-"] + outputTree = + OpBranches + [ OpBranches [n "a", n "b", n "c"] ["*", "*"], + OpBranches [n "d", n "e"] ["*"], + n "f" + ] + ["+", "-"] + fixities = + [ ("+", FixityInfo InfixL 5), + ("*", FixityInfo InfixL 8), + ("-", FixityInfo InfixL 5) + ] + checkReassociate fixities inputTree outputTree + + it + "defaults to 'hardSplitter' strategy if both 'minOps' and 'maxOps' \ + \strategies fail" + $ do + let inputTree = + OpBranches + [n "a", n "b", n "c", n "d", n "e", n "f"] + ["@", "@", "|", "@", "$"] + outputTree = + OpBranches + [ OpBranches + [n "a", n "b", n "c", n "d", n "e"] + ["@", "@", "|", "@"], + n "f" + ] + ["$"] + fixities = + [ ("@", FixityInfo InfixL 4), + ("|", FixityInfo InfixL 4), + ("$", FixityInfo InfixR 0) + ] + checkReassociate fixities inputTree outputTree + + it "reassociates correctly: complex example 1" $ do + let inputTree = + OpBranches + [n "f", n "1", n "2", n "3", n "4", n "5", n "6"] + ["$", "+", "*", "$", "*", "+"] + outputTree = + OpBranches + [ n "f", + OpBranches + [n "1", OpBranches [n "2", n "3"] ["*"]] + ["+"], + OpBranches + [OpBranches [n "4", n "5"] ["*"], n "6"] + ["+"] + ] + ["$", "$"] + fixities = + [ ("$", FixityInfo InfixR 0), + ("+", FixityInfo InfixL 6), + ("*", FixityInfo InfixL 7) + ] + checkReassociate fixities inputTree outputTree diff --git a/tests/Ormolu/Parser/OptionsSpec.hs b/tests/Ormolu/Parser/OptionsSpec.hs --- a/tests/Ormolu/Parser/OptionsSpec.hs +++ b/tests/Ormolu/Parser/OptionsSpec.hs @@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Ormolu.Parser.OptionsSpec (spec) where -import qualified Data.Text as T +import Data.Text qualified as T import Ormolu import Test.Hspec @@ -10,7 +11,7 @@ spec = describe "GHC options in source files take priority" $ do it "default extensions can be disabled locally" $ do let src = - unlines + T.unlines [ "{-# LANGUAGE NoBlockArguments #-}", "", "test = test do test" @@ -20,7 +21,7 @@ _ -> False it "extensions disabled via CLI can be enabled locally" $ do let src = - unlines + T.unlines [ "{-# LANGUAGE BlockArguments #-}", "", "test = test do test" @@ -29,4 +30,4 @@ where fixedPoint opts input = do output <- ormolu defaultConfig {cfgDynOptions = DynOption <$> opts} "" input - T.unpack output `shouldBe` input + output `shouldBe` input diff --git a/tests/Ormolu/Parser/ParseFailureSpec.hs b/tests/Ormolu/Parser/ParseFailureSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Ormolu/Parser/ParseFailureSpec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE LambdaCase #-} + +module Ormolu.Parser.ParseFailureSpec (spec) where + +import Ormolu +import Ormolu.Utils (showOutputable) +import System.FilePath +import Test.Hspec + +spec :: Spec +spec = do + "disabling-preserves-error-location.hs" `failsAt` "12:1" + "line-pragma.hs" `failsAt` "4:47" + +failsAt :: String -> String -> Spec +failsAt filename location = + let filePath = baseDir filename + in it (filename ++ " fails at " ++ location) $ + ormoluFile defaultConfig filePath + `shouldThrow` \case + OrmoluParsingFailed srcSpan _ -> + showOutputable srcSpan == filePath ++ ":" ++ location + _ -> False + +baseDir :: FilePath +baseDir = "data" "parse-failures" diff --git a/tests/Ormolu/Parser/PragmaSpec.hs b/tests/Ormolu/Parser/PragmaSpec.hs --- a/tests/Ormolu/Parser/PragmaSpec.hs +++ b/tests/Ormolu/Parser/PragmaSpec.hs @@ -1,5 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} + module Ormolu.Parser.PragmaSpec (spec) where +import Data.Text (Text) +import Data.Text qualified as T import Ormolu.Parser.Pragma import Test.Hspec @@ -20,7 +24,7 @@ stdTest "{-# OPTIONS_GHC foo bar baz #-}" (Just $ PragmaOptionsGHC "foo bar baz") stdTest "{-#OPTIONS_HADDOCK foo, bar, baz #-}" (Just $ PragmaOptionsHaddock "foo, bar, baz") -stdTest :: String -> Maybe Pragma -> Spec +stdTest :: Text -> Maybe Pragma -> Spec stdTest input result = - it input $ + it (T.unpack input) $ parsePragma input `shouldBe` result diff --git a/tests/Ormolu/PrinterSpec.hs b/tests/Ormolu/PrinterSpec.hs --- a/tests/Ormolu/PrinterSpec.hs +++ b/tests/Ormolu/PrinterSpec.hs @@ -1,18 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Ormolu.PrinterSpec (spec) where import Control.Exception import Control.Monad -import Control.Monad.IO.Class import Data.List (isSuffixOf) +import Data.Maybe (isJust) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Data.Text qualified as T +import Data.Text.IO.Utf8 qualified as T.Utf8 import Ormolu +import Ormolu.TestConfig import Path import Path.IO -import qualified System.FilePath as F +import System.Environment (lookupEnv) +import System.FilePath qualified as F import Test.Hspec spec :: Spec @@ -24,40 +27,45 @@ checkExample :: Path Rel File -> Spec checkExample srcPath' = it (fromRelFile srcPath' ++ " works") . withNiceExceptions $ do let srcPath = examplesDir srcPath' + inputPath = fromRelFile srcPath + config = exampleConfig inputPath expectedOutputPath <- deriveOutput srcPath - -- 1. Given input snippet of source code parse it and pretty print it. - -- 2. Parse the result of pretty-printing again and make sure that AST - -- is the same as AST of the original snippet. (This happens in + -- 1. Given an input snippet of source code, parse it and pretty-print it. + -- 2. Parse the result of pretty-printing again and make sure that its AST + -- is the same as the AST of the original snippet. (This happens in -- 'ormoluFile' automatically.) - formatted0 <- ormoluFile defaultConfig (fromRelFile srcPath) - -- 3. Check the output against expected output. Thus all tests should - -- include two files: input and expected output. - -- T.writeFile (fromRelFile expectedOutputPath) formatted0 - expected <- (liftIO . T.readFile . fromRelFile) expectedOutputPath + formatted0 <- ormoluFile config inputPath + -- 3. Check the output against the expected output. Thus all tests should + -- include two files: the input and the expected output. + whenShouldRegenerateOutput $ + T.Utf8.writeFile (fromRelFile expectedOutputPath) formatted0 + expected <- T.Utf8.readFile $ fromRelFile expectedOutputPath shouldMatch False formatted0 expected -- 4. Check that running the formatter on the output produces the same -- output again (the transformation is idempotent). - formatted1 <- ormolu defaultConfig "" (T.unpack formatted0) + formatted1 <- ormolu config "" formatted0 shouldMatch True formatted1 formatted0 --- | Build list of examples for testing. +-- | Build a list of examples for testing. locateExamples :: IO [Path Rel File] locateExamples = filter isInput . snd <$> listDirRecurRel examplesDir --- | Does given path look like input path (as opposed to expected output --- path)? +-- | Does the given path look like an input path (as opposed to an expected +-- output path)? isInput :: Path Rel File -> Bool isInput path = let s = fromRelFile path (s', exts) = F.splitExtensions s - in exts == ".hs" && not ("-out" `isSuffixOf` s') + in exts `elem` [".hs", ".hsig"] && not ("-out" `isSuffixOf` s') --- | For given path of input file return expected name of output. +-- | For the given input file path, return the expected output name. deriveOutput :: Path Rel File -> IO (Path Rel File) deriveOutput path = parseRelFile $ - F.addExtension (F.dropExtensions (fromRelFile path) ++ "-out") "hs" + F.addExtension (radical ++ "-out") exts + where + (radical, exts) = F.splitExtensions (fromRelFile path) -- | A version of 'shouldBe' that is specialized to comparing 'Text' values. -- It also prints multi-line snippets in a more readable form. @@ -79,7 +87,7 @@ examplesDir :: Path Rel Dir examplesDir = $(mkRelDir "data/examples") --- | Inside this wrapper 'OrmoluException' will be caught and displayed +-- | Inside this wrapper, 'OrmoluException' will be caught and displayed -- nicely using 'displayException'. withNiceExceptions :: -- | Action that may throw the exception @@ -89,3 +97,8 @@ where h :: OrmoluException -> IO () h = expectationFailure . displayException + +whenShouldRegenerateOutput :: IO () -> IO () +whenShouldRegenerateOutput action = do + shouldRegenerateOutput <- isJust <$> lookupEnv "ORMOLU_REGENERATE_EXAMPLES" + when shouldRegenerateOutput action diff --git a/tests/Ormolu/TestConfig.hs b/tests/Ormolu/TestConfig.hs new file mode 100644 --- /dev/null +++ b/tests/Ormolu/TestConfig.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The 'Config' that all corpora of test inputs are formatted with. +-- +-- Fixity information affects the shape of operator trees, and therefore +-- both the layout and which AST element claims a comment, so every spec +-- that formats an input file has to agree on it. +module Ormolu.TestConfig + ( exampleConfig, + ) +where + +import Data.Map qualified as Map +import Data.Set qualified as Set +import Ormolu +import Ormolu.Fixity + +-- | The configuration to use for a test input at the given path. +exampleConfig :: FilePath -> Config RegionIndices +exampleConfig inputPath = + defaultConfig + { cfgSourceType = detectSourceType inputPath, + cfgFixityOverrides = testsuiteOverrides, + cfgDependencies = + Set.fromList + [ "base", + "esqueleto", + "hspec", + "lens", + "megaparsec", + "optics", + "relude", + "rio", + "servant" + ] + } + +-- | Fixity overrides that are to be used with the test inputs. +testsuiteOverrides :: FixityOverrides +testsuiteOverrides = + FixityOverrides + ( Map.fromList + [ (".=", FixityInfo InfixR 8), + ("#", FixityInfo InfixR 5), + (">~<", FixityInfo InfixR 3), + ("|~|", FixityInfo InfixR 3.3), + ("<~>", FixityInfo InfixR 3.7) + ] + )