packages feed

hindent 5.3.4 → 6.3.0

raw patch · 172 files changed

Files

BENCHMARKS.md view
@@ -3,6 +3,8 @@ Bunch of declarations  ``` haskell+{-# LANGUGAE QuasiQuotes #-}+ listPrinters =   [(''[]    ,\(typeVariable:_) _automaticPrinter ->@@ -59,6 +61,8 @@ Bunch of declarations - sans comments  ``` haskell+{-# LANGUGAE QuasiQuotes #-}+ listPrinters =   [(''[]    ,\(typeVariable:_) _automaticPrinter ->@@ -116,6 +120,8 @@ Quasi-quotes with nested lets and operators  ``` haskell+{-# LANGUGAE QuasiQuotes #-}+ quasiQuotes =   [(''[]    ,\(typeVariable:_) _automaticPrinter ->
CHANGELOG.md view
@@ -1,136 +1,505 @@-5.3.0:-    * Handle multiple deriving clauses in a DerivingStrategies scenario-    * Ignore non-files in findCabalFiles-    * Allow batch processing of multiple files-    * Prevent hindent from trying to open non-files when searching for-      .cabal files-    * Specify default extensions in configuration file-    * Fix bad output for [p|Foo|] pattern quasi-quotes-    * Parse C preprocessor line continuations-    * Fix pretty printing of '(:)-    * Add parens around symbols (:|) when required-    * Support $p pattern splices-    * Fix associated type families-    * Non-dependent record constructor formatting+# Changelog -5.2.7:-    * Fix -X option bug+## [Unreleased] -5.2.6:-    * Switch to optparse-applicative+### Added -5.2.5:+### Changed -    * Support get extensions from `.cabal` file-    * Improve indention with record constructions and updates-    * Fix `let ... in` bug-    * Fix top-level lambda expressions in TemplateHaskell slices-    * Update to haskell-src-exts dependency to version `>= 1.20.0`+### Fixed -5.2.4:+### Removed -    * Pretty print imports-    * Fix pretty print for string literals for `DataKinds`-    * Support `--validate` option for checking the format without reformatting-    * Support parse `#include`, `#error`, `#warning` directives-    * Support read `LANGUAGE` pragma and parse the declared extensions from source-    * Treat `TypeApplications` extension as 'badExtensions' due to the `@` symbol-    * Improve pretty print for unboxed tuples-    * Fix many issues related to infix operators, includes TH name quotes,-      `INLINE`/`NOINLINE` pragmas, infix type operator and infix constructor-    * Fix pretty print for operators in `INLINE`/`NOINLINE` pragmas-    * Support for `EmptyCases` extension-    * Fix TH name quotes on operator names-    * Optimize pretty print for many fundeps-    * Fix extra linebreaks after short identifiers+## [6.3.0] - 2026-01-24 -5.2.3:+### Added -    * Sort explicit import lists-    * Report the `SrcLoc` when there's a parse error-    * Improve long type signatures pretty printing-    * Support custom line-break operators, add `--line-breaks` argument-    * Fix infix data constructor-    * Disable `RecursiveDo` and `DoRec` extensions by default-    * Add RecStmt support-    * Improve GADT records, data declaration records-    * Complicated type alias and type signatures pretty printing-    * Fix quasi-quoter names+- Support for GHC 9.12 ([#1000])+- Support for GHC2024 ([#1040])+- Support for linear types ([#1077]) -5.2.2:+### Changed -    * Parallel list comprehensions-    * Leave do, lambda, lambda-case on previous line of $-    * Misc fixes+- Unified `where` clause formatting and respect `configIndentSpaces` for bindings ([#1118])+- `hindent-mode`: Show an error string on any return code that's not 0 ([#1096])+- `hindent-mode`: The `hindent-extra-args` variable may now be a function ([#1096]) -5.2.1:+### Fixed -    * Fix hanging on large constraints-    * Render multi-line comments-    * Rename --tab-size to --indent-size-    * Don't add a spurious space for comments at the end of the file-    * Don't add trailing whitespace on <--    * Disable PatternSynonyms-    * Put a newline before the closing bracket on a list+- Template Haskell functions no longer get unwanted '$' symbols prepended ([#1033])+- Default method signatures with constraints are now properly indented ([#1042])+- Fix formatting of associated data families in type classes ([#1051])+- Kind signatures and deriving clauses in GADTs are now properly printed ([#1053])+- Visible forall (`forall a ->`) is now correctly formatted instead of being converted to invisible forall ([#1060])+- Keep `where` clauses that contain implicit parameter bindings ([#1121])+- Keep `as Foo` module aliases also with unqualified modules ([#1140])+- Preserve default associated type families in classes instead of dropping them ([#1143]) -5.2.0:+## [6.2.1] - 2024-11-28 -    * Default tab-width is now 2-    * Supports .hindent.yaml file to specify alt tab-width and max-      column-    * Put last paren of export list on a new line-    * Implement tab-size support in Emacs Lisp+### Removed -5.1.1:+- Support for GHC 9.0 ([#967]) -    * Preserve spaces between groups of imports (fixes #200)-    * Support shebangs (closes #208)-    * Output filename for parse errors (fixes #179)-    * Input with newline ends with newline (closes #211)-    * Document -X (closes #212)-    * Fix explicit forall in instances (closes #218)-    * Put last paren of export list on a new line #227+## [6.2.0] - 2024-09-07 -5.1.0:+### Added -    * Rewrote comment association, more reliable-    * Added --tab-size flag for indentation spaces-    * Fixed some miscellaneous bugs+- Support for GHC 9.8 ([#775]) and GHC 9.10([#904]).+- Support for `ImportPostQualified` ([#875]).+- HIndent now formats multiple files in parallel ([#914]). -5.0.1:+### Changed -    * Re-implement using bytestring instead of text-    * Made compatible with GHC 7.8 through to GHC 8.0-    * Added test suite and benchmarks in TESTS.md and BENCHMARKS.md+- The formatting style of import declarations with constructors ([#829]).+- HIndent no longer inserts an empty line after a standalone kind signature ([#873]).+- Bumped Stack LTS to 22.26 ([#918]).+- HIndent re-assumes the default extensions are enabled ([#904]). -5.0.0:+### Fixed -	* Drop support for styles+- Wrong default HIndent configuration in [`README.md`] ([#750]).+- Fix the bug of panicking when the given source code has CPP lines and space-prefixed lines ([#780]).+- Fix not pretty-printing multiple signatures in a `SPECIALISE` ([#784]).+- Fix the bug of not pretty-printing multiple module-level warning messages ([#822])+- Fix the bug of wrongly converting a `newtype` instance to a `data` one ([#839])+- Fix the bug of not pretty-printing multiple functional dependencies in a typeclass ([#843])+- Fix the bug of not pretty-printing data declarations with records and typeclass constraints ([#849])+- Fix the bug of not pretty-printing unboxed tuples ([#868]) -4.6.4+### Removed -	* Copy/delete file instead of renaming+- Support for GHC 8.10 ([#950]) -4.4.6+## [6.1.0] - 2023-05-17 -	* Fix whole module printer-	* Accept a filename to reformat+### Added -4.4.5+- Support for GHC 9.6 ([#699])+- The `hindent` function for easy use within a project ([#709]). -	* Fix bug in infix patterns+### Changed -4.4.2+- `reformat` now takes a list of `Extension`s instead of a `Maybe` value containing the list ([#712]).+- `reformat` and `testAst` now return a `ParseError` on error ([#715]).+- `reformat` now returns the formatted code as a `ByteString` instead of a `Builder`. ([#720]).+- HIndent now assumes no extensions are enabled by default ([#728]).+- All modules except for `HIndent` are now private, and the minimum necessary definitions are exposed from the module ([#729]).+- HIndent now prints all `do` expressions in a unified style  ([#739]).+- HIndent now formats operators based on their fixities ([#741], [#742]). -	* Bunch of Gibiansky style fixes.-	* Support CPP.-	* Tibell style fixes.+### Fixed -4.3.8+- Fixed module names being removed from uses of qualified `do` ([#696]).+- Misplaced haddocks for class declarations ([#706]).+- Misplaced comments in do expressions ([#707]).+- Misplaced comments in case expressions  ([#708]).+- The bug of extensions specified via pragmas not enabling implied ones ([#727]).+- Language extensions enabled via pragmas were not effective across CPP boundaries ([#731]). -	* Fixed: bug in printing operators in statements.+### Removed -4.5.4+- `HIndent.LanguageExtension.defaultExtensions` ([#728])+- `HIndent.LanguageExtension.allExtensions` ([#728]) -	* Improvements to Tibell style.-	* 6x speed up on rendering operators.+## [6.0.0] - 2023-02-20++### Added++- The getConfig function is exported.++### Changed++- Switched the parser from [`haskell-src-exts`] to [`ghc-lib-parser`].+  This switch causes changes in the formatting results in some cases.+- Changed how to format a data type with a record constructor to follow+  the [Johan Tibell's Haskell Style Guide]. ([#662]).+- A newline is no longer inserted after a pattern signature ([#663]).+- A type with many type applications are now broken into multiple lines.+  ([#664]).+- A long type-level list is broken into multiple lines. ([#665]).+- Spaces around typed expression brackets are removed ([#666]).+- HIndent no longer breaks short class constraints in function signautres into+  multiple lines ([#669]).++### Fixed++- Fixed the wrong formatting of data family instances inside class instances+  ([#667]).+- Fixed the bug of removing the space before the enclosing parenthesis of a+  record syntax in a signature in a GADT declaration ([#670]).+- Fixed the bug of inserting unnecessary empty lines if a file contains only+  comments ([#672]).++### Removed++- Test functions except `testAst`.+- Atom support ([#671]).++## [5.3.4] - 2022-07-07++This version is accidentally pushlished, and is the same as 5.3.3.++## [5.3.3] - 2022-07-07++### Added++- Support for GHC 9.2.2.+- Test CI with GitHub Actions (WIP).++### Fixed++- Fixed a broken link to Servant by [@mattfbacon] in [#579].+- Fixed a build with Cabal 3.6 by [@uhbif19] in [#584].+- Fixed a compile error for GHC 9.2.2 by [@toku-sa-n] in [#588].++## [5.3.2] - 2022-02-02++### Fixed++- `MonadFix` issues to support newer GHC versions.++## [5.3.1] - 2019-06-28++### Fixed++- Comment relocations in where clauses of top-level function declarations.++## [5.3.0] - 2019-04-29++### Added++- Allow batch processing of multiple files.+- You can now specify default extensions in the configuration file.++### Fixed++- Handle multiple deriving clauses in the `DerivingStrategies` scenario.+- Ignore non-files in `findCabalFiles`.+- Prevent HIndent from trying to open non-files when searching for `.cabal` files.+- Fix the bad output for `[p|Foo|]` pattern quasi-quotes.+- Fix pretty-printing of `'(:)`.+- Fix parsing C preprocessor line continuations.+- Add parentheses around symbols `(:|)` when required.+- Support `$p` pattern splices.+- Fix formatting of associated type families.+- Fix formatting of non-dependent record constructors.++## [5.2.7] - 2019-03-16++### Fixed++- A bug in the `-X` option++## [5.2.6] - 2019-03-16++### Changed++- Switched to [`optparse-applicative`].++## [5.2.5] - 2018-01-04++### Added++- Support getting extensions from a `.cabal` file++### Changed++- Improved the indentation with record constructions and updates+- Updated [`haskell-src-exts`] dependency to version `>= 1.20.0`++### Fixed++- Fix the `let ... in` bug+- Fix formatting top-level lambda expressions in `TemplateHaskell` slices++## [5.2.4] - 2017-10-20++### Added++- Improved pretty-printing unboxed tuples.+- Support the `--validate` option for checking the format without reformatting+- Support parsing `#include`, `#error`, and `#warning` directives.+- Support reading `LANGUAGE` pragmas and parse the declared extensions from sources.+- Support the `EmptyCases` extension+- Optimize pretty-printing for many functional dependencies.++### Changed++- The `TypeApplications` extension is now disabled-by-default due to the `@` symbol++### Fixed++- Fixed pretty-printing imports+- Fixed pretty-printing string literals for `DataKinds`+- Fixed many issues related to infix operators including TH name quotes,+  `INLINE`/`NOINLINE` pragmas, infix type operators, and infix constructors.+- Fix extra linebreaks after short identifiers.++## [5.2.3] - 2017-05-07++### Added++- HIndent now reports where a parse happened.+- Added `--line-breaks` parameter to support custom line breaks.+- Added the `RecStmt` support++### Changed++- Explicit import lists are now sorted.+- Improved pretty-printing long type signatures.+- Improved pretty-printing GADT records.+- Improved pretty-printing data declaration records.+- The `RecursiveDo` and `DoRec` extensions are now disabled-by-default.++## Fixed++- Fixed pretty-printing for infix data constructors.+- Fixed pretty-printing of quasi-quoter names.+- Fixed pretty-printing of complicated type aliases.+- Fixed pretty-printing of complicated type signatures.++## [5.2.2] - 2017-01-16++### Changed++- HIndent now leaves `do`, lambda (`\x->`), and lambda-case (`\case->`) on the previous line of `$`.++### Fixed++- Fixed pretty-printing of parallel list comprehensions.+- Miscellaneous fixes.++## [5.2.1] - 2016-09-01++### Changed++- The `--tab-size` option is renamed to `--indent-size`.+- The `PatternSynonyms` extension is now disabled by default.+- HIndent now puts a newline before the closing bracket on a list.++### Fixed++- Fixed handling of paragraph overhang when using large constraints.+- Fixed pretty-printing of multi-line comments.+- Fixed bug resulting in adding a spurious space for comments at the end of a file.+- Fixed bug which results in adding a trailing white space on `<-`++## [5.2.0] - 2016-08-30++### Added++- Support the `.hindent.yaml` file to specify alternative tab width and max+  column numbers.+- Implement the tab-size support in Emacs Lisp.++### Changed++- The default number of spaces for a tab is changed to 2.++## [5.1.1] - 2016-08-29++### Added++- Add shebang support (Fixes [#208]).+- Output the filename for parse errors (Fixes [#179]).+- Added a document of the `-X` option (Fixes [#212]).++### Changed++- HIndent now preserves spaces between groups of imports (Fixes [#200]).+- HIndent now preserves the last newline if the input ends with one (Fixes [#211]).+- HIndent now puts the last parenthesis of an export list on a new line (Fixes [#227]).++### Fixed++- Fixed pretty-printing explicit `forall`s in instances (Fixes [#218]).++## [5.1.0] - 2016-08-25++### Added++- Add `--tab-size` parameter to control indentation spaces.++### Changed++- Rewrote comment association for more reliability.++### Fixed++- Some miscellaneous bugs.++## [5.0.1] - 2016-08-20++### Added++- Made HIndent compatible with GHC 7.8 through GHC 8.0+- Added test suites and benchmarks in [`TESTS.md`] and [`BENCHMARKS.md`]++### Changed++- Re-implement using [`bytestring`] instead of [`text`]++## [5.0.0] - 2016-08-11++### Removed++- Support for styles++## [4.6.4] - 2016-07-15++### Changed++- The formatted file is now created by coping/deleting a file instead of renaming.++## [4.6.3] - 2016-04-18++### Added++- Accept a filename to reformat.++### Fixed++- Fixed the whole module printer.++## [4.5.4] - 2015-06-22++### Added++- Improvements to Tibell style.+- 6x speed up on rendering operators.++## [4.4.5] - 2015-11-10++### Fixed++- Fixed a bug in infix patterns.++## [4.4.2] - 2015-04-05++### Added++- Support for CPP.++### Fixed++- Bunch of Gibiansky style bugs.+- Tibell style bugs.++## [4.3.8] - 2015-02-06++### Fixed++- A bug in printing operators in statements.++[unreleased]: https://github.com/mihaimaruseac/hindent/compare/v6.3.0...HEAD+[6.3.0]: https://github.com/mihaimaruseac/hindent/compare/v6.2.1...v6.3.0+[6.2.1]: https://github.com/mihaimaruseac/hindent/compare/v6.2.0...v6.2.1+[6.2.0]: https://github.com/mihaimaruseac/hindent/compare/v6.1.0...v6.2.0+[6.1.0]: https://github.com/mihaimaruseac/hindent/compare/v6.0.0...v6.1.0+[6.0.0]: https://github.com/mihaimaruseac/hindent/compare/v5.3.4...v6.0.0+[5.3.4]: https://github.com/mihaimaruseac/hindent/compare/v5.3.3...v5.3.4+[5.3.3]: https://github.com/mihaimaruseac/hindent/compare/v5.3.2...v5.3.3+[5.3.2]: https://github.com/mihaimaruseac/hindent/compare/5.3.1...v5.3.2+[5.3.1]: https://github.com/mihaimaruseac/hindent/compare/5.3.0...5.3.1+[5.3.0]: https://github.com/mihaimaruseac/hindent/compare/5.2.7...5.3.0+[5.2.7]: https://github.com/mihaimaruseac/hindent/compare/5.2.6...5.2.7+[5.2.6]: https://github.com/mihaimaruseac/hindent/compare/5.2.5...5.2.6+[5.2.5]: https://github.com/mihaimaruseac/hindent/compare/5.2.4...5.2.5+[5.2.4]: https://github.com/mihaimaruseac/hindent/compare/5.2.3...5.2.4+[5.2.3]: https://github.com/mihaimaruseac/hindent/compare/5.2.2...5.2.3+[5.2.2]: https://github.com/mihaimaruseac/hindent/compare/5.2.1...5.2.2+[5.2.1]: https://github.com/mihaimaruseac/hindent/compare/5.2.0...5.2.1+[5.2.0]: https://github.com/mihaimaruseac/hindent/compare/5.1.1...5.2.0+[5.1.1]: https://github.com/mihaimaruseac/hindent/compare/5.1.0...5.1.1+[5.1.0]: https://github.com/mihaimaruseac/hindent/compare/5.0.1...5.1.0+[5.0.1]: https://github.com/mihaimaruseac/hindent/compare/5.0.0...5.0.1+[5.0.0]: https://github.com/mihaimaruseac/hindent/compare/4.6.4...5.0.0+[4.6.4]: https://github.com/mihaimaruseac/hindent/compare/4.6.3...4.6.4+[4.6.3]: https://github.com/mihaimaruseac/hindent/compare/4.6.2...4.6.3+[4.5.4]: https://github.com/mihaimaruseac/hindent/compare/4.5.3...4.5.4+[4.4.5]: https://github.com/mihaimaruseac/hindent/compare/4.4.4...4.4.5+[4.4.2]: https://github.com/mihaimaruseac/hindent/compare/4.4.1...4.4.2+[4.3.8]: https://github.com/mihaimaruseac/hindent/compare/4.3.7...4.3.8++[@mattfbacon]: https://github.com/mattfbacon+[@uhbif19]: https://github.com/uhbif19+[@toku-sa-n]: https://github.com/toku-sa-n++[#1143]: https://github.com/mihaimaruseac/hindent/pull/1143+[#1140]: https://github.com/mihaimaruseac/hindent/pull/1140+[#1121]: https://github.com/mihaimaruseac/hindent/pull/1121+[#1096]: https://github.com/mihaimaruseac/hindent/pull/1096+[#1077]: https://github.com/mihaimaruseac/hindent/pull/1077+[#1060]: https://github.com/mihaimaruseac/hindent/pull/1060+[#1053]: https://github.com/mihaimaruseac/hindent/pull/1053+[#1051]: https://github.com/mihaimaruseac/hindent/pull/1051+[#1042]: https://github.com/mihaimaruseac/hindent/pull/1042+[#1040]: https://github.com/mihaimaruseac/hindent/pull/1040+[#1033]: https://github.com/mihaimaruseac/hindent/pull/1033+[#1000]: https://github.com/mihaimaruseac/hindent/pull/1000+[#967]: https://github.com/mihaimaruseac/hindent/pull/967+[#950]: https://github.com/mihaimaruseac/hindent/pull/950+[#918]: https://github.com/mihaimaruseac/hindent/pull/918+[#914]: https://github.com/mihaimaruseac/hindent/pull/914+[#904]: https://github.com/mihaimaruseac/hindent/pull/904+[#875]: https://github.com/mihaimaruseac/hindent/pull/875+[#873]: https://github.com/mihaimaruseac/hindent/pull/873+[#868]: https://github.com/mihaimaruseac/hindent/pull/868+[#849]: https://github.com/mihaimaruseac/hindent/pull/849+[#843]: https://github.com/mihaimaruseac/hindent/pull/843+[#839]: https://github.com/mihaimaruseac/hindent/pull/839+[#829]: https://github.com/mihaimaruseac/hindent/pull/829+[#822]: https://github.com/mihaimaruseac/hindent/pull/822+[#784]: https://github.com/mihaimaruseac/hindent/pull/784+[#780]: https://github.com/mihaimaruseac/hindent/pull/780+[#775]: https://github.com/mihaimaruseac/hindent/pull/775+[#750]: https://github.com/mihaimaruseac/hindent/pull/750+[#742]: https://github.com/mihaimaruseac/hindent/pull/742+[#741]: https://github.com/mihaimaruseac/hindent/pull/741+[#739]: https://github.com/mihaimaruseac/hindent/pull/739+[#731]: https://github.com/mihaimaruseac/hindent/pull/731+[#729]: https://github.com/mihaimaruseac/hindent/pull/729+[#728]: https://github.com/mihaimaruseac/hindent/pull/728+[#727]: https://github.com/mihaimaruseac/hindent/pull/727+[#720]: https://github.com/mihaimaruseac/hindent/pull/720+[#715]: https://github.com/mihaimaruseac/hindent/pull/715+[#712]: https://github.com/mihaimaruseac/hindent/pull/712+[#709]: https://github.com/mihaimaruseac/hindent/pull/709+[#708]: https://github.com/mihaimaruseac/hindent/pull/708+[#707]: https://github.com/mihaimaruseac/hindent/pull/707+[#706]: https://github.com/mihaimaruseac/hindent/pull/706+[#699]: https://github.com/mihaimaruseac/hindent/pull/699+[#696]: https://github.com/mihaimaruseac/hindent/pull/696+[#672]: https://github.com/mihaimaruseac/hindent/pull/672+[#671]: https://github.com/mihaimaruseac/hindent/pull/671+[#670]: https://github.com/mihaimaruseac/hindent/pull/670+[#669]: https://github.com/mihaimaruseac/hindent/pull/669+[#667]: https://github.com/mihaimaruseac/hindent/pull/667+[#666]: https://github.com/mihaimaruseac/hindent/pull/666+[#665]: https://github.com/mihaimaruseac/hindent/pull/665+[#664]: https://github.com/mihaimaruseac/hindent/pull/664+[#663]: https://github.com/mihaimaruseac/hindent/pull/663+[#662]: https://github.com/mihaimaruseac/hindent/pull/662+[#588]: https://github.com/mihaimaruseac/hindent/pull/588+[#584]: https://github.com/mihaimaruseac/hindent/pull/584+[#579]: https://github.com/mihaimaruseac/hindent/pull/579+[#227]: https://github.com/mihaimaruseac/hindent/pull/227+[#218]: https://github.com/mihaimaruseac/hindent/pull/218+[#212]: https://github.com/mihaimaruseac/hindent/pull/212+[#211]: https://github.com/mihaimaruseac/hindent/pull/211+[#208]: https://github.com/mihaimaruseac/hindent/pull/208+[#200]: https://github.com/mihaimaruseac/hindent/pull/200+[#179]: https://github.com/mihaimaruseac/hindent/pull/179++[`haskell-src-exts`]: https://hackage.haskell.org/package/haskell-src-exts+[`ghc-lib-parser`]: https://hackage.haskell.org/package/ghc-lib-parser+[`optparse-applicative`]: https://hackage.haskell.org/package/optparse-applicative+[`bytestring`]: https://hackage.haskell.org/package/bytestring+[`text`]: https://hackage.haskell.org/package/text++[`TESTS.md`]: TESTS.md+[`BENCHMARKS.md`]: BENCHMARKS.md+[`README.md`]: README.md++[Johan Tibell's Haskell Style Guide]: https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md
LICENSE.md view
@@ -1,4 +1,6 @@ Copyright (c) 2014, Chris Done+Copyright (c) 2015, Andrew Gibiansky+Copyright (c) 2021, Mihai Maruseac  All rights reserved.
README.md view
@@ -1,4 +1,4 @@-# hindent [![Hackage](https://img.shields.io/hackage/v/hindent.svg?style=flat)](https://hackage.haskell.org/package/hindent) ![CI (Stack)](https://github.com/mihaimaruseac/hindent/workflows/CI%20(Stack)/badge.svg) ![CI (Cabal)](https://github.com/mihaimaruseac/hindent/workflows/CI%20(Cabal)/badge.svg)+# hindent [![Hackage](https://img.shields.io/hackage/v/hindent.svg?style=flat)](https://hackage.haskell.org/package/hindent) [![Haskell Cabal](https://github.com/mihaimaruseac/hindent/actions/workflows/presubmit-cabal.yaml/badge.svg)](https://github.com/mihaimaruseac/hindent/actions/workflows/presubmit-cabal.yaml) [![Haskell Stack](https://github.com/mihaimaruseac/hindent/actions/workflows/presubmit-stack.yaml/badge.svg)](https://github.com/mihaimaruseac/hindent/actions/workflows/presubmit-stack.yaml) [![OpenSSF Scorecard](https://api.securityscorecards.dev/projects/github.com/mihaimaruseac/hindent/badge)](https://api.securityscorecards.dev/projects/github.com/mihaimaruseac/hindent)  Haskell pretty printer @@ -11,13 +11,26 @@ ## Usage      $ hindent --help-    hindent --version --help --style STYLE --line-length <...> --indent-size <...> --no-force-newline [-X<...>]* [<FILENAME>]-    Version 5.1.1-    Default --indent-size is 2. Specify --indent-size 4 if you prefer that.-    -X to pass extensions e.g. -XMagicHash etc.-    The --style option is now ignored, but preserved for backwards-compatibility.-    Johan Tibell is the default and only style.+    hindent - Reformat Haskell source code +    Usage: hindent [--version | [--line-length ARG]+                     [--indent-size ARG | --tab-size ARG] [--no-force-newline]+                     [--sort-imports | --no-sort-imports] [--style STYLE]+                     [-X GHCEXT] [--validate] [FILENAMES]]++    Available options:+      --version                Print the version+      --line-length ARG        Desired length of lines (default: 80)+      --indent-size ARG        Indentation size in spaces (default: 2)+      --tab-size ARG           Same as --indent-size, for compatibility+      --no-force-newline       Don't force a trailing newline+      --sort-imports           Sort imports in groups+      --no-sort-imports        Don't sort imports+      --style STYLE            Style to print with (historical, now ignored)+      -X GHCEXT                Language extension+      --validate               Check if files are formatted without changing them+      -h,--help                Show this help text+ hindent is used in a pipeline style      $ cat path/to/sourcefile.hs | hindent@@ -43,11 +56,12 @@ indent-size: 2 line-length: 80 force-trailing-newline: true-line-breaks: [":>", ":<|>"]-extensions:-  - DataKinds-  - GADTs-  - TypeApplications+sort-imports: true+line-breaks: []+extensions: [+    "GHC2021",+    "ListTuplePuns",+] ```  By default, hindent preserves the newline or lack of newline in your input. With `force-trailing-newline`, it will make sure there is always a trailing newline.@@ -109,16 +123,10 @@ [vim-hindent](https://github.com/alx741/vim-hindent) plugin which runs hindent automatically when a Haskell file is saved. -## Atom--Fortunately, you can use https://atom.io/packages/ide-haskell with the-path to hindent specified instead of that to stylish-haskell. Works-like a charm that way!- ## IntelliJ / other JetBrains IDEs 1. Install the "HaskForce" Haskell plugin (this is so we get the language type recognized in the file watcher) 2. Install the "File Watchers" plugin under "Browse Repositories"-3. Add a File Watcher with +3. Add a File Watcher with     1. File type: Haskell Language     2. Program: `/path/to/hindent`     3. Arguments: `$FilePath$`
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
TESTS.md view
@@ -1,1808 +1,3714 @@-# Introduction--This file is a test suite. Each section maps to an HSpec test, and-each line that is followed by a Haskell code fence is tested to make-sure re-formatting that code snippet produces the same result.--You can browse through this document to see what HIndent's style is-like, or contribute additional sections to it, or regression tests.--# Modules--Empty module--``` haskell-```--Double shebangs--``` haskell-#!/usr/bin/env stack-#!/usr/bin/env stack-main = pure ()-```--Extension pragmas--```haskell-{-# LANGUAGE TypeApplications #-}--fun @Int 12-```--Module header--``` haskell-module X where--x = 1-```--Exports--``` haskell-module X-  ( x-  , y-  , Z-  , P(x, z)-  ) where-```--Exports, indentation 4--``` haskell 4-module X-    ( x-    , y-    , Z-    , P(x, z)-    ) where-```--# Imports--Import lists--``` haskell-import Data.Text-import Data.Text-import qualified Data.Text as T-import qualified Data.Text (a, b, c)-import Data.Text (a, b, c)-import Data.Text hiding (a, b, c)-```--Sorted--```haskell given-import B-import A-```--```haskell expect-import A-import B-```--Explicit imports - capitals first (typeclasses/types), then operators, then identifiers--```haskell given-import qualified MegaModule as M ((>>>), MonadBaseControl, void, MaybeT(..), join, Maybe(Nothing, Just), liftIO, Either, (<<<), Monad(return, (>>=), (>>)))-```--```haskell expect-import qualified MegaModule as M-  ( Either-  , Maybe(Just, Nothing)-  , MaybeT(..)-  , Monad((>>), (>>=), return)-  , MonadBaseControl-  , (<<<)-  , (>>>)-  , join-  , liftIO-  , void-  )-```--Pretty import specification--```haskell-import A hiding-  ( foobarbazqux-  , foobarbazqux-  , foobarbazqux-  , foobarbazqux-  , foobarbazqux-  , foobarbazqux-  , foobarbazqux-  )--import Name hiding ()--import {-# SOURCE #-} safe qualified Module as M hiding (a, b, c, d, e, f)-```--# Declarations--Type declaration--``` haskell-type EventSource a = (AddHandler a, a -> IO ())-```--Type declaration with infix promoted type constructor--```haskell-fun1 :: Def ('[ Ref s (Stored Uint32), IBool] 'T.:-> IBool)-fun1 = undefined--fun2 :: Def ('[ Ref s (Stored Uint32), IBool] ':-> IBool)-fun2 = undefined-```--Instance declaration without decls--``` haskell-instance C a-```--Instance declaration with decls--``` haskell-instance C a where-  foobar = do-    x y-    k p-```--Symbol class constructor in instance declaration--```haskell-instance Bool :?: Bool--instance (:?:) Int Bool-```--GADT declarations--```haskell-data Ty :: (* -> *) where-  TCon-    :: { field1 :: Int-       , field2 :: Bool}-    -> Ty Bool-  TCon' :: (a :: *) -> a -> Ty a-```--# Expressions--Lazy patterns in a lambda--``` haskell-f = \ ~a -> undefined--- \~a yields parse error on input ‘\~’-```--Bang patterns in a lambda--``` haskell-f = \ !a -> undefined--- \!a yields parse error on input ‘\!’-```--List comprehensions, short--``` haskell-map f xs = [f x | x <- xs]-```--List comprehensions, long--``` haskell-defaultExtensions =-  [ e-  | EnableExtension {extensionField1 = extensionField1} <--      knownExtensions knownExtensions-  , let a = b-    -- comment-  , let c = d-    -- comment-  ]-```--List comprehensions with operators--```haskell-defaultExtensions =-  [e | e@EnableExtension {} <- knownExtensions] \\-  map EnableExtension badExtensions-```--Parallel list comprehension, short--```haskell-zip xs ys = [(x, y) | x <- xs | y <- ys]-```--Parallel list comprehension, long--```haskell-fun xs ys =-  [ (alphaBetaGamma, deltaEpsilonZeta)-  | x <- xs-  , z <- zs-  | y <- ys-  , cond-  , let t = t-  ]-```--Record, short--``` haskell-getGitProvider :: EventProvider GitRecord ()-getGitProvider =-  EventProvider {getModuleName = "Git", getEvents = getRepoCommits}-```--Record, medium--``` haskell-commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event-commitToEvent gitFolderPath timezone commit =-  Event.Event-    {pluginName = getModuleName getGitProvider, eventIcon = "glyphicon-cog"}-```--Record, long--``` haskell-commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event-commitToEvent gitFolderPath timezone commit =-  Event.Event-    { pluginName = getModuleName getGitProvider-    , eventIcon = "glyphicon-cog"-    , eventDate = localTimeToUTC timezone (commitDate commit)-    }-```--Record with symbol constructor--```haskell-f = (:..?) {}-```--Record with symbol field--```haskell-f x = x {(..?) = wat}--g x = Rec {(..?)}-```--Cases--``` haskell-strToMonth :: String -> Int-strToMonth month =-  case month of-    "Jan" -> 1-    "Feb" -> 2-    _ -> error $ "Unknown month " ++ month-```--Operators, bad--``` haskell-x =-  Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*>-  Just thisissolong <*>-  Just stilllonger <*>-  evenlonger-```--Operators, good--```haskell pending-x =-  Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*>-  Just thisissolong <*> Just stilllonger <*> evenlonger-```--Operator with `do`--```haskell-for xs $ do-  left x-  right x-```--Operator with lambda--```haskell-for xs $ \x -> do-  left x-  right x-```--Operator with lambda-case--```haskell-for xs $ \case-  Left x -> x-```--Operator in parentheses--```haskell-cat = (++)-```--Symbol data constructor in parentheses--```haskell-cons = (:)--cons' = (:|)-```--n+k patterns--``` haskell-f (n+5) = 0-```--Binary symbol data constructor in pattern--```haskell-f (x :| _) = x--f' ((:|) x _) = x--f'' ((Data.List.NonEmpty.:|) x _) = x--g (x:xs) = x--g' ((:) x _) = x-```--Type application--```haskell-{-# LANGUAGE TypeApplications #-}--fun @Int 12-```--Transform list comprehensions--```haskell-list =-  [ (x, y, map the v)-  | x <- [1 .. 10]-  , y <- [1 .. 10]-  , let v = x + y-  , then group by v using groupWith-  , then take 10-  , then group using permutations-  , t <- concat v-  , then takeWhile by t < 3-  ]-```--Type families--```haskell-type family Id a-```--Type family annotations--``` haskell-type family Id a :: *-```--Type family instances--```haskell-type instance Id Int = Int-```--Type family dependencies--```haskell-type family Id a = r | r -> a-```--Binding implicit parameters--```haskell-f =-  let ?x = 42-   in f-```--Closed type families--```haskell-type family Closed (a :: k) :: Bool where-  Closed x = 'True-```--# Template Haskell--Expression brackets--```haskell-add1 x = [|x + 1|]-```--Pattern brackets--```haskell-mkPat = [p|(x, y)|]-```--Type brackets--```haskell-foo :: $([t|Bool|]) -> a-```--Quoted data constructors--```haskell-cons = '(:)-```--Pattern splices--```haskell-f $pat = ()--g =-  case x of-    $(mkPat y z) -> True-    _ -> False-```--# Type signatures--Long argument list should line break--```haskell-longLongFunction ::-     ReaderT r (WriterT w (StateT s m)) a-  -> StateT s (WriterT w (ReaderT r m)) a-```--Class constraints should leave `::` on same line--``` haskell--- see https://github.com/chrisdone/hindent/pull/266#issuecomment-244182805-fun ::-     (Class a, Class b)-  => fooooooooooo bar mu zot-  -> fooooooooooo bar mu zot-  -> c-```--Class constraints--``` haskell-fun :: (Class a, Class b) => a -> b -> c-```--Symbol class constructor in class constraint--```haskell-f :: (a :?: b) => (a, b)-f' :: ((:?:) a b) => (a, b)-```--Tuples--``` haskell-fun :: (a, b, c) -> (a, b)-```--Quasiquotes in types--```haskell-fun :: [a|bc|]-```--Default signatures--```haskell--- https://github.com/chrisdone/hindent/issues/283-class Foo a where-  bar :: a -> a -> a-  default bar :: Monoid a =>-    a -> a -> a-  bar = mappend-```--Implicit parameters--```haskell-f :: (?x :: Int) => Int-```--Symbol type constructor--```haskell-f :: a :?: b-f' :: (:?:) a b-```--Promoted list (issue #348)--```haskell-a :: A '[ 'True]-a = undefined---- nested promoted list with multiple elements.-b :: A '[ '[ 'True, 'False], '[ 'False, 'True]]-b = undefined-```--Promoted list with a tuple (issue #348)--```haskell-a :: A '[ '( a, b, c, d)]-a = undefined---- nested promoted tuples.-b :: A '[ '( 'True, 'False, '[], '( 'False, 'True))]-b = undefined-```--Prefix promoted symbol type constructor--```haskell-a :: '(T.:->) 'True 'False-b :: (T.:->) 'True 'False-c :: '(:->) 'True 'False-d :: (:->) 'True 'False-```--# Function declarations--Prefix notation for operators--``` haskell-(+) :: Num a => a -> a -> a-(+) a b = a-```--Where clause--``` haskell-sayHello = do-  name <- getLine-  putStrLn $ greeting name-  where-    greeting name = "Hello, " ++ name ++ "!"-```--Guards and pattern guards--``` haskell-f x-  | x <- Just x-  , x <- Just x =-    case x of-      Just x -> e-  | otherwise = do e-  where-    x = y-```--Multi-way if--``` haskell-x =-  if | x <- Just x,-       x <- Just x ->-       case x of-         Just x -> e-         Nothing -> p-     | otherwise -> e-```--Case inside a `where` and `do`--``` haskell-g x =-  case x of-    a -> x-  where-    foo =-      case x of-        _ -> do-          launchMissiles-      where-        y = 2-```--Let inside a `where`--``` haskell-g x =-  let x = 1-   in x-  where-    foo =-      let y = 2-          z = 3-       in y-```--Lists--``` haskell-exceptions = [InvalidStatusCode, MissingContentHeader, InternalServerError]--exceptions =-  [ InvalidStatusCode-  , MissingContentHeader-  , InternalServerError-  , InvalidStatusCode-  , MissingContentHeader-  , InternalServerError-  ]-```--Long line, function application--```haskell-test = do-  alphaBetaGamma deltaEpsilonZeta etaThetaIota kappaLambdaMu nuXiOmicron piRh79-  alphaBetaGamma deltaEpsilonZeta etaThetaIota kappaLambdaMu nuXiOmicron piRho80-  alphaBetaGamma-    deltaEpsilonZeta-    etaThetaIota-    kappaLambdaMu-    nuXiOmicron-    piRhoS81-```--Long line, tuple--```haskell-test-  (alphaBetaGamma, deltaEpsilonZeta, etaThetaIota, kappaLambdaMu, nuXiOmicro79)-  (alphaBetaGamma, deltaEpsilonZeta, etaThetaIota, kappaLambdaMu, nuXiOmicron80)-  ( alphaBetaGamma-  , deltaEpsilonZeta-  , etaThetaIota-  , kappaLambdaMu-  , nuXiOmicronP81)-```--Long line, tuple section--```haskell-test-  (, alphaBetaGamma, , deltaEpsilonZeta, , etaThetaIota, kappaLambdaMu, nu79, )-  (, alphaBetaGamma, , deltaEpsilonZeta, , etaThetaIota, kappaLambdaMu, , n80, )-  (-  , alphaBetaGamma-  ,-  , deltaEpsilonZeta-  ,-  , etaThetaIota-  , kappaLambdaMu-  ,-  , nu81-  ,)-```--# Record syntax--Pattern matching, short--```haskell-fun Rec {alpha = beta, gamma = delta, epsilon = zeta, eta = theta, iota = kappa} = do-  beta + delta + zeta + theta + kappa-```--Pattern matching, long--```haskell-fun Rec { alpha = beta-        , gamma = delta-        , epsilon = zeta-        , eta = theta-        , iota = kappa-        , lambda = mu-        } =-  beta + delta + zeta + theta + kappa + mu + beta + delta + zeta + theta + kappa-```--Symbol constructor, short--```haskell-fun ((:..?) {}) = undefined-```--Symbol constructor, long--```-fun (:..?) { alpha = beta-           , gamma = delta-           , epsilon = zeta-           , eta = theta-           , iota = kappa-           , lambda = mu-           } =-  beta + delta + zeta + theta + kappa + mu + beta + delta + zeta + theta + kappa-```--Symbol field--```haskell-f (X {(..?) = x}) = x-```--Punned symbol field--```haskell-f' (X {(..?)}) = (..?)-```--# Johan Tibell compatibility checks--Basic example from Tibbe's style--``` haskell-sayHello :: IO ()-sayHello = do-  name <- getLine-  putStrLn $ greeting name-  where-    greeting name = "Hello, " ++ name ++ "!"--filter :: (a -> Bool) -> [a] -> [a]-filter _ [] = []-filter p (x:xs)-  | p x = x : filter p xs-  | otherwise = filter p xs-```--Data declarations--``` haskell-data Tree a-  = Branch !a !(Tree a) !(Tree a)-  | Leaf--data Tree a-  = Branch-      !a-      !(Tree a)-      !(Tree a)-      !(Tree a)-      !(Tree a)-      !(Tree a)-      !(Tree a)-      !(Tree a)-  | Leaf--data HttpException-  = InvalidStatusCode Int-  | MissingContentHeader--data Person =-  Person-    { firstName :: !String -- ^ First name-    , lastName :: !String -- ^ Last name-    , age :: !Int -- ^ Age-    }--data Expression a-  = VariableExpression-      { id :: Id Expression-      , label :: a-      }-  | FunctionExpression-      { var :: Id Expression-      , body :: Expression a-      , label :: a-      }-  | ApplyExpression-      { func :: Expression a-      , arg :: Expression a-      , label :: a-      }-  | ConstructorExpression-      { id :: Id Constructor-      , label :: a-      }-```--Spaces between deriving classes--``` haskell--- From https://github.com/chrisdone/hindent/issues/167-data Person =-  Person-    { firstName :: !String -- ^ First name-    , lastName :: !String -- ^ Last name-    , age :: !Int -- ^ Age-    }-  deriving (Eq, Show)-```--Hanging lambdas--``` haskell-bar :: IO ()-bar =-  forM_ [1, 2, 3] $ \n -> do-    putStrLn "Here comes a number!"-    print n--foo :: IO ()-foo =-  alloca 10 $ \a ->-    alloca 20 $ \b ->-      cFunction fooo barrr muuu (fooo barrr muuu) (fooo barrr muuu)-```--# Comments--Comments within a declaration--``` haskell-bob -- after bob- =-  foo -- next to foo-  -- line after foo-    (bar-       foo -- next to bar foo-       bar -- next to bar-     ) -- next to the end paren of (bar)-    -- line after (bar)-    mu -- next to mu-    -- line after mu-    -- another line after mu-    zot -- next to zot-    -- line after zot-    (case casey -- after casey-           of-       Just -- after Just-        -> do-         justice -- after justice-          *-           foo-             (blah * blah + z + 2 / 4 + a - -- before a line break-              2 * -- inside this mess-              z /-              2 /-              2 /-              aooooo /-              aaaaa -- bob comment-              ) +-           (sdfsdfsd fsdfsdf) -- blah comment-         putStrLn "")-    [1, 2, 3]-    [ 1 -- foo-    , ( 2 -- bar-      , 2.5 -- mu-       )-    , 3-    ]-    -- in the end of the function-  where-    alpha = alpha-    -- between alpha and beta-    beta = beta-    -- after beta--foo = 1 -- after foo--gamma = do-  delta-  epsilon-  -- in the end of a do-block 1--gamma = do-  delta-  epsilon-  -- the very last block is detected differently-```--Doesn't work yet (wrong comment position detection)--```haskell pending-gamma = do-  -- in the beginning of a do-block-  delta-  where-    -- before alpha-    alpha = alpha-```--Haddock comments--``` haskell--- | Module comment.-module X where---- | Main doc.-main :: IO ()-main = return ()--data X-  = X -- ^ X is for xylophone.-  | Y -- ^ Y is for why did I eat that pizza.--data X =-  X-    { field1 :: Int -- ^ Field1 is the first field.-    , field11 :: Char-      -- ^ This field comment is on its own line.-    , field2 :: Int -- ^ Field2 is the second field.-    , field3 :: Char -- ^ This is a long comment which starts next to-      -- the field but continues onto the next line, it aligns exactly-      -- with the field name.-    , field4 :: Char-      -- ^ This is a long comment which starts on the following line-      -- from from the field, lines continue at the sme column.-    }-```--Comments around regular declarations--``` haskell--- This is some random comment.--- | Main entry point.-main = putStrLn "Hello, World!"--- This is another random comment.-```--Multi-line comments--``` haskell-bob {- after bob -}- =-  foo {- next to foo -}-  {- line after foo -}-    (bar-       foo {- next to bar foo -}-       bar {- next to bar -}-     ) {- next to the end paren of (bar) -}-    {- line after (bar) -}-    mu {- next to mu -}-    {- line after mu -}-    {- another line after mu -}-    zot {- next to zot -}-    {- line after zot -}-    (case casey {- after casey -}-           of-       Just {- after Just -}-        -> do-         justice {- after justice -}-          *-           foo-             (blah * blah + z + 2 / 4 + a - {- before a line break -}-              2 * {- inside this mess -}-              z /-              2 /-              2 /-              aooooo /-              aaaaa {- bob comment -}-              ) +-           (sdfsdfsd fsdfsdf) {- blah comment -}-         putStrLn "")-    [1, 2, 3]-    [ 1 {- foo -}-    , ( 2 {- bar -}-      , 2.5 {- mu -}-       )-    , 3-    ]--foo = 1 {- after foo -}-```--Multi-line comments with multi-line contents--``` haskell-{- | This is some random comment.-Here is more docs and such.-Etc.--}-main = putStrLn "Hello, World!"-{- This is another random comment. -}-```--# MINIMAL pragma--Monad example--```haskell-class A where-  {-# MINIMAL return, ((>>=) | (join, fmap)) #-}-```--Very long names #310--```haskell-class A where-  {-# MINIMAL averylongnamewithnoparticularmeaning-            | ananotherverylongnamewithnomoremeaning #-}-```--# Behaviour checks--Unicode--``` haskell-α = γ * "ω"--- υ-```--Empty module--``` haskell-```--Trailing newline is preserved--``` haskell-module X where--foo = 123-```--# Complex input--A complex, slow-to-print decl--``` haskell-quasiQuotes =-  [ ( ''[]-    , \(typeVariable:_) _automaticPrinter ->-        (let presentVar = varE (presentVarName typeVariable)-          in lamE-               [varP (presentVarName typeVariable)]-               [|(let typeString = "[" ++ fst $(presentVar) ++ "]"-                   in ( typeString-                      , \xs ->-                          case fst $(presentVar) of-                            "GHC.Types.Char" ->-                              ChoicePresentation-                                "String"-                                [ ( "String"-                                  , StringPresentation-                                      "String"-                                      (concatMap-                                         getCh-                                         (map (snd $(presentVar)) xs)))-                                , ( "List of characters"-                                  , ListPresentation-                                      typeString-                                      (map (snd $(presentVar)) xs))-                                ]-                              where getCh (CharPresentation "GHC.Types.Char" ch) =-                                      ch-                                    getCh (ChoicePresentation _ ((_, CharPresentation _ ch):_)) =-                                      ch-                                    getCh _ = ""-                            _ ->-                              ListPresentation-                                typeString-                                (map (snd $(presentVar)) xs)))|]))-  ]-```--Random snippet from hindent itself--``` haskell-exp' (App _ op a) = do-  (fits, st) <- fitsOnOneLine (spaced (map pretty (f : args)))-  if fits-    then put st-    else do-      pretty f-      newline-      spaces <- getIndentSpaces-      indented spaces (lined (map pretty args))-  where-    (f, args) = flatten op [a]-    flatten :: Exp NodeInfo -> [Exp NodeInfo] -> (Exp NodeInfo, [Exp NodeInfo])-    flatten (App _ f' a') b = flatten f' (a' : b)-    flatten f' as = (f', as)-```--Quasi quotes--```haskell-exp = [name|exp|]--f [qq|pattern|] = ()-```--# C preprocessor--Conditionals (`#if`)--```haskell-isDebug :: Bool-#if DEBUG-isDebug = True-#else-isDebug = False-#endif-```--Macro definitions (`#define`)--```haskell-#define STRINGIFY(x) #x-f = STRINGIFY (y)-```--Escaped newlines--```haskell-#define LONG_MACRO_DEFINITION \-  data Pair a b = Pair \-    { first :: a \-    , second :: b \-    }-#define SHORT_MACRO_DEFINITION \-  x-```--# Regression tests--jml Adds trailing whitespace when wrapping #221--``` haskell-x = do-  config <- execParser options-  comments <--    case config of-      Diff False args -> commentsFromDiff args-      Diff True args -> commentsFromDiff ("--cached" : args)-      Files args -> commentsFromFiles args-  mapM_ (putStrLn . Fixme.formatTodo) (concatMap Fixme.getTodos comments)-```--meditans hindent freezes when trying to format this code #222--``` haskell-c :: forall new.-     ( Settable "pitch" Pitch (Map.AsMap (new Map.:\ "pitch")) new-     , Default (Book' (Map.AsMap (new Map.:\ "pitch")))-     )-  => Book' new-c = set #pitch C (def :: Book' (Map.AsMap (new Map.:\ "pitch")))--foo ::-     ( Foooooooooooooooooooooooooooooooooooooooooo-     , Foooooooooooooooooooooooooooooooooooooooooo-     )-  => A-```--bitemyapp wonky multiline comment handling #231--``` haskell-module Woo where--hi = "hello"-{--test comment--}--- blah blah--- blah blah--- blah blah-```--cocreature removed from declaration issue #186--``` haskell--- https://github.com/chrisdone/hindent/issues/186-trans One e n =-  M.singleton-    (Query Unmarked (Mark NonExistent)) -- The goal of this is to fail always-    (emptyImage {notPresent = S.singleton (TransitionResult Two (Just A) n)})-```--sheyll explicit forall in instances #218--``` haskell--- https://github.com/chrisdone/hindent/issues/218-instance forall x. C--instance forall x. Show x => C x-```--tfausak support shebangs #208--``` haskell given-#!/usr/bin/env stack--- stack runghc-main =- pure ()--- https://github.com/chrisdone/hindent/issues/208-```--``` haskell expect-#!/usr/bin/env stack--- stack runghc-main = pure ()--- https://github.com/chrisdone/hindent/issues/208-```--joe9 preserve newlines between import groups--``` haskell--- https://github.com/chrisdone/hindent/issues/200-import Data.List-import Data.Maybe--import FooBar-import MyProject--import GHC.Monad---- blah-import Hello--import CommentAfter -- Comment here shouldn't affect newlines-import HelloWorld--import CommentAfter -- Comment here shouldn't affect newlines--import HelloWorld---- Comment here shouldn't affect newlines-import CommentAfter--import HelloWorld-```--Wrapped import list shouldn't add newline--```haskell given-import ATooLongList-       (alpha, beta, gamma, delta, epsilon, zeta, eta, theta)-import B-```--```haskell expect-import ATooLongList (alpha, beta, delta, epsilon, eta, gamma, theta, zeta)-import B-```--radupopescu `deriving` keyword not aligned with pipe symbol for type declarations--``` haskell-data Stuffs-  = Things-  | This-  | That-  deriving (Show)--data Simple =-  Simple-  deriving (Show)-```--sgraf812 top-level pragmas should not add an additional newline #255--``` haskell--- https://github.com/chrisdone/hindent/issues/255-{-# INLINE f #-}-f :: Int -> Int-f n = n-```--ivan-timokhin breaks code with type operators #277--```haskell--- https://github.com/chrisdone/hindent/issues/277-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}--type m ~> n = ()--class (a :< b) c-```--ivan-timokhin variables swapped around in constraints #278--```haskell--- https://github.com/chrisdone/hindent/issues/278-data Link c1 c2 a c =-  forall b. (c1 a b, c2 b c) =>-            Link (Proxy b)-```--ttuegel qualified infix sections get mangled #273--```haskell--- https://github.com/chrisdone/hindent/issues/273-import qualified Data.Vector as V--main :: IO ()-main = do-  let _ = foldr1 (V.++) [V.empty, V.empty]-  pure ()---- more corner cases.-xs = V.empty V.++ V.empty--ys = (++) [] []--cons :: V.Vector a -> V.Vector a -> V.Vector a-cons = (V.++)-```--ivan-timokhin breaks operators type signatures #301--```haskell--- https://github.com/chrisdone/hindent/issues/301-(+) :: ()-```--cdepillabout Long deriving clauses are not reformatted #289--```haskell-newtype Foo =-  Foo Proxy-  deriving ( Functor-           , Applicative-           , Monad-           , Semigroup-           , Monoid-           , Alternative-           , MonadPlus-           , Foldable-           , Traversable-           )-```--ivan-timokhin Breaks instances with type operators #342--```haskell--- https://github.com/chrisdone/hindent/issues/342-instance Foo (->)--instance Foo (^>)--instance Foo (T.<^)-```--Indents record constructions and updates #358-```haskell-foo =-  assert-    sanityCheck-    BomSnapshotAggr-      { snapshot = Just bs-      , previousId = M.bomSnapshotHistoryPreviousId . entityVal <$> bsp-      , nextId = M.bomSnapshotHistoryNextId . entityVal <$> bsn-      , bomEx = bx''-      , orderSubstitutes =-          S.fromList . map OrderSubstituteAggrByCreatedAtAsc $ subs-      , snapshotSubstitute = msub-      }-```--paraseba Deriving strategies with multiple deriving clauses-```haskell--- https://github.com/commercialhaskell/hindent/issues/503-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Foo where--import Data.Typeable-import GHC.Generics--newtype Number a =-  Number a-  deriving (Generic)-  deriving newtype (Show, Eq)-  deriving anyclass (Typeable)-```--neongreen "{" is lost when formatting "Foo{}" #366--```haskell--- https://github.com/chrisdone/hindent/issues/366-foo = Nothing {}-```--jparoz Trailing space in list comprehension #357--```haskell--- https://github.com/chrisdone/hindent/issues/357-foo =-  [ (x, y)-  | x <- [1 .. 10]-  , y <- [11 .. 20]-  , even x-  , even x-  , even x-  , even x-  , even x-  , odd y-  ]-```--ttuegel Record formatting applied to expressions with RecordWildCards #274--```haskell--- https://github.com/chrisdone/hindent/issues/274-foo (Bar {..}) = Bar {..}-```--RecursiveDo `rec` and `mdo` keyword #328--```haskell-rec = undefined--mdo = undefined-```--sophie-h Record syntax change in 5.2.2 #393--```haskell--- https://github.com/commercialhaskell/hindent/issues/393-data X-  = X-      { x :: Int-      }-  | X'--data X =-  X-    { x :: Int-    , x' :: Int-    }--data X-  = X-      { x :: Int-      , x' :: Int-      }-  | X'-```--k-bx Infix data constructor gets reformatted into a parse error #328--```haskell--- https://github.com/commercialhaskell/hindent/issues/328-data Expect =-  String :--> String-  deriving (Show)-```--tfausak Class constraints cause too many newlines #244--```haskell--- https://github.com/commercialhaskell/hindent/issues/244-x :: Num a => a-x = undefined---- instance-instance Num a => C a---- long instance-instance Nuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuum a =>-         C a where-  f = undefined-```--expipiplus1 Always break before `::` on overlong signatures #390--```haskell--- https://github.com/commercialhaskell/hindent/issues/390-fun :: Is => Short-fun = undefined--someFunctionSignature ::-     Wiiiiiiiiiiiiiiiiith-  -> Enough-  -> (Arguments -> To ())-  -> Overflow (The Line Limit)-```--duog Long Type Constraint Synonyms are not reformatted #290--```haskell--- https://github.com/commercialhaskell/hindent/issues/290-type MyContext m-   = ( MonadState Int m-     , MonadReader Int m-     , MonadError Text m-     , MonadMask m-     , Monoid m-     , Functor m)-```--ocharles Type application differs from function application (leading to long lines) #359--```haskell--- https://github.com/commercialhaskell/hindent/issues/359-thing ::-     ( ResB.BomEx-     , Maybe [( Entity BomSnapshot-              , ( [ResBS.OrderSubstituteAggr]-                , ( Maybe (Entity BomSnapshotHistory)-                  , Maybe (Entity BomSnapshotHistory))))])-  -> [(ResB.BomEx, Maybe ResBS.BomSnapshotAggr)]-```--NorfairKing Do as left-hand side of an infix operation #296--```haskell--- https://github.com/commercialhaskell/hindent/issues/296-block =-  do ds <- inBraces $ inWhiteSpace declarations-     return $ Block ds-     <?> "block"-```--NorfairKing Hindent linebreaks after very short names if the total line length goes over 80 #405--```haskell--- https://github.com/commercialhaskell/hindent/issues/405-t =-  f "this is a very loooooooooooooooooooooooooooong string that goes over the line length"-    argx-    argy-    argz--t =-  function-    "this is a very loooooooooooooooooooooooooooong string that goes over the line length"-    argx-    argy-    argz-```--ivan-timokhin No linebreaks for long functional dependency declarations #323--```haskell--- https://github.com/commercialhaskell/hindent/issues/323-class Foo a b | a -> b where-  f :: a -> b--class Foo a b c d e f-  | a b c d e -> f-  , a b c d f -> e-  , a b c e f -> d-  , a b d e f -> c-  , a c d e f -> b-  , b c d e f -> a-  where-  foo :: a -> b -> c -> d -> e -> f-```--utdemir Hindent breaks TH name captures of operators #412--```haskell--- https://github.com/commercialhaskell/hindent/issues/412-data T =-  (-)--q = '(-)--data (-)--q = ''(-)-```--utdemir Hindent can not parse empty case statements #414--```haskell--- https://github.com/commercialhaskell/hindent/issues/414-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE LambdaCase #-}--f1 = case () of {}--f2 = \case {}-```--TimoFreiberg INLINE (and other) pragmas for operators are reformatted without parens #415--```haskell--- https://github.com/commercialhaskell/hindent/issues/415-{-# NOINLINE (<>) #-}-```--NorfairKing Hindent breaks servant API's #417--```haskell--- https://github.com/commercialhaskell/hindent/issues/417-type API = api1 :<|> api2-```--andersk Cannot parse @: operator #421--```haskell--- https://github.com/commercialhaskell/hindent/issues/421-a @: b = a + b--main = print (2 @: 2)-```--andersk Corrupts parenthesized type operators #422--```haskell--- https://github.com/commercialhaskell/hindent/issues/422-data T a =-  a :@ a--test = (:@)-```--NorfairKing Infix constructor pattern is broken #424--```haskell--- https://github.com/commercialhaskell/hindent/issues/424-from $ \(author `InnerJoin` post) -> pure ()-```--NorfairKing Hindent can no longer parse type applications code #426--```haskell--- https://github.com/commercialhaskell/hindent/issues/426-{-# LANGUAGE TypeApplications #-}--f :: Num a => a-f = id--x = f @Int 12-```--michalrus Multiline `GHC.TypeLits.Symbol`s are being broken #451--```haskell--- https://github.com/commercialhaskell/hindent/issues/451-import GHC.TypeLits (Symbol)--data X (sym :: Symbol)-  deriving (Typeable)--type Y = X "abc\n\n\ndef"-```--DavidEichmann Existential Quantification reordered #443--```haskell--- https://github.com/commercialhaskell/hindent/issues/443-{-# LANGUAGE ExistentialQuantification #-}--data D =-  forall a b c. D a b c-```--sophie-h Regression: Breaks basic type class code by inserting "|" #459--```haskell--- https://github.com/commercialhaskell/hindent/issues/459-class Class1 a =>-      Class2 a-  where-  f :: a -> Int--class (Eq a, Show a) =>-      Num a-  where-  (+), (-), (*) :: a -> a -> a-  negate :: a -> a-  abs, signum :: a -> a-  fromInteger :: Integer -> a-```--michalrus `let … in …` inside of `do` breaks compilation #467--```haskell--- https://github.com/commercialhaskell/hindent/issues/467-main :: IO ()-main = do-  let x = 5-   in when (x > 0) (return ())-```--sophie-h Breaking valid top-level template haskell #473--```haskell--- https://github.com/commercialhaskell/hindent/issues/473-template $-  haskell-    [ ''SomeVeryLongName-    , ''AnotherLongNameEvenLongToBreakTheLine-    , ''LastLongNameInList-    ]-```--schroffl Hindent produces invalid Syntax from FFI exports #479--```haskell--- https://github.com/commercialhaskell/hindent/issues/479-foreign export ccall "test" test :: IO ()--foreign import ccall "test" test :: IO ()--foreign import ccall safe "test" test :: IO ()--foreign import ccall unsafe "test" test :: IO ()-```--ptek Reformatting of the {-# OVERLAPPING #-} pragma #386--```haskell--- https://github.com/commercialhaskell/hindent/issues/386-instance {-# OVERLAPPING #-} Arbitrary (Set Int) where-  arbitrary = undefined-```--cdsmith Quotes are dropped from package imports #480--```haskell--- https://github.com/commercialhaskell/hindent/issues/480-{-# LANGUAGE PackageImports #-}--import qualified "base" Prelude as P-```--alexwl Hindent breaks associated type families annotated with injectivity information #528--```haskell--- https://github.com/commercialhaskell/hindent/issues/528-class C a where-  type F a = b | b -> a-```--sophie-h Fails to create required indentation for infix #238--```haskell--- https://github.com/commercialhaskell/hindent/issues/238-{-# LANGUAGE ScopedTypeVariables #-}--import Control.Exception--x :: IO Int-x =-  do putStrLn "ok"-     error "ok"-     `catch` (\(_ :: IOException) -> pure 1) `catch`-  (\(_ :: ErrorCall) -> pure 2)--```--lippirk Comments on functions in where clause not quite right #540--```haskell--- https://github.com/chrisdone/hindent/issues/540-topLevelFunc1 = f-  where-    -- comment on func in where clause-    -- stays in the where clause-    f = undefined--topLevelFunc2 = f . g-  where-    {- multi-       line-       comment -}-    f = undefined-    -- single line comment-    g = undefined+# HIndent test codes++This file is a test suite. Each section maps to an HSpec test, and+each line that is followed by a Haskell code fence is tested to make+sure re-formatting that code snippet produces the same result.++You can browse through this document to see what HIndent's style is+like, or contribute additional sections to it, or regression tests.++## Shebangs++No newlines after a shebang++```haskell given+#!/usr/bin/env stack++-- stack runghc+main =+ pure ()+-- https://github.com/mihaimaruseac/hindent/issues/208+```++```haskell expect+#!/usr/bin/env stack+-- stack runghc+main = pure ()+-- https://github.com/mihaimaruseac/hindent/issues/208+```++Double shebangs++```haskell+#!/usr/bin/env stack+#!/usr/bin/env stack+main = pure ()+```++## Modules++Empty module++```haskell+```++### Module headers++Without an export list++```haskell+module X where++x = 1+```++With an export list++```haskell+module X+  ( x+  , y+  , Z+  , P(x, z)+  , Q(..)+  , module Foo+  ) where+```++With an export list; indentation 4++```haskell 4+module X+    ( x+    , y+    , Z+    , P(x, z)+    ) where+```++### Module-level pragmas++A pragma's name is converted to the SHOUT_CASE.++```haskell given+{-# lAnGuAgE CPP #-}+```++```haskell expect+{-# LANGUAGE CPP #-}+```++Pragmas, GHC options, and haddock options.++```haskell+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}+{-# OPTIONS_GHC -w #-}+{-# OPTIONS_HADDOCK show-extensions #-}++module Foo where+```++Accept pragmas via `OPTIONS -XFOO`++```haskell+{-# OPTIONS -XPatternSynonyms #-}++import Foo (pattern Bar)+```++Accept pragmas via `OPTIONS_GHC -XFOO`++```haskell+{-# OPTIONS_GHC -XPatternSynonyms #-}++import Foo (pattern Bar)+```++A pragma's length is adjusted automatically++```haskell given+{-#         LANGUAGE OverloadedStrings          #-}+```++```haskell expect+{-# LANGUAGE OverloadedStrings #-}+```++Collect multiple extensions correctly++```haskell+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE PatternSynonyms #-}++import Language.C.Types (pattern TypeName)+```++Collect multiple extensions separated by commas correctly++```haskell given+{-# LANGUAGE TypeApplications,+    PatternSynonyms #-}++import Foo (pattern Bar)++foo = bar @Int 3+```++```haskell expect+{-# LANGUAGE TypeApplications, PatternSynonyms #-}++import Foo (pattern Bar)++foo = bar @Int 3+```++Do not collect pragma-like comments++```haskell+-- {-# LANGUAGE StaticPointers #-}+{-++{-# LANGUAGE StaticPointers #-}++-}+-- @static@ is no longer a valid identifier+-- once `StaticPointers` is enabled.+static = 3+```++#### `WARNING`++Without messages and an export list.++```haskell+module Foo {-# WARNING [] #-} where+```++With a string without an export list.++```haskell+module Foo {-# WARNING "Debug purpose only." #-} where+```++With a list of reasons without an export list.++```haskell+module Foo {-# WARNING ["Debug purpose only.", "Okay?"] #-} where+```++#### `DEPRECATED`++Without messages and an export list.++```haskell+module Foo {-# DEPRECATED [] #-} where+```++With a string without an export list.++```haskell+module Foo {-# DEPRECATED "Use Bar." #-} where+```++With a list of reasons and an export list.++```haskell+module Foo {-# DEPRECATED ["Use Bar.", "Or use Baz."] #-}+  ( x+  , y+  , z+  ) where+```++## Imports, foreign imports, and foreign exports++Import lists++```haskell+import Control.Lens (_2, _Just)+import Control.Lens as Optic+import Data.Text+import Data.Text+import qualified Data.Text as T+import qualified Data.Text (a, b, c)+import Data.Text (a, b, c)+import Data.Text hiding (a, b, c)+```++Shorter identifiers come first++```haskell+import Foo ((!), (!!))+```++Import with `ExplicitNamespaces`.++```haskell+{-# LANGUAGE ExplicitNamespaces #-}++import Prlude (type FilePath)+```++Import a pattern++```haskell+{-# LANGUAGE PatternSynonyms #-}++import Foo (pattern Bar)+```++Sorted++```haskell given+import B+import A+```++```haskell expect+import A+import B+```++Explicit imports - capitals first (typeclasses/types), then operators, then identifiers++```haskell given+import qualified MegaModule as M ((>>>), MonadBaseControl, void, MaybeT(..), join, Maybe(Nothing, Just), liftIO, Either, (<<<), Monad(return, (>>=), (>>)))+```++```haskell expect+import qualified MegaModule as M+  ( Either+  , Maybe(Just, Nothing)+  , MaybeT(..)+  , Monad((>>), (>>=), return)+  , MonadBaseControl+  , (<<<)+  , (>>>)+  , join+  , liftIO+  , void+  )+```++Pretty import specification++```haskell+{-# LANGUAGE ForeignFunctionInterface #-}++import A hiding+  ( foobarbazqux+  , foobarbazqux+  , foobarbazqux+  , foobarbazqux+  , foobarbazqux+  , foobarbazqux+  , foobarbazqux+  )++import Name hiding ()++import {-# SOURCE #-} safe qualified Module as M hiding (a, b, c, d, e, f)+```++An import declaration importing lots of data constructors++```haskell+import Language+  ( Language(Ada, Ada, Assembly, C, CPlusPlus, CSharp, Clojure, Cobol, Dart, Elixir,+             Elm, Erlang, Fortran, Go, Groovy, Haskell, Java, JavaScript, Julia,+             Kotlin, Lisp, Lua, ObjectiveC, PHP, Pascal, Perl, Prolog, Python, Ruby,+             Rust, Scala)+  , allLanguages+  )+```++Preserve newlines between import groups++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/200+import GHC.Monad++import CommentAfter -- Comment here shouldn't affect newlines+import HelloWorld++import CommentAfter -- Comment here shouldn't affect newlines++-- Comment here shouldn't affect newlines+import CommentAfter+```++`PackageImports`++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/480+{-# LANGUAGE PackageImports #-}++import qualified "base" Prelude as P+```++`ImportQualifiedPost`++```haskell+{-# LANGUAGE ImportQualifiedPost #-}++import Data.Text qualified as T+```++Importing a `#`++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/547+import Diagrams.Prelude ((#))+```++### Foreign imports and exports++A `ccall` foreign export++```haskell+{-# LANGUAGE ForeignFunctionInterface #-}++foreign export ccall "test" test :: IO ()+```++A `ccall` unsafe foreign import++```haskell+{-# LANGUAGE ForeignFunctionInterface #-}++foreign import ccall unsafe "test" test :: IO ()+```++A `capi` foreign import++```haskell+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE ForeignFunctionInterface #-}++foreign import capi safe "foo" test :: IO Int+```++A `stdcall` foreign import++```haskell+{-# LANGUAGE ForeignFunctionInterface #-}++foreign import stdcall safe "test" bar :: IO ()+```++A `prim` foreign import++```haskell+{-# LANGUAGE ForeignFunctionInterface #-}++foreign import prim safe "test" test :: IO ()+```++A `javascript` foreign import++```haskell+{-# LANGUAGE ForeignFunctionInterface #-}++foreign import javascript safe "test" test :: IO ()+```++## Declarations++Data family++```haskell+data family Foo a+```++`StandaloneKindSignatures`++```haskell+{-# LANGUAGE StandaloneKindSignatures #-}++type Foo :: Type -> Type -> Type+data Foo a b =+  Foo a b+```++Default declaration++```haskell+default (Integer, Double)+```++### `ANN` pragmas++Value annotation.++```haskell+{-# ANN foo "annotation" #-}+```++Type annotation.++```haskell+{-# ANN type Foo "annotation" #-}+```++Module annotation.++```haskell+{-# ANN module "annotation" #-}+```++### Class declarations++Default signatures++```haskell+-- https://github.com/chrisdone/hindent/issues/283+class Foo a where+  bar :: a -> a -> a+  default bar :: Monoid a => a -> a -> a+  bar = mappend+```++Default signatures with constraints++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/492+class HasEnvExpr m =>+      MonadRecordEnvExpr m+  where+  addEnvExpression :: EnvExpr m -> m HostExpr+  default addEnvExpression ::+       ( MonadTrans t+       , Monad n+       , MonadRecordEnvExpr n+       , t n ~ m+       , EnvExpr m ~ EnvExpr n+       )+    => EnvExpr m+    -> m HostExpr+```++`TypeOperators` and `MultiParamTypeClasses`++```haskell+-- https://github.com/chrisdone/hindent/issues/277+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}++class (a :< b) c+```++#### Class constraints++Empty++```haskell+class () =>+      Foo a+```++Long++```haskell+class ( Foo a+      , Bar a+      , Baz a+      , Hoge a+      , Fuga a+      , Piyo a+      , Hogera a+      , Hogehoge a+      , Spam a+      , Ham a+      ) =>+      Quux a+```++#### Class methods++With class constraints++```haskell+class Foo f where+  myEq :: (Eq a) => f a -> f a -> Bool+```++Long signatures++```haskell+class Foo a where+  fooBarBazQuuxHogeFuga ::+       a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a -> a+```++#### Associated type synonyms++Associated type synonyms++```haskell+class Foo a where+  type Bar b+```++Associated type synonyms annotated with injectivity information++```haskell+-- https://github.com/commercialhaskell/hindent/issues/528+class C a where+  type F a = b | b -> a+```++Associated data families in classes++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/1050+class MyClass a where+  data AssociatedData a+```++### Class instance declarations++Without methods++```haskell+instance C a+```++With methods++```haskell+instance C a where+  foobar = do+    x y+    k p+```++With type operators++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/342+instance Foo (->)++instance Foo (^>)++instance Foo (T.<^)+```++With a type alias++```haskell+instance Foo a where+  type Bar a = Int+```++A `where` clause between instance functions++```haskell+instance Pretty HsModule where+  pretty' = undefined+    where+      a = b+  commentsBefore = Nothing+```++With a `SPECIALISE` pragma++```haskell+instance (Show a) => Show (Foo a) where+  {-# SPECIALISE instance Show (Foo String) #-}+  show = undefined+```++With associated data types++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/493+instance GM 'Practice where+  data MatchConfig 'Practice = MatchConfig'Practice+    { teamSize :: Int+    , ladder :: Ladder+    }+```++With associated newtypes++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/837+instance Foo a where+  newtype Bar a =+    FooBar a+```++Default associated type family keeps its default++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/897+class Foo a where+  type Bar a+  type instance Bar a = ()+```++#### With overlapping pragmas++`OVERLAPPING`++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/386+instance {-# OVERLAPPING #-} Arbitrary (Set Int) where+  arbitrary = undefined+```++`OVERLAPPABLE`++```haskell+instance {-# OVERLAPPABLE #-} Arbitrary Int where+  arbitrary = undefined+```++`OVERLAPS`++```haskell+instance {-# OVERLAPS #-} Arbitrary String where+  arbitrary = undefined+```++`INCOHERENT`++```haskell+instance {-# INCOHERENT #-} Arbitrary String where+  arbitrary = undefined+```++#### With class constraints++Short name++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/244+instance Num a => C a+```++Long name++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/244+instance Nuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuum a =>+         C a where+  f = undefined+```++#### Explicit foralls++Without class constraints++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/218+instance forall x. C+```++With class constraints++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/218+instance forall x. Show x => C x+```++#### Symbol class constructor++Infix++```haskell+instance Bool :?: Bool+```++Prefix++```haskell+instance (:?:) Int Bool+```++### Data declarations++Data declaration with underscore++```haskell+data Stanza = MkStanza+  { _stanzaBuildInfo :: BuildInfo+  , stanzaIsSourceFilePath :: FilePath -> Bool+  }+```++A data declaration with typeclass constraints++```haskell+data Ord a =>+     Foo =+  Foo a+```++Multiple constructors at once++```haskell+data Foo = Foo+  { foo, bar, baz, qux, quux :: Int+  }+```++No fields++```haskell+data Foo+```++Single field++```haskell+data Foo =+  Foo+```++Multiple unnamed fields++```haskell+data HttpException+  = InvalidStatusCode Int+  | MissingContentHeader+```++A lot of unnamed fields in a constructor++```haskell+data Foo =+  Foo+    String+    String+    String+    String+    String+    String+    String+    String+    String+    String+    String+```++A banged field++```haskell+data Foo =+  Foo !Int+```++A record constructor with a field++```haskell+data Foo = Foo+  { foo :: Int+  }+```++Multiple constructors with fields++```haskell+data Expression a+  = VariableExpression+      { id :: Id Expression+      , label :: a+      }+  | FunctionExpression+      { var :: Id Expression+      , body :: Expression a+      , label :: a+      }+  | ApplyExpression+      { func :: Expression a+      , arg :: Expression a+      , label :: a+      }+  | ConstructorExpression+      { id :: Id Constructor+      , label :: a+      }+```++A mixture of constructors with unnamed fields and record constructors++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/393+data X+  = X+      { x :: Int+      , x' :: Int+      }+  | X'+```++An infix data constructor++```haskell+data Foo =+  Int :--> Int+```++An `UNPACK`ed field.++```haskell+data Foo = Foo+  { x :: {-# UNPACK #-} Int+  }+```++An `NOUNPACK`ed field.++```haskell+data Foo = Foo+  { x :: {-# NOUNPACK #-} !Int+  }+```++A lazy field.++```haskell+data Foo = Foo+  { x :: ~Int+  }+```++#### Fields with `forall` constraints++Single++```haskell+data D =+  forall a. D a+```++Multiple++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/443+{-# LANGUAGE ExistentialQuantification #-}++data D =+  forall a b c. D a b c+```++With an infix constructor++```haskell+data D =+  forall a. a :== a+```++#### Fields with contexts++Without a `forall`++```haskell+data Foo =+  Eq a => Foo a+```++With a `forall`++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/278+data Link c1 c2 a c =+  forall b. (c1 a b, c2 b c) =>+            Link (Proxy b)+```++With an infix constructor without a `forall`++```haskell+data Foo =+  Eq a => a :== a+```++With an infix constructor with a `forall`++```haskell+data Foo =+  forall a. Eq a =>+            a :== a+```++#### Derivings++With a single constructor++```haskell+data Simple =+  Simple+  deriving (Show)+```++With multiple constructors++```haskell+data Stuffs+  = Things+  | This+  | That+  deriving (Show)+```++With a record constructor++```haskell+-- From https://github.com/mihaimaruseac/hindent/issues/167+data Person = Person+  { firstName :: !String -- ^ First name+  , lastName :: !String -- ^ Last name+  , age :: !Int -- ^ Age+  } deriving (Eq, Show)+```++Multiple derivings++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/289+newtype Foo =+  Foo Proxy+  deriving ( Functor+           , Applicative+           , Monad+           , Semigroup+           , Monoid+           , Alternative+           , MonadPlus+           , Foldable+           , Traversable+           )+```++Various deriving strategies++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/503+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Foo where++import Data.Typeable+import GHC.Generics++newtype Number a =+  Number a+  deriving (Generic)+  deriving stock (Ord)+  deriving newtype (Eq)+  deriving anyclass (Typeable)+  deriving (Show) via a+```++`StandaloneDeriving`++```haskell+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}++data Foo =+  Foo++deriving instance Eq Foo++deriving stock instance Ord Foo++deriving via (Foo a) instance Show (Bar a)+```++#### GADT declarations++With a kind signature++```haskell+data Ty :: (* -> *) where+  TCon+    :: { field1 :: Int+       , field2 :: Bool}+    -> Ty Bool+  TCon' :: (a :: *) -> a -> Ty a+```++Without a kind signature++```haskell+data Foo where+  Foo+    :: forall v. Ord v+    => v+    -> v+    -> Foo+```++With a `forall` but no contexts++```haskell+data Foo where+  Foo :: forall v. v -> v -> Foo+```++With a context but no `forall`s++```haskell+data Foo where+  Foo :: (Ord v) => v -> v -> Foo+```++With methods with record signatures++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/581+data Test where+  Test :: Eq a => { test :: a } -> Test+```++### Data instance declarations++Without type applications++```haskell+data instance Foo Int =+  FInt+```++With type applications++```haskell+data instance Foo @k a =+  FString+```++### Function declarations++Case inside `do` and lambda++```haskell+foo =+  \x -> do+    case x of+      Just _ -> 1+      Nothing -> 2+```++A `case` inside a `let`.++```haskell+f = do+  let (x, xs) =+        case gs of+          [] -> undefined+          (x':xs') -> (x', xs')+  undefined+```++A `do` inside a lambda.++```haskell+printCommentsAfter =+  case commentsAfter p of+    xs -> do+      forM_ xs $ \(L loc c) -> do+        eolCommentsArePrinted+```++Case with natural pattern (See NPat of https://hackage.haskell.org/package/ghc-lib-parser-9.2.3.20220527/docs/Language-Haskell-Syntax-Pat.html#t:Pat)++```haskell+foo =+  case x of+    0 -> pure ()+    _ -> undefined+```++```haskell+s8_stripPrefix bs1@(S.PS _ _ l1) bs2+  | bs1 `S.isPrefixOf` bs2 = Just (S.unsafeDrop l1 bs2)+  | otherwise = Nothing+```++A `do` inside a guard arm++```haskell+f+  | x == 1 = do+    a+    b+```++`if` having a long condition++```haskell+foo =+  if fooooooo+       || baaaaaaaaaaaaaaaaaaaaa+       || apsdgiuhasdpfgiuahdfpgiuah+       || bazzzzzzzzzzzzz+    then a+    else b+```++A long signature inside a where clause++```haskell+cppSplitBlocks :: ByteString -> [CodeBlock]+cppSplitBlocks inp = undefined+  where+    spanCPPLines ::+         [(Int, ByteString)] -> ([(Int, ByteString)], [(Int, ByteString)])+    spanCPPLines = undefined+```++A `forall` type inside a where clause++```haskell+replaceAllNotUsedAnns :: HsModule -> HsModule+replaceAllNotUsedAnns = everywhere app+  where+    app ::+         forall a. Data a+      => (a -> a)+    app = undefined++f :: a+f = undefined+  where+    ggg ::+         forall a. Typeable a+      => a+      -> a+    ggg = undefined+```++Prefix notation for operators++```haskell+(+) a b = a+```++Guards and pattern guards++```haskell+f x+  | x <- Just x+  , x <- Just x =+    case x of+      Just x -> e+  | otherwise = do+    e+  where+    x = y+```++Where clause++```haskell+sayHello = do+  name <- getLine+  putStrLn $ greeting name+  where+    greeting name = "Hello, " ++ name ++ "!"+```++An empty line is inserted after an empty `where`++```haskell given+f = evalState+    -- A comment+  where+```++```haskell expect+f = evalState+    -- A comment+  where++```++Multiple function declarations with an empty `where`++```haskell+f = undefined+  where+++g = undefined+```++Let inside a `where`++```haskell+g x =+  let x = 1+   in x+  where+    foo =+      let y = 2+          z = 3+       in y+```++The indent after a top-level `where` respects the indent size setting.++```haskell 4+f = undefined+    where+        g = undefined+```++The indent after a `where` inside a `case` respects the indent size setting++```haskell 4+f =+    case x of+        x -> undefined+            where+                y = undefined+```++#### Pattern matchings++View pattern++```haskell+foo (f -> Just x) = print x+foo _ = Nothing+```++Match against a list++```haskell+head [] = undefined+head [x] = x+head xs = head $ init xs++foo [Coord _ _, Coord _ _] = undefined+```++Multiple matchings++```haskell+head' [] = Nothing+head' (x:_) = Just x+```++n+k patterns++```haskell+{-# LANGUAGE NPlusKPatterns #-}++f (n+5) = 0+```++Binary symbol data constructor in pattern++```haskell+f (x :| _) = x++f' ((:|) x _) = x++f'' ((Data.List.NonEmpty.:|) x _) = x++g (x:xs) = x++g' ((:) x _) = x+```++Infix constructor pattern++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/424+a = from $ \(author `InnerJoin` post) -> pure ()+```++Unboxed sum pattern matching.++```haskell+{-# LANGUAGE UnboxedSums #-}++f (# (# n, _ #) | #) = (# n | #)+f (# | b #) = (# | b #)+```++Pattern matching against a infix constructor with a module name prefix++```haskell+foo (a FOO.:@: b) = undefined+```++##### Pattern matchings against record++Short++```haskell+fun Rec {alpha = beta, gamma = delta, epsilon = zeta, eta = theta, iota = kappa} = do+  beta + delta + zeta + theta + kappa+```++Long++```haskell+fun Rec { alpha = beta+        , gamma = delta+        , epsilon = zeta+        , eta = theta+        , iota = kappa+        , lambda = mu+        } =+  beta + delta + zeta + theta + kappa + mu + beta + delta + zeta + theta + kappa+```++Another long one++```haskell+resetModuleStartLine m@HsModule { hsmodAnn = epa@EpAnn {..}+                                , hsmodName = Just (L (SrcSpanAnn _ (RealSrcSpan sp _)) _)+                                } = undefined+```++Symbol constructor, short++```haskell+fun ((:..?) {}) = undefined+```++Symbol constructor, long++```haskell+fun (:..?) { alpha = beta+           , gamma = delta+           , epsilon = zeta+           , eta = theta+           , iota = kappa+           , lambda = mu+           } =+  beta + delta + zeta + theta + kappa + mu + beta + delta + zeta + theta + kappa+```++Symbol field++```haskell+f (X {(..?) = x}) = x+```++Punned symbol field++```haskell+f' (X {(..?)}) = (..?)+```++`RecordWileCards`++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/274+foo (bar@Bar {..}) = Bar {..}++resetModuleNameColumn m@HsModule {hsmodName = Just (L (SrcSpanAnn epa@EpAnn {..} sp) name)} =+  m++bar Bar {baz = before, ..} = Bar {baz = after, ..}+```++As pattern++```haskell+f all@(x:xs) = all+```++Empty data declarations with kind signatures and deriving clauses++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/1049+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++data Void :: Type++data Unit :: Type where+  MkUnit :: Unit+  deriving (Show)+```++Or patterns++```haskell since 9.12.1+{-# LANGUAGE OrPatterns #-}++isLeftOrRight :: Either a b -> Bool+isLeftOrRight (Left _; Right _) = True+```++### Infix declarations++infixl++```haskell+infixl 1 ^-^+```++infixr++```haskell+infixr 1 ^-^+```++infix++```haskell+infix 1 ^-^+```++### Pattern synonym declarations++Unidirectional with a pattern type signature++```haskell+{-# LANGUAGE PatternSynonyms #-}++pattern Foo :: Int -> Int -> [Int]+pattern Foo x y <- [x, y]+```++Bidirectional record pattern++```haskell+{-# LANGUAGE PatternSynonyms #-}++pattern Pair {x, y} = (x, y)+```++#### Explicit bidirectional++With a prefix constructor++```haskell+{-# LANGUAGE PatternSynonyms #-}++pattern Fst x <- (x, x)+  where Fst x = (x, 0)+```++With an infix constructor++```haskell+{-# LANGUAGE PatternSynonyms #-}++pattern x :| xs <- x : xs+  where a :| b = a : b+```++### Pragma declarations++`INLINE`++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/255+{-# INLINE f #-}+f :: Int -> Int+f n = n+```++`NOINLINE` with an operator enclosed by parentheses++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/415+{-# NOINLINE (<>) #-}+```++`INLINABLE`++```haskell+{-# INLINABLE f #-}+f :: a+f = undefined+```++`OPAQUE`++```haskell since 9.4.0+{-# OPAQUE f #-}+f :: a+f = undefined+```++`INLINE` with levels++```haskell+{-# INLINE [0] f #-}+{-# INLINE [~1] g #-}+```++A `DEPRECATED`.++```haskell+{-# DEPRECATED+giveUp "Never give up."+ #-}++giveUp = undefined+```++A `WARNING`.++```haskell+{-# WARNING+debugCode "The use of 'debugCode'"+ #-}+```++A `COMPLETE`++```haskell+{-# COMPLETE Single, Anylist #-}+```++Top-level `SPECIALISE`++```haskell+{-# SPECIALISE lookup :: [(Int, Int)] -> Int -> Maybe Int #-}+```++Multiple signatures in a `SPECIALISE`++```haskell+-- https://github.com/mihaimaruseac/hindent/pull/784+{-# SPECIALISE foo :: Int -> Int, Double -> Double #-}+```++A `SCC`++```haskell+{-# SCC bar #-}+```++#### Rule declarations++Without `forall`s++```haskell+{-# RULES+"foo/bar" foo = bar+ #-}+```++With `forall` but no type signatures++```haskell+{-# RULES+"piyo/pochi" forall a. piyo a = pochi a a+ #-}+```++With `forall` and type signatures++```haskell+{-# RULES+"hoge/fuga" forall (a :: Int). hoge a = fuga a a+ #-}+```++### Role annotation declarations++`normal`++```haskell+{-# LANGUAGE RoleAnnotations #-}++type role Foo nominal+```++`representational`++```haskell+{-# LANGUAGE RoleAnnotations #-}++type role Bar representational+```++`phantom`++```haskell+{-# LANGUAGE RoleAnnotations #-}++type role Baz phantom+```++### Type family declarations++Without annotations++```haskell+type family Id a+```++With annotations++```haskell+type family Id a :: *+```++With injectivity annotations++```haskell+type family Id a = r | r -> a+```++Closed type families++```haskell+type family Closed (a :: k) :: Bool where+  Closed (x @Int) = 'Int+  Closed x = 'True+```++### Type family instance declarations++Without holes++```haskell+type instance Id Int = Int+```++With a hole++```haskell+type instance Id _ = String+```++### Type signature declarations++Multiple function signatures at once++```haskell+a, b, c :: Int+```++Type using a numeric value++```haskell+f :: Foo 0+```++Type using a character value++```haskell+f :: Foo 'a'+```++Type using a unicode string value++```haskell+f :: Foo "あ"+```++A dot not enclosed by spaces is printed correctly if `OverloadedRecordDot` is not enabled.++```haskell given+f :: forall a.(Data a, Typeable a) => a+```++```haskell expect+f :: forall a. (Data a, Typeable a)+  => a+```++Short++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/390+fun :: Short+fun = undefined+```++Always break after `::` on overlong signatures++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/390+someFunctionSignature ::+     Wiiiiiiiiiiiiiiiiith+  -> Enough+  -> (Arguments -> To ())+  -> Overflow (The Line Limit)+```++A long type is broken into lines++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/359+thing ::+     ( ResB.BomEx+     , Maybe+         [( Entity BomSnapshot+          , ( [ResBS.OrderSubstituteAggr]+            , ( Maybe (Entity BomSnapshotHistory)+              , Maybe (Entity BomSnapshotHistory))))])+  -> [(ResB.BomEx, Maybe ResBS.BomSnapshotAggr)]+```++Long parameter list with a `forall`++```haskell+fooooooooo ::+     forall a.+     Fooooooooooooooo a+  -> Fooooooooooooooo a+  -> Fooooooooooooooo a+  -> Fooooooooooooooo a+```++Implicit parameters++```haskell+{-# LANGUAGE ImplicitParams #-}++f :: (?x :: Int) => Int+```++Quasiquotes in types++```haskell+{-# LANGUAGE QuasiQuotes #-}++fun :: [a|bc|]+```++Tuples++```haskell+fun :: (a, b, c) -> (a, b)+```++Infix operator++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/301+(+) :: ()+```++With a record++```haskell+url :: r {url :: String} => r -> Integer+```++#### Forall quantification++Invisible forall++```haskell+f :: (forall a. Data a => a -> a) -> (forall a b. Data a => a -> b)+g :: forall a b. a -> b+```++Visible forall with single type variable++```haskell+idVis :: forall a -> a -> a+```++Visible forall with multiple type variables++```haskell+pairVis :: forall a -> forall b -> a -> b -> (a, b)+```++Visible forall with mixed visibility++```haskell+mixed :: forall a -> forall b. (a -> b) -> a -> b+```++Visible forall with kind annotation++```haskell+proxyVis :: forall (a :: Type) -> Proxy a+```++An infix operator containing `#`++```haskell+(#!) :: Int -> Int -> Int+```++Multiple line function signature inside a `where`++```haskell 4+foo = undefined+    where+        go :: Fooooooooooooooooooooooo+           -> Fooooooooooooooooooooooo+           -> Fooooooooooooooooooooooo+           -> Fooooooooooooooooooooooo+        go = undefined+```++Types with many type applications++```haskell+foo ::+     Foo+       LongLongType+       LongLongType+       LongLongType+       LongLongType+       LongLongType+       LongLongType+  -> Int+```++#### Promoted types++Class constraints should leave `::` on same line++```haskell+-- see https://github.com/chrisdone/hindent/pull/266#issuecomment-244182805+fun ::+     (Class a, Class b)+  => fooooooooooo bar mu zot+  -> fooooooooooo bar mu zot+  -> c+```++An infix operator containing `#`++```haskell+(#!) :: Int -> Int -> Int+```++Prefix promoted symbol type constructor++```haskell+a :: '(T.:->) 'True 'False+b :: (T.:->) 'True 'False+c :: '(:->) 'True 'False+d :: (:->) 'True 'False+```++##### Promoted lists++Short++```haskell+fun1 :: Def ('[ Ref s (Stored Uint32), IBool] T.:-> IBool)+fun1 = undefined++fun2 :: Def ('[ Ref s (Stored Uint32), IBool] :-> IBool)+fun2 = undefined+```++Long++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/522+type OurContext+  = '[ AuthHandler W.Request (ExtendedPayloadWrapper UserSession)+     , BasicAuthCheck GameInstanceId+     , BasicAuthCheck (RegionId, RegionName)+     , BasicAuthCheck Alert.SourceId+     , M.MultipartOptions M.Tmp+     ]+```++Nested++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/348+a :: A '[ 'True]+-- nested promoted list with multiple elements.+b :: A '[ '[ 'True, 'False], '[ 'False, 'True]]+```++#### Symbol type constructors++Infix++```haskell+f :: a :?: b+```++Prefix++```haskell+f' :: (:?:) a b+```++#### Type signature with class constraints++Single++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/244+x :: Num a => a+x = undefined+```++Multiple++```haskell+fun :: (Class a, Class b) => a -> b -> c+```++Multiple without parentheses++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/554+g :: Semigroup a => Monoid a => Maybe a -> a+```++Long constraints++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/222+foo ::+     ( Foooooooooooooooooooooooooooooooooooooooooo+     , Foooooooooooooooooooooooooooooooooooooooooo+     )+  => A+```++Class constraints should leave `::` on same line++```haskell+-- see https://github.com/mihaimaruseac/hindent/pull/266#issuecomment-244182805+fun ::+     (Class a, Class b)+  => fooooooooooo bar mu zot+  -> fooooooooooo bar mu zot+  -> c+```++Symbol class constructor in class constraint++```haskell+f :: (a :?: b) => (a, b)+f' :: ((:?:) a b) => (a, b)+```++#### Unboxed types++Short unboxed sums++```haskell+{-# LANGUAGE UnboxedSums #-}++f :: (# (# Int, String #) | String #) -> (# Int | String #)+```++Long unboxed sums++```haskell+{-# LANGUAGE UnboxedSums #-}++f' ::+     (# (# Int, String #)+      | Either Bool Int+      | Either Bool Int+      | Either Bool Int+      | Either Bool Int+      | Either Bool Int+      | String #)+  -> (# Int | String #)+```++Large unboxed tuples++```haskell+{-# LANGUAGE UnboxedTuples #-}++f :: (# Looooooooooooooooooooooooooooooooooooooooooooong+      , Looooooooooooooooooooooooooooooooooooooooooooong+      , Looooooooooooooooooooooooooooooooooooooooooooong #)+```++### Linear types++Linear function arrow (%1 ->)++```haskell+{-# LANGUAGE LinearTypes #-}++f :: a %1 -> b+```++Linear types in GADT constructors++```haskell+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LinearTypes #-}++data T where+  C :: a %1 -> T+```++### Type synonym declarations++Short++```haskell+type EventSource a = (AddHandler a, a -> IO ())+```++Long++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/290+type MyContext m+  = ( MonadState Int m+    , MonadReader Int m+    , MonadError Text m+    , MonadMask m+    , Monoid m+    , Functor m)+```++Very higher-kinded type++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/534+type SomeTypeSynonym+  = RecordWithManyFields+      FieldNumber1+      FieldNumber2+      FieldNumber3+      FieldNumber4+      FieldNumber5+      FieldNumber6+      FieldNumber7+      FieldNumber8+      FieldNumber9+      FieldNumber10+      FieldNumber11+      FieldNumber12+      FieldNumber13+      FieldNumber14+      FieldNumber15+```++Infix type constructor++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/417+type API = api1 :<|> api2+```++Type with a string++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/451+type Y = X "abc\n\n\ndef"+```++`TypeOperators`++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/277+{-# LANGUAGE TypeOperators #-}++type m ~> n = ()+```++#### Functional dependencies++Single++```haskell+-- https://github.com/commercialhaskell/hindent/issues/323+class Foo a b | a -> b where+  f :: a -> b+```++Multiple dependencies in a line++```haskell+class Foo a b | a -> b, b -> a+```++Long++```haskell+-- https://github.com/commercialhaskell/hindent/issues/323+class Foo a b c d e f+  | a b c d e -> f+  , a b c d f -> e+  , a b c e f -> d+  , a b d e f -> c+  , a c d e f -> b+  , b c d e f -> a+  where+  foo :: a -> b -> c -> d -> e -> f+```++#### With class constraints++Single++```haskell+-- https://github.com/commercialhaskell/hindent/issues/459+class Class1 a =>+      Class2 a+  where+  f :: a -> Int+```++Multiple++```haskell+-- https://github.com/commercialhaskell/hindent/issues/459+class (Eq a, Show a) =>+      Num a+  where+  (+), (-), (*) :: a -> a -> a+  negate :: a -> a+  abs, signum :: a -> a+  fromInteger :: Integer -> a+```++#### MINIMAL pragmas++Monad example++```haskell+class A where+  {-# MINIMAL return, ((>>=) | (join, fmap)) #-}+```++Very long names #310++```haskell+class A where+  {-# MINIMAL averylongnamewithnoparticularmeaning+            | ananotherverylongnamewithnomoremeaning #-}+```++## Expressions++A minus sign++```haskell+f = -(3 + 5)+```++Lists++```haskell+exceptions = [InvalidStatusCode, MissingContentHeader, InternalServerError]++exceptions =+  [ InvalidStatusCode+  , MissingContentHeader+  , InternalServerError+  , InvalidStatusCode+  , MissingContentHeader+  , InternalServerError+  ]+```++Multi-way if++```haskell+x =+  if | x <- Just x+     , x <- Just x ->+       case x of+         Just x -> e+         Nothing -> p+     | otherwise -> e+```++Type application++```haskell+{-# LANGUAGE TypeApplications #-}++a = fun @Int 12+```++An expression with a SCC pragma++```haskell+foo = {-# SCC foo #-} undefined+```++A hole++```haskell+foo = 3 + _+```++Implicit value++```haskell+{-# LANGUAGE ImplicitParams #-}++foo = ?undefined+```++`UnboxedSums`++```haskell+{-# LANGUAGE UnboxedSums #-}++f = (# | Bool #)+```++`StaticPointers`++```haskell+{-# LANGUAGE StaticPointers #-}++f = static 1+```++`OverloadedLabels`++```haskell+{-# LANGUAGE OverloadedLabels #-}++f = #foo+```++### Arrows++`-<`++```haskell+{-# LANGUAGE Arrows #-}++f =+  proc foo -> do+    bar -< baz+    aaa >- bbb+```++`-<<`++```haskell+{-# LANGUAGE Arrows #-}++f =+  proc foo -> do+    g bar -<< baz+    aaaaa >>- h bbb+```++`(| ... |)`++```haskell+{-# LANGUAGE Arrows #-}++f = proc g -> (|foo (bar -< g) (baz -< g)|) zz+```++Lambda equation.++```haskell+{-# LANGUAGE Arrows #-}++f = proc g -> \x -> x -< g+```++Case expression.++```haskell+{-# LANGUAGE Arrows #-}++f =+  proc g ->+    case h of+      [] -> i -< ()+      (_:_) -> j -< ()+```++Lambda case++```haskell+{-# LANGUAGE Arrows #-}+{-# LANGUAGE LambdaCase #-}++f =+  proc g ->+    \case+      _ -> h -< ()+```++`if ... then ... else`++```haskell+{-# LANGUAGE Arrows #-}++f =+  proc g ->+    if x+      then h -< g+      else t -< g+```++`let ... in`++```haskell+{-# LANGUAGE Arrows #-}++f =+  proc g ->+    let x = undefined+        y = undefined+     in returnA -< g+```++### Case expressions++Normal case++```haskell+strToMonth :: String -> Int+strToMonth month =+  case month of+    "Jan" -> 1+    "Feb" -> 2+    _ -> error $ "Unknown month " ++ month+```++Inside a `where` and `do`++```haskell+g x =+  case x of+    a -> x+  where+    foo =+      case x of+        _ -> do+          launchMissiles+      where+        y = 2+```++Empty case++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/414+{-# LANGUAGE EmptyCase #-}++f1 = case () of {}+```++Empty lambda case++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/414+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE LambdaCase #-}++f2 = \case {}+```++A guard in a case++```haskell+f =+  case g of+    []+      | even h -> Nothing+    _ -> undefined+```++cases++```haskell since 9.4.1+{-# LANGUAGE Arrows #-}+{-# LANGUAGE LambdaCase #-}++foo =+  \cases+    1 1 -> 1+    _ _ -> 2+```++### `do` expressions++Long function applications++```haskell+test = do+  alphaBetaGamma deltaEpsilonZeta etaThetaIota kappaLambdaMu nuXiOmicron piRh79+  alphaBetaGamma deltaEpsilonZeta etaThetaIota kappaLambdaMu nuXiOmicron piRho80+  alphaBetaGamma+    deltaEpsilonZeta+    etaThetaIota+    kappaLambdaMu+    nuXiOmicron+    piRhoS81+```++Do as a left-hand side of an infix operation++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/238+-- https://github.com/mihaimaruseac/hindent/issues/296+block = do+  ds <- inBraces $ inWhiteSpace declarations+  return $ Block ds+  <?> "block"+```++#### Bindings++Short++```haskell+foo = do+  mcp <- findCabalFiles (takeDirectory abssrcpath) (takeFileName abssrcpath)+  print mcp+```++Large++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/221+x = do+  config <- execParser options+  comments <-+    case config of+      Diff False args -> commentsFromDiff args+      Diff True args -> commentsFromDiff ("--cached" : args)+      Files args -> commentsFromFiles args+  mapM_ (putStrLn . Fixme.formatTodo) (concatMap Fixme.getTodos comments)+```++#### `let` bindings++With type signatures but no class constraints++```haskell+f = do+  let g :: Int+      g = 3+  print g+```++With both type signatures and class constraints++```haskell+f = do+  let try :: Typeable b => b+      try = undefined+  undefined+```++#### `RecursiveDo`++`rec`++```haskell+{-# LANGUAGE RecursiveDo #-}++f = do+  a <- foo+  rec b <- a c+      c <- a b+  return $ b + c+```++`mdo`++```haskell+{-# LANGUAGE RecursiveDo #-}++g = mdo+  foo+  bar+```++#### `QualifiedDo`++Qualified do++```haskell+{-# LANGUAGE QualifiedDo #-}++f = Module.Path.do+  a <- foo+  return a+```++Qualified do with `mdo`++```haskell+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE QualifiedDo #-}++f = Module.Path.mdo+  a <- foo+  return a+```++### Function applications++Long line, tuple++```haskell+a =+  test+    (alphaBetaGamma, deltaEpsilonZeta, etaThetaIota, kappaLambdaMu, nuXiOmic79)+    (alphaBetaGamma, deltaEpsilonZeta, etaThetaIota, kappaLambdaMu, nuXiOmicr80)+    ( alphaBetaGamma+    , deltaEpsilonZeta+    , etaThetaIota+    , kappaLambdaMu+    , nuXiOmicro81)+```++Long line, tuple section++```haskell+a =+  test+    (, alphaBetaGamma, , deltaEpsilonZeta, , etaThetaIota, kappaLambdaMu, nu79)+    (, alphaBetaGamma, , deltaEpsilonZeta, , etaThetaIota, kappaLambdaMu, nuX80)+    (+    , alphaBetaGamma+    ,+    , deltaEpsilonZeta+    ,+    , etaThetaIota+    , kappaLambdaMu+    , nuXi81+    ,)+```++Linebreaks after very short names if the total line length goes over the limit++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/405+t =+  f "this is a very loooooooooooooooooooooooooooong string that goes over the line length"+    argx+    argy+    argz++t =+  function+    "this is a very loooooooooooooooooooooooooooong string that goes over the line length"+    argx+    argy+    argz+```++### Lambda expressions++Lazy patterns++```haskell+f = \ ~a -> undefined+-- \~a yields parse error on input ‘\~’+```++Bang patterns++```haskell+f = \ !a -> undefined+-- \!a yields parse error on input ‘\!’+```++An infix operator with a lambda expression++```haskell+a =+  for xs $ \x -> do+    left x+    right x+```++Nested lambdas++```haskell+foo :: IO ()+foo =+  alloca 10 $ \a ->+    alloca 20 $ \b ->+      cFunction fooo barrr muuu (fooo barrr muuu) (fooo barrr muuu)+```++In a `case`++```haskell+f x =+  case filter (\y -> isHappy y x) of+    [] -> Nothing+    (z:_) -> Just (\a b -> makeSmile z a b)+```++### Let ... in expressions++With bang parameters++```haskell+f =+  let !x = 3+   in x+```++With implicit parameters++```haskell+{-# LANGUAGE ImplicitParams #-}++f =+  let ?x = 42+   in f+```++With implicit parameters in a `where`++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/1120+{-# LANGUAGE ImplicitParams #-}++foo :: Int -> Int+foo x+  | x > 0 = ?bar+  where+    ?bar = x + 1+```++inside a `do`++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/467+main :: IO ()+main = do+  let x = 5+   in when (x > 0) (return ())+```++### List comprehensions++Short++```haskell+map f xs = [f x | x <- xs]+```++Long++```haskell+defaultExtensions =+  [ e+  | EnableExtension {extensionField1 = extensionField1} <-+      knownExtensions knownExtensions+  , let a = b+    -- comment+  , let c = d+    -- comment+  ]+```++Another long one++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/357+foo =+  [ (x, y)+  | x <- [1 .. 10]+  , y <- [11 .. 20]+  , even x+  , even x+  , even x+  , even x+  , even x+  , odd y+  ]+```++With operators++```haskell+defaultExtensions =+  [e | e@EnableExtension {} <- knownExtensions]+    \\ map EnableExtension badExtensions+```++Transform list comprehensions++```haskell+list =+  [ (x, y, map the v)+  | x <- [1 .. 10]+  , y <- [1 .. 10]+  , let v = x + y+  , then group by v using groupWith+  , then take 10+  , then group using permutations+  , t <- concat v+  , then takeWhile by t < 3+  ]+```++#### Parallel list comprehensions++Short++```haskell+zip xs ys = [(x, y) | x <- xs | y <- ys]+```++Long++```haskell+fun xs ys =+  [ (alphaBetaGamma, deltaEpsilonZeta)+  | x <- xs+  , z <- zs+  | y <- ys+  , cond+  , let t = t+  ]+```++### Operators++With `do`++```haskell+a =+  for xs $ do+    left x+    right x+```++With lambda-case++```haskell+a =+  for xs $ \case+    Left x -> x+```++Qualified operator as an argument++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/273+foo = foldr1 (V.++) [V.empty, V.empty]+```++Apply an infix operator in prefix style++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/273+ys = (++) [] []+```++Qualified operator++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/273+xs = V.empty V.++ V.empty+```++In parentheses++```haskell+cat = (++)+```++Qualified operator in parentheses++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/273+cons = (V.++)+```++A list constructor enclosed by parentheses++```haskell+cons = (:)+```++A data constructor enclosed by parentheses++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/422+data T a =+  a :@ a++test = (:@)+```++Force indent and print RHS in a top-level expression++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/473+a =+  template+    $ haskell+        [ SomeVeryLongName+        , AnotherLongNameEvenLongToBreakTheLine+        , LastLongNameInList+        ]+```++#### Operator chains++Applicative style++```haskell+x =+  Value+    <$> thing+    <*> secondThing+    <*> thirdThing+    <*> fourthThing+    <*> Just thisissolong+    <*> Just stilllonger+    <*> evenlonger+```++`$` chain++```haskell+f =+  Right+    $ S.lazyByteStrings+    $ addPrefix prefix+    $ S.toLazyByteString+    $ prettyPrint m+```++Arithmetic operations++```haskell+f =+  aaaaaaaaaa * bbbbbbbbbbbbbb / cccccccccccccccccccccc+    + dddddddddddddd * eeeeeeeeeeeeeeee+    - ffffffffffffffff / -ggggggggggggg+```++Lens operators++```haskell+updateUsr usr =+  usr+    & userFirstName .~ "newfirst"+    & userLastName .~ "newlast"+    & userEmail .~ "newemail"+    & userPassword .~ "newpass"+```++### Primitive type values++`Char`++```haskell+a = 'a'+```++`\n` as a `Char`++```haskell+a = '\n'+```++`String` with a `\n`++```haskell+a = "bcd\nefgh"+```++Multiple line string++```haskell+foo =+  "hoge \+ \ fuga"+  where+    bar =+      "foo \+     \ bar"+```++Hex integers++```haskell+a = 0xa5+```++Unboxed integers++```haskell+{-# LANGUAGE MagicHash #-}++a = 0#+```++Unboxed floating point numbers++```haskell+{-# LANGUAGE MagicHash #-}++a = 3.3#+```++Unboxed `Char`++```haskell+{-# LANGUAGE MagicHash #-}++a = 'c'#+```++Unboxed `String`++```haskell+{-# LANGUAGE MagicHash #-}++a = "Foo"#+```++`UnboxedTuple`++```haskell+{-# LANGUAGE UnboxedTuples #-}++f :: (# Int, Int #) -> (# Int, Int #)+f t =+  case t of+    (# x, y #) -> (# x, y #)+```++`NumericUnderscores`++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/542+{-# LANGUAGE NumericUnderscores #-}++foo = 10_000+```++### Quasi-quotes++Body has multiple lines.++```haskell+{-# LANGUAGE QuasiQuotes #-}++f =+  [s|First line+Second line|]+```++Body has a top-level declaration.++```haskell+{-# LANGUAGE QuasiQuotes #-}++f =+  [d| f :: Int -> Int+      f = undefined |]+```++Typed quote.++```haskell+f = [||a||]+```++Preserve the trailing newline.++```haskell+{-# LANGUAGE QuasiQuotes #-}++f =+  [s|foo+|]+```++### Ranges++from++```haskell+a = [1 ..]+```++from to++```haskell+a = [1 .. 9]+```++from then++```haskell+b = [1,3 ..]+```++from then to++```haskell+c = [1,3 .. 9]+```++### Records++No fields++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/366+foo = Nothing {}+```++Short++```haskell+getGitProvider :: EventProvider GitRecord ()+getGitProvider =+  EventProvider {getModuleName = "Git", getEvents = getRepoCommits}+```++Medium++```haskell+commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event+commitToEvent gitFolderPath timezone commit =+  Event.Event+    {pluginName = getModuleName getGitProvider, eventIcon = "glyphicon-cog"}+```++Long++```haskell+commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event+commitToEvent gitFolderPath timezone commit =+  Event.Event+    { pluginName = getModuleName getGitProvider+    , eventIcon = "glyphicon-cog"+    , eventDate = localTimeToUTC timezone (commitDate commit)+    }+```++Another long one++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/358+foo =+  assert+    sanityCheck+    BomSnapshotAggr+      { snapshot = Just bs+      , previousId = M.bomSnapshotHistoryPreviousId . entityVal <$> bsp+      , nextId = M.bomSnapshotHistoryNextId . entityVal <$> bsn+      , bomEx = bx''+      , orderSubstitutes =+          S.fromList . map OrderSubstituteAggrByCreatedAtAsc $ subs+      , snapshotSubstitute = msub+      }+```++Record body may be in one line even if a new line is inserted after the variable name.++```haskell+addCommentsToNode mkNodeComment newComments nodeInfo@(NodeInfo (SrcSpanInfo _ _) existingComments) =+  nodeInfo+    {nodeInfoComments = existingComments <> map mkBeforeNodeComment newComments}+```++Symbol constructor++```haskell+f = (:..?) {}+```++Symbol field++```haskell+f x = x {(..?) = wat}++g x = Rec {(..?)}+```++A field updater in a `do` inside a `let ... in`.++```haskell+f = undefined+  where+    g h =+      let x = undefined+       in do+            foo+            pure+              h+                { grhssLocalBinds =+                    HsValBinds x (ValBinds (newSigs newSigMethods))+                }+```++`OverloadedRecordDot`++```haskell since 9.2.2+{-# LANGUAGE OverloadedRecordDot #-}++data Rectangle = Rectangle+  { width :: Int+  , height :: Int+  }++area :: Rectangle -> Int+area r = r.width * r.height++foo = (.x.y)+```++`OverloadedRecordUpdate`++```haskell since 9.2.0+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedRecordUpdate #-}++foo = bar {baz.qux = 1}+```++### Sections++With a LHS++```haskell+double = (2 *)+```++With a RHS++```haskell+halve = (/ 2)+```++With a large RHS++```haskell+foo =+  (`elem` concat+            [ [20, 68, 92, 112, 28, 124, 116, 80]+            , [21, 84, 87, 221, 127, 255, 241, 17]+            ])+```++## Template Haskell++Expression brackets++```haskell+add1 x = [|x + 1|]+```++Pattern brackets++```haskell+{-# LANGUAGE TemplateHaskell #-}++mkPat = [p|(x, y)|]+```++Type brackets++```haskell+{-# LANGUAGE TemplateHaskell #-}++foo :: $([t|Bool|]) -> a+```++A quoted TH name from a type name++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/412+{-# LANGUAGE TemplateHaskell #-}++data (-)++q = ''(-)+```++Quoted list constructors++```haskell+{-# LANGUAGE TemplateHaskell #-}++cons = '(:)+```++Pattern splices++```haskell+{-# LANGUAGE TemplateHaskell #-}++f $pat = ()++g =+  case x of+    $(mkPat y z) -> True+    _ -> False+```++Typed splice++```haskell+{-# LANGUAGE TemplateHaskell #-}++foo = $$bar+```++Template Haskell function calls without arguments should not get '$' prepended++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/973+{-# LANGUAGE TemplateHaskell #-}++makeSem ''MyData++deriveJSON+```++## Comments++Only comments++```haskell+-- foo+```++Double comments in a line++```haskell+f = undefined {- Comment 1 -} {- Comment 2 -} -- Comment 3+```++Comments within a declaration++```haskell+bob -- after bob+ =+  foo -- next to foo+  -- line after foo+    (bar+       foo -- next to bar foo+       bar -- next to bar+     ) -- next to the end paren of (bar)+    -- line after (bar)+    mu -- next to mu+    -- line after mu+    -- another line after mu+    zot -- next to zot+    -- line after zot+    (case casey -- after casey+           of+       Just -- after Just+        -> do+         justice -- after justice+           * foo+               (blah * blah+                  + z+                  + 2 / 4+                  + a+                  - -- before a line break+                   2+                     * -- inside this mess+                      z+                     / 2+                     / 2+                     / aooooo+                     / aaaaa -- bob comment+                )+           + (sdfsdfsd fsdfsdf) -- blah comment+         putStrLn "")+    [1, 2, 3]+    [ 1 -- foo+    , ( 2 -- bar+      , 2.5 -- mu+       )+    , 3+    ]+    -- in the end of the function+  where+    alpha = alpha+    -- between alpha and beta+    beta = beta+    -- after beta++foo = 1 -- after foo++gamma = do+  delta+  epsilon+  -- in the end of a do-block 1++gamma = do+  delta+  epsilon+  -- the very last block is detected differently+```++Comments in a do expression++```haskell+gamma = do+  -- in the beginning of a do-block+  delta+```++Comments in a class instance++```haskell+instance Pretty MatchForCase+  -- TODO: Do not forget to handle comments!+                                             where+  pretty' = undefined+```++Comments in a case expression++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/553+f x =+  case x of+    -- Bla bla+    Nothing -> 0+    Just y -> y+```++Haddock comments++```haskell+-- | Module comment.+module X where++-- | Main doc.+main :: IO ()+main = return ()++data X+  = X -- ^ X is for xylophone.+  | Y -- ^ Y is for why did I eat that pizza.++data X = X+  { field1 :: Int -- ^ Field1 is the first field.+  , field11 :: Char+    -- ^ This field comment is on its own line.+  , field2 :: Int -- ^ Field2 is the second field.+  , field3 :: Char -- ^ This is a long comment which starts next to+    -- the field but continues onto the next line, it aligns exactly+    -- with the field name.+  , field4 :: Char+    -- ^ This is a long comment which starts on the following line+    -- from from the field, lines continue at the sme column.+  }++foo ::+     String -- ^ Reason for eating pizza.+  -> Int -- ^ How many did you eat pizza?+  -> String -- ^ The report.+foo = undefined+```++Haddock for a class method++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/607+class Foo a where+  -- | Doc+  foo :: a+```++Module header with haddock comments++```haskell+-- | A module+module HIndent -- Foo+  ( -- * Formatting functions.+    reformat+  , -- * Testing+    test+  ) where+```++Comments around regular declarations++```haskell+-- This is some random comment.+-- | Main entry point.+main = putStrLn "Hello, World!"+-- This is another random comment.+```++Multi-line comments++```haskell+bob {- after bob -}+ =+  foo {- next to foo -}+  {- line after foo -}+    (bar+       foo {- next to bar foo -}+       bar {- next to bar -}+     ) {- next to the end paren of (bar) -}+    {- line after (bar) -}+    mu {- next to mu -}+    {- line after mu -}+    {- another line after mu -}+    zot {- next to zot -}+    {- line after zot -}+    (case casey {- after casey -}+           of+       Just {- after Just -}+        -> do+         justice {- after justice -}+           * foo+               (blah * blah+                  + z+                  + 2 / 4+                  + a+                  - {- before a line break -}+                   2+                     * {- inside this mess -}+                      z+                     / 2+                     / 2+                     / aooooo+                     / aaaaa {- bob comment -}+                )+           + (sdfsdfsd fsdfsdf) {- blah comment -}+         putStrLn "")+    [1, 2, 3]+    [ 1 {- foo -}+    , ( 2 {- bar -}+      , 2.5 {- mu -}+       )+    , 3+    ]++foo = 1 {- after foo -}+```++Multi-line comments with multi-line contents++```haskell+{- | This is some random comment.+Here is more docs and such.+Etc.+-}+main = putStrLn "Hello, World!"+{- This is another random comment. -}+```++Comments on functions in where clause++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/540+topLevelFunc1 = f+  where+    -- comment on func in where clause+    -- stays in the where clause+    f = undefined++topLevelFunc2 = f . g+    -- Another comment+  where+    {- multi+       line+       comment -}+    f = undefined -- single line comment+    -- single line comment+        -- Different size of indent+    g :: a+    g = undefined+```++Comments in a 'where' clause++```haskell+foo = undefined+  where+    bar+      -- A comment+     = undefined+      where+        a = b+    baz = undefined+```++Haddocks around data constructors++```haskell+data Foo+    -- | A haddock comment for 'Bar'.+  = Bar+    -- | A haddock comment for 'Baz'.+  | Baz+    -- | A haddock comment for 'Quuz'.+  | Quuz+```++## Identifiers++Unicode++```haskell+α = γ * "ω"+-- υ+```++`rec` and `mdo` are valid identifiers unless `RecursiveDo` is enabled++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/328+rec = undefined++mdo = undefined+```++The first character of an infix operator can be `@` unless `TypeApplications` is enabled.++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/421+a @: b = a + b++main = print (2 @: 2)+```++## Complex input++A complex, slow-to-print decl++```haskell+{-# LANGUAGE TemplateHaskell #-}++quasiQuotes =+  [ ( ''[]+    , \(typeVariable:_) _automaticPrinter ->+        (let presentVar = varE (presentVarName typeVariable)+          in lamE+               [varP (presentVarName typeVariable)]+               [|(let typeString = "[" ++ fst $(presentVar) ++ "]"+                   in ( typeString+                      , \xs ->+                          case fst $(presentVar) of+                            "GHC.Types.Char" ->+                              ChoicePresentation+                                "String"+                                [ ( "String"+                                  , StringPresentation+                                      "String"+                                      (concatMap+                                         getCh+                                         (map (snd $(presentVar)) xs)))+                                , ( "List of characters"+                                  , ListPresentation+                                      typeString+                                      (map (snd $(presentVar)) xs))+                                ]+                              where+                                getCh (CharPresentation "GHC.Types.Char" ch) =+                                  ch+                                getCh (ChoicePresentation _ ((_, CharPresentation _ ch):_)) =+                                  ch+                                getCh _ = ""+                            _ ->+                              ListPresentation+                                typeString+                                (map (snd $(presentVar)) xs)))|]))+  ]+```++Random snippet from hindent itself++```haskell+exp' (App _ op a) = do+  (fits, st) <- fitsOnOneLine (spaced (map pretty (f : args)))+  if fits+    then put st+    else do+      pretty f+      newline+      spaces <- getIndentSpaces+      indented spaces (lined (map pretty args))+  where+    (f, args) = flatten op [a]+    flatten :: Exp NodeInfo -> [Exp NodeInfo] -> (Exp NodeInfo, [Exp NodeInfo])+    flatten (App _ f' a') b = flatten f' (a' : b)+    flatten f' as = (f', as)+```++Quasi quotes++```haskell+{-# LANGUAGE QuasiQuotes #-}++exp = [name|exp|]++f [qq|pattern|] = ()+```++## C preprocessor++Conditionals (`#if`)++```haskell+isDebug :: Bool+#if DEBUG+isDebug = True+#else+isDebug = False+#endif+```++Conditionals inside a `where` with empty lines and CPP++```haskell+-- https://github.com/mihaimaruseac/hindent/issues/779+foo = bar + baz+  where++#if 0+    bar = 1+    +    baz = 1+#else+    bar = 2+    +    baz = 2+#endif+```++Macro definitions (`#define`)++```haskell+#define STRINGIFY(x) #x+f = STRINGIFY (y)+```++Escaped newlines++```haskell+#define LONG_MACRO_DEFINITION \+  data Pair a b = Pair \+    { first :: a \+    , second :: b \+    }+#define SHORT_MACRO_DEFINITION \+  x+```++Language extensions are effective across CPP boundaries.++```haskell+{-# LANGUAGE PatternSynonyms #-}+#if 1+pattern Foo :: Int -> Bar+#else+pattern Foo :: Int -> Bar+#endif+```++## Literate Haskell++Code with `>`s++```haskell+> -- https://github.com/mihaimaruseac/hindent/issues/103+> foo :: a+> foo = undefined ```
+ app/Main.hs view
@@ -0,0 +1,13 @@+-- | Main entry point to hindent.+--+-- hindent+module Main+  ( main+  ) where++import HIndent+import System.Environment++-- | Main entry point.+main :: IO ()+main = getArgs >>= hindent
+ benchmarks/Main.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Benchmark the pretty printer.+module Main where++import Control.DeepSeq+import Criterion+import Criterion.Main+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.UTF8 as UTF8+import HIndent+import HIndent.Internal.Test.Markdone++-- | Main benchmarks.+main :: IO ()+main = do+  bytes <- S.readFile "BENCHMARKS.md"+  !forest <- fmap force (parse (tokenize bytes))+  defaultMain (toCriterion forest)++-- | Convert the Markdone document to Criterion benchmarks.+toCriterion :: [Markdone] -> [Benchmark]+toCriterion = go+  where+    go (Section name children:next) =+      bgroup (S8.unpack name) (go children) : go next+    go (PlainText desc:CodeFence lang code:next) =+      if lang == "haskell"+        then bench+               (UTF8.toString desc)+               (nf+                  (either (error . show) id+                     . reformat HIndent.defaultConfig defaultExtensions Nothing)+                  code)+               : go next+        else go next+    go (PlainText {}:next) = go next+    go (CodeFence {}:next) = go next+    go [] = []
elisp/hindent.el view
@@ -1,10 +1,10 @@-;;; hindent.el --- Indent haskell code using the "hindent" program+;;; hindent.el --- Indent haskell code using the "hindent" program -*- lexical-binding: t -*-  ;; Copyright (c) 2014 Chris Done. All rights reserved.  ;; Author: Chris Done <chrisdone@gmail.com>-;; URL: https://github.com/chrisdone/hindent-;; Package-Requires: ((cl-lib "0.5"))+;; URL: https://github.com/mihaimaruseac/hindent+;; Package-Requires: ((emacs "27.1"))  ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by@@ -31,7 +31,7 @@  ;;; Code: -(require 'cl-lib)+(eval-when-compile (require 'cl-lib))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Customization properties@@ -63,11 +63,13 @@ (defcustom hindent-extra-args nil   "Extra arguments to give to hindent"   :group 'hindent-  :type 'sexp-  :safe #'listp)+  :type '(choice+          (repeat string)+          (function :tag "Function with no arguments returning a list of strings")))  (defcustom hindent-reformat-buffer-on-save nil-  "Set to t to run `hindent-reformat-buffer' when a buffer in `hindent-mode' is saved."+  "Set to t to run `hindent-reformat-buffer' when a buffer in+`hindent-mode' is saved."   :group 'hindent   :type 'boolean   :safe #'booleanp)@@ -196,16 +198,6 @@                                           nil)                                     (hindent-extra-arguments)))))             (cond-             ((= ret 1)-              (let ((error-string-                     (with-current-buffer temp-                       (let ((string (progn (goto-char (point-min))-                                            (buffer-substring (line-beginning-position)-                                                              (line-end-position)))))-                         string))))-                (if (string= error-string "hindent: Parse error: EOF")-                    (message "language pragma")-                  (error error-string))))              ((= ret 0)               (let* ((last-decl (= end (point-max)))                      (new-str (with-current-buffer temp@@ -213,20 +205,24 @@                                   (goto-char (point-max))                                   (when (looking-back "\n" (1- (point)))                                     (delete-char -1)))-				(delete-trailing-whitespace)+                                (delete-trailing-whitespace)                                 (buffer-string))))                 (if (not (string= new-str orig-str))-		    (progn-		      (if (fboundp 'replace-region-contents)-			  (replace-region-contents-			   beg end (lambda () temp))-			(let ((line (line-number-at-pos))-			      (col (current-column)))-			  (delete-region beg-					 end)-			  (insert new-str)))-		      (message "Formatted."))-                  (message "Already formatted.")))))))))))+                    (progn+                      (replace-region-contents beg end (lambda () temp))+                      (message "Formatted."))+                  (message "Already formatted."))))+             (t+              (let ((error-string+                     (with-current-buffer temp+                       (let ((string (progn (goto-char (point-min))+                                            (buffer-substring (line-beginning-position)+                                                              (line-end-position)))))+                         string))))+                (if (string= error-string "hindent: Parse error: EOF")+                    (message "language pragma")+                  (error error-string))))+             )))))))  (defun hindent-decl-points ()   "Get the start and end position of the current declaration.@@ -253,35 +249,33 @@    (t     (save-excursion       (let ((start-             (or (cl-letf-                     (((symbol-function 'jump)-                       #'(lambda ()-                           (search-backward-regexp "^[^ \n]" nil t 1)-                           (cond-                            ((save-excursion (goto-char (line-beginning-position))-                                             (looking-at "|]"))-                             (jump))-                            (t (unless (or (looking-at "^-}$")-                                           (looking-at "^{-$"))-                                 (point)))))))+             (or (cl-labels+                     ((jump ()+                        (search-backward-regexp "^[^ \n]" nil t 1)+                        (cond+                         ((save-excursion (goto-char (line-beginning-position))+                                          (looking-at "|]"))+                          (jump))+                         (t (unless (or (looking-at "^-}$")+                                        (looking-at "^{-$"))+                              (point))))))                    (goto-char (line-end-position))                    (jump))                  0))             (end              (progn                (goto-char (1+ (point)))-               (or (cl-letf-                       (((symbol-function 'jump)-                         #'(lambda ()-                             (when (search-forward-regexp "[\n]+[^ \n]" nil t 1)-                               (cond-                                ((save-excursion (goto-char (line-beginning-position))-                                                 (looking-at "|]"))-                                 (jump))-                                (t (forward-char -1)-                                   (search-backward-regexp "[^\n ]" nil t)-                                   (forward-char)-                                   (point)))))))+               (or (cl-labels+                       ((jump ()+                          (when (search-forward-regexp "[\n]+[^ \n]" nil t 1)+                            (cond+                             ((save-excursion (goto-char (line-beginning-position))+                                              (looking-at "|]"))+                              (jump))+                             (t (forward-char -1)+                                (search-backward-regexp "[^\n ]" nil t)+                                (forward-char)+                                (point))))))                      (jump))                    (point-max)))))         (cons start end))))))@@ -308,7 +302,9 @@    (when hindent-style      (list "--style" hindent-style))    (when hindent-extra-args-     hindent-extra-args)))+     (if (functionp hindent-extra-args)+         (funcall hindent-extra-args)+       hindent-extra-args))))  (provide 'hindent)
hindent.cabal view
@@ -1,113 +1,361 @@-name:                hindent-version:             5.3.4-synopsis:            Extensible Haskell pretty printer-description:         Extensible Haskell pretty printer. Both a library and an executable.-                     .-                     See the Github page for usage\/explanation: <https://github.com/mihaimaruseac/hindent>-license:             BSD3-stability:           Unstable-license-file:        LICENSE.md-author:              Mihai Maruseac, Chris Done, Andrew Gibiansky, Tobias Pflug, Pierre Radermecker-maintainer:          Mihai Maruseac-copyright:           2014 Chris Done, 2015 Andrew Gibiansky, 2021 Mihai Maruseac-category:            Development-build-type:          Simple-cabal-version:       >=1.10-homepage:            https://github.com/mihaimaruseac/hindent-bug-reports:         https://github.com/mihaimaruseac/hindent/issues-data-files:          elisp/hindent.el+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.39.1.+--+-- see: https://github.com/sol/hpack++name:           hindent+version:        6.3.0+synopsis:       Extensible Haskell pretty printer+description:    Extensible Haskell pretty printer. Both a library and an executable.+                See the GitHub page for usage \/ explanation: <https://github.com/mihaimaruseac/hindent>+category:       Development+stability:      Unstable+homepage:       https://github.com/mihaimaruseac/hindent+bug-reports:    https://github.com/mihaimaruseac/hindent/issues+author:         Mihai Maruseac, Chris Done, Andrew Gibiansky, Tobias Pflug, Pierre Radermecker+maintainer:     Mihai Maruseac+copyright:      2014 Chris Done, 2015 Andrew Gibiansky, 2021 Mihai Maruseac+license:        BSD3+license-file:   LICENSE.md+build-type:     Simple extra-source-files:- README.md- CHANGELOG.md- BENCHMARKS.md- TESTS.md+    README.md+    CHANGELOG.md+    BENCHMARKS.md+    TESTS.md+data-files:+    elisp/hindent.el  source-repository head-    type:           git-    location:       https://github.com/mihaimaruseac/hindent+  type: git+  location: https://github.com/mihaimaruseac/hindent  library-  hs-source-dirs:    src/-  ghc-options:       -Wall -O2-  default-language:  Haskell2010-  exposed-modules:   HIndent-                     HIndent.Types-                     HIndent.Pretty-                     HIndent.CabalFile-                     HIndent.CodeBlock-  build-depends:     base >= 4.7 && <5-                   , containers-                   , Cabal-                   , filepath-                   , directory-                   , haskell-src-exts >= 1.20-                   , monad-loops-                   , mtl-                   , bytestring-                   , utf8-string-                   , transformers-                   , exceptions-                   , text-                   , yaml+  exposed-modules:+      HIndent+  other-modules:+      HIndent.Applicative+      HIndent.Ast+      HIndent.Ast.Cmd+      HIndent.Ast.Comment+      HIndent.Ast.Context+      HIndent.Ast.Declaration+      HIndent.Ast.Declaration.Annotation+      HIndent.Ast.Declaration.Annotation.Provenance+      HIndent.Ast.Declaration.Annotation.Role+      HIndent.Ast.Declaration.Bind+      HIndent.Ast.Declaration.Bind.GuardedRhs+      HIndent.Ast.Declaration.Class+      HIndent.Ast.Declaration.Class.FunctionalDependency+      HIndent.Ast.Declaration.Class.NameAndTypeVariables+      HIndent.Ast.Declaration.Collection+      HIndent.Ast.Declaration.Data+      HIndent.Ast.Declaration.Data.Body+      HIndent.Ast.Declaration.Data.Constructor.Field+      HIndent.Ast.Declaration.Data.Deriving+      HIndent.Ast.Declaration.Data.Deriving.Clause+      HIndent.Ast.Declaration.Data.Deriving.Strategy+      HIndent.Ast.Declaration.Data.GADT.Constructor+      HIndent.Ast.Declaration.Data.GADT.Constructor.Signature+      HIndent.Ast.Declaration.Data.Haskell98.Constructor+      HIndent.Ast.Declaration.Data.Haskell98.Constructor.Body+      HIndent.Ast.Declaration.Data.Header+      HIndent.Ast.Declaration.Data.NewOrData+      HIndent.Ast.Declaration.Data.Record.Field+      HIndent.Ast.Declaration.Default+      HIndent.Ast.Declaration.Family.Data+      HIndent.Ast.Declaration.Family.Type+      HIndent.Ast.Declaration.Family.Type.Injectivity+      HIndent.Ast.Declaration.Family.Type.ResultSignature+      HIndent.Ast.Declaration.Foreign+      HIndent.Ast.Declaration.Foreign.CallingConvention+      HIndent.Ast.Declaration.Foreign.Safety+      HIndent.Ast.Declaration.Instance.Class+      HIndent.Ast.Declaration.Instance.Class.OverlapMode+      HIndent.Ast.Declaration.Instance.Family.Data+      HIndent.Ast.Declaration.Instance.Family.Type+      HIndent.Ast.Declaration.Instance.Family.Type.Associated+      HIndent.Ast.Declaration.Instance.Family.Type.Associated.Default+      HIndent.Ast.Declaration.PatternSynonym+      HIndent.Ast.Declaration.Rule+      HIndent.Ast.Declaration.Rule.Binder+      HIndent.Ast.Declaration.Rule.Collection+      HIndent.Ast.Declaration.Rule.Name+      HIndent.Ast.Declaration.Signature+      HIndent.Ast.Declaration.Signature.BooleanFormula+      HIndent.Ast.Declaration.Signature.Fixity+      HIndent.Ast.Declaration.Signature.Fixity.Associativity+      HIndent.Ast.Declaration.Signature.Inline.Phase+      HIndent.Ast.Declaration.Signature.Inline.Spec+      HIndent.Ast.Declaration.Signature.StandaloneKind+      HIndent.Ast.Declaration.Splice+      HIndent.Ast.Declaration.StandAloneDeriving+      HIndent.Ast.Declaration.TypeSynonym+      HIndent.Ast.Declaration.TypeSynonym.Lhs+      HIndent.Ast.Declaration.Warning+      HIndent.Ast.Declaration.Warning.Collection+      HIndent.Ast.Declaration.Warning.Kind+      HIndent.Ast.Expression+      HIndent.Ast.Expression.Bracket+      HIndent.Ast.Expression.FieldSelector+      HIndent.Ast.Expression.ListComprehension+      HIndent.Ast.Expression.OverloadedLabel+      HIndent.Ast.Expression.Pragmatic+      HIndent.Ast.Expression.RangeExpression+      HIndent.Ast.Expression.RecordConstructionField+      HIndent.Ast.Expression.RecordUpdateField+      HIndent.Ast.Expression.Splice+      HIndent.Ast.FileHeaderPragma+      HIndent.Ast.FileHeaderPragma.Collection+      HIndent.Ast.Guard+      HIndent.Ast.Import+      HIndent.Ast.Import.Collection+      HIndent.Ast.Import.Entry+      HIndent.Ast.Import.Entry.Collection+      HIndent.Ast.Import.ImportingOrHiding+      HIndent.Ast.LocalBinds+      HIndent.Ast.LocalBinds.ImplicitBinding+      HIndent.Ast.LocalBinds.ImplicitBindings+      HIndent.Ast.Match+      HIndent.Ast.MatchGroup+      HIndent.Ast.Module+      HIndent.Ast.Module.Declaration+      HIndent.Ast.Module.Export.Collection+      HIndent.Ast.Module.Export.Entry+      HIndent.Ast.Module.Name+      HIndent.Ast.Module.Warning+      HIndent.Ast.Name.ImportExport+      HIndent.Ast.Name.Infix+      HIndent.Ast.Name.Prefix+      HIndent.Ast.Name.RecordField+      HIndent.Ast.NodeComments+      HIndent.Ast.Pattern+      HIndent.Ast.Pattern.RecordFields+      HIndent.Ast.Record.Field+      HIndent.Ast.Role+      HIndent.Ast.Statement+      HIndent.Ast.Type+      HIndent.Ast.Type.Bang+      HIndent.Ast.Type.Forall+      HIndent.Ast.Type.ImplicitParameterName+      HIndent.Ast.Type.Literal+      HIndent.Ast.Type.Multiplicity+      HIndent.Ast.Type.Strictness+      HIndent.Ast.Type.Unpackedness+      HIndent.Ast.Type.Variable+      HIndent.Ast.WithComments+      HIndent.ByteString+      HIndent.CabalFile+      HIndent.CodeBlock+      HIndent.CommandlineOptions+      HIndent.Config+      HIndent.Error+      HIndent.Fixity+      HIndent.GhcLibParserWrapper.GHC.Hs+      HIndent.GhcLibParserWrapper.GHC.Hs.ImpExp+      HIndent.GhcLibParserWrapper.GHC.Parser.Annotation+      HIndent.GhcLibParserWrapper.GHC.Unit.Module.Warnings+      HIndent.Language+      HIndent.LanguageExtension+      HIndent.LanguageExtension.Conversion+      HIndent.LanguageExtension.Types+      HIndent.ModulePreprocessing+      HIndent.ModulePreprocessing.CommentRelocation+      HIndent.Parse+      HIndent.Path.Find+      HIndent.Pragma+      HIndent.Pretty+      HIndent.Pretty.Combinators+      HIndent.Pretty.Combinators.Comment+      HIndent.Pretty.Combinators.Getter+      HIndent.Pretty.Combinators.Indent+      HIndent.Pretty.Combinators.Lineup+      HIndent.Pretty.Combinators.Op+      HIndent.Pretty.Combinators.Outputable+      HIndent.Pretty.Combinators.String+      HIndent.Pretty.Combinators.Switch+      HIndent.Pretty.Combinators.Wrap+      HIndent.Pretty.NodeComments+      HIndent.Pretty.SigBindFamily+      HIndent.Pretty.Types+      HIndent.Printer+      Paths_hindent+  autogen-modules:+      Paths_hindent+  hs-source-dirs:+      src+  ghc-options: -Wall -O2 -threaded+  build-depends:+      Cabal+    , async >=2.2.5+    , base >=4.7 && <5+    , bytestring+    , containers+    , directory+    , exceptions+    , filepath+    , ghc-lib-parser >=9.2 && <9.13+    , ghc-lib-parser-ex+    , monad-loops+    , mtl+    , optparse-applicative+    , path+    , path-io+    , regex-tdfa+    , split+    , syb+    , transformers+    , unicode-show+    , utf8-string+    , yaml+  default-language: Haskell2010 +library hindent-internal+  exposed-modules:+      HIndent.Internal.Test.Markdone+  other-modules:+      Paths_hindent+  autogen-modules:+      Paths_hindent+  hs-source-dirs:+      internal+  ghc-options: -Wall -O2 -threaded+  build-depends:+      Cabal+    , async >=2.2.5+    , base >=4.7 && <5+    , bytestring+    , containers+    , deepseq+    , directory+    , exceptions+    , filepath+    , ghc-lib-parser >=9.2 && <9.13+    , ghc-lib-parser-ex+    , monad-loops+    , mtl+    , optparse-applicative+    , path+    , path-io+    , regex-tdfa+    , split+    , syb+    , transformers+    , unicode-show+    , utf8-string+    , yaml+  default-language: Haskell2010+ executable hindent-  hs-source-dirs:    src/main-  ghc-options:       -Wall -O2-  default-language:  Haskell2010-  main-is:           Main.hs-  other-modules: Path.Find-  build-depends:     base >= 4 && < 5-                   , hindent-                   , bytestring-                   , utf8-string-                   , haskell-src-exts-                   , ghc-prim-                   , directory-                   , text-                   , yaml-                   , unix-compat-                   , deepseq-                   , path-                   , path-io-                   , transformers-                   , exceptions-                   , optparse-applicative+  main-is: Main.hs+  other-modules:+      Paths_hindent+  autogen-modules:+      Paths_hindent+  hs-source-dirs:+      app+  ghc-options: -Wall -O2 -threaded+  build-depends:+      Cabal+    , async >=2.2.5+    , base >=4.7 && <5+    , bytestring+    , containers+    , directory+    , exceptions+    , filepath+    , ghc-lib-parser >=9.2 && <9.13+    , ghc-lib-parser-ex+    , hindent+    , monad-loops+    , mtl+    , optparse-applicative+    , path+    , path-io+    , regex-tdfa+    , split+    , syb+    , transformers+    , unicode-show+    , utf8-string+    , yaml+  default-language: Haskell2010  test-suite hindent-test   type: exitcode-stdio-1.0-  hs-source-dirs: src/main/-  default-language:  Haskell2010-  main-is: Test.hs-  other-modules: Markdone-  build-depends:     base >= 4 && <5-                   , hindent-                   , haskell-src-exts-                   , monad-loops-                   , mtl-                   , bytestring-                   , utf8-string-                   , hspec-                   , directory-                   , deepseq-                   , exceptions-                   , utf8-string-                   , Diff+  main-is: Main.hs+  other-modules:+      Paths_hindent+  autogen-modules:+      Paths_hindent+  hs-source-dirs:+      tests+  ghc-options: -Wall -O2 -threaded+  build-depends:+      Cabal+    , Diff+    , async >=2.2.5+    , base >=4.7 && <5+    , bytestring+    , containers+    , directory+    , exceptions+    , filepath+    , ghc-lib-parser >=9.2 && <9.13+    , ghc-lib-parser-ex+    , hindent+    , hindent-internal+    , hspec+    , monad-loops+    , mtl+    , optparse-applicative+    , path+    , path-io+    , regex-tdfa+    , split+    , syb+    , transformers+    , unicode-show+    , utf8-string+    , yaml+  default-language: Haskell2010  benchmark hindent-bench   type: exitcode-stdio-1.0-  hs-source-dirs:    src/main-  default-language:  Haskell2010-  ghc-options:       -Wall -O2 -rtsopts-  main-is:           Benchmark.hs-  other-modules: Markdone-  build-depends:     base >= 4 && < 5-                   , hindent-                   , bytestring-                   , utf8-string-                   , haskell-src-exts-                   , ghc-prim-                   , directory-                   , criterion-                   , deepseq-                   , exceptions-                   , mtl+  main-is: Main.hs+  other-modules:+      Paths_hindent+  autogen-modules:+      Paths_hindent+  hs-source-dirs:+      benchmarks+  ghc-options: -Wall -O2 -threaded+  build-depends:+      Cabal+    , async >=2.2.5+    , base >=4.7 && <5+    , bytestring+    , containers+    , criterion+    , deepseq+    , directory+    , exceptions+    , filepath+    , ghc-lib-parser >=9.2 && <9.13+    , ghc-lib-parser-ex+    , hindent+    , hindent-internal+    , monad-loops+    , mtl+    , optparse-applicative+    , path+    , path-io+    , regex-tdfa+    , split+    , syb+    , transformers+    , unicode-show+    , utf8-string+    , yaml+  default-language: Haskell2010
+ internal/HIndent/Internal/Test/Markdone.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | A subset of markdown that only supports @#headings@ and code+-- fences.+--+-- All content must be in section headings with proper hierarchy,+-- anything else is rejected.+module HIndent.Internal.Test.Markdone+  ( Token(..)+  , Markdone(..)+  , tokenize+  , parse+  ) where++import Control.DeepSeq+import Control.Monad.Catch+import Control.Monad.State.Strict (State, evalState, get, put)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Char+import GHC.Generics++-- | A markdone token.+data Token+  = Heading !Int !ByteString+  | PlainLine !ByteString+  | BeginFence !ByteString+  | EndFence+  deriving (Eq, Show)++-- | A markdone document.+data Markdone+  = Section !ByteString ![Markdone]+  | CodeFence !ByteString !ByteString+  | PlainText !ByteString+  deriving (Eq, Show, Generic)++instance NFData Markdone++-- | Parse error.+data MarkdownError+  = NoFenceEnd+  | ExpectedSection+  deriving (Show)++instance Exception MarkdownError++data TokenizerMode+  = Normal+  | Fenced++-- | Tokenize the bytestring.+tokenize :: ByteString -> [Token]+tokenize input =+  evalState (mapM token (S8.filter (/= '\r') <$> S8.lines input)) Normal+  where+    token :: ByteString -> State TokenizerMode Token+    token line = do+      mode <- get+      case mode of+        Normal ->+          if S8.isPrefixOf "#" line+            then let (hashes, title) = S8.span (== '#') line+                  in return+                       $ Heading (S8.length hashes) (S8.dropWhile isSpace title)+            else if S8.isPrefixOf "```" line+                   then do+                     put Fenced+                     return+                       $ BeginFence+                           (S8.dropWhile (\c -> c == '`' || c == ' ') line)+                   else return $ PlainLine line+        Fenced ->+          if line == "```"+            then do+              put Normal+              return EndFence+            else return $ PlainLine line++-- | Parse into a forest.+parse :: (Functor m, MonadThrow m) => [Token] -> m [Markdone]+parse = go (0 :: Int)+  where+    go level =+      \case+        (Heading n label:rest) ->+          let (children, rest') =+                span+                  (\case+                     Heading nextN _ -> nextN > n+                     _ -> True)+                  rest+           in do+                childs <- go (level + 1) children+                siblings <- go level rest'+                return (Section label childs : siblings)+        (BeginFence label:rest)+          | level > 0 ->+            let (content, rest') =+                  span+                    (\case+                       PlainLine {} -> True+                       _ -> False)+                    rest+             in case rest' of+                  (EndFence:rest'') ->+                    fmap+                      (CodeFence+                         label+                         (S8.intercalate "\n" (map getPlain content)) :)+                      (go level rest'')+                  _ -> throwM NoFenceEnd+        PlainLine p:rest+          | level > 0 ->+            let (content, rest') =+                  span+                    (\case+                       PlainLine {} -> True+                       _ -> False)+                    (PlainLine p : rest)+             in fmap+                  (PlainText+                     (S8.intercalate+                        "\n"+                        (filter (not . S8.null) (map getPlain content))) :)+                  (go level rest')+        [] -> return []+        _ -> throwM ExpectedSection+    getPlain (PlainLine x) = x+    getPlain _ = ""
src/HIndent.hs view
@@ -1,434 +1,188 @@-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Haskell indenter.- module HIndent-  (-- * Formatting functions.-   reformat-  ,prettyPrint-  ,parseMode-  -- * Testing-  ,test-  ,testFile-  ,testAst-  ,testFileAst-  ,defaultExtensions-  ,getExtensions-  )-  where+  ( -- * The entry point.+    hindent+  , -- * Formatting functions.+    reformat+  , -- * Config+    Config(..)+  , defaultConfig+  , getConfig+  , -- * Extension+    Extension(..)+  , defaultExtensions+  , -- * Error+    ParseError(..)+  , prettyParseError+  , -- * Testing+    testAst+  , HsModule'+  ) where -import           Control.Monad.State.Strict-import           Control.Monad.Trans.Maybe-import           Data.ByteString (ByteString)+import Control.Concurrent.Async+import Control.Exception+import Control.Monad+import Data.ByteString (ByteString) import qualified Data.ByteString as S-import           Data.ByteString.Builder (Builder)+import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as S import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.UTF8 as UTF8-import qualified Data.ByteString.Unsafe as S-import           Data.Char-import           Data.Foldable (foldr')-import           Data.Either-import           Data.Function-import           Data.Functor.Identity-import           Data.List-import           Data.Maybe-import           Data.Monoid-import           Data.Text (Text)-import qualified Data.Text as T-import           Data.Traversable hiding (mapM)-import           HIndent.CodeBlock-import           HIndent.Pretty-import           HIndent.Types-import qualified Language.Haskell.Exts as Exts-import           Language.Haskell.Exts hiding (Style, prettyPrint, Pretty, style, parse)-import           Prelude+import Data.Char+import Data.Maybe+import Data.Version+import Foreign.C+import GHC.IO.Exception+import GHC.Parser.Lexer hiding (buffer, options)+import GHC.Types.SrcLoc+import HIndent.Ast+import HIndent.ByteString+import HIndent.CabalFile+import HIndent.CodeBlock+import HIndent.CommandlineOptions+import HIndent.Config+import HIndent.Error+import HIndent.GhcLibParserWrapper.GHC.Hs+import HIndent.LanguageExtension+import qualified HIndent.LanguageExtension.Conversion as CE+import HIndent.LanguageExtension.Types+import HIndent.ModulePreprocessing+import HIndent.Parse+import HIndent.Pretty+import HIndent.Printer+import Options.Applicative hiding (ParseError, action, style)+import Paths_hindent+import qualified System.Directory as IO+import System.Exit+import qualified System.IO as IO +-- | Runs HIndent with the given commandline options.+hindent :: [String] -> IO ()+hindent args = do+  config <- getConfig+  runMode <-+    handleParseResult+      $ execParserPure+          defaultPrefs+          (info+             (options config <**> helper)+             (header "hindent - Reformat Haskell source code"))+          args+  case runMode of+    ShowVersion -> putStrLn ("hindent " ++ showVersion version)+    Run style exts action paths ->+      if null paths+        then S8.interact+               (either (error . prettyParseError) id+                  . reformat style exts Nothing)+        else forConcurrently_ paths $ \filepath -> do+               cabalexts <- getCabalExtensionsForSourcePath filepath+               text <- S.readFile filepath+               case reformat style (cabalexts ++ exts) (Just filepath) text of+                 Left e -> error $ prettyParseError e+                 Right out ->+                   unless (text == out)+                     $ case action of+                         Validate -> do+                           IO.putStrLn $ filepath ++ " is not formatted"+                           exitWith (ExitFailure 1)+                         Reformat -> do+                           tmpDir <- IO.getTemporaryDirectory+                           (fp, h) <- IO.openTempFile tmpDir "hindent.hs"+                           S8.hPutStr h out+                           IO.hFlush h+                           IO.hClose h+                           let exdev e =+                                 if ioe_errno e+                                      == Just ((\(Errno a) -> a) eXDEV)+                                   then IO.copyFile fp filepath+                                          >> IO.removeFile fp+                                   else throw e+                           IO.copyPermissions filepath fp+                           IO.renameFile fp filepath `catch` exdev+ -- | Format the given source.-reformat :: Config -> Maybe [Extension] -> Maybe FilePath -> ByteString -> Either String Builder-reformat config mexts mfilepath =-    preserveTrailingNewline-        (fmap (mconcat . intersperse "\n") . mapM processBlock . cppSplitBlocks)+reformat ::+     Config+  -> [Extension]+  -> Maybe FilePath+  -> ByteString+  -> Either ParseError ByteString+reformat config mexts mfilepath rawCode =+  preserveTrailingNewline+    (fmap unlines' . mapM processBlock . cppSplitBlocks)+    rawCode   where-    processBlock :: CodeBlock -> Either String Builder-    processBlock (Shebang text) = Right $ S.byteString text-    processBlock (CPPDirectives text) = Right $ S.byteString text-    processBlock (HaskellSource line text) =-        let ls = S8.lines text-            prefix = findPrefix ls-            code = unlines' (map (stripPrefix prefix) ls)-            exts = readExtensions (UTF8.toString code)-            mode'' = case exts of-                       Nothing -> mode'-                       Just (Nothing, exts') ->-                         mode' { extensions =-                                   exts'-                                   ++ configExtensions config-                                   ++ extensions mode' }-                       Just (Just lang, exts') ->-                         mode' { baseLanguage = lang-                               , extensions =-                                   exts'-                                   ++ configExtensions config-                                   ++ extensions mode' }-        in case parseModuleWithComments mode'' (UTF8.toString code) of-               ParseOk (m, comments) ->-                   fmap-                       (S.lazyByteString . addPrefix prefix . S.toLazyByteString)-                       (prettyPrint config m comments)-               ParseFailed loc e ->-                 Left (Exts.prettyPrint (loc {srcLine = srcLine loc + line}) ++ ": " ++ e)-    unlines' = S.concat . intersperse "\n"-    unlines'' = L.concat . intersperse "\n"-    addPrefix :: ByteString -> L8.ByteString -> L8.ByteString-    addPrefix prefix = unlines'' . map (L8.fromStrict prefix <>) . L8.lines-    stripPrefix :: ByteString -> ByteString -> ByteString-    stripPrefix prefix line =-        if S.null (S8.dropWhile (== '\n') line)-            then line-            else fromMaybe (error "Missing expected prefix") . s8_stripPrefix prefix $-                 line-    findPrefix :: [ByteString] -> ByteString-    findPrefix = takePrefix False . findSmallestPrefix . dropNewlines-    dropNewlines :: [ByteString] -> [ByteString]-    dropNewlines = filter (not . S.null . S8.dropWhile (== '\n'))-    takePrefix :: Bool -> ByteString -> ByteString-    takePrefix bracketUsed txt =-        case S8.uncons txt of-            Nothing -> ""-            Just ('>', txt') ->-                if not bracketUsed-                    then S8.cons '>' (takePrefix True txt')-                    else ""-            Just (c, txt') ->-                if c == ' ' || c == '\t'-                    then S8.cons c (takePrefix bracketUsed txt')-                    else ""-    findSmallestPrefix :: [ByteString] -> ByteString-    findSmallestPrefix [] = ""-    findSmallestPrefix ("":_) = ""-    findSmallestPrefix (p:ps) =-        let first = S8.head p-            startsWithChar c x = S8.length x > 0 && S8.head x == c-        in if all (startsWithChar first) ps-               then S8.cons-                        first-                        (findSmallestPrefix (S.tail p : map S.tail ps))-               else ""-    mode' =-        let m = case mexts of-                  Just exts ->-                    parseMode-                    { extensions = exts-                    }-                  Nothing -> parseMode-        in m { parseFilename = fromMaybe "<interactive>" mfilepath }-    preserveTrailingNewline f x =-        if S8.null x || S8.all isSpace x-            then return mempty-            else if hasTrailingLine x || configTrailingNewline config-                     then fmap-                              (\x' ->-                                    if hasTrailingLine-                                           (L.toStrict (S.toLazyByteString x'))-                                        then x'-                                        else x' <> "\n")-                              (f x)-                     else f x---- | Does the strict bytestring have a trailing newline?-hasTrailingLine :: ByteString -> Bool-hasTrailingLine xs =-    if S8.null xs-        then False-        else S8.last xs == '\n'---- | Print the module.-prettyPrint :: Config-            -> Module SrcSpanInfo-            -> [Comment]-            -> Either a Builder-prettyPrint config m comments =-  let ast =-        evalState-          (collectAllComments-             (fromMaybe m (applyFixities baseFixities m)))-          comments-  in Right (runPrinterStyle config (pretty ast))---- | Pretty print the given printable thing.-runPrinterStyle :: Config -> Printer () -> Builder-runPrinterStyle config m =-  maybe-    (error "Printer failed with mzero call.")-    psOutput-    (runIdentity-       (runMaybeT-          (execStateT-             (runPrinter m)-             (PrintState-              { psIndentLevel = 0-              , psOutput = mempty-              , psNewline = False-              , psColumn = 0-              , psLine = 1-              , psConfig = config-              , psInsideCase = False-              , psFitOnOneLine = False-              , psEolComment = False-              }))))---- | Parse mode, includes all extensions, doesn't assume any fixities.-parseMode :: ParseMode-parseMode =-  defaultParseMode {extensions = allExtensions-                   ,fixities = Nothing}-  where allExtensions =-          filter isDisabledExtension knownExtensions-        isDisabledExtension (DisableExtension _) = False-        isDisabledExtension _ = True---- | Test the given file.-testFile :: FilePath -> IO ()-testFile fp  = S.readFile fp >>= test---- | Test the given file.-testFileAst :: FilePath -> IO ()-testFileAst fp  = S.readFile fp >>= print . testAst---- | Test with the given style, prints to stdout.-test :: ByteString -> IO ()-test =-  either error (L8.putStrLn . S.toLazyByteString) .-  reformat defaultConfig Nothing Nothing+    processBlock :: CodeBlock -> Either ParseError ByteString+    processBlock (Shebang text) = Right text+    processBlock (CPPDirectives text) = Right text+    processBlock (HaskellSource yPos text) =+      let ls = S8.lines text+          prefix = findPrefix ls+          code = unlines' (map stripPrefixIfNotNull ls)+          stripPrefixIfNotNull s =+            if S.null s+              then s+              else stripPrefix prefix s+       in case parseModule mfilepath allExts (UTF8.toString code) of+            POk _ m ->+              Right+                $ addPrefix prefix+                $ L.toStrict+                $ S.toLazyByteString+                $ prettyPrint config m+            PFailed st ->+              let rawErrLoc = psRealLoc $ loc st+               in Left+                    $ ParseError+                        { errorLine = srcLocLine rawErrLoc + yPos+                        , errorCol = srcLocCol rawErrLoc+                        , errorFile = fromMaybe "<interactive>" mfilepath+                        }+    preserveTrailingNewline f x+      | S8.null x || S8.all isSpace x = return mempty+      | hasTrailingLine x || configTrailingNewline config =+        fmap+          (\x' ->+             if hasTrailingLine x'+               then x'+               else x' <> "\n")+          (f x)+      | otherwise = f x+    allExts =+      CE.uniqueExtensions+        $ concatMap (\x -> x : extensionImplies x)+        $ mexts ++ configExtensions config ++ allExtsFromCode+    allExtsFromCode = concatMap f codeBlocks+      where+        f (HaskellSource _ text) =+          collectLanguageExtensionsFromSource $ UTF8.toString text+        f _ = []+    codeBlocks = cppSplitBlocks rawCode --- | Parse the source and annotate it with comments, yielding the resulting AST.-testAst :: ByteString -> Either String (Module NodeInfo)+-- | Generate an AST from the given module for debugging.+testAst :: ByteString -> Either ParseError HsModule' testAst x =-  case parseModuleWithComments parseMode (UTF8.toString x) of-    ParseOk (m,comments) ->-      Right-        (let ast =-               evalState-                 (collectAllComments-                    (fromMaybe m (applyFixities baseFixities m)))-                 comments-         in ast)-    ParseFailed _ e -> Left e---- | Default extensions.-defaultExtensions :: [Extension]-defaultExtensions =-  [ e-  | e@EnableExtension {} <- knownExtensions ] \\-  map EnableExtension badExtensions---- | Extensions which steal too much syntax.-badExtensions :: [KnownExtension]-badExtensions =-    [Arrows -- steals proc-    ,TransformListComp -- steals the group keyword-    ,XmlSyntax, RegularPatterns -- steals a-b-    ,UnboxedTuples -- breaks (#) lens operator-    -- ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break-    ,PatternSynonyms -- steals the pattern keyword-    ,RecursiveDo -- steals the rec keyword-    ,DoRec -- same-    ,TypeApplications -- since GHC 8 and haskell-src-exts-1.19-    ]---s8_stripPrefix :: ByteString -> ByteString -> Maybe ByteString-s8_stripPrefix bs1@(S.PS _ _ l1) bs2-   | bs1 `S.isPrefixOf` bs2 = Just (S.unsafeDrop l1 bs2)-   | otherwise = Nothing------------------------------------------------------------------------------------- Extensions stuff stolen from hlint---- | Consume an extensions list from arguments.-getExtensions :: [Text] -> [Extension]-getExtensions = foldl f defaultExtensions . map T.unpack-  where f _ "Haskell98" = []-        f a ('N':'o':x)-          | Just x' <- readExtension x =-            delete x' a-        f a x-          | Just x' <- readExtension x =-            x' :-            delete x' a-        f _ x = error $ "Unknown extension: " ++ x------------------------------------------------------------------------------------- Comments---- | Traverse the structure backwards.-traverseInOrder-  :: (Monad m, Traversable t, Functor m)-  => (b -> b -> Ordering) -> (b -> m b) -> t b -> m (t b)-traverseInOrder cmp f ast = do-  indexed <--    fmap (zip [0 :: Integer ..] . reverse) (execStateT (traverse (modify . (:)) ast) [])-  let sorted = sortBy (\(_,x) (_,y) -> cmp x y) indexed-  results <--    mapM-      (\(i,m) -> do-         v <- f m-         return (i, v))-      sorted-  evalStateT-    (traverse-       (const-          (do i <- gets head-              modify tail-              case lookup i results of-                Nothing -> error "traverseInOrder"-                Just x -> return x))-       ast)-    [0 ..]---- | Collect all comments in the module by traversing the tree. Read--- this from bottom to top.-collectAllComments :: Module SrcSpanInfo -> State [Comment] (Module NodeInfo)-collectAllComments =-  shortCircuit-    (traverseBackwards-     -- Finally, collect backwards comments which come after each node.-       (collectCommentsBy-          CommentAfterLine-          (\nodeSpan commentSpan ->-              fst (srcSpanStart commentSpan) >= fst (srcSpanEnd nodeSpan)))) <=<-  shortCircuit addCommentsToTopLevelWhereClauses <=<-  shortCircuit-    (traverse-     -- Collect forwards comments which start at the end line of a-     -- node: Does the start line of the comment match the end-line-     -- of the node?-       (collectCommentsBy-          CommentSameLine-          (\nodeSpan commentSpan ->-              fst (srcSpanStart commentSpan) == fst (srcSpanEnd nodeSpan)))) <=<-  shortCircuit-    (traverseBackwards-     -- Collect backwards comments which are on the same line as a-     -- node: Does the start line & end line of the comment match-     -- that of the node?-       (collectCommentsBy-          CommentSameLine-          (\nodeSpan commentSpan ->-              fst (srcSpanStart commentSpan) == fst (srcSpanStart nodeSpan) &&-              fst (srcSpanStart commentSpan) == fst (srcSpanEnd nodeSpan)))) <=<-  shortCircuit-    (traverse-     -- First, collect forwards comments for declarations which both-     -- start on column 1 and occur before the declaration.-       (collectCommentsBy-          CommentBeforeLine-          (\nodeSpan commentSpan ->-              (snd (srcSpanStart nodeSpan) == 1 &&-               snd (srcSpanStart commentSpan) == 1) &&-              fst (srcSpanStart commentSpan) < fst (srcSpanStart nodeSpan)))) .-  fmap nodify-  where-    nodify s = NodeInfo s mempty-    -- Sort the comments by their end position.-    traverseBackwards =-      traverseInOrder-        (\x y -> on (flip compare) (srcSpanEnd . srcInfoSpan . nodeInfoSpan) x y)-    -- Stop traversing if all comments have been consumed.-    shortCircuit m v = do-      comments <- get-      if null comments-        then return v-        else m v---- | Collect comments by satisfying the given predicate, to collect a--- comment means to remove it from the pool of available comments in--- the State. This allows for a multiple pass approach.-collectCommentsBy-  :: (SrcSpan -> SomeComment -> NodeComment)-  -> (SrcSpan -> SrcSpan -> Bool)-  -> NodeInfo-  -> State [Comment] NodeInfo-collectCommentsBy cons predicate nodeInfo@(NodeInfo (SrcSpanInfo nodeSpan _) _) = do-  comments <- get-  let (others, mine) =-        partitionEithers-          (map-             (\comment@(Comment _ commentSpan _) ->-                 if predicate nodeSpan commentSpan-                   then Right comment-                   else Left comment)-             comments)-  put others-  return $ addCommentsToNode cons mine nodeInfo---- | Reintroduce comments which were immediately above declarations in where clauses.--- Affects where clauses of top level declarations only.-addCommentsToTopLevelWhereClauses ::-     Module NodeInfo -> State [Comment] (Module NodeInfo)-addCommentsToTopLevelWhereClauses (Module x x' x'' x''' topLevelDecls) =-  Module x x' x'' x''' <$>-  traverse addCommentsToWhereClauses topLevelDecls+  case parseModule Nothing exts (UTF8.toString x) of+    POk _ m -> Right $ modifyASTForPrettyPrinting m+    PFailed st ->+      Left+        $ ParseError <$> srcLocLine <*> srcLocCol <*> pure "<interactive>"+        $ psRealLoc+        $ loc st   where-    addCommentsToWhereClauses ::-         Decl NodeInfo -> State [Comment] (Decl NodeInfo)-    addCommentsToWhereClauses (PatBind x x' x'' (Just (BDecls x''' whereDecls))) = do-      newWhereDecls <- traverse addCommentsToPatBind whereDecls-      return $ PatBind x x' x'' (Just (BDecls x''' newWhereDecls))-    addCommentsToWhereClauses other = return other-    addCommentsToPatBind :: Decl NodeInfo -> State [Comment] (Decl NodeInfo)-    addCommentsToPatBind (PatBind bindInfo (PVar x (Ident declNodeInfo declString)) x' x'') = do-      bindInfoWithComments <- addCommentsBeforeNode bindInfo-      return $-        PatBind-          bindInfoWithComments-          (PVar x (Ident declNodeInfo declString))-          x'-          x''-    addCommentsToPatBind other = return other-    addCommentsBeforeNode :: NodeInfo -> State [Comment] NodeInfo-    addCommentsBeforeNode nodeInfo = do-      comments <- get-      let (notAbove, above) = partitionAboveNotAbove comments nodeInfo-      put notAbove-      return $ addCommentsToNode CommentBeforeLine above nodeInfo-    partitionAboveNotAbove :: [Comment] -> NodeInfo -> ([Comment], [Comment])-    partitionAboveNotAbove cs (NodeInfo (SrcSpanInfo nodeSpan _) _) =-      fst $-      foldr'-        (\comment@(Comment _ commentSpan _) ((ls, rs), lastSpan) ->-           if comment `isAbove` lastSpan-             then ((ls, comment : rs), commentSpan)-             else ((comment : ls, rs), lastSpan))-        (([], []), nodeSpan)-        cs-    isAbove :: Comment -> SrcSpan -> Bool-    isAbove (Comment _ commentSpan _) span =-      let (_, commentColStart) = srcSpanStart commentSpan-          (commentLnEnd, _) = srcSpanEnd commentSpan-          (lnStart, colStart) = srcSpanStart span-       in commentColStart == colStart && commentLnEnd + 1 == lnStart-addCommentsToTopLevelWhereClauses other = return other+    exts =+      CE.uniqueExtensions+        $ collectLanguageExtensionsFromSource+        $ UTF8.toString x -addCommentsToNode :: (SrcSpan -> SomeComment -> NodeComment)-                  -> [Comment]-                  -> NodeInfo-                  -> NodeInfo-addCommentsToNode mkNodeComment newComments nodeInfo@(NodeInfo (SrcSpanInfo _ _) existingComments) =-  nodeInfo-    {nodeInfoComments = existingComments <> map mkBeforeNodeComment newComments}-  where-    mkBeforeNodeComment :: Comment -> NodeComment-    mkBeforeNodeComment (Comment multiLine commentSpan commentString) =-      mkNodeComment-        commentSpan-        ((if multiLine-            then MultiLine-            else EndOfLine)-           commentString)+-- | Print the module.+prettyPrint :: Config -> HsModule' -> Builder+prettyPrint config =+  runPrinterStyle config . pretty . mkModule . modifyASTForPrettyPrinting
+ src/HIndent/Applicative.hs view
@@ -0,0 +1,11 @@+-- | Helper functions to handle 'Applicative's+module HIndent.Applicative+  ( whenJust+  ) where++-- | If the first argument is a 'Just' value, this function applies its+-- internal value to the function passed as the second argument. Otherwise,+-- this function returne a 'pure ()'.+whenJust :: (Applicative m) => Maybe a -> (a -> m ()) -> m ()+whenJust Nothing _ = pure ()+whenJust (Just x) f = f x
+ src/HIndent/Ast.hs view
@@ -0,0 +1,17 @@+-- | This module defines the AST for Haskell code.+--+-- GHC provides its AST for Haskell code, but the structure it offers may change+-- with version updates. In other words, when directly using GHC's AST as the+-- AST for pretty-printing, updates in GHC require direct modifications to the+-- pretty-printing functions. On the other hand, when there is a need to change+-- the pretty-printing style, corresponding modifications to the functions are+-- also necessary. The presence of these two reasons for modification leads to a+-- suboptimal design state.+--+-- Therefore, this module defines a custom AST for HIndent, allowing flexibility+-- to adapt to changes in GHC's AST across different versions.+module HIndent.Ast+  ( mkModule+  ) where++import HIndent.Ast.Module
+ src/HIndent/Ast/Cmd.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Cmd+  ( Cmd+  , CmdDoBlock+  , mkCmd+  , mkCmdDoBlock+  , mkCmdFromHsCmdTop+  ) where++import Data.Maybe (fromMaybe)+import qualified GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.LocalBinds (LocalBinds, mkLocalBinds)+import {-# SOURCE #-} HIndent.Ast.MatchGroup (MatchGroup, mkCmdMatchGroup)+import HIndent.Ast.Statement (CmdStatement, mkCmdStatement)+import HIndent.Ast.WithComments+  ( WithComments+  , flattenComments+  , fromGenLocated+  , prettyWith+  )+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments (CommentExtraction(..), emptyNodeComments)++data ArrowKind+  = Higher+  | First++data ArrowDirection+  = FunctionThenArgument+  | ArgumentThenFunction++data Cmd+  = ArrowApp+      { arrowKind :: ArrowKind+      , arrowDirection :: ArrowDirection+      , function :: WithComments Expression+      , argument :: WithComments Expression+      }+  | ArrowForm+      { function :: WithComments Expression+      , arguments :: [WithComments Cmd]+      }+  | CmdApp+      { cmd :: WithComments Cmd+      , argument :: WithComments Expression+      }+  | Lambda+      { matches :: MatchGroup+      }+  | LambdaCase+      { usesCases :: Bool+      , matches :: MatchGroup+      }+  | Case+      { scrutinee :: WithComments Expression+      , matches :: MatchGroup+      }+  | If+      { predicate :: WithComments Expression+      , thenBranch :: WithComments Cmd+      , elseBranch :: WithComments Cmd+      }+  | Let+      { localBinds :: WithComments LocalBinds+      , inCommand :: WithComments Cmd+      }+  | DoBlock+      { statements :: WithComments [WithComments CmdStatement]+      }+  | Parenthesized (WithComments Cmd)++instance CommentExtraction Cmd where+  nodeComments _ = emptyNodeComments++instance Pretty Cmd where+  pretty' ArrowApp {..} =+    case arrowDirection of+      FunctionThenArgument ->+        spaced [pretty function, string operator, pretty argument]+      ArgumentThenFunction ->+        spaced [pretty argument, string operator, pretty function]+    where+      operator =+        case (arrowKind, arrowDirection) of+          (Higher, FunctionThenArgument) -> "-<<"+          (Higher, ArgumentThenFunction) -> ">>-"+          (First, FunctionThenArgument) -> "-<"+          (First, ArgumentThenFunction) -> ">-"+  pretty' ArrowForm {..} =+    bananaBrackets $ spaced $ pretty function : fmap pretty arguments+  pretty' CmdApp {..} = spaced [pretty cmd, pretty argument]+  pretty' Lambda {..} = pretty matches+  pretty' LambdaCase {..} = do+    string+      $ if usesCases+          then "\\cases"+          else "\\case"+    newline+    indentedBlock $ pretty matches+  pretty' Case {..} = do+    spaced [string "case", pretty scrutinee, string "of"]+    newline+    indentedBlock $ pretty matches+  pretty' If {..} = do+    string "if "+    pretty predicate+    newline+    indentedBlock+      $ lined+          [ string "then " >> pretty thenBranch+          , string "else " >> pretty elseBranch+          ]+  pretty' Let {..} =+    lined+      [string "let " |=> pretty localBinds, string " in " |=> pretty inCommand]+  pretty' DoBlock {..} = do+    string "do"+    newline+    indentedBlock $ prettyWith statements $ lined . fmap pretty+  pretty' (Parenthesized cmd) = parens $ pretty cmd++mkCmd :: GHC.HsCmd GHC.GhcPs -> Cmd+mkCmd (GHC.HsCmdArrApp _ f arg appKind isFwd) =+  ArrowApp+    { arrowKind =+        case appKind of+          GHC.HsHigherOrderApp -> Higher+          GHC.HsFirstOrderApp -> First+    , arrowDirection =+        if isFwd+          then FunctionThenArgument+          else ArgumentThenFunction+    , function = mkExpression <$> fromGenLocated f+    , argument = mkExpression <$> fromGenLocated arg+    }+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkCmd (GHC.HsCmdArrForm _ f _ args) =+  ArrowForm+    { function = mkExpression <$> fromGenLocated f+    , arguments =+        fmap (flattenComments . fmap mkCmdFromHsCmdTop . fromGenLocated) args+    }+#else+mkCmd (GHC.HsCmdArrForm _ f _ _ args) =+  ArrowForm+    { function = mkExpression <$> fromGenLocated f+    , arguments =+        fmap (flattenComments . fmap mkCmdFromHsCmdTop . fromGenLocated) args+    }+#endif+mkCmd (GHC.HsCmdApp _ cmd arg) =+  CmdApp+    { cmd = mkCmd <$> fromGenLocated cmd+    , argument = mkExpression <$> fromGenLocated arg+    }+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkCmd (GHC.HsCmdLam _ GHC.LamSingle matches) =+  Lambda {matches = mkCmdMatchGroup matches}+mkCmd (GHC.HsCmdLam _ GHC.LamCase matches) =+  LambdaCase {usesCases = False, matches = mkCmdMatchGroup matches}+mkCmd (GHC.HsCmdLam _ GHC.LamCases matches) =+  LambdaCase {usesCases = True, matches = mkCmdMatchGroup matches}+#else+mkCmd (GHC.HsCmdLam _ matches) = Lambda {matches = mkCmdMatchGroup matches}+#endif+#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkCmd (GHC.HsCmdPar _ _ cmd _) = Parenthesized $ mkCmd <$> fromGenLocated cmd+#else+mkCmd (GHC.HsCmdPar _ cmd) = Parenthesized $ mkCmd <$> fromGenLocated cmd+#endif+mkCmd (GHC.HsCmdCase _ expr matches) =+  Case+    { scrutinee = mkExpression <$> fromGenLocated expr+    , matches = mkCmdMatchGroup matches+    }+#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkCmd (GHC.HsCmdLamCase _ _ matches) =+  LambdaCase {usesCases = False, matches = mkCmdMatchGroup matches}+#elif !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkCmd (GHC.HsCmdLamCase _ matches) =+  LambdaCase {usesCases = False, matches = mkCmdMatchGroup matches}+#endif+mkCmd (GHC.HsCmdIf _ _ predicate thenCmd elseCmd) =+  If+    { predicate = mkExpression <$> fromGenLocated predicate+    , thenBranch = mkCmd <$> fromGenLocated thenCmd+    , elseBranch = mkCmd <$> fromGenLocated elseCmd+    }+#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkCmd (GHC.HsCmdLet _ _ binds _ cmd) =+  Let+    { localBinds =+        fromMaybe+          (error "`ghc-lib-parser` never generates an empty `HsCmdLet` node.")+          $ mkLocalBinds binds+    , inCommand = mkCmd <$> fromGenLocated cmd+    }+#else+mkCmd (GHC.HsCmdLet _ binds cmd) =+  Let+    { localBinds =+        fromMaybe+          (error "`ghc-lib-parser` never generates an empty `HsCmdLet` node.")+          $ mkLocalBinds binds+    , inCommand = mkCmd <$> fromGenLocated cmd+    }+#endif+mkCmd (GHC.HsCmdDo _ stmts) =+  DoBlock+    { statements =+        fmap (fmap mkCmdStatement . fromGenLocated) <$> fromGenLocated stmts+    }+mkCmd _ = error "`ghc-lib-parser` never generates this AST node."++mkCmdFromHsCmdTop :: GHC.HsCmdTop GHC.GhcPs -> WithComments Cmd+mkCmdFromHsCmdTop (GHC.HsCmdTop _ cmd) = mkCmd <$> fromGenLocated cmd++newtype CmdDoBlock =+  CmdDoBlock Cmd++instance CommentExtraction CmdDoBlock where+  nodeComments _ = emptyNodeComments++instance Pretty CmdDoBlock where+  pretty' (CmdDoBlock DoBlock {statements = stmts}) =+    prettyWith stmts $ lined . fmap pretty+  pretty' (CmdDoBlock _) =+    error "mkCmdDoBlock must be used before pretty-printing CmdDoBlock"++mkCmdDoBlock :: Cmd -> Maybe CmdDoBlock+mkCmdDoBlock cmd+  | DoBlock {} <- cmd = Just (CmdDoBlock cmd)+  | otherwise = Nothing
+ src/HIndent/Ast/Cmd.hs-boot view
@@ -0,0 +1,10 @@+module HIndent.Ast.Cmd+  ( Cmd+  , mkCmd+  ) where++import qualified GHC.Hs as GHC++data Cmd++mkCmd :: GHC.HsCmd GHC.GhcPs -> Cmd
+ src/HIndent/Ast/Comment.hs view
@@ -0,0 +1,35 @@+module HIndent.Ast.Comment+  ( Comment+  , mkComment+  ) where++import qualified GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments (CommentExtraction(..))++data Comment+  = Line String+  | Block String+  deriving (Eq, Show)++instance CommentExtraction Comment where+  nodeComments _ = mempty++instance Pretty Comment where+  pretty' (Line c) = string c+  pretty' (Block c) =+    case lines c of+      [] -> pure ()+      [x] -> string x+      (x:xs) -> do+        string x+        newline+        -- 'indentedWithFixedLevel 0' is used because a 'BlockComment'+        -- contains indent spaces for all lines except the first one.+        indentedWithFixedLevel 0 $ lined $ fmap string xs++mkComment :: GHC.EpaCommentTok -> Comment+mkComment (GHC.EpaLineComment c) = Line c+mkComment (GHC.EpaBlockComment c) = Block c+mkComment _ = Line ""
+ src/HIndent/Ast/Context.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Context+  ( Context+  , mkContext+  ) where++import HIndent.Ast.NodeComments+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype Context =+  Context [WithComments Type]++instance CommentExtraction Context where+  nodeComments (Context _) = NodeComments [] [] []++instance Pretty Context where+  pretty' (Context xs) = hor <-|> ver+    where+      hor = parensConditional $ hCommaSep $ fmap pretty xs+        where+          parensConditional =+            case xs of+              [_] -> id+              _ -> parens+      ver =+        case xs of+          [] -> string "()"+          [x] -> pretty x+          _ -> vTuple $ fmap pretty xs++mkContext :: GHC.HsContext GHC.GhcPs -> Context+mkContext = Context . fmap (fmap mkType . fromGenLocated)
+ src/HIndent/Ast/Declaration.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration+  ( Declaration(..)+  , mkDeclaration+  , isSignature+  ) where++import Control.Applicative+import Data.Maybe+import HIndent.Ast.Declaration.Annotation+import HIndent.Ast.Declaration.Annotation.Role+import HIndent.Ast.Declaration.Bind+import HIndent.Ast.Declaration.Class+import HIndent.Ast.Declaration.Data+import HIndent.Ast.Declaration.Default+import HIndent.Ast.Declaration.Family.Data+import HIndent.Ast.Declaration.Family.Type+import HIndent.Ast.Declaration.Foreign+import HIndent.Ast.Declaration.Instance.Class+import HIndent.Ast.Declaration.Instance.Family.Data+import HIndent.Ast.Declaration.Instance.Family.Type+import HIndent.Ast.Declaration.Rule.Collection+import HIndent.Ast.Declaration.Signature+import HIndent.Ast.Declaration.Signature.StandaloneKind+import HIndent.Ast.Declaration.Splice+import HIndent.Ast.Declaration.StandAloneDeriving+import HIndent.Ast.Declaration.TypeSynonym+import HIndent.Ast.Declaration.Warning.Collection+import HIndent.Ast.NodeComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.NodeComments++data Declaration+  = DataFamily DataFamily+  | TypeFamily TypeFamily+  | DataDeclaration DataDeclaration+  | ClassDeclaration ClassDeclaration+  | TypeSynonym TypeSynonym+  | ClassInstance ClassInstance+  | DataFamilyInstance DataFamilyInstance+  | TypeFamilyInstance TypeFamilyInstance+  | StandAloneDeriving StandAloneDeriving+  | Bind Bind+  | Signature Signature+  | StandaloneKindSignature StandaloneKind+  | Default DefaultDeclaration+  | Foreign ForeignDeclaration+  | Warnings WarningCollection+  | Annotation Annotation+  | RuleDecl RuleCollection+  | Splice SpliceDeclaration+  | RoleAnnotDecl RoleAnnotation++instance CommentExtraction Declaration where+  nodeComments DataFamily {} = NodeComments [] [] []+  nodeComments TypeFamily {} = NodeComments [] [] []+  nodeComments DataDeclaration {} = NodeComments [] [] []+  nodeComments ClassDeclaration {} = NodeComments [] [] []+  nodeComments TypeSynonym {} = NodeComments [] [] []+  nodeComments ClassInstance {} = NodeComments [] [] []+  nodeComments DataFamilyInstance {} = NodeComments [] [] []+  nodeComments TypeFamilyInstance {} = NodeComments [] [] []+  nodeComments StandAloneDeriving {} = NodeComments [] [] []+  nodeComments Bind {} = NodeComments [] [] []+  nodeComments Signature {} = NodeComments [] [] []+  nodeComments StandaloneKindSignature {} = NodeComments [] [] []+  nodeComments Default {} = NodeComments [] [] []+  nodeComments Foreign {} = NodeComments [] [] []+  nodeComments Warnings {} = NodeComments [] [] []+  nodeComments Annotation {} = NodeComments [] [] []+  nodeComments RuleDecl {} = NodeComments [] [] []+  nodeComments Splice {} = NodeComments [] [] []+  nodeComments RoleAnnotDecl {} = NodeComments [] [] []++instance Pretty Declaration where+  pretty' (DataFamily x) = pretty x+  pretty' (TypeFamily x) = pretty x+  pretty' (DataDeclaration x) = pretty x+  pretty' (ClassDeclaration x) = pretty x+  pretty' (TypeSynonym x) = pretty x+  pretty' (ClassInstance x) = pretty x+  pretty' (DataFamilyInstance x) = pretty x+  pretty' (TypeFamilyInstance x) = pretty x+  pretty' (StandAloneDeriving x) = pretty x+  pretty' (Bind x) = pretty x+  pretty' (Signature x) = pretty x+  pretty' (StandaloneKindSignature x) = pretty x+  pretty' (Default x) = pretty x+  pretty' (Foreign x) = pretty x+  pretty' (Warnings x) = pretty x+  pretty' (Annotation x) = pretty x+  pretty' (RuleDecl x) = pretty x+  pretty' (Splice x) = pretty x+  pretty' (RoleAnnotDecl x) = pretty x++mkDeclaration :: GHC.HsDecl GHC.GhcPs -> Declaration+mkDeclaration (GHC.TyClD _ (GHC.FamDecl _ x)) =+  fromMaybe (error "Unreachable.")+    $ DataFamily <$> mkDataFamily x <|> TypeFamily <$> mkTypeFamily x+mkDeclaration (GHC.TyClD _ x@GHC.SynDecl {}) = TypeSynonym $ mkTypeSynonym x+mkDeclaration (GHC.TyClD _ x@GHC.DataDecl {}) =+  maybe (error "Unreachable.") DataDeclaration (mkDataDeclaration x)+mkDeclaration (GHC.TyClD _ x@GHC.ClassDecl {}) =+  maybe (error "Unreachable.") ClassDeclaration (mkClassDeclaration x)+mkDeclaration (GHC.InstD _ x@GHC.ClsInstD {}) =+  maybe (error "Unreachable.") ClassInstance (mkClassInstance x)+mkDeclaration (GHC.InstD _ GHC.DataFamInstD {GHC.dfid_inst = GHC.DataFamInstDecl {..}}) =+  DataFamilyInstance $ mkDataFamilyInstance dfid_eqn+mkDeclaration (GHC.InstD _ x@GHC.TyFamInstD {}) =+  maybe (error "Unreachable.") TypeFamilyInstance $ mkTypeFamilyInstance x+mkDeclaration (GHC.DerivD _ x) = StandAloneDeriving $ mkStandAloneDeriving x+mkDeclaration (GHC.ValD _ x) = Bind $ mkBind x+mkDeclaration (GHC.SigD _ x) = Signature $ mkSignature x+mkDeclaration (GHC.KindSigD _ x) = StandaloneKindSignature $ mkStandaloneKind x+mkDeclaration (GHC.DefD _ x) = Default $ mkDefaultDeclaration x+mkDeclaration (GHC.ForD _ x) = Foreign $ mkForeignDeclaration x+mkDeclaration (GHC.WarningD _ x) = Warnings $ mkWarningCollection x+mkDeclaration (GHC.AnnD _ x) = Annotation $ mkAnnotation x+mkDeclaration (GHC.RuleD _ x) = RuleDecl $ mkRuleCollection x+mkDeclaration (GHC.SpliceD _ x) = Splice $ mkSpliceDeclaration x+mkDeclaration (GHC.RoleAnnotD _ x) = RoleAnnotDecl $ mkRoleAnnotation x+mkDeclaration GHC.DocD {} =+  error+    "This node should never appear in the AST. If you see this error, please report it to the HIndent maintainers."++isSignature :: Declaration -> Bool+isSignature Signature {} = True+isSignature StandaloneKindSignature {} = True+isSignature _ = False
+ src/HIndent/Ast/Declaration/Annotation.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Annotation+  ( Annotation+  , mkAnnotation+  ) where++import HIndent.Ast.Declaration.Annotation.Provenance+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Annotation = Annotation+  { provenance :: Provenance+  , expr :: WithComments Expression+  }++instance CommentExtraction Annotation where+  nodeComments Annotation {} = NodeComments [] [] []++instance Pretty Annotation where+  pretty' Annotation {..} =+    spaced [string "{-# ANN", pretty provenance, pretty expr, string "#-}"]++mkAnnotation :: GHC.AnnDecl GHC.GhcPs -> Annotation+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+mkAnnotation (GHC.HsAnnotation _ prov expression) = Annotation {..}+  where+    provenance = mkProvenance prov+    expr = mkExpression <$> fromGenLocated expression+#else+mkAnnotation (GHC.HsAnnotation _ _ prov expression) = Annotation {..}+  where+    provenance = mkProvenance prov+    expr = mkExpression <$> fromGenLocated expression+#endif
+ src/HIndent/Ast/Declaration/Annotation/Provenance.hs view
@@ -0,0 +1,34 @@+module HIndent.Ast.Declaration.Annotation.Provenance+  ( Provenance+  , mkProvenance+  ) where++import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Provenance+  = Value (WithComments PrefixName)+  | Type (WithComments PrefixName)+  | Module++instance CommentExtraction Provenance where+  nodeComments Value {} = NodeComments [] [] []+  nodeComments Type {} = NodeComments [] [] []+  nodeComments Module = NodeComments [] [] []++instance Pretty Provenance where+  pretty' (Value x) = pretty x+  pretty' (Type x) = string "type " >> pretty x+  pretty' Module = string "module"++mkProvenance :: GHC.AnnProvenance GHC.GhcPs -> Provenance+mkProvenance (GHC.ValueAnnProvenance x) =+  Value $ fromGenLocated $ fmap mkPrefixName x+mkProvenance (GHC.TypeAnnProvenance x) =+  Type $ fromGenLocated $ fmap mkPrefixName x+mkProvenance GHC.ModuleAnnProvenance = Module
+ src/HIndent/Ast/Declaration/Annotation/Role.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Annotation.Role+  ( RoleAnnotation+  , mkRoleAnnotation+  ) where++import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Role+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data RoleAnnotation = RoleAnnotation+  { name :: WithComments PrefixName+  , roles :: [WithComments (Maybe Role)]+  }++instance CommentExtraction RoleAnnotation where+  nodeComments RoleAnnotation {} = NodeComments [] [] []++instance Pretty RoleAnnotation where+  pretty' RoleAnnotation {..} =+    spaced+      $ [string "type role", pretty name]+          ++ fmap (`prettyWith` maybe (string "_") pretty) roles++mkRoleAnnotation :: GHC.RoleAnnotDecl GHC.GhcPs -> RoleAnnotation+mkRoleAnnotation (GHC.RoleAnnotDecl _ nm rs) = RoleAnnotation {..}+  where+    name = fromGenLocated $ fmap mkPrefixName nm+    roles = fmap (fmap (fmap mkRole) . fromGenLocated) rs
+ src/HIndent/Ast/Declaration/Bind.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Bind+  ( Bind+  , mkBind+  ) where++import HIndent.Ast.Declaration.Bind.GuardedRhs+import HIndent.Ast.Declaration.PatternSynonym+import HIndent.Ast.MatchGroup (MatchGroup, mkExprMatchGroup)+import HIndent.Ast.Pattern+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.NodeComments++-- The difference between `Function` and `Pattern` is the same as the difference+-- between `FunBind` and `PatBind` in GHC AST. See+-- https://hackage.haskell.org/package/ghc-lib-parser-9.8.2.20240223/docs/src/Language.Haskell.Syntax.Binds.html.+--+-- TODO: Merge them.+data Bind+  = Function MatchGroup+  | Pattern+      { lhs :: WithComments Pattern+      , rhs :: WithComments GuardedRhs+      }+  | PatternSynonym (WithComments PatternSynonym)++instance CommentExtraction Bind where+  nodeComments Function {} = emptyNodeComments+  nodeComments Pattern {} = emptyNodeComments+  nodeComments PatternSynonym {} = emptyNodeComments++instance Pretty Bind where+  pretty' (Function matches) = pretty matches+  pretty' Pattern {..} = pretty lhs >> pretty rhs+  pretty' (PatternSynonym ps) = pretty ps++mkBind :: GHC.HsBind GHC.GhcPs -> Bind+mkBind GHC.FunBind {..} = Function $ mkExprMatchGroup fun_matches+mkBind GHC.PatBind {..} = Pattern {..}+  where+    lhs = mkPattern <$> fromGenLocated pat_lhs+    rhs = mkWithComments $ mkGuardedRhs pat_rhs+mkBind (GHC.PatSynBind _ psb) =+  PatternSynonym $ mkWithComments $ mkPatternSynonym psb+mkBind _ = error "This AST node should not appear."
+ src/HIndent/Ast/Declaration/Bind/GuardedRhs.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Bind.GuardedRhs+  ( GuardedRhs+  , mkGuardedRhs+  , mkCaseGuardedRhs+  , mkLambdaGuardedRhs+  , mkMultiWayIfGuardedRhs+  , mkCaseCmdGuardedRhs+  , mkLambdaCmdGuardedRhs+  ) where++import HIndent.Applicative (whenJust)+import HIndent.Ast.Guard+  ( Guard+  , mkCaseCmdGuard+  , mkCaseExprGuard+  , mkExprGuard+  , mkLambdaCmdGuard+  , mkLambdaExprGuard+  , mkMultiWayIfExprGuard+  )+import HIndent.Ast.LocalBinds (LocalBinds, mkLocalBinds)+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.WithComments (WithComments, fromGenLocated, prettyWith)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data GuardedRhs = GuardedRhs+  { guards :: [WithComments Guard]+  , localBinds :: Maybe (WithComments LocalBinds)+  }++instance CommentExtraction GuardedRhs where+  nodeComments _ = NodeComments [] [] []++instance Pretty GuardedRhs where+  pretty' GuardedRhs {..} = do+    mapM_ pretty guards+    whenJust localBinds $ \lbs ->+      indentedBlock+        $ newlinePrefixed+            [string "where", prettyWith lbs $ indentedBlock . pretty]++mkGuardedRhs :: GHC.GRHSs GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> GuardedRhs+mkGuardedRhs GHC.GRHSs {..} =+  GuardedRhs+    { guards = map (fmap mkExprGuard . fromGenLocated) grhssGRHSs+    , localBinds = mkLocalBinds grhssLocalBinds+    }++mkCaseGuardedRhs :: GHC.GRHSs GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> GuardedRhs+mkCaseGuardedRhs GHC.GRHSs {..} =+  GuardedRhs+    { guards = map (fmap mkCaseExprGuard . fromGenLocated) grhssGRHSs+    , localBinds = mkLocalBinds grhssLocalBinds+    }++mkLambdaGuardedRhs :: GHC.GRHSs GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> GuardedRhs+mkLambdaGuardedRhs GHC.GRHSs {..} =+  GuardedRhs+    { guards = map (fmap mkLambdaExprGuard . fromGenLocated) grhssGRHSs+    , localBinds = mkLocalBinds grhssLocalBinds+    }++mkMultiWayIfGuardedRhs ::+     GHC.GRHSs GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> GuardedRhs+mkMultiWayIfGuardedRhs GHC.GRHSs {..} =+  GuardedRhs+    { guards = map (fmap mkMultiWayIfExprGuard . fromGenLocated) grhssGRHSs+    , localBinds = mkLocalBinds grhssLocalBinds+    }++mkCaseCmdGuardedRhs :: GHC.GRHSs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> GuardedRhs+mkCaseCmdGuardedRhs GHC.GRHSs {..} =+  GuardedRhs+    { guards = map (fmap mkCaseCmdGuard . fromGenLocated) grhssGRHSs+    , localBinds = mkLocalBinds grhssLocalBinds+    }++mkLambdaCmdGuardedRhs ::+     GHC.GRHSs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> GuardedRhs+mkLambdaCmdGuardedRhs GHC.GRHSs {..} =+  GuardedRhs+    { guards = map (fmap mkLambdaCmdGuard . fromGenLocated) grhssGRHSs+    , localBinds = mkLocalBinds grhssLocalBinds+    }
+ src/HIndent/Ast/Declaration/Class.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Class+  ( ClassDeclaration+  , mkClassDeclaration+  ) where++import Control.Monad+import Data.Maybe+import HIndent.Applicative+import HIndent.Ast.Context+import HIndent.Ast.Declaration.Class.FunctionalDependency+import HIndent.Ast.Declaration.Class.NameAndTypeVariables+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import HIndent.Pretty.SigBindFamily+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+import qualified GHC.Data.Bag as GHC+#endif+data ClassDeclaration = ClassDeclaration+  { context :: Maybe (WithComments Context)+  , nameAndTypeVariables :: NameAndTypeVariables+  , functionalDependencies :: [WithComments FunctionalDependency]+  , associatedThings :: [LSigBindFamily]+  }++instance CommentExtraction ClassDeclaration where+  nodeComments ClassDeclaration {} = NodeComments [] [] []++instance Pretty ClassDeclaration where+  pretty' ClassDeclaration {..} = do+    if isJust context+      then verHead+      else horHead <-|> verHead+    indentedBlock $ newlinePrefixed $ fmap pretty associatedThings+    where+      horHead = do+        string "class "+        pretty nameAndTypeVariables+        unless (null functionalDependencies)+          $ string " | " >> hCommaSep (fmap pretty functionalDependencies)+        unless (null associatedThings) $ string " where"+      verHead = do+        string "class " |=> do+          whenJust context $ \ctx -> pretty ctx >> string " =>" >> newline+          pretty nameAndTypeVariables+        unless (null functionalDependencies) $ do+          newline+          indentedBlock+            $ string "| " |=> vCommaSep (fmap pretty functionalDependencies)+        unless (null associatedThings)+          $ newline >> indentedBlock (string "where")++mkClassDeclaration :: GHC.TyClDecl GHC.GhcPs -> Maybe ClassDeclaration+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkClassDeclaration x@GHC.ClassDecl {..}+  | Just nameAndTypeVariables <- mkNameAndTypeVariables x =+    Just ClassDeclaration {..}+  where+    context = fmap (fmap mkContext . fromGenLocated) tcdCtxt+    functionalDependencies =+      fmap (fmap mkFunctionalDependency . fromGenLocated) tcdFDs+    associatedThings =+      mkSortedLSigBindFamilyList tcdSigs tcdMeths tcdATs [] tcdATDefs []+#else+mkClassDeclaration x@GHC.ClassDecl {..}+  | Just nameAndTypeVariables <- mkNameAndTypeVariables x =+    Just ClassDeclaration {..}+  where+    context = fmap (fmap mkContext . fromGenLocated) tcdCtxt+    functionalDependencies =+      fmap (fmap mkFunctionalDependency . fromGenLocated) tcdFDs+    associatedThings =+      mkSortedLSigBindFamilyList+        tcdSigs+        (GHC.bagToList tcdMeths)+        tcdATs+        []+        tcdATDefs+        []+#endif+mkClassDeclaration _ = Nothing
+ src/HIndent/Ast/Declaration/Class/FunctionalDependency.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Class.FunctionalDependency+  ( FunctionalDependency+  , mkFunctionalDependency+  ) where++import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data FunctionalDependency = FunctionalDependency+  { from :: [WithComments PrefixName]+  , to :: [WithComments PrefixName]+  }++instance CommentExtraction FunctionalDependency where+  nodeComments FunctionalDependency {} = NodeComments [] [] []++instance Pretty FunctionalDependency where+  pretty' (FunctionalDependency {..}) =+    spaced $ fmap pretty from ++ [string "->"] ++ fmap pretty to++mkFunctionalDependency :: GHC.FunDep GHC.GhcPs -> FunctionalDependency+mkFunctionalDependency (GHC.FunDep _ f t) = FunctionalDependency {..}+  where+    from = fmap (fromGenLocated . fmap mkPrefixName) f+    to = fmap (fromGenLocated . fmap mkPrefixName) t
+ src/HIndent/Ast/Declaration/Class/NameAndTypeVariables.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Class.NameAndTypeVariables+  ( NameAndTypeVariables+  , mkNameAndTypeVariables+  ) where++import qualified GHC.Types.Fixity as GHC+import HIndent.Ast.Name.Infix+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Type.Variable+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data NameAndTypeVariables+  = Prefix+      { pName :: WithComments PrefixName -- Using `name` in both `Prefix` and `Infix` causes a type conflict.+      , typeVariables :: [WithComments TypeVariable]+      }+  | Infix+      { left :: WithComments TypeVariable+      , iName :: WithComments InfixName+      , right :: WithComments TypeVariable+      , remains :: [WithComments TypeVariable]+      }++instance CommentExtraction NameAndTypeVariables where+  nodeComments Prefix {} = NodeComments [] [] []+  nodeComments Infix {} = NodeComments [] [] []++instance Pretty NameAndTypeVariables where+  pretty' Prefix {..} = spaced $ pretty pName : fmap pretty typeVariables+  pretty' Infix {..} = do+    parens $ spaced [pretty left, pretty iName, pretty right]+    spacePrefixed $ fmap pretty remains++mkNameAndTypeVariables :: GHC.TyClDecl GHC.GhcPs -> Maybe NameAndTypeVariables+mkNameAndTypeVariables GHC.ClassDecl {tcdFixity = GHC.Prefix, ..} =+  Just Prefix {..}+  where+    pName = fromGenLocated $ fmap mkPrefixName tcdLName+    typeVariables =+      fmap mkTypeVariable . fromGenLocated <$> GHC.hsq_explicit tcdTyVars+mkNameAndTypeVariables GHC.ClassDecl { tcdFixity = GHC.Infix+                                     , tcdTyVars = GHC.HsQTvs {hsq_explicit = h:t:xs}+                                     , ..+                                     } = Just Infix {..}+  where+    left = mkTypeVariable <$> fromGenLocated h+    iName = fromGenLocated $ fmap mkInfixName tcdLName+    right = mkTypeVariable <$> fromGenLocated t+    remains = fmap (fmap mkTypeVariable . fromGenLocated) xs+mkNameAndTypeVariables _ = Nothing
+ src/HIndent/Ast/Declaration/Collection.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module HIndent.Ast.Declaration.Collection+  ( DeclarationCollection+  , mkDeclarationCollection+  , hasDeclarations+  ) where++import Data.Maybe+import qualified GHC.Hs as GHC+import HIndent.Ast.Declaration+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype DeclarationCollection =+  DeclarationCollection [WithComments Declaration]++instance CommentExtraction DeclarationCollection where+  nodeComments DeclarationCollection {} = NodeComments [] [] []++instance Pretty DeclarationCollection where+  pretty' (DeclarationCollection decls) =+    mapM_ (\(x, sp) -> pretty x >> fromMaybe (return ()) sp)+      $ addDeclSeparator decls+    where+      addDeclSeparator [] = []+      addDeclSeparator [x] = [(x, Nothing)]+      addDeclSeparator (x:xs) =+        (x, Just $ declSeparator $ getNode x) : addDeclSeparator xs+      declSeparator (isSignature -> True) = newline+      declSeparator _ = blankline++mkDeclarationCollection :: GHC.HsModule' -> DeclarationCollection+mkDeclarationCollection GHC.HsModule {..} =+  DeclarationCollection $ fmap mkDeclaration . fromGenLocated <$> hsmodDecls++hasDeclarations :: DeclarationCollection -> Bool+hasDeclarations (DeclarationCollection xs) = not $ null xs
+ src/HIndent/Ast/Declaration/Data.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Data+  ( DataDeclaration+  , mkDataDeclaration+  ) where++import HIndent.Ast.Declaration.Data.Body+import HIndent.Ast.Declaration.Data.Header+import HIndent.Ast.NodeComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.NodeComments++data DataDeclaration = DataDeclaration+  { header :: Header+  , body :: DataBody+  }++instance CommentExtraction DataDeclaration where+  nodeComments DataDeclaration {} = NodeComments [] [] []++instance Pretty DataDeclaration where+  pretty' DataDeclaration {..} = pretty header >> pretty body++mkDataDeclaration :: GHC.TyClDecl GHC.GhcPs -> Maybe DataDeclaration+mkDataDeclaration decl@GHC.DataDecl {..} =+  DataDeclaration <$> mkHeader decl <*> pure (mkDataBody tcdDataDefn)+mkDataDeclaration _ = Nothing
+ src/HIndent/Ast/Declaration/Data/Body.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module HIndent.Ast.Declaration.Data.Body+  ( DataBody+  , mkDataBody+  ) where++import Control.Monad+import Data.Maybe+import GHC.Hs (HsDataDefn(dd_derivs, dd_kindSig))+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Applicative+import HIndent.Ast.Declaration.Data.Deriving.Clause+import HIndent.Ast.Declaration.Data.GADT.Constructor+import HIndent.Ast.Declaration.Data.Haskell98.Constructor+import HIndent.Ast.NodeComments hiding (fromEpAnn)+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data DataBody+  = GADT+      { kind :: Maybe (WithComments Type)+      , constructors :: [WithComments GADTConstructor]+      , derivings :: DerivingClause+      }+  | Haskell98+      { kind :: Maybe (WithComments Type)+      , constructorsH98 :: [WithComments Haskell98Constructor]+      , derivings :: DerivingClause+      }++instance CommentExtraction DataBody where+  nodeComments GADT {} = NodeComments [] [] []+  nodeComments Haskell98 {} = NodeComments [] [] []++instance Pretty DataBody where+  pretty' GADT {..} = do+    whenJust kind $ \x -> string " :: " >> pretty x+    string " where"+    case constructors of+      [] ->+        when (hasDerivings derivings) $ do+          newline+          indentedBlock $ pretty derivings+      _ ->+        indentedBlock $ do+          newlinePrefixed $ fmap pretty constructors+          when (hasDerivings derivings) $ do+            newline+            pretty derivings+  pretty' Haskell98 {..} = do+    whenJust kind $ \x -> string " :: " >> pretty x+    case constructorsH98 of+      [] -> indentedBlock derivingsAfterNewline+      [x]+        | hasSingleRecordConstructor $ getNode x -> do+          string " = "+          pretty x+          when (hasDerivings derivings) $ space |=> pretty derivings+        | otherwise -> do+          string " ="+          newline+          indentedBlock $ pretty x >> derivingsAfterNewline+      _ ->+        indentedBlock $ do+          newline+          string "= " |=> vBarSep (fmap pretty constructorsH98)+          derivingsAfterNewline+    where+      derivingsAfterNewline =+        when (hasDerivings derivings) $ newline >> pretty derivings++mkDataBody :: GHC.HsDataDefn GHC.GhcPs -> DataBody+mkDataBody defn@GHC.HsDataDefn {..} =+  if isGADT defn+    then GADT+           { constructors =+               fromMaybe (error "Some constructors are not GADT ones.")+                 $ mapM (traverse mkGADTConstructor . fromGenLocated)+                 $ getConDecls defn+           , ..+           }+    else Haskell98+           { constructorsH98 =+               fmap+                 (fromMaybe+                    (error "Some constructors are not in the Haskell 98 style.")+                    . mkHaskell98Constructor)+                 . fromGenLocated+                 <$> getConDecls defn+           , ..+           }+  where+    kind = fmap mkType . fromGenLocated <$> dd_kindSig+    derivings = mkDerivingClause dd_derivs++isGADT :: GHC.HsDataDefn GHC.GhcPs -> Bool+isGADT (getConDecls -> (GHC.L _ GHC.ConDeclGADT {}:_)) = True+isGADT _ = False++getConDecls :: GHC.HsDataDefn GHC.GhcPs -> [GHC.LConDecl GHC.GhcPs]+#if MIN_VERSION_ghc_lib_parser(9, 6, 0)+getConDecls GHC.HsDataDefn {..} =+  case dd_cons of+    GHC.NewTypeCon x -> [x]+    GHC.DataTypeCons _ xs -> xs+#else+getConDecls GHC.HsDataDefn {..} = dd_cons+#endif
+ src/HIndent/Ast/Declaration/Data/Constructor/Field.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Data.Constructor.Field+  ( ConstructorField+  , mkConstructorField+  ) where++import HIndent.Ast.NodeComments+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.NodeComments++newtype ConstructorField = ConstructorField+  { ty :: WithComments Type+  }++instance CommentExtraction ConstructorField where+  nodeComments ConstructorField {} = NodeComments [] [] []++instance Pretty ConstructorField where+  pretty' ConstructorField {..} = pretty ty++mkConstructorField ::+     GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs) -> ConstructorField+mkConstructorField (GHC.HsScaled _ bangTy) =+  ConstructorField {ty = mkType <$> fromGenLocated bangTy}
+ src/HIndent/Ast/Declaration/Data/Deriving.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Data.Deriving+  ( Deriving+  , mkDeriving+  ) where++import qualified GHC.Types.SrcLoc as GHC+import HIndent.Applicative+import HIndent.Ast.Declaration.Data.Deriving.Strategy+import HIndent.Ast.NodeComments+import HIndent.Ast.Type (Type, mkTypeFromHsSigType)+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Deriving = Deriving+  { strategy :: Maybe (WithComments DerivingStrategy)+  , classes :: WithComments [WithComments Type]+  }++instance CommentExtraction Deriving where+  nodeComments Deriving {} = NodeComments [] [] []++instance Pretty Deriving where+  pretty' Deriving {strategy = Just strategy, ..}+    | isViaStrategy (getNode strategy) = do+      spaced+        [ string "deriving"+        , prettyWith classes (hvTuple . fmap pretty)+        , pretty strategy+        ]+  pretty' Deriving {..} = do+    string "deriving "+    whenJust strategy $ \x -> pretty x >> space+    prettyWith classes (hvTuple . fmap pretty)++mkDeriving :: GHC.HsDerivingClause GHC.GhcPs -> Deriving+mkDeriving GHC.HsDerivingClause {..} = Deriving {..}+  where+    strategy =+      fmap (fmap mkDerivingStrategy . fromGenLocated) deriv_clause_strategy+    classes = fromGenLocated $ fmap (const rawClasses) deriv_clause_tys+    rawClasses =+      case GHC.unLoc deriv_clause_tys of+        GHC.DctSingle _ ty ->+          [flattenComments $ mkTypeFromHsSigType <$> fromGenLocated ty]+        GHC.DctMulti _ tys ->+          flattenComments . fmap mkTypeFromHsSigType . fromGenLocated <$> tys
+ src/HIndent/Ast/Declaration/Data/Deriving/Clause.hs view
@@ -0,0 +1,29 @@+module HIndent.Ast.Declaration.Data.Deriving.Clause+  ( DerivingClause+  , mkDerivingClause+  , hasDerivings+  ) where++import HIndent.Ast.Declaration.Data.Deriving+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype DerivingClause =+  DerivingClause [WithComments Deriving]++instance CommentExtraction DerivingClause where+  nodeComments DerivingClause {} = NodeComments [] [] []++instance Pretty DerivingClause where+  pretty' (DerivingClause xs) = lined $ fmap pretty xs++mkDerivingClause :: GHC.HsDeriving GHC.GhcPs -> DerivingClause+mkDerivingClause = DerivingClause . fmap (fmap mkDeriving . fromGenLocated)++hasDerivings :: DerivingClause -> Bool+hasDerivings (DerivingClause []) = False+hasDerivings _ = True
+ src/HIndent/Ast/Declaration/Data/Deriving/Strategy.hs view
@@ -0,0 +1,42 @@+module HIndent.Ast.Declaration.Data.Deriving.Strategy+  ( DerivingStrategy+  , mkDerivingStrategy+  , isViaStrategy+  ) where++import HIndent.Ast.NodeComments+import HIndent.Ast.Type (Type, mkTypeFromHsSigType)+import HIndent.Ast.WithComments (WithComments, flattenComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data DerivingStrategy+  = Stock+  | Anyclass+  | Newtype+  | Via (WithComments Type)++instance CommentExtraction DerivingStrategy where+  nodeComments Stock {} = NodeComments [] [] []+  nodeComments Anyclass {} = NodeComments [] [] []+  nodeComments Newtype {} = NodeComments [] [] []+  nodeComments Via {} = NodeComments [] [] []++instance Pretty DerivingStrategy where+  pretty' Stock = string "stock"+  pretty' Anyclass = string "anyclass"+  pretty' Newtype = string "newtype"+  pretty' (Via x) = string "via " >> pretty x++mkDerivingStrategy :: GHC.DerivStrategy GHC.GhcPs -> DerivingStrategy+mkDerivingStrategy GHC.StockStrategy {} = Stock+mkDerivingStrategy GHC.AnyclassStrategy {} = Anyclass+mkDerivingStrategy GHC.NewtypeStrategy {} = Newtype+mkDerivingStrategy (GHC.ViaStrategy (GHC.XViaStrategyPs _ x)) =+  Via $ flattenComments $ mkTypeFromHsSigType <$> fromGenLocated x++isViaStrategy :: DerivingStrategy -> Bool+isViaStrategy Via {} = True+isViaStrategy _ = False
+ src/HIndent/Ast/Declaration/Data/GADT/Constructor.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Data.GADT.Constructor+  ( GADTConstructor+  , mkGADTConstructor+  ) where++import Data.Maybe+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Ast.Context+import HIndent.Ast.Declaration.Data.GADT.Constructor.Signature+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Type.Variable+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 6, 0)+import qualified Data.List.NonEmpty as NE+#endif+data GADTConstructor = GADTConstructor+  { names :: [WithComments PrefixName]+  , bindings :: Maybe (WithComments [WithComments TypeVariable])+  , context :: Maybe (WithComments Context)+  , signature :: ConstructorSignature+  }++instance CommentExtraction GADTConstructor where+  nodeComments GADTConstructor {} = NodeComments [] [] []++instance Pretty GADTConstructor where+  pretty' (GADTConstructor {..}) = do+    hCommaSep $ fmap (`prettyWith` pretty) names+    hor <-|> ver+    where+      hor = string " :: " |=> body+      ver = newline >> indentedBlock (string ":: " |=> body)+      body =+        case (bindings, context) of+          (Just bs, Just ctx) -> withForallCtx bs ctx+          (Just bs, Nothing) -> withForallOnly bs+          (Nothing, Just ctx) -> withCtxOnly ctx+          (Nothing, Nothing) -> noForallCtx+      withForallCtx bs ctx = do+        string "forall"+        prettyWith bs (spacePrefixed . fmap pretty)+        dot+        (space >> pretty ctx) <-|> (newline >> pretty ctx)+        newline+        prefixed "=> " $ prettyVertically signature+      withForallOnly bs = do+        string "forall"+        prettyWith bs (spacePrefixed . fmap pretty)+        dot+        (space >> prettyHorizontally signature)+          <-|> (newline >> prettyVertically signature)+      withCtxOnly ctx =+        (pretty ctx >> string " => " >> prettyHorizontally signature)+          <-|> (pretty ctx >> prefixed "=> " (prettyVertically signature))+      noForallCtx = prettyHorizontally signature <-|> prettyVertically signature++mkGADTConstructor :: GHC.ConDecl GHC.GhcPs -> Maybe GADTConstructor+mkGADTConstructor decl@GHC.ConDeclGADT {..} = Just $ GADTConstructor {..}+  where+    names = fromMaybe (error "Couldn't get names.") $ getNames decl+    bindings =+      case con_bndrs of+        GHC.L _ GHC.HsOuterImplicit {} -> Nothing+        GHC.L l GHC.HsOuterExplicit {..} ->+          Just+            $ fromGenLocated+            $ fmap+                (fmap (fmap mkTypeVariable . fromGenLocated))+                (GHC.L l hso_bndrs)+    signature =+      fromMaybe (error "Couldn't get signature.") $ mkConstructorSignature decl+    context = fmap (fmap mkContext . fromGenLocated) con_mb_cxt+mkGADTConstructor _ = Nothing++getNames :: GHC.ConDecl GHC.GhcPs -> Maybe [WithComments PrefixName]+#if MIN_VERSION_ghc_lib_parser(9, 6, 0)+getNames GHC.ConDeclGADT {..} =+  Just $ NE.toList $ fmap (fromGenLocated . fmap mkPrefixName) con_names+#else+getNames GHC.ConDeclGADT {..} =+  Just $ fmap (fromGenLocated . fmap mkPrefixName) con_names+#endif+getNames _ = Nothing
+ src/HIndent/Ast/Declaration/Data/GADT/Constructor/Signature.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Data.GADT.Constructor.Signature+  ( ConstructorSignature+  , mkConstructorSignature+  , prettyHorizontally+  , prettyVertically+  ) where++import HIndent.Ast.Declaration.Data.Record.Field+import HIndent.Ast.NodeComments+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import HIndent.Printer++data ConstructorSignature+  = ByArrows (WithComments Type)+  | Record+      { fields :: WithComments [WithComments RecordField]+      , result :: WithComments Type+      }++instance CommentExtraction ConstructorSignature where+  nodeComments (ByArrows _) = NodeComments [] [] []+  nodeComments Record {} = NodeComments [] [] []++prettyHorizontally :: ConstructorSignature -> Printer ()+prettyHorizontally (ByArrows signature) = pretty signature+prettyHorizontally Record {..} =+  inter+    (string " -> ")+    [prettyWith fields (vFields' . fmap pretty), pretty result]++prettyVertically :: ConstructorSignature -> Printer ()+prettyVertically (ByArrows signature) =+  pretty $ fmap mkVerticalFuncType signature+prettyVertically Record {..} =+  prefixedLined+    "-> "+    [prettyWith fields (vFields' . fmap pretty), pretty result]++mkConstructorSignature :: GHC.ConDecl GHC.GhcPs -> Maybe ConstructorSignature+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.PrefixConGADT _ xs, ..} =+  Just $ ByArrows (buildFunctionType xs con_res_ty)+#else+mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.PrefixConGADT xs, ..} =+  Just $ ByArrows (buildFunctionType xs con_res_ty)+#endif+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.RecConGADT _ xs, ..} =+  Just+    $ Record+        { fields =+            fromGenLocated+              $ fmap (fmap (fmap mkRecordField . fromGenLocated)) xs+        , result = mkType <$> fromGenLocated con_res_ty+        }+#elif MIN_VERSION_ghc_lib_parser(9, 4, 0)+mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.RecConGADT xs _, ..} =+  Just+    $ Record+        { fields =+            fromGenLocated+              $ fmap (fmap (fmap mkRecordField . fromGenLocated)) xs+        , result = mkType <$> fromGenLocated con_res_ty+        }+#else+mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.RecConGADT xs, ..} =+  Just+    $ Record+        { fields =+            fromGenLocated+              $ fmap (fmap (fmap mkRecordField . fromGenLocated)) xs+        , result = mkType <$> fromGenLocated con_res_ty+        }+#endif+mkConstructorSignature GHC.ConDeclH98 {} = Nothing++buildFunctionType ::+     [GHC.HsScaled GHC.GhcPs (GHC.LHsType GHC.GhcPs)]+  -> GHC.LHsType GHC.GhcPs+  -> WithComments Type+buildFunctionType scaledTypes resultTy =+  mkType <$> fromGenLocated (foldr mkFun resultTy scaledTypes)++mkFun ::+     GHC.HsScaled GHC.GhcPs (GHC.LHsType GHC.GhcPs)+  -> GHC.LHsType GHC.GhcPs+  -> GHC.LHsType GHC.GhcPs+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkFun (GHC.HsScaled mult paramTy) accTy =+  GHC.noLocA (GHC.HsFunTy GHC.noExtField mult paramTy accTy)+#elif MIN_VERSION_ghc_lib_parser(9, 4, 0)+mkFun (GHC.HsScaled mult paramTy) accTy =+  GHC.noLocA (GHC.HsFunTy GHC.noAnn mult paramTy accTy)+#else+mkFun (GHC.HsScaled mult paramTy) accTy =+  GHC.noLocA (GHC.HsFunTy GHC.NoExtField mult paramTy accTy)+#endif
+ src/HIndent/Ast/Declaration/Data/Haskell98/Constructor.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Data.Haskell98.Constructor+  ( Haskell98Constructor+  , mkHaskell98Constructor+  , hasSingleRecordConstructor+  ) where++import HIndent.Applicative+import HIndent.Ast.Context+import HIndent.Ast.Declaration.Data.Haskell98.Constructor.Body+import HIndent.Ast.NodeComments+import HIndent.Ast.Type.Variable+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Haskell98Constructor = Haskell98Constructor+  { existentialVariables :: [WithComments TypeVariable]+  , context :: Maybe (WithComments Context)+  , body :: Haskell98ConstructorBody+  }++instance CommentExtraction Haskell98Constructor where+  nodeComments Haskell98Constructor {} = NodeComments [] [] []++instance Pretty Haskell98Constructor where+  pretty' Haskell98Constructor {existentialVariables = [], ..} = do+    whenJust context $ \c -> pretty c >> string " => "+    pretty body+  pretty' Haskell98Constructor {..} = do+    string "forall "+    spaced (fmap pretty existentialVariables)+    string ". " |=> do+      whenJust context $ \c -> pretty c >> string " =>" >> newline+      pretty body++mkHaskell98Constructor :: GHC.ConDecl GHC.GhcPs -> Maybe Haskell98Constructor+mkHaskell98Constructor GHC.ConDeclH98 {..}+  | Just body <- mkHaskell98ConstructorBody GHC.ConDeclH98 {..} =+    Just Haskell98Constructor {..}+  where+    existentialVariables =+      if con_forall+        then fmap (fmap mkTypeVariable . fromGenLocated) con_ex_tvs+        else []+    context = fmap (fmap mkContext . fromGenLocated) con_mb_cxt+mkHaskell98Constructor _ = Nothing++hasSingleRecordConstructor :: Haskell98Constructor -> Bool+hasSingleRecordConstructor = isRecord . body
+ src/HIndent/Ast/Declaration/Data/Haskell98/Constructor/Body.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Data.Haskell98.Constructor.Body+  ( Haskell98ConstructorBody+  , mkHaskell98ConstructorBody+  , isRecord+  ) where++import HIndent.Ast.Declaration.Data.Constructor.Field+import HIndent.Ast.Declaration.Data.Record.Field+import HIndent.Ast.Name.Infix+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Haskell98ConstructorBody+  = Infix+      { iName :: WithComments InfixName -- Using `name` in all constructors causes a type clash+      , left :: ConstructorField+      , right :: ConstructorField+      }+  | Prefix+      { pName :: WithComments PrefixName+      , types :: [ConstructorField]+      }+  | Record+      { rName :: WithComments PrefixName+      , records :: WithComments [WithComments RecordField]+      }++instance CommentExtraction Haskell98ConstructorBody where+  nodeComments Infix {} = NodeComments [] [] []+  nodeComments Prefix {} = NodeComments [] [] []+  nodeComments Record {} = NodeComments [] [] []++instance Pretty Haskell98ConstructorBody where+  pretty' Infix {..} = spaced [pretty left, pretty iName, pretty right]+  pretty' Prefix {..} = pretty pName >> hor <-|> ver+    where+      hor = spacePrefixed $ fmap pretty types+      ver = indentedBlock $ newlinePrefixed $ fmap pretty types+  pretty' Record {..} = do+    pretty rName+    prettyWith records $ \r ->+      newline >> indentedBlock (vFields $ fmap pretty r)++mkHaskell98ConstructorBody ::+     GHC.ConDecl GHC.GhcPs -> Maybe Haskell98ConstructorBody+mkHaskell98ConstructorBody GHC.ConDeclH98 { con_args = GHC.InfixCon leftField rightField+                                          , ..+                                          } = Just Infix {..}+  where+    iName = fromGenLocated $ fmap mkInfixName con_name+    left = mkConstructorField leftField+    right = mkConstructorField rightField+mkHaskell98ConstructorBody GHC.ConDeclH98 { con_args = GHC.PrefixCon _ rawTypes+                                          , ..+                                          } = Just Prefix {..}+  where+    pName = fromGenLocated $ fmap mkPrefixName con_name+    types = fmap mkConstructorField rawTypes+mkHaskell98ConstructorBody GHC.ConDeclH98 {con_args = GHC.RecCon rs, ..} =+  Just Record {..}+  where+    rName = fromGenLocated $ fmap mkPrefixName con_name+    records =+      fromGenLocated $ fmap (fmap (fmap mkRecordField . fromGenLocated)) rs+mkHaskell98ConstructorBody GHC.ConDeclGADT {} = Nothing++isRecord :: Haskell98ConstructorBody -> Bool+isRecord Record {} = True+isRecord _ = False
+ src/HIndent/Ast/Declaration/Data/Header.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Data.Header+  ( Header+  , mkHeader+  ) where++import HIndent.Applicative+import HIndent.Ast.Context+import HIndent.Ast.Declaration.Data.NewOrData+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Type.Variable+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Header = Header+  { newOrData :: NewOrData+  , name :: WithComments PrefixName+  , context :: Maybe (WithComments Context)+  , typeVariables :: [WithComments TypeVariable]+  }++instance CommentExtraction Header where+  nodeComments Header {} = NodeComments [] [] []++instance Pretty Header where+  pretty' Header {..} = do+    (pretty newOrData >> space) |=> do+      whenJust context $ \c -> pretty c >> string " =>" >> newline+      pretty name+    spacePrefixed $ fmap pretty typeVariables++mkHeader :: GHC.TyClDecl GHC.GhcPs -> Maybe Header+mkHeader GHC.DataDecl {tcdDataDefn = defn@GHC.HsDataDefn {..}, ..} =+  Just Header {..}+  where+    newOrData = mkNewOrData defn+    context = fmap (fmap mkContext . fromGenLocated) dd_ctxt+    name = fromGenLocated $ fmap mkPrefixName tcdLName+    typeVariables =+      fmap mkTypeVariable . fromGenLocated <$> GHC.hsq_explicit tcdTyVars+mkHeader _ = Nothing
+ src/HIndent/Ast/Declaration/Data/NewOrData.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Data.NewOrData+  ( NewOrData+  , mkNewOrData+  ) where++import HIndent.Ast.NodeComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data NewOrData+  = Newtype+  | Data++instance CommentExtraction NewOrData where+  nodeComments Newtype = NodeComments [] [] []+  nodeComments Data = NodeComments [] [] []++instance Pretty NewOrData where+  pretty' Newtype = string "newtype"+  pretty' Data = string "data"++mkNewOrData :: GHC.HsDataDefn GHC.GhcPs -> NewOrData+#if MIN_VERSION_ghc_lib_parser(9, 6, 0)+mkNewOrData GHC.HsDataDefn {..}+  | GHC.NewTypeCon _ <- dd_cons = Newtype+  | GHC.DataTypeCons _ _ <- dd_cons = Data+#else+mkNewOrData GHC.HsDataDefn {..}+  | GHC.NewType <- dd_ND = Newtype+  | GHC.DataType <- dd_ND = Data+#endif
+ src/HIndent/Ast/Declaration/Data/Record/Field.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Data.Record.Field+  ( RecordField+  , mkRecordField+  ) where++import HIndent.Ast.Name.RecordField (FieldName, mkFieldNameFromFieldOcc)+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data RecordField = RecordField+  { names :: [WithComments FieldName]+  , ty :: WithComments Type+  }++instance CommentExtraction RecordField where+  nodeComments RecordField {} = NodeComments [] [] []++instance Pretty RecordField where+  pretty' RecordField {..} =+    spaced [hCommaSep $ fmap pretty names, string "::", pretty ty]++mkRecordField :: GHC.ConDeclField GHC.GhcPs -> RecordField+mkRecordField GHC.ConDeclField {..} = RecordField {..}+  where+    names = fmap mkFieldNameFromFieldOcc . fromGenLocated <$> cd_fld_names+    ty = mkType <$> fromGenLocated cd_fld_type
+ src/HIndent/Ast/Declaration/Default.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Declaration.Default+  ( DefaultDeclaration+  , mkDefaultDeclaration+  ) where++import qualified GHC.Hs as GHC+import HIndent.Ast.NodeComments+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype DefaultDeclaration =+  DefaultDeclaration [WithComments Type]++instance CommentExtraction DefaultDeclaration where+  nodeComments DefaultDeclaration {} = NodeComments [] [] []++instance Pretty DefaultDeclaration where+  pretty' (DefaultDeclaration xs) =+    spaced [string "default", hTuple $ fmap pretty xs]++mkDefaultDeclaration :: GHC.DefaultDecl GHC.GhcPs -> DefaultDeclaration+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkDefaultDeclaration (GHC.DefaultDecl _ _ xs) =+  DefaultDeclaration $ fmap (fmap mkType . fromGenLocated) xs+#else+mkDefaultDeclaration (GHC.DefaultDecl _ xs) =+  DefaultDeclaration $ fmap (fmap mkType . fromGenLocated) xs+#endif
+ src/HIndent/Ast/Declaration/Family/Data.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Family.Data+  ( DataFamily+  , mkDataFamily+  ) where++import Control.Monad+import qualified GHC.Types.Basic as GHC+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Applicative+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments hiding (fromEpAnn)+import HIndent.Ast.Type+import HIndent.Ast.Type.Variable+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data DataFamily = DataFamily+  { isTopLevel :: Bool+  , name :: WithComments PrefixName+  , typeVariables :: [WithComments TypeVariable]+  , signature :: Maybe (WithComments Type)+  }++instance CommentExtraction DataFamily where+  nodeComments DataFamily {} = NodeComments [] [] []++instance Pretty DataFamily where+  pretty' DataFamily {..} = do+    string "data "+    when isTopLevel $ string "family "+    pretty name+    spacePrefixed $ fmap pretty typeVariables+    whenJust signature $ \sig -> space >> pretty sig++mkDataFamily :: GHC.FamilyDecl GHC.GhcPs -> Maybe DataFamily+mkDataFamily GHC.FamilyDecl {fdTyVars = GHC.HsQTvs {..}, ..}+  | GHC.DataFamily <- fdInfo+  , Nothing <- fdInjectivityAnn = Just DataFamily {..}+  | otherwise = Nothing+  where+    isTopLevel =+      case fdTopLevel of+        GHC.TopLevel -> True+        GHC.NotTopLevel -> False+    name = fromGenLocated $ fmap mkPrefixName fdLName+    typeVariables = fmap (fmap mkTypeVariable . fromGenLocated) hsq_explicit+    signature =+      case GHC.unLoc fdResultSig of+        GHC.NoSig {} -> Nothing+        GHC.KindSig _ kind -> Just $ mkType <$> fromGenLocated kind+        GHC.TyVarSig {} ->+          error+            "Data family should never have this AST node. If you see this error, please report it to the HIndent maintainers."
+ src/HIndent/Ast/Declaration/Family/Type.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Family.Type+  ( TypeFamily+  , mkTypeFamily+  ) where++import Control.Monad+import qualified GHC.Types.Basic as GHC+import HIndent.Applicative+import HIndent.Ast.Declaration.Family.Type.Injectivity+import HIndent.Ast.Declaration.Family.Type.ResultSignature+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments hiding (fromEpAnn)+import HIndent.Ast.Type.Variable+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data TypeFamily = TypeFamily+  { isTopLevel :: Bool+  , name :: WithComments PrefixName+  , typeVariables :: [WithComments TypeVariable]+  , signature :: WithComments ResultSignature+  , injectivity :: Maybe (WithComments Injectivity)+  , equations :: Maybe [WithComments (GHC.TyFamInstEqn GHC.GhcPs)]+  }++instance CommentExtraction TypeFamily where+  nodeComments TypeFamily {} = NodeComments [] [] []++instance Pretty TypeFamily where+  pretty' TypeFamily {..} = do+    string "type "+    when isTopLevel $ string "family "+    pretty name+    spacePrefixed $ fmap pretty typeVariables+    pretty signature+    whenJust injectivity $ \x -> string " | " >> pretty x+    whenJust equations $ \xs ->+      string " where" >> newline >> indentedBlock (lined $ fmap pretty xs)++mkTypeFamily :: GHC.FamilyDecl GHC.GhcPs -> Maybe TypeFamily+mkTypeFamily GHC.FamilyDecl {fdTyVars = GHC.HsQTvs {..}, ..}+  | GHC.DataFamily <- fdInfo = Nothing+  | otherwise = Just TypeFamily {..}+  where+    isTopLevel =+      case fdTopLevel of+        GHC.TopLevel -> True+        GHC.NotTopLevel -> False+    name = fromGenLocated $ fmap mkPrefixName fdLName+    typeVariables = fmap (fmap mkTypeVariable . fromGenLocated) hsq_explicit+    signature = mkResultSignature <$> fromGenLocated fdResultSig+    injectivity = fmap (fmap mkInjectivity . fromGenLocated) fdInjectivityAnn+    equations =+      case fdInfo of+        GHC.DataFamily -> error "Not a TypeFamily"+        GHC.OpenTypeFamily -> Nothing+        GHC.ClosedTypeFamily Nothing -> Just []+        GHC.ClosedTypeFamily (Just xs) -> Just $ fmap fromGenLocated xs
+ src/HIndent/Ast/Declaration/Family/Type/Injectivity.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Family.Type.Injectivity+  ( Injectivity+  , mkInjectivity+  ) where++import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Injectivity = Injectivity+  { from :: WithComments PrefixName+  , to :: [WithComments PrefixName]+  }++instance CommentExtraction Injectivity where+  nodeComments Injectivity {} = NodeComments [] [] []++instance Pretty Injectivity where+  pretty' Injectivity {..} = spaced $ pretty from : string "->" : fmap pretty to++mkInjectivity :: GHC.InjectivityAnn GHC.GhcPs -> Injectivity+mkInjectivity (GHC.InjectivityAnn _ f t) = Injectivity {..}+  where+    from = fromGenLocated $ fmap mkPrefixName f+    to = fmap (fromGenLocated . fmap mkPrefixName) t
+ src/HIndent/Ast/Declaration/Family/Type/ResultSignature.hs view
@@ -0,0 +1,35 @@+module HIndent.Ast.Declaration.Family.Type.ResultSignature+  ( ResultSignature(..)+  , mkResultSignature+  ) where++import HIndent.Ast.NodeComments+import HIndent.Ast.Type+import HIndent.Ast.Type.Variable+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data ResultSignature+  = NoSig+  | Kind (WithComments Type)+  | TypeVariable (WithComments TypeVariable)++instance CommentExtraction ResultSignature where+  nodeComments NoSig = NodeComments [] [] []+  nodeComments Kind {} = NodeComments [] [] []+  nodeComments TypeVariable {} = NodeComments [] [] []++instance Pretty ResultSignature where+  pretty' NoSig = return ()+  pretty' (Kind x) = string " :: " >> pretty x+  pretty' (TypeVariable x) = string " = " >> pretty x++mkResultSignature :: GHC.FamilyResultSig GHC.GhcPs -> ResultSignature+mkResultSignature (GHC.NoSig _) = NoSig+mkResultSignature (GHC.KindSig _ x) = Kind $ mkType <$> fromGenLocated x+mkResultSignature (GHC.TyVarSig _ x) = TypeVariable var+  where+    var = mkTypeVariable <$> fromGenLocated x
+ src/HIndent/Ast/Declaration/Foreign.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Foreign+  ( ForeignDeclaration+  , mkForeignDeclaration+  ) where++import Data.Maybe+import qualified GHC.Types.ForeignCall as GHC+import qualified GHC.Types.SourceText as GHC+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Ast.Declaration.Foreign.CallingConvention+import HIndent.Ast.Declaration.Foreign.Safety+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Type (Type, mkTypeFromHsSigType)+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 8, 0)+import qualified GHC.Data.FastString as GHC+#endif+data ForeignDeclaration+  = ForeignImport+      { convention :: CallingConvention+      , safety :: Safety+      , srcIdent :: Maybe String+      , dstIdent :: WithComments PrefixName+      , signature :: WithComments Type+      }+  | ForeignExport+      { convention :: CallingConvention+      , srcIdent :: Maybe String+      , dstIdent :: WithComments PrefixName+      , signature :: WithComments Type+      }++instance CommentExtraction ForeignDeclaration where+  nodeComments ForeignImport {} = NodeComments [] [] []+  nodeComments ForeignExport {} = NodeComments [] [] []++instance Pretty ForeignDeclaration where+  pretty' ForeignImport {..} =+    spaced+      $ [string "foreign import", pretty convention, pretty safety]+          ++ maybeToList (fmap string srcIdent)+          ++ [pretty dstIdent, string "::", pretty signature]+  pretty' ForeignExport {..} =+    spaced+      $ [string "foreign export", pretty convention]+          ++ maybeToList (fmap string srcIdent)+          ++ [pretty dstIdent, string "::", pretty signature]++mkForeignDeclaration :: GHC.ForeignDecl GHC.GhcPs -> ForeignDeclaration+#if MIN_VERSION_ghc_lib_parser(9, 8, 0)+mkForeignDeclaration GHC.ForeignImport { fd_fi = (GHC.CImport (GHC.L _ src) (GHC.L _ conv) (GHC.L _ sfty) _ _)+                                       , ..+                                       } = ForeignImport {..}+  where+    convention = mkCallingConvention conv+    safety = mkSafety sfty+    srcIdent =+      case src of+        GHC.SourceText s -> Just $ GHC.unpackFS s+        _ -> Nothing+    dstIdent = fromGenLocated $ fmap mkPrefixName fd_name+    signature =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated fd_sig_ty+mkForeignDeclaration GHC.ForeignExport { fd_fe = (GHC.CExport (GHC.L _ src) (GHC.L _ (GHC.CExportStatic _ _ conv)))+                                       , ..+                                       } = ForeignExport {..}+  where+    convention = mkCallingConvention conv+    srcIdent =+      case src of+        GHC.SourceText s -> Just $ GHC.unpackFS s+        _ -> Nothing+    dstIdent = fromGenLocated $ fmap mkPrefixName fd_name+    signature =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated fd_sig_ty+#elif MIN_VERSION_ghc_lib_parser(9, 6, 0)+mkForeignDeclaration GHC.ForeignImport { fd_fi = (GHC.CImport (GHC.L _ src) (GHC.L _ conv) (GHC.L _ sfty) _ _)+                                       , ..+                                       } = ForeignImport {..}+  where+    convention = mkCallingConvention conv+    safety = mkSafety sfty+    srcIdent =+      case src of+        GHC.SourceText s -> Just s+        _ -> Nothing+    dstIdent = fromGenLocated $ fmap mkPrefixName fd_name+    signature =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated fd_sig_ty+mkForeignDeclaration GHC.ForeignExport { fd_fe = (GHC.CExport (GHC.L _ src) (GHC.L _ (GHC.CExportStatic _ _ conv)))+                                       , ..+                                       } = ForeignExport {..}+  where+    convention = mkCallingConvention conv+    srcIdent =+      case src of+        GHC.SourceText s -> Just s+        _ -> Nothing+    dstIdent = fromGenLocated $ fmap mkPrefixName fd_name+    signature =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated fd_sig_ty+#else+mkForeignDeclaration GHC.ForeignImport { fd_fi = (GHC.CImport (GHC.L _ conv) (GHC.L _ sfty) _ _ (GHC.L _ src))+                                       , ..+                                       } = ForeignImport {..}+  where+    convention = mkCallingConvention conv+    safety = mkSafety sfty+    srcIdent =+      case src of+        GHC.SourceText s -> Just s+        _ -> Nothing+    dstIdent = fromGenLocated $ fmap mkPrefixName fd_name+    signature =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated fd_sig_ty+mkForeignDeclaration GHC.ForeignExport { fd_fe = (GHC.CExport (GHC.L _ (GHC.CExportStatic _ _ conv)) (GHC.L _ src))+                                       , ..+                                       } = ForeignExport {..}+  where+    convention = mkCallingConvention conv+    srcIdent =+      case src of+        GHC.SourceText s -> Just s+        _ -> Nothing+    dstIdent = fromGenLocated $ fmap mkPrefixName fd_name+    signature =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated fd_sig_ty+#endif
+ src/HIndent/Ast/Declaration/Foreign/CallingConvention.hs view
@@ -0,0 +1,34 @@+module HIndent.Ast.Declaration.Foreign.CallingConvention+  ( CallingConvention+  , mkCallingConvention+  ) where++import qualified GHC.Types.ForeignCall as GHC+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data CallingConvention+  = CCall+  | CApi+  | StdCall+  | Prim+  | JavaScript++instance CommentExtraction CallingConvention where+  nodeComments _ = NodeComments [] [] []++instance Pretty CallingConvention where+  pretty' CCall = string "ccall"+  pretty' CApi = string "capi"+  pretty' StdCall = string "stdcall"+  pretty' Prim = string "prim"+  pretty' JavaScript = string "javascript"++mkCallingConvention :: GHC.CCallConv -> CallingConvention+mkCallingConvention GHC.CCallConv = CCall+mkCallingConvention GHC.StdCallConv = StdCall+mkCallingConvention GHC.CApiConv = CApi+mkCallingConvention GHC.PrimCallConv = Prim+mkCallingConvention GHC.JavaScriptCallConv = JavaScript
+ src/HIndent/Ast/Declaration/Foreign/Safety.hs view
@@ -0,0 +1,28 @@+module HIndent.Ast.Declaration.Foreign.Safety+  ( Safety+  , mkSafety+  ) where++import qualified GHC.Types.ForeignCall as GHC+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Safety+  = Safe+  | Interruptible+  | Unsafe++instance CommentExtraction Safety where+  nodeComments _ = NodeComments [] [] []++instance Pretty Safety where+  pretty' Safe = string "safe"+  pretty' Interruptible = string "interruptible"+  pretty' Unsafe = string "unsafe"++mkSafety :: GHC.Safety -> Safety+mkSafety GHC.PlaySafe = Safe+mkSafety GHC.PlayInterruptible = Interruptible+mkSafety GHC.PlayRisky = Unsafe
+ src/HIndent/Ast/Declaration/Instance/Class.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Instance.Class+  ( ClassInstance+  , mkClassInstance+  ) where++import Control.Monad+import HIndent.Applicative+import HIndent.Ast.Declaration.Instance.Class.OverlapMode+import HIndent.Ast.NodeComments+import HIndent.Ast.Type (InstDeclType, mkInstDeclType)+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import HIndent.Pretty.SigBindFamily+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+import qualified GHC.Data.Bag as GHC+#endif+data ClassInstance = ClassInstance+  { overlapMode :: Maybe (WithComments OverlapMode)+  , cid_sigs :: [GHC.LSig GHC.GhcPs]+  , binds :: [GHC.LocatedA (GHC.HsBindLR GHC.GhcPs GHC.GhcPs)]+  , cid_tyfam_insts :: [GHC.LTyFamInstDecl GHC.GhcPs]+  , cid_datafam_insts :: [GHC.LDataFamInstDecl GHC.GhcPs]+  , cid_poly_ty :: WithComments InstDeclType+  }++instance CommentExtraction ClassInstance where+  nodeComments ClassInstance {} = NodeComments [] [] []++instance Pretty ClassInstance where+  pretty' (ClassInstance {..}) = do+    string "instance " |=> do+      whenJust overlapMode $ \x -> do+        pretty x+        space+      pretty cid_poly_ty |=> unless (null sigsAndMethods) (string " where")+    unless (null sigsAndMethods) $ do+      newline+      indentedBlock $ lined $ fmap pretty sigsAndMethods+    where+      sigsAndMethods =+        mkSortedLSigBindFamilyList+          cid_sigs+          binds+          []+          cid_tyfam_insts+          []+          cid_datafam_insts++mkClassInstance :: GHC.InstDecl GHC.GhcPs -> Maybe ClassInstance+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkClassInstance GHC.ClsInstD {cid_inst = GHC.ClsInstDecl {..}} =+  Just+    $ ClassInstance+        { cid_poly_ty =+            flattenComments $ mkInstDeclType <$> fromGenLocated cid_poly_ty+        , binds = cid_binds+        , overlapMode = fmap mkOverlapMode . fromGenLocated <$> cid_overlap_mode+        , ..+        }+#else+mkClassInstance GHC.ClsInstD {cid_inst = GHC.ClsInstDecl {..}} =+  Just+    $ ClassInstance+        { cid_poly_ty =+            flattenComments $ mkInstDeclType <$> fromGenLocated cid_poly_ty+        , binds = GHC.bagToList cid_binds+        , overlapMode = fmap mkOverlapMode . fromGenLocated <$> cid_overlap_mode+        , ..+        }+#endif+mkClassInstance _ = Nothing
+ src/HIndent/Ast/Declaration/Instance/Class/OverlapMode.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Declaration.Instance.Class.OverlapMode+  ( OverlapMode+  , mkOverlapMode+  ) where++import qualified GHC.Types.Basic as GHC+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators.String+import HIndent.Pretty.NodeComments++data OverlapMode+  = Overlappable+  | Overlapping+  | Overlaps+  | Incoherent++instance CommentExtraction OverlapMode where+  nodeComments Overlappable = NodeComments [] [] []+  nodeComments Overlapping = NodeComments [] [] []+  nodeComments Overlaps = NodeComments [] [] []+  nodeComments Incoherent = NodeComments [] [] []++instance Pretty OverlapMode where+  pretty' Overlappable = string "{-# OVERLAPPABLE #-}"+  pretty' Overlapping = string "{-# OVERLAPPING #-}"+  pretty' Overlaps = string "{-# OVERLAPS #-}"+  pretty' Incoherent = string "{-# INCOHERENT #-}"++mkOverlapMode :: GHC.OverlapMode -> OverlapMode+mkOverlapMode GHC.NoOverlap {} =+  error "This AST node should never appear in the tree"+mkOverlapMode GHC.Overlappable {} = Overlappable+mkOverlapMode GHC.Overlapping {} = Overlapping+mkOverlapMode GHC.Overlaps {} = Overlaps+mkOverlapMode GHC.Incoherent {} = Incoherent+#if MIN_VERSION_ghc_lib_parser(9, 8, 0)+-- From https://hackage-content.haskell.org/package/ghc-9.12.2/docs/GHC-Core-InstEnv.html#v:NonCanonical+-- > We don't have surface syntax for the distinction between Incoherent and NonCanonical instances; instead,+-- > the flag `-f{no-}specialise-incoherents` (on by default) controls whether INCOHERENT instances are+-- > regarded as Incoherent or NonCanonical.+mkOverlapMode GHC.NonCanonical {} = Incoherent+#endif
+ src/HIndent/Ast/Declaration/Instance/Family/Data.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE RecordWildCards, CPP #-}++module HIndent.Ast.Declaration.Instance.Family.Data+  ( DataFamilyInstance+  , mkDataFamilyInstance+  ) where++import qualified GHC.Hs as GG+import HIndent.Ast.Declaration.Data.Body+import HIndent.Ast.Declaration.Data.NewOrData+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+data DataFamilyInstance = DataFamilyInstance+  { newOrData :: NewOrData+  , name :: WithComments PrefixName+  , types :: GHC.HsFamEqnPats GHC.GhcPs+  , body :: DataBody+  }+#else+data DataFamilyInstance = DataFamilyInstance+  { newOrData :: NewOrData+  , name :: WithComments PrefixName+  , types :: GHC.HsTyPats GHC.GhcPs+  , body :: DataBody+  }+#endif+instance CommentExtraction DataFamilyInstance where+  nodeComments DataFamilyInstance {} = NodeComments [] [] []++instance Pretty DataFamilyInstance where+  pretty' DataFamilyInstance {..} = do+    spaced+      $ pretty newOrData : string "instance" : pretty name : fmap pretty types+    pretty body++mkDataFamilyInstance ::+     GHC.FamEqn GHC.GhcPs (GHC.HsDataDefn GHC.GhcPs) -> DataFamilyInstance+mkDataFamilyInstance GHC.FamEqn {..} = DataFamilyInstance {..}+  where+    newOrData = mkNewOrData feqn_rhs+    name = fromGenLocated $ fmap mkPrefixName feqn_tycon+    types = feqn_pats+    body = mkDataBody feqn_rhs
+ src/HIndent/Ast/Declaration/Instance/Family/Type.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE RecordWildCards, CPP #-}++module HIndent.Ast.Declaration.Instance.Family.Type+  ( TypeFamilyInstance+  , mkTypeFamilyInstance+  ) where++import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+data TypeFamilyInstance = TypeFamilyInstance+  { name :: WithComments PrefixName+  , types :: GHC.HsFamEqnPats GHC.GhcPs+  , bind :: WithComments Type+  }+#else+data TypeFamilyInstance = TypeFamilyInstance+  { name :: WithComments PrefixName+  , types :: GHC.HsTyPats GHC.GhcPs+  , bind :: WithComments Type+  }+#endif+instance CommentExtraction TypeFamilyInstance where+  nodeComments TypeFamilyInstance {} = NodeComments [] [] []++instance Pretty TypeFamilyInstance where+  pretty' TypeFamilyInstance {..} = do+    spaced $ string "type instance" : pretty name : fmap pretty types+    string " = "+    pretty bind++mkTypeFamilyInstance :: GHC.InstDecl GHC.GhcPs -> Maybe TypeFamilyInstance+mkTypeFamilyInstance GHC.TyFamInstD {GHC.tfid_inst = GHC.TyFamInstDecl {GHC.tfid_eqn = GHC.FamEqn {..}}} =+  Just $ TypeFamilyInstance {..}+  where+    name = fromGenLocated $ fmap mkPrefixName feqn_tycon+    types = feqn_pats+    bind = mkType <$> fromGenLocated feqn_rhs+mkTypeFamilyInstance _ = Nothing
+ src/HIndent/Ast/Declaration/Instance/Family/Type/Associated.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE RecordWildCards, CPP #-}++module HIndent.Ast.Declaration.Instance.Family.Type.Associated+  ( AssociatedType+  , mkAssociatedType+  ) where++import HIndent.Ast.NodeComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype AssociatedType =+  AssociatedType (GHC.FamEqn GHC.GhcPs (GHC.LocatedA (GHC.HsType GHC.GhcPs)))++instance CommentExtraction AssociatedType where+  nodeComments (AssociatedType _) = NodeComments [] [] []++instance Pretty AssociatedType where+  pretty' (AssociatedType equation) = string "type " >> pretty equation++mkAssociatedType :: GHC.TyFamInstDecl GHC.GhcPs -> AssociatedType+mkAssociatedType GHC.TyFamInstDecl {..} = AssociatedType tfid_eqn
+ src/HIndent/Ast/Declaration/Instance/Family/Type/Associated/Default.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}++module HIndent.Ast.Declaration.Instance.Family.Type.Associated.Default+  ( AssociatedTypeDefault+  , mkAssociatedTypeDefault+  ) where++import HIndent.Ast.NodeComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype AssociatedTypeDefault =+  AssociatedTypeDefault+    (GHC.FamEqn GHC.GhcPs (GHC.LocatedA (GHC.HsType GHC.GhcPs)))++instance CommentExtraction AssociatedTypeDefault where+  nodeComments (AssociatedTypeDefault _) = NodeComments [] [] []++instance Pretty AssociatedTypeDefault where+  pretty' (AssociatedTypeDefault equation) =+    string "type instance " >> pretty equation++mkAssociatedTypeDefault :: GHC.TyFamInstDecl GHC.GhcPs -> AssociatedTypeDefault+mkAssociatedTypeDefault GHC.TyFamInstDecl {..} = AssociatedTypeDefault tfid_eqn
+ src/HIndent/Ast/Declaration/PatternSynonym.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.PatternSynonym+  ( PatternSynonym+  , mkPatternSynonym+  ) where++import HIndent.Applicative+import HIndent.Ast.MatchGroup (MatchGroup, mkExprMatchGroup)+import HIndent.Ast.Name.Infix+import HIndent.Ast.Name.Prefix+import HIndent.Ast.Name.RecordField (FieldName, mkFieldNameFromFieldOcc)+import HIndent.Ast.Pattern+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Parameters+  = Prefix+      { args :: [WithComments PrefixName]+      }+  | Infix+      { leftArg :: WithComments PrefixName+      , rightArg :: WithComments PrefixName+      }+  | Record+      { fields :: [WithComments FieldName]+      }++data PatternSynonym = PatternSynonym+  { name :: GHC.LIdP GHC.GhcPs+  , parameters :: WithComments Parameters+  , isImplicitBidirectional :: Bool+  , explicitMatches :: Maybe MatchGroup+  , definition :: WithComments PatInsidePatDecl+  }++instance CommentExtraction Parameters where+  nodeComments Prefix {} = emptyNodeComments+  nodeComments Infix {} = emptyNodeComments+  nodeComments Record {} = emptyNodeComments++instance CommentExtraction PatternSynonym where+  nodeComments PatternSynonym {} = emptyNodeComments++instance Pretty Parameters where+  pretty' Prefix {..} = spaced $ fmap pretty args+  pretty' Infix {..} = spaced [pretty leftArg, pretty rightArg]+  pretty' Record {..} = hFields $ fmap pretty fields++instance Pretty PatternSynonym where+  pretty' PatternSynonym {..} = do+    string "pattern "+    case getNode parameters of+      Infix {..} ->+        spaced [pretty leftArg, pretty $ fmap mkInfixName name, pretty rightArg]+      Prefix {args = []} -> pretty $ fmap mkPrefixName name+      _ -> spaced [pretty $ fmap mkPrefixName name, pretty parameters]+    let arrow =+          if isImplicitBidirectional+            then "="+            else "<-"+    spacePrefixed [string arrow, pretty definition]+    whenJust explicitMatches $ \matches -> do+      newline+      indentedBlock $ string "where " |=> pretty matches++mkParameters :: GHC.HsPatSynDetails GHC.GhcPs -> Parameters+mkParameters (GHC.PrefixCon _ args) =+  Prefix {args = map (fromGenLocated . fmap mkPrefixName) args}+mkParameters (GHC.InfixCon l r) =+  Infix+    { leftArg = fromGenLocated $ fmap mkPrefixName l+    , rightArg = fromGenLocated $ fmap mkPrefixName r+    }+mkParameters (GHC.RecCon fields) =+  Record+    { fields =+        map+          (mkWithComments . mkFieldNameFromFieldOcc . GHC.recordPatSynField)+          fields+    }++mkPatternSynonym :: GHC.PatSynBind GHC.GhcPs GHC.GhcPs -> PatternSynonym+mkPatternSynonym GHC.PSB {..} = PatternSynonym {..}+  where+    name = psb_id+    parameters = mkWithComments $ mkParameters psb_args+    (isImplicitBidirectional, explicitMatches) =+      case psb_dir of+        GHC.Unidirectional -> (False, Nothing)+        GHC.ImplicitBidirectional -> (True, Nothing)+        GHC.ExplicitBidirectional matches ->+          (False, Just $ mkExprMatchGroup matches)+    definition = mkPatInsidePatDecl <$> fromGenLocated psb_def
+ src/HIndent/Ast/Declaration/Rule.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Rule+  ( RuleDeclaration+  , mkRuleDeclaration+  ) where++import qualified GHC.Types.Basic as GHC+import HIndent.Ast.Declaration.Rule.Binder+import HIndent.Ast.Declaration.Rule.Name+import HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data RuleDeclaration = RuleDeclaration+  { name :: WithComments RuleName+  , binders :: [WithComments RuleBinder]+  , lhs :: WithComments Expression+  , rhs :: WithComments Expression+  }++instance CommentExtraction RuleDeclaration where+  nodeComments RuleDeclaration {} = NodeComments [] [] []++instance Pretty RuleDeclaration where+  pretty' (RuleDeclaration {..}) =+    spaced [pretty name, prettyLhs, string "=", pretty rhs]+    where+      prettyLhs =+        if null binders+          then pretty lhs+          else do+            string "forall "+            spaced $ fmap pretty binders+            dot+            space+            pretty lhs++mkRuleDeclaration :: GHC.RuleDecl GHC.GhcPs -> RuleDeclaration+mkRuleDeclaration rule@GHC.HsRule {..} = RuleDeclaration {..}+  where+    name = mkRuleName <$> getName rule+    binders = fmap (fmap mkRuleBinder . fromGenLocated) rd_tmvs+    lhs = mkExpression <$> fromGenLocated rd_lhs+    rhs = mkExpression <$> fromGenLocated rd_rhs++getName :: GHC.RuleDecl GHC.GhcPs -> WithComments GHC.RuleName+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+getName = fromGenLocated . GHC.rd_name+#else+getName = fromGenLocated . fmap snd . GHC.rd_name+#endif
+ src/HIndent/Ast/Declaration/Rule.hs-boot view
@@ -0,0 +1,15 @@+module HIndent.Ast.Declaration.Rule+  ( RuleDeclaration+  , mkRuleDeclaration+  ) where++import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty.NodeComments+import {-# SOURCE #-} HIndent.Pretty++data RuleDeclaration++instance CommentExtraction RuleDeclaration+instance Pretty RuleDeclaration++mkRuleDeclaration :: GHC.RuleDecl GHC.GhcPs -> RuleDeclaration
+ src/HIndent/Ast/Declaration/Rule/Binder.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Rule.Binder+  ( RuleBinder+  , mkRuleBinder+  ) where++import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data RuleBinder = RuleBinder+  { name :: WithComments PrefixName+  , signature :: Maybe (WithComments Type)+  }++instance CommentExtraction RuleBinder where+  nodeComments RuleBinder {} = NodeComments [] [] []++instance Pretty RuleBinder where+  pretty' RuleBinder {signature = Nothing, ..} = pretty name+  pretty' RuleBinder {signature = Just sig, ..} =+    parens $ spaced [pretty name, string "::", pretty sig]++mkRuleBinder :: GHC.RuleBndr GHC.GhcPs -> RuleBinder+mkRuleBinder (GHC.RuleBndr _ n) = RuleBinder {..}+  where+    signature = Nothing+    name = fromGenLocated $ fmap mkPrefixName n+mkRuleBinder (GHC.RuleBndrSig _ n GHC.HsPS {..}) = RuleBinder {..}+  where+    signature = Just $ fromGenLocated $ fmap mkType hsps_body+    name = fromGenLocated $ fmap mkPrefixName n
+ src/HIndent/Ast/Declaration/Rule/Collection.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Rule.Collection+  ( RuleCollection+  , mkRuleCollection+  ) where++import {-# SOURCE #-} HIndent.Ast.Declaration.Rule+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype RuleCollection =+  RuleCollection [WithComments RuleDeclaration]++instance CommentExtraction RuleCollection where+  nodeComments RuleCollection {} = NodeComments [] [] []++instance Pretty RuleCollection where+  pretty' (RuleCollection xs) =+    lined $ string "{-# RULES" : fmap pretty xs ++ [string " #-}"]++mkRuleCollection :: GHC.RuleDecls GHC.GhcPs -> RuleCollection+mkRuleCollection GHC.HsRules {..} =+  RuleCollection $ fmap (fmap mkRuleDeclaration . fromGenLocated) rds_rules
+ src/HIndent/Ast/Declaration/Rule/Name.hs view
@@ -0,0 +1,23 @@+module HIndent.Ast.Declaration.Rule.Name+  ( RuleName+  , mkRuleName+  ) where++import qualified GHC.Data.FastString as GHC+import qualified GHC.Types.Basic as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype RuleName =+  RuleName String+  deriving (Eq, Show)++instance CommentExtraction RuleName where+  nodeComments _ = emptyNodeComments++instance Pretty RuleName where+  pretty' (RuleName name) = doubleQuotes $ string name++mkRuleName :: GHC.RuleName -> RuleName+mkRuleName = RuleName . GHC.unpackFS
+ src/HIndent/Ast/Declaration/Signature.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Signature+  ( Signature+  , mkSignature+  ) where++import qualified GHC.Types.Basic as GHC+import HIndent.Applicative+import HIndent.Ast.Declaration.Signature.BooleanFormula+import HIndent.Ast.Declaration.Signature.Fixity+import HIndent.Ast.Declaration.Signature.Inline.Phase+import HIndent.Ast.Declaration.Signature.Inline.Spec+import HIndent.Ast.Name.Infix+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Type (DeclSigType, Type, mkDeclSigType, mkTypeFromHsSigType)+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++-- We want to use the same name for `parameters` and `signature`, but GHC+-- doesn't allow it.+data Signature+  = Type+      { names :: [WithComments PrefixName]+      , parameters :: WithComments DeclSigType+      }+  | Pattern+      { names :: [WithComments PrefixName]+      , signature :: WithComments Type+      }+  | DefaultClassMethod+      { names :: [WithComments PrefixName]+      , methodSig :: WithComments DeclSigType+      }+  | ClassMethod+      { names :: [WithComments PrefixName]+      , methodSig :: WithComments DeclSigType+      }+  | Fixity+      { opNames :: [WithComments InfixName] -- Using `names` causes a type conflict.+      , fixity :: Fixity+      }+  | Inline+      { name :: WithComments PrefixName+      , spec :: InlineSpec+      , phase :: Maybe InlinePhase+      }+  | Specialise+      { name :: WithComments PrefixName+      , sigs :: [WithComments Type]+      }+  | SpecialiseInstance (WithComments Type)+  | Minimal (WithComments BooleanFormula)+  | Scc (WithComments PrefixName)+  | Complete (WithComments [WithComments PrefixName])++instance CommentExtraction Signature where+  nodeComments Type {} = NodeComments [] [] []+  nodeComments Pattern {} = NodeComments [] [] []+  nodeComments DefaultClassMethod {} = NodeComments [] [] []+  nodeComments ClassMethod {} = NodeComments [] [] []+  nodeComments Fixity {} = NodeComments [] [] []+  nodeComments Inline {} = NodeComments [] [] []+  nodeComments Specialise {} = NodeComments [] [] []+  nodeComments SpecialiseInstance {} = NodeComments [] [] []+  nodeComments Minimal {} = NodeComments [] [] []+  nodeComments Scc {} = NodeComments [] [] []+  nodeComments Complete {} = NodeComments [] [] []++instance Pretty Signature where+  pretty' Type {..} = do+    printFunName+    string " ::"+    horizontal <-|> vertical+    where+      horizontal = do+        space+        pretty parameters+      vertical = do+        headLen <- printerLength printFunName+        indentSpaces <- getIndentSpaces+        if headLen < indentSpaces+          then space |=> pretty parameters+          else do+            newline+            indentedBlock $ indentedWithSpace 3 $ pretty parameters+      printFunName = hCommaSep $ fmap pretty names+  pretty' Pattern {..} =+    spaced+      [ string "pattern"+      , hCommaSep $ fmap pretty names+      , string "::"+      , pretty signature+      ]+  pretty' DefaultClassMethod {..} = do+    string "default "+    hCommaSep $ fmap pretty names+    string " ::"+    hor <-|> ver+    where+      hor = space >> pretty methodSig+      ver = do+        newline+        indentedBlock $ indentedWithSpace 3 $ pretty methodSig+  pretty' ClassMethod {..} = do+    hCommaSep $ fmap pretty names+    string " ::"+    hor <-|> ver+    where+      hor = space >> pretty methodSig+      ver = do+        newline+        indentedBlock $ indentedWithSpace 3 $ pretty methodSig+  pretty' Fixity {..} = spaced [pretty fixity, hCommaSep $ fmap pretty opNames]+  pretty' Inline {..} = do+    string "{-# "+    pretty spec+    whenJust phase $ \x -> space >> pretty x+    space+    pretty name+    string " #-}"+  pretty' Specialise {..} =+    spaced+      [ string "{-# SPECIALISE"+      , pretty name+      , string "::"+      , hCommaSep $ fmap pretty sigs+      , string "#-}"+      ]+  pretty' (SpecialiseInstance sig) =+    spaced [string "{-# SPECIALISE instance", pretty sig, string "#-}"]+  pretty' (Minimal xs) =+    string "{-# MINIMAL " |=> do+      pretty xs+      string " #-}"+  pretty' (Scc name) = spaced [string "{-# SCC", pretty name, string "#-}"]+  pretty' (Complete names) =+    spaced+      [ string "{-# COMPLETE"+      , prettyWith names (hCommaSep . fmap pretty)+      , string "#-}"+      ]++mkSignature :: GHC.Sig GHC.GhcPs -> Signature+mkSignature (GHC.TypeSig _ ns GHC.HsWC { hswc_ext = GHC.NoExtField+                                       , GHC.hswc_body = params+                                       }) = Type {..}+  where+    names = fmap (fromGenLocated . fmap mkPrefixName) ns+    parameters = flattenComments $ mkDeclSigType <$> fromGenLocated params+mkSignature (GHC.PatSynSig _ ns s) = Pattern {..}+  where+    names = fmap (fromGenLocated . fmap mkPrefixName) ns+    signature = flattenComments $ mkTypeFromHsSigType <$> fromGenLocated s+mkSignature (GHC.ClassOpSig _ True ns s) = DefaultClassMethod {..}+  where+    names = fmap (fromGenLocated . fmap mkPrefixName) ns+    methodSig = flattenComments $ mkDeclSigType <$> fromGenLocated s+mkSignature (GHC.ClassOpSig _ False ns s) = ClassMethod {..}+  where+    names = fmap (fromGenLocated . fmap mkPrefixName) ns+    methodSig = flattenComments $ mkDeclSigType <$> fromGenLocated s+mkSignature (GHC.FixSig _ (GHC.FixitySig _ ops fy)) = Fixity {..}+  where+    fixity = mkFixity fy+    opNames = fmap (fromGenLocated . fmap mkInfixName) ops+mkSignature (GHC.InlineSig _ n GHC.InlinePragma {..}) = Inline {..}+  where+    name = fromGenLocated $ fmap mkPrefixName n+    spec = mkInlineSpec inl_inline+    phase = mkInlinePhase inl_act+mkSignature (GHC.SpecSig _ n s _) = Specialise {..}+  where+    name = fromGenLocated $ fmap mkPrefixName n+    sigs = flattenComments . fmap mkTypeFromHsSigType . fromGenLocated <$> s+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkSignature (GHC.SCCFunSig _ n _) = Scc name+  where+    name = fromGenLocated $ fmap mkPrefixName n+mkSignature (GHC.CompleteMatchSig _ ns _) = Complete names+  where+    names = mkWithComments $ fmap (fromGenLocated . fmap mkPrefixName) ns+#elif MIN_VERSION_ghc_lib_parser(9, 6, 0)+mkSignature (GHC.SCCFunSig _ n _) = Scc name+  where+    name = fromGenLocated $ fmap mkPrefixName n+mkSignature (GHC.CompleteMatchSig _ ns _) = Complete names+  where+    names = fromGenLocated $ fmap (fmap (fromGenLocated . fmap mkPrefixName)) ns+#elif MIN_VERSION_ghc_lib_parser(9, 4, 0)+mkSignature (GHC.SCCFunSig _ _ name _) =+  Scc $ fromGenLocated $ fmap mkPrefixName name+mkSignature (GHC.CompleteMatchSig _ _ names _) =+  Complete+    $ fromGenLocated+    $ fmap (fmap (fromGenLocated . fmap mkPrefixName)) names+#else+mkSignature (GHC.SCCFunSig _ _ name _) =+  Scc $ fromGenLocated $ fmap mkPrefixName name+mkSignature (GHC.CompleteMatchSig _ _ names _) =+  Complete+    $ fromGenLocated+    $ fmap (fmap (fromGenLocated . fmap mkPrefixName)) names+#endif+#if MIN_VERSION_ghc_lib_parser(9, 6, 0)+mkSignature (GHC.SpecInstSig _ sig) =+  SpecialiseInstance+    $ flattenComments+    $ mkTypeFromHsSigType <$> fromGenLocated sig+mkSignature (GHC.MinimalSig _ xs) =+  Minimal $ mkBooleanFormula <$> fromGenLocated xs+#else+mkSignature (GHC.SpecInstSig _ _ sig) = SpecialiseInstance sig+mkSignature (GHC.MinimalSig _ _ xs) =+  Minimal $ mkBooleanFormula <$> fromGenLocated xs+mkSignature GHC.IdSig {} =+  error "`ghc-lib-parser` never generates this AST node."+#endif
+ src/HIndent/Ast/Declaration/Signature/BooleanFormula.hs view
@@ -0,0 +1,39 @@+module HIndent.Ast.Declaration.Signature.BooleanFormula+  ( BooleanFormula+  , mkBooleanFormula+  ) where++import qualified GHC.Data.BooleanFormula as GHC+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data BooleanFormula+  = Var (WithComments PrefixName)+  | And [WithComments BooleanFormula]+  | Or [WithComments BooleanFormula]+  | Parens (WithComments BooleanFormula)++instance CommentExtraction BooleanFormula where+  nodeComments Var {} = NodeComments [] [] []+  nodeComments And {} = NodeComments [] [] []+  nodeComments Or {} = NodeComments [] [] []+  nodeComments Parens {} = NodeComments [] [] []++instance Pretty BooleanFormula where+  pretty' (Var x) = pretty x+  pretty' (And xs) = hvCommaSep $ fmap pretty xs+  pretty' (Or xs) = hvBarSep $ fmap pretty xs+  pretty' (Parens x) = parens $ pretty x++mkBooleanFormula :: GHC.BooleanFormula (GHC.LIdP GHC.GhcPs) -> BooleanFormula+mkBooleanFormula (GHC.Var x) = Var $ fromGenLocated $ fmap mkPrefixName x+mkBooleanFormula (GHC.And xs) =+  And $ fmap (fmap mkBooleanFormula . fromGenLocated) xs+mkBooleanFormula (GHC.Or xs) =+  Or $ fmap (fmap mkBooleanFormula . fromGenLocated) xs+mkBooleanFormula (GHC.Parens x) = Parens $ mkBooleanFormula <$> fromGenLocated x
+ src/HIndent/Ast/Declaration/Signature/Fixity.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Signature.Fixity+  ( Fixity+  , mkFixity+  ) where++import qualified GHC.Types.Fixity as GHC+import HIndent.Ast.Declaration.Signature.Fixity.Associativity+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Fixity = Fixity+  { level :: Int+  , associativity :: Associativity+  }++instance CommentExtraction Fixity where+  nodeComments Fixity {} = NodeComments [] [] []++instance Pretty Fixity where+  pretty' Fixity {..} = spaced [pretty associativity, string $ show level]++mkFixity :: GHC.Fixity -> Fixity+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkFixity (GHC.Fixity level associativity) =+  Fixity level (mkAssociativity associativity)+#else+mkFixity (GHC.Fixity _ level associativity) =+  Fixity level (mkAssociativity associativity)+#endif
+ src/HIndent/Ast/Declaration/Signature/Fixity/Associativity.hs view
@@ -0,0 +1,30 @@+module HIndent.Ast.Declaration.Signature.Fixity.Associativity+  ( Associativity+  , mkAssociativity+  ) where++import qualified GHC.Types.Fixity as GHC+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Associativity+  = LeftAssoc+  | RightAssoc+  | None++instance CommentExtraction Associativity where+  nodeComments LeftAssoc = NodeComments [] [] []+  nodeComments RightAssoc = NodeComments [] [] []+  nodeComments None = NodeComments [] [] []++instance Pretty Associativity where+  pretty' LeftAssoc = string "infixl"+  pretty' RightAssoc = string "infixr"+  pretty' None = string "infix"++mkAssociativity :: GHC.FixityDirection -> Associativity+mkAssociativity GHC.InfixL = LeftAssoc+mkAssociativity GHC.InfixR = RightAssoc+mkAssociativity GHC.InfixN = None
+ src/HIndent/Ast/Declaration/Signature/Inline/Phase.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Signature.Inline.Phase+  ( InlinePhase+  , mkInlinePhase+  ) where++import qualified GHC.Types.Basic as GHC+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data BeforeOrAfter+  = Before+  | After++data InlinePhase = InlinePhase+  { beforeOrAfter :: BeforeOrAfter+  , phase :: Int+  }++instance CommentExtraction InlinePhase where+  nodeComments InlinePhase {} = NodeComments [] [] []++instance Pretty InlinePhase where+  pretty' InlinePhase {beforeOrAfter = Before, ..} =+    brackets (string $ '~' : show phase)+  pretty' InlinePhase {beforeOrAfter = After, ..} =+    brackets (string $ show phase)++mkInlinePhase :: GHC.Activation -> Maybe InlinePhase+mkInlinePhase (GHC.ActiveBefore _ phase) = Just $ InlinePhase Before phase+mkInlinePhase (GHC.ActiveAfter _ phase) = Just $ InlinePhase After phase+mkInlinePhase _ = Nothing
+ src/HIndent/Ast/Declaration/Signature/Inline/Spec.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Declaration.Signature.Inline.Spec+  ( InlineSpec+  , mkInlineSpec+  ) where++import qualified GHC.Types.Basic as GHC+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data InlineSpec+  = Inline+  | Inlinable+  | NoInline+  | Opaque++instance CommentExtraction InlineSpec where+  nodeComments Inline = NodeComments [] [] []+  nodeComments Inlinable = NodeComments [] [] []+  nodeComments NoInline = NodeComments [] [] []+  nodeComments Opaque = NodeComments [] [] []++instance Pretty InlineSpec where+  pretty' Inline = string "INLINE"+  pretty' Inlinable = string "INLINABLE"+  pretty' NoInline = string "NOINLINE"+  pretty' Opaque = string "OPAQUE"++mkInlineSpec :: GHC.InlineSpec -> InlineSpec+mkInlineSpec GHC.Inline {} = Inline+mkInlineSpec GHC.Inlinable {} = Inlinable+mkInlineSpec GHC.NoInline {} = NoInline+mkInlineSpec GHC.NoUserInlinePrag = error "NoUserInlinePrag is not supported"+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkInlineSpec GHC.Opaque {} = Opaque+#endif
+ src/HIndent/Ast/Declaration/Signature/StandaloneKind.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Signature.StandaloneKind+  ( StandaloneKind+  , mkStandaloneKind+  ) where++import qualified GHC.Hs as GHC+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Type (Type, mkTypeFromHsSigType)+import HIndent.Ast.WithComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data StandaloneKind = StandaloneKind+  { name :: WithComments PrefixName+  , kind :: WithComments Type+  }++instance CommentExtraction StandaloneKind where+  nodeComments StandaloneKind {} = NodeComments [] [] []++instance Pretty StandaloneKind where+  pretty' StandaloneKind {..} =+    spaced [string "type", pretty name, string "::", pretty kind]++mkStandaloneKind :: GHC.StandaloneKindSig GHC.GhcPs -> StandaloneKind+mkStandaloneKind (GHC.StandaloneKindSig _ n k) = StandaloneKind {..}+  where+    name = fromGenLocated $ fmap mkPrefixName n+    kind = flattenComments $ mkTypeFromHsSigType <$> fromGenLocated k
+ src/HIndent/Ast/Declaration/Splice.hs view
@@ -0,0 +1,24 @@+module HIndent.Ast.Declaration.Splice+  ( SpliceDeclaration+  , mkSpliceDeclaration+  ) where++import HIndent.Ast.Expression.Splice+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.NodeComments++newtype SpliceDeclaration =+  SpliceDeclaration (WithComments Splice)++instance CommentExtraction SpliceDeclaration where+  nodeComments SpliceDeclaration {} = NodeComments [] [] []++instance Pretty SpliceDeclaration where+  pretty' (SpliceDeclaration splice) = pretty splice++mkSpliceDeclaration :: GHC.SpliceDecl GHC.GhcPs -> SpliceDeclaration+mkSpliceDeclaration (GHC.SpliceDecl _ sp _) =+  SpliceDeclaration $ mkSplice <$> fromGenLocated sp
+ src/HIndent/Ast/Declaration/StandAloneDeriving.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.StandAloneDeriving+  ( StandAloneDeriving+  , mkStandAloneDeriving+  ) where++import HIndent.Applicative+import HIndent.Ast.Declaration.Data.Deriving.Strategy+import HIndent.Ast.NodeComments+import HIndent.Ast.Type (Type, mkTypeFromHsSigType)+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data StandAloneDeriving = StandAloneDeriving+  { strategy :: Maybe (WithComments DerivingStrategy)+  , className :: WithComments Type+  }++instance CommentExtraction StandAloneDeriving where+  nodeComments StandAloneDeriving {} = NodeComments [] [] []++instance Pretty StandAloneDeriving where+  pretty' StandAloneDeriving {strategy = Just strategy, ..}+    | isViaStrategy (getNode strategy) =+      spaced+        [ string "deriving"+        , pretty strategy+        , string "instance"+        , pretty className+        ]+  pretty' StandAloneDeriving {..} = do+    string "deriving "+    whenJust strategy $ \x -> pretty x >> space+    string "instance "+    pretty className++mkStandAloneDeriving :: GHC.DerivDecl GHC.GhcPs -> StandAloneDeriving+mkStandAloneDeriving GHC.DerivDecl {deriv_type = GHC.HsWC {..}, ..} =+  StandAloneDeriving {..}+  where+    strategy = fmap (fmap mkDerivingStrategy . fromGenLocated) deriv_strategy+    className =+      flattenComments $ mkTypeFromHsSigType <$> fromGenLocated hswc_body
+ src/HIndent/Ast/Declaration/TypeSynonym.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.TypeSynonym+  ( TypeSynonym+  , mkTypeSynonym+  ) where++import HIndent.Ast.Declaration.TypeSynonym.Lhs+import HIndent.Ast.NodeComments+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data TypeSynonym = TypeSynonym+  { lhs :: TypeSynonymLhs+  , rhs :: WithComments Type+  }++instance CommentExtraction TypeSynonym where+  nodeComments TypeSynonym {} = NodeComments [] [] []++instance Pretty TypeSynonym where+  pretty' TypeSynonym {..} = do+    string "type "+    pretty lhs+    hor <-|> ver+    where+      hor = string " = " >> pretty rhs+      ver = newline >> indentedBlock (string "= " |=> pretty rhs)++mkTypeSynonym :: GHC.TyClDecl GHC.GhcPs -> TypeSynonym+mkTypeSynonym synonym@GHC.SynDecl {..} = TypeSynonym {..}+  where+    lhs = mkTypeSynonymLhs synonym+    rhs = mkType <$> fromGenLocated tcdRhs+mkTypeSynonym _ = error "Not a type synonym."
+ src/HIndent/Ast/Declaration/TypeSynonym/Lhs.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.TypeSynonym.Lhs+  ( TypeSynonymLhs+  , mkTypeSynonymLhs+  ) where++import qualified GHC.Types.Fixity as GHC+import HIndent.Ast.Name.Infix+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Type.Variable+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data TypeSynonymLhs+  = Prefix+      { pName :: WithComments PrefixName -- Using `name` in both `Prefix` and `Infix` causes a type conflict.+      , typeVariables :: [WithComments TypeVariable]+      }+  | Infix+      { left :: WithComments TypeVariable+      , iName :: WithComments InfixName+      , right :: WithComments TypeVariable+      }++instance CommentExtraction TypeSynonymLhs where+  nodeComments Prefix {} = NodeComments [] [] []+  nodeComments Infix {} = NodeComments [] [] []++instance Pretty TypeSynonymLhs where+  pretty' Prefix {..} = spaced $ pretty pName : fmap pretty typeVariables+  pretty' Infix {..} = spaced [pretty left, pretty iName, pretty right]++mkTypeSynonymLhs :: GHC.TyClDecl GHC.GhcPs -> TypeSynonymLhs+mkTypeSynonymLhs GHC.SynDecl {tcdFixity = GHC.Prefix, ..} = Prefix {..}+  where+    pName = fromGenLocated $ fmap mkPrefixName tcdLName+    typeVariables =+      fmap mkTypeVariable . fromGenLocated <$> GHC.hsq_explicit tcdTyVars+mkTypeSynonymLhs GHC.SynDecl {tcdFixity = GHC.Infix, ..} =+  case GHC.hsq_explicit tcdTyVars of+    [l, r] -> Infix {..}+      where+        left = mkTypeVariable <$> fromGenLocated l+        iName = fromGenLocated $ fmap mkInfixName tcdLName+        right = mkTypeVariable <$> fromGenLocated r+    _ -> error "Unexpected number of type variables for infix type synonym."+mkTypeSynonymLhs _ = error "Not a type synonym."
+ src/HIndent/Ast/Declaration/Warning.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Declaration.Warning+  ( WarningDeclaration+  , mkWarningDeclaration+  ) where++import qualified GHC.Types.SourceText as GHC+import HIndent.Ast.Declaration.Warning.Kind+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import qualified HIndent.GhcLibParserWrapper.GHC.Unit.Module.Warnings as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data WarningDeclaration = WarningDeclaration+  { names :: [WithComments PrefixName]+  , kind :: Kind+  , reasons :: [WithComments GHC.StringLiteral]+  }++instance CommentExtraction WarningDeclaration where+  nodeComments _ = NodeComments [] [] []++instance Pretty WarningDeclaration where+  pretty' WarningDeclaration {..} = do+    lined+      [ string "{-# " >> pretty kind+      , spaced [hCommaSep $ fmap pretty names, hCommaSep $ fmap pretty reasons]+      , string " #-}"+      ]++mkWarningDeclaration :: GHC.WarnDecl GHC.GhcPs -> WarningDeclaration+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkWarningDeclaration (GHC.Warning _ ns (GHC.DeprecatedTxt _ rs)) =+  WarningDeclaration {kind = Deprecated, ..}+  where+    names = fmap (fromGenLocated . fmap mkPrefixName) ns+    reasons = fmap (fromGenLocated . fmap GHC.hsDocString) rs+mkWarningDeclaration (GHC.Warning _ ns (GHC.WarningTxt _ _ rs)) =+  WarningDeclaration {kind = Warning, ..}+  where+    names = fmap (fromGenLocated . fmap mkPrefixName) ns+    reasons = fmap (fromGenLocated . fmap GHC.hsDocString) rs+#elif MIN_VERSION_ghc_lib_parser(9, 8, 1)+mkWarningDeclaration (GHC.Warning _ ns (GHC.DeprecatedTxt _ rs)) =+  WarningDeclaration {kind = Deprecated, ..}+  where+    names = fmap (fromGenLocated . fmap mkPrefixName) ns+    reasons = fmap (fromGenLocated . fmap GHC.hsDocString) rs+mkWarningDeclaration (GHC.Warning _ ns (GHC.WarningTxt _ _ rs)) =+  WarningDeclaration {kind = Warning, ..}+  where+    names = fmap (fromGenLocated . fmap mkPrefixName) ns+    reasons = fmap (fromGenLocated . fmap GHC.hsDocString) rs+#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkWarningDeclaration (GHC.Warning _ ns (GHC.DeprecatedTxt _ rs)) =+  WarningDeclaration {kind = Deprecated, ..}+  where+    names = fmap (fromGenLocated . fmap mkPrefixName) ns+    reasons = fmap (fromGenLocated . fmap GHC.hsDocString) rs+mkWarningDeclaration (GHC.Warning _ ns (GHC.WarningTxt _ rs)) =+  WarningDeclaration {kind = Warning, ..}+  where+    names = fmap (fromGenLocated . fmap mkPrefixName) ns+    reasons = fmap (fromGenLocated . fmap GHC.hsDocString) rs+#else+mkWarningDeclaration (GHC.Warning _ ns (GHC.DeprecatedTxt _ rs)) =+  WarningDeclaration {kind = Deprecated, ..}+  where+    names = fmap (fromGenLocated . fmap mkPrefixName) ns+    reasons = fmap fromGenLocated rs+mkWarningDeclaration (GHC.Warning _ ns (GHC.WarningTxt _ rs)) =+  WarningDeclaration {kind = Warning, ..}+  where+    names = fmap (fromGenLocated . fmap mkPrefixName) ns+    reasons = fmap fromGenLocated rs+#endif
+ src/HIndent/Ast/Declaration/Warning/Collection.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Declaration.Warning.Collection+  ( WarningCollection+  , mkWarningCollection+  ) where++import HIndent.Ast.Declaration.Warning+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype WarningCollection =+  WarningCollection [WithComments WarningDeclaration]++instance CommentExtraction WarningCollection where+  nodeComments WarningCollection {} = NodeComments [] [] []++instance Pretty WarningCollection where+  pretty' (WarningCollection xs) = lined $ fmap pretty xs++mkWarningCollection :: GHC.WarnDecls GHC.GhcPs -> WarningCollection+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+mkWarningCollection (GHC.Warnings _ xs) =+  WarningCollection $ fmap (fmap mkWarningDeclaration . fromGenLocated) xs+#else+mkWarningCollection (GHC.Warnings _ _ xs) =+  WarningCollection $ fmap (fmap mkWarningDeclaration . fromGenLocated) xs+#endif
+ src/HIndent/Ast/Declaration/Warning/Kind.hs view
@@ -0,0 +1,19 @@+module HIndent.Ast.Declaration.Warning.Kind+  ( Kind(..)+  ) where++import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Kind+  = Warning+  | Deprecated++instance CommentExtraction Kind where+  nodeComments _ = NodeComments [] [] []++instance Pretty Kind where+  pretty' Warning = string "WARNING"+  pretty' Deprecated = string "DEPRECATED"
+ src/HIndent/Ast/Expression.hs view
@@ -0,0 +1,676 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module HIndent.Ast.Expression+  ( Expression+  , GuardExpression+  , mkExpression+  , mkGuardExpression+  ) where++import Control.Monad+import Control.Monad.RWS (gets)+import Data.List.NonEmpty (NonEmpty(..), (<|))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Monoid (First(..))+import qualified GHC.Hs as GHC+import qualified GHC.Types.Basic as GHC+import qualified GHC.Types.Fixity as GHC+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Ast.Cmd (Cmd, CmdDoBlock, mkCmdDoBlock, mkCmdFromHsCmdTop)+import HIndent.Ast.Expression.Bracket (Bracket, mkBracket)+import HIndent.Ast.Expression.FieldSelector (FieldSelector, mkFieldSelector)+import qualified HIndent.Ast.Expression.ListComprehension as LC+import HIndent.Ast.Expression.OverloadedLabel+  ( OverloadedLabel+  , mkOverloadedLabel+  )+import HIndent.Ast.Expression.Pragmatic (ExpressionPragma, mkExpressionPragma)+import HIndent.Ast.Expression.RangeExpression+  ( RangeExpression+  , mkRangeExpression+  )+import HIndent.Ast.Expression.RecordConstructionField+  ( RecordConstructionFields+  , mkRecordConstructionFields+  )+import HIndent.Ast.Expression.RecordUpdateField+  ( RecordUpdateFields+  , mkRecordUpdateFields+  )+import HIndent.Ast.Guard (Guard, mkMultiWayIfExprGuard)+import HIndent.Ast.LocalBinds (LocalBinds, mkLocalBinds)+import HIndent.Ast.MatchGroup (MatchGroup, hasMatches, mkExprMatchGroup)+import HIndent.Ast.Module.Name (mkModuleName)+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.Pattern+import HIndent.Ast.Statement (ExprStatement, mkExprStatement)+import HIndent.Ast.Type+import HIndent.Ast.Type.ImplicitParameterName+  ( ImplicitParameterName+  , mkImplicitParameterName+  )+import HIndent.Ast.WithComments+import HIndent.CabalFile ()+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import HIndent.Pretty.Types (DoOrMdo(..), QualifiedDo(..))+import HIndent.Printer+import qualified Language.Haskell.Syntax.Basic as HS+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+import Data.Maybe+import HIndent.Ast.Expression.Splice (Splice, mkSplice, mkTypedSplice)+import HIndent.Fixity (fixities)+import qualified Language.Haskell.GhclibParserEx.GHC.Hs.Expr as GHC+#else+import qualified GHC.Types.Name.Reader as NameReader+import HIndent.Ast.Expression.Splice (Splice, mkSplice)+#endif+data Expression+  = Variable (WithComments PrefixName)+  | UnboundVariable PrefixName+  | OverloadedLabel OverloadedLabel+  | ImplicitParameter ImplicitParameterName+  | OverloadedLiteral (GHC.HsOverLit GHC.GhcPs)+  | Literal (GHC.HsLit GHC.GhcPs)+  | Lambda MatchGroup+  | LambdaCase+      { usesCases :: Bool+      , matches :: MatchGroup+      }+  | Application (NonEmpty (WithComments Expression))+  | TypeApplication+      { expression :: WithComments Expression+      , typeArg :: WithComments Type+      }+  | OperatorApplication+      { firstOperand :: WithComments Expression+      , operatorOperandPairs :: NonEmpty+          (WithComments InfixExpr, WithComments Expression)+      }+  | Negation (WithComments Expression)+  | Parenthesized (WithComments Expression)+  | LeftSection+      { left :: WithComments Expression+      , operator :: WithComments InfixExpr+      }+  | RightSection+      { operator :: WithComments InfixExpr+      , right :: WithComments Expression+      }+  | Tuple+      { arguments :: [WithComments (Maybe (WithComments Expression))]+      , isBoxed :: Bool+      }+  | Sum+      { position :: GHC.ConTag+      , arity :: HS.SumWidth+      , expression :: WithComments Expression+      }+  | CaseExpression+      { scrutinee :: WithComments Expression+      , matches :: MatchGroup+      }+  | IfExpression+      { predicate :: WithComments Expression+      , thenBranch :: WithComments Expression+      , elseBranch :: WithComments Expression+      }+  | MultiIf [WithComments Guard]+  | LetBinding+      { bindings :: WithComments LocalBinds+      , expression :: WithComments Expression+      }+  | DoBlock+      { qualifiedDo :: QualifiedDo+      , statements :: WithComments [WithComments ExprStatement]+      }+  | ListComprehension (WithComments LC.ListComprehension)+  | ListLiteral [WithComments Expression]+  | RecordConstruction+      { name :: WithComments PrefixName+      , fields :: RecordConstructionFields+      }+  | RecordUpdate RecordUpdateFields+  | FieldProjection+      { expression :: WithComments Expression+      , selector :: WithComments FieldSelector+      }+  | Projection (NonEmpty (WithComments FieldSelector))+  | TypeSignature+      { expression :: WithComments Expression+      , signature :: WithComments Type+      }+  | ArithmeticSequence RangeExpression+  | TypedQuotation (WithComments Expression)+  | UntypedQuotation Bracket+  | Splice Splice+  | ProcExpression+      { pat :: WithComments Pattern+      , cmd :: WithComments Cmd+      }+  | ProcDo+      { pat :: WithComments Pattern+      , block :: CmdDoBlock+      }+  | StaticExpression (WithComments Expression)+  | PragmaticExpression+      { pragma :: WithComments ExpressionPragma+      , expression :: WithComments Expression+      }++instance CommentExtraction Expression where+  nodeComments _ = NodeComments [] [] []++instance Pretty Expression where+  pretty' (Variable name) = pretty name+  pretty' (UnboundVariable name) = pretty name+  pretty' (OverloadedLabel label) = pretty label+  pretty' (ImplicitParameter name) = pretty name+  pretty' (OverloadedLiteral lit) = pretty lit+  pretty' (Literal lit) = pretty lit+  pretty' (Lambda matches) = pretty matches+  pretty' LambdaCase {..} = do+    string+      $ if usesCases+          then "\\cases"+          else "\\case"+    if not $ hasMatches matches+      then string " {}"+      else do+        newline+        indentedBlock $ pretty matches+  pretty' (Application (headExpr :| argList)) = horizontal <-|> vertical+    where+      horizontal = spaced $ pretty <$> headExpr : argList+      vertical = do+        col <- gets psColumn+        indentSpaces <- getIndentSpaces+        pretty headExpr+        col' <- gets psColumn+        let headLength =+              col'+                - col+                - if col == 0+                    then indentSpaces+                    else 0+            hangFirstArg = headLength + 1 <= indentSpaces+        if hangFirstArg+          then space+          else newline+        spaces' <- getIndentSpaces+        indentedWithSpace spaces' $ lined $ fmap pretty argList+  pretty' TypeApplication {..} = do+    pretty expression+    string " @"+    pretty typeArg+  pretty' OperatorApplication {..} = horizontal <-|> vertical+    where+      horizontal = do+        pretty firstOperand+        space+        spaced+          $ concatMap (\(op, r) -> [pretty op, pretty r]) operatorOperandPairs+      vertical = do+        pretty firstOperand+        prettyOpAndRhs $ NonEmpty.toList operatorOperandPairs+        where+          prettyOpAndRhs [] = pure ()+          prettyOpAndRhs [(o, r)]+            | shouldBeInline (getNode r) = space >> spaced [pretty o, pretty r]+          prettyOpAndRhs ((o, r):xs) = do+            newline+            indentedBlock $ (pretty o >> space) |=> pretty r+            prettyOpAndRhs xs+          shouldBeInline DoBlock {} = True+          shouldBeInline Lambda {} = True+          shouldBeInline LambdaCase {} = True+          shouldBeInline _ = False+  pretty' (Negation expr) = string "-" >> pretty expr+  pretty' (Parenthesized expr) = parens $ pretty expr+  pretty' LeftSection {..} = spaced [pretty left, pretty operator]+  pretty' RightSection {..} = (pretty operator >> space) |=> pretty right+  pretty' Tuple {..} = horizontal <-|> vertical+    where+      horizontal = parH $ prettyArg pretty <$> arguments+      vertical =+        parV+          $ prefixedLined ","+          $ prettyArg (\expr -> space |=> pretty expr) <$> arguments+      prettyArg f arg = prettyWith arg (maybe (pure ()) f)+      (parH, parV) =+        if isBoxed+          then (hTuple, parens)+          else (hUnboxedTuple, unboxedParens)+  pretty' Sum {..} = do+    string "(#"+    forM_ [1 .. arity] $ \idx -> do+      if idx == position+        then space >> pretty expression >> space+        else space+      when (idx < arity) $ string "|"+    string "#)"+  pretty' CaseExpression {..} = do+    string "case " |=> do+      pretty scrutinee+      string " of"+    if not $ hasMatches matches+      then string " {}"+      else do+        newline+        indentedBlock $ pretty matches+  pretty' IfExpression {..} = do+    string "if " |=> pretty predicate+    indentedBlock+      $ newlinePrefixed [branch "then " thenBranch, branch "else " elseBranch]+    where+      branch str exprWithComments =+        prettyWith exprWithComments $ \expr ->+          case expr of+            DoBlock {} -> do+              string str+              pretty expr+            _ -> string str |=> pretty expr+  pretty' (MultiIf multiIfClauses) =+    string "if " |=> lined (fmap pretty multiIfClauses)+  pretty' LetBinding {..} =+    lined+      [string "let " |=> pretty bindings, string " in " |=> pretty expression]+  pretty' DoBlock {..} = do+    pretty qualifiedDo+    newline+    indentedBlock $ prettyWith statements (lined . fmap pretty)+  pretty' (ListComprehension listComprehension) = pretty listComprehension+  pretty' (ListLiteral listItems) = horizontal <-|> vertical+    where+      horizontal = brackets $ hCommaSep $ fmap pretty listItems+      vertical = vList $ fmap pretty listItems+  pretty' RecordConstruction {..} = horizontal <-|> vertical+    where+      horizontal = spaced [pretty name, pretty fields]+      vertical = do+        pretty name+        (space >> pretty fields) <-|> (newline >> indentedBlock (pretty fields))+  pretty' (RecordUpdate fields) = pretty fields+  pretty' FieldProjection {..} = do+    pretty expression+    dot+    pretty selector+  pretty' (Projection projectionFields) =+    parens $ forM_ projectionFields prettyProjectionField+    where+      prettyProjectionField projectionField = do+        string "."+        pretty projectionField+  pretty' TypeSignature {..} =+    spaced [pretty expression, string "::", pretty signature]+  pretty' (ArithmeticSequence rangeExpression) = pretty rangeExpression+  pretty' (TypedQuotation expr) = typedBrackets $ pretty expr+  pretty' (UntypedQuotation bracket) = pretty bracket+  pretty' ProcExpression {..} = hor <-|> ver+    where+      hor = spaced [string "proc", pretty pat, string "->", pretty cmd]+      ver = do+        spaced [string "proc", pretty pat, string "->"]+        newline+        indentedBlock $ pretty cmd+  pretty' ProcDo {..} = do+    spaced [string "proc", pretty pat, string "-> do"]+    newline+    indentedBlock $ pretty block+  pretty' (StaticExpression expr) = spaced [string "static", pretty expr]+  pretty' PragmaticExpression {..} = spaced [pretty pragma, pretty expression]+  pretty' (Splice splice') = pretty splice'++mkExpression :: GHC.HsExpr GHC.GhcPs -> Expression+mkExpression (GHC.HsVar _ name) =+  Variable $ mkPrefixName <$> fromGenLocated name+#if MIN_VERSION_ghc_lib_parser(9, 6, 0)+mkExpression (GHC.HsUnboundVar _ name) = UnboundVariable $ mkPrefixName name+#else+mkExpression (GHC.HsUnboundVar _ name) =+  UnboundVariable $ mkPrefixName $ NameReader.mkRdrUnqual name+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkExpression (GHC.HsOverLabel _ label) =+  OverloadedLabel $ mkOverloadedLabel label+#elif MIN_VERSION_ghc_lib_parser(9, 6, 1)+mkExpression (GHC.HsOverLabel _ _ label) =+  OverloadedLabel $ mkOverloadedLabel label+#else+mkExpression (GHC.HsOverLabel _ label) =+  OverloadedLabel $ mkOverloadedLabel label+#endif+mkExpression (GHC.HsIPVar _ name) =+  ImplicitParameter $ mkImplicitParameterName name+mkExpression (GHC.HsOverLit _ lit) = OverloadedLiteral lit+mkExpression (GHC.HsLit _ lit) = Literal lit+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpression (GHC.HsEmbTy _ _) =+  error "`ghc-lib-parser` never generates this AST node."+#endif+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpression (GHC.HsLam _ GHC.LamSingle matches) =+  Lambda $ mkExprMatchGroup matches+mkExpression (GHC.HsLam _ GHC.LamCases matches) =+  LambdaCase {usesCases = True, matches = mkExprMatchGroup matches}+mkExpression (GHC.HsLam _ GHC.LamCase matches) =+  LambdaCase {usesCases = False, matches = mkExprMatchGroup matches}+#else+mkExpression (GHC.HsLam _ matches) = Lambda $ mkExprMatchGroup matches+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkExpression (GHC.HsLamCase _ GHC.LamCases matches) =+  LambdaCase {usesCases = True, matches = mkExprMatchGroup matches}+mkExpression (GHC.HsLamCase _ GHC.LamCase matches) =+  LambdaCase {usesCases = False, matches = mkExprMatchGroup matches}+#else+mkExpression (GHC.HsLamCase _ _ matches) =+  LambdaCase {usesCases = False, matches = mkExprMatchGroup matches}+#endif+#endif+mkExpression (GHC.HsApp _ function argument) =+  case getNode f of+    Application (h :| as) -> Application $ h :| push as+    _ -> Application $ f :| [a]+  where+    f = mkExpression <$> fromGenLocated function+    a = mkExpression <$> fromGenLocated argument+    push [] = [a]+    push (x:xs) = go x xs+      where+        go final [] = [addComments (getComments f) final, a]+        go current (y:ys) = current : go y ys+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpression (GHC.HsAppType _ fun typeArg) =+  TypeApplication+    { expression = mkExpression <$> fromGenLocated fun+    , typeArg = mkTypeFromLHsWcType typeArg+    }+#else+mkExpression (GHC.HsAppType _ fun _ typeArg) =+  TypeApplication+    { expression = mkExpression <$> fromGenLocated fun+    , typeArg = mkTypeFromLHsWcType typeArg+    }+#endif+mkExpression (GHC.OpApp _ lhs op rhs) = OperatorApplication {..}+  where+    (firstOperand, operatorOperandPairs) =+      case fixityDir operatorFixity of+        GHC.InfixL -> build leftChain+        GHC.InfixR -> build rightChain+        GHC.InfixN+          | GHC.L _ (GHC.OpApp _ _ o _) <- lhs+          , isSameAssoc o -> build leftChain+          | otherwise -> build rightChain+    operatorFixity = findFixity op+    build (x:xs) = (mkExpression <$> fromGenLocated x, f xs)+      where+        f [l, o] =+          NonEmpty.singleton+            ( InfixExpr . mkExpression <$> fromGenLocated l+            , mkExpression <$> fromGenLocated o)+        f (l:o:rs) =+          ( InfixExpr . mkExpression <$> fromGenLocated l+          , mkExpression <$> fromGenLocated o)+            <| f rs+        f _ = error "Malformed operator chain"+    build _ = error "Empty operator chain"+    findFixity o =+      fromMaybe GHC.defaultFixity $ lookup (GHC.varToStr o) fixities+    leftChain = reverse $ rhs : op : collect lhs+      where+        collect :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]+        collect (GHC.L _ (GHC.OpApp _ l o r))+          | isSameAssoc o = r : o : collect l+        collect x = [x]+    rightChain = lhs : op : collect rhs+      where+        collect :: GHC.LHsExpr GHC.GhcPs -> [GHC.LHsExpr GHC.GhcPs]+        collect (GHC.L _ (GHC.OpApp _ l o r))+          | isSameAssoc o = l : o : collect r+        collect x = [x]+    isSameAssoc (findFixity -> fixity) =+      fixityLevel fixity == level && fixityDir fixity == dir+    level = fixityLevel operatorFixity+    dir = fixityDir operatorFixity+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+    fixityLevel (GHC.Fixity lvl _) = lvl+    +    fixityDir (GHC.Fixity _ direction) = direction+#else+    fixityLevel (GHC.Fixity _ lvl _) = lvl+    +    fixityDir (GHC.Fixity _ _ direction) = direction+#endif+mkExpression (GHC.NegApp _ expr _) =+  Negation $ mkExpression <$> fromGenLocated expr+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpression (GHC.HsPar _ expr) =+  Parenthesized $ mkExpression <$> fromGenLocated expr+#elif MIN_VERSION_ghc_lib_parser(9, 8, 1)+mkExpression (GHC.HsPar _ _ expr _) =+  Parenthesized $ mkExpression <$> fromGenLocated expr+#else+mkExpression (GHC.HsPar _ expr) =+  Parenthesized $ mkExpression <$> fromGenLocated expr+#endif+mkExpression (GHC.SectionL _ l r) =+  LeftSection+    { left = mkExpression <$> fromGenLocated l+    , operator = InfixExpr . mkExpression <$> fromGenLocated r+    }+mkExpression (GHC.SectionR _ l r) =+  RightSection+    { operator = InfixExpr . mkExpression <$> fromGenLocated l+    , right = mkExpression <$> fromGenLocated r+    }+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpression (GHC.ExplicitTuple _ tupleArgs boxity) =+  Tuple+    { arguments = mkTupleArgument <$> tupleArgs+    , isBoxed =+        case boxity of+          GHC.Boxed -> True+          GHC.Unboxed -> False+    }+  where+    mkTupleArgument (GHC.Present _ expr) =+      mkWithComments $ Just $ mkExpression <$> fromGenLocated expr+    mkTupleArgument (GHC.Missing ann) = fromEpAnn ann Nothing+#else+mkExpression (GHC.ExplicitTuple _ tupleArgs boxity) =+  Tuple+    { arguments = mkTupleArgument <$> tupleArgs+    , isBoxed =+        case boxity of+          GHC.Boxed -> True+          GHC.Unboxed -> False+    }+  where+    mkTupleArgument (GHC.Present ann expr) =+      fromEpAnn ann $ Just $ mkExpression <$> fromGenLocated expr+    mkTupleArgument (GHC.Missing ann) = fromEpAnn ann Nothing+#endif+mkExpression (GHC.ExplicitSum _ position arity expr) =+  Sum {expression = mkExpression <$> fromGenLocated expr, ..}+mkExpression (GHC.HsCase _ scrut matches) =+  CaseExpression+    { scrutinee = mkExpression <$> fromGenLocated scrut+    , matches = mkExprMatchGroup matches+    }+mkExpression (GHC.HsIf _ predicateExpr thenExpr elseExpr) =+  IfExpression+    { predicate = mkExpression <$> fromGenLocated predicateExpr+    , thenBranch = mkExpression <$> fromGenLocated thenExpr+    , elseBranch = mkExpression <$> fromGenLocated elseExpr+    }+mkExpression (GHC.HsMultiIf _ clauses) =+  MultiIf (fmap (fmap mkMultiWayIfExprGuard . fromGenLocated) clauses)+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpression (GHC.HsLet _ localBinds body) =+  case mkLocalBinds localBinds of+    Nothing ->+      error+        "`ghc-lib-parser` never generates a `HsLet` node with empty bindings."+    Just bindings ->+      LetBinding {expression = mkExpression <$> fromGenLocated body, ..}+#elif MIN_VERSION_ghc_lib_parser(9, 8, 1)+mkExpression (GHC.HsLet _ _ localBinds _ body) =+  case mkLocalBinds localBinds of+    Nothing ->+      error+        "`ghc-lib-parser` never generates a `HsLet` node with empty bindings."+    Just bindings ->+      LetBinding {expression = mkExpression <$> fromGenLocated body, ..}+#else+mkExpression (GHC.HsLet _ localBinds body) =+  case mkLocalBinds localBinds of+    Nothing ->+      error+        "`ghc-lib-parser` never generates a `HsLet` node with empty bindings."+    Just bindings ->+      LetBinding {expression = mkExpression <$> fromGenLocated body, ..}+#endif+mkExpression (GHC.HsDo _ GHC.ListComp statements) =+  ListComprehension+    $ LC.mkListComprehension . fmap (fmap mkExprStatement . fromGenLocated)+        <$> fromGenLocated statements+mkExpression (GHC.HsDo _ GHC.MonadComp statements) =+  ListComprehension+    $ LC.mkListComprehension . fmap (fmap mkExprStatement . fromGenLocated)+        <$> fromGenLocated statements+mkExpression (GHC.HsDo _ (GHC.DoExpr moduleName) statements) =+  DoBlock+    { qualifiedDo = QualifiedDo (fmap mkModuleName moduleName) Do+    , statements =+        fmap (fmap mkExprStatement . fromGenLocated)+          <$> fromGenLocated statements+    }+mkExpression (GHC.HsDo _ (GHC.MDoExpr moduleName) statements) =+  DoBlock+    { qualifiedDo = QualifiedDo (fmap mkModuleName moduleName) Mdo+    , statements =+        fmap (fmap mkExprStatement . fromGenLocated)+          <$> fromGenLocated statements+    }+mkExpression (GHC.HsDo _ GHC.GhciStmtCtxt {} _) =+  error "`ghc-lib-parser` never generates this AST node."+mkExpression (GHC.ExplicitList _ items) =+  ListLiteral (fmap (fmap mkExpression . fromGenLocated) items)+mkExpression (GHC.RecordCon { GHC.rcon_con = conName+                            , GHC.rcon_flds = recordFields+                            }) =+  RecordConstruction+    { name = mkPrefixName <$> fromGenLocated conName+    , fields = mkRecordConstructionFields recordFields+    }+mkExpression (GHC.RecordUpd { GHC.rupd_expr = recordExpr+                            , GHC.rupd_flds = updates+                            }) =+  RecordUpdate+    $ mkRecordUpdateFields (mkExpression <$> fromGenLocated recordExpr) updates+mkExpression (GHC.HsGetField {GHC.gf_expr = fieldExpr, GHC.gf_field = selector}) =+  FieldProjection+    { expression = mkExpression <$> fromGenLocated fieldExpr+    , selector = fmap mkFieldSelector (fromGenLocated selector)+    }+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkExpression (GHC.HsProjection {GHC.proj_flds = fields}) =+  Projection $ fmap (mkWithComments . mkFieldSelector) fields+#else+mkExpression (GHC.HsProjection {GHC.proj_flds = fields}) =+  Projection $ fmap (fmap mkFieldSelector . fromGenLocated) fields+#endif+mkExpression (GHC.ExprWithTySig _ signatureExpr ty) =+  TypeSignature+    { expression = mkExpression <$> fromGenLocated signatureExpr+    , signature =+        flattenComments+          $ mkTypeFromHsSigType <$> fromGenLocated (GHC.hswc_body ty)+    }+mkExpression (GHC.ArithSeq _ _ info) =+  ArithmeticSequence $ mkRangeExpression info+mkExpression (GHC.HsTypedBracket _ typedExpr) =+  TypedQuotation $ mkExpression <$> fromGenLocated typedExpr+mkExpression (GHC.HsUntypedBracket _ content) =+  UntypedQuotation $ mkBracket content+#if MIN_VERSION_ghc_lib_parser(9, 12, 2)+mkExpression GHC.HsForAll {} =+  error "`ghc-lib-parser` never generates this AST node."+mkExpression GHC.HsQual {} =+  error "`ghc-lib-parser` never generates this AST node."+mkExpression GHC.HsFunArr {} =+  error "`ghc-lib-parser` never generates this AST node."+#endif+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+mkExpression (GHC.HsTypedSplice _ expr) = Splice $ mkTypedSplice expr+mkExpression (GHC.HsUntypedSplice _ splice) = Splice $ mkSplice splice+#else+mkExpression (GHC.HsSpliceE _ splice) = Splice $ mkSplice splice+mkExpression (GHC.HsTypedSplice _ expr) = Splice $ mkSplice expr+mkExpression (GHC.HsUntypedSplice _ splice) = Splice $ mkSplice splice+#endif+mkExpression (GHC.HsProc _ pat command) =+  case getFirst $ foldMap (First . mkCmdDoBlock) cmd of+    Just block -> ProcDo {pat = mkPattern <$> fromGenLocated pat, block}+    Nothing -> ProcExpression {pat = mkPattern <$> fromGenLocated pat, cmd}+  where+    cmd = flattenComments $ mkCmdFromHsCmdTop <$> fromGenLocated command+mkExpression (GHC.HsStatic _ staticExpr) =+  StaticExpression $ mkExpression <$> fromGenLocated staticExpr+mkExpression (GHC.HsPragE _ pragma pragmaticExpr) =+  PragmaticExpression+    { expression = mkExpression <$> fromGenLocated pragmaticExpr+    , pragma = mkExpressionPragma pragma+    }+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkExpression (GHC.HsRecSel _ _) =+  error "`ghc-lib-parser` never generates this AST node."+#endif+newtype InfixExpr =+  InfixExpr Expression++instance CommentExtraction InfixExpr where+  nodeComments _ = NodeComments [] [] []++instance Pretty InfixExpr where+  pretty' (InfixExpr (Variable name)) = pretty $ mkPrefixAsInfix <$> name+  pretty' (InfixExpr (UnboundVariable name)) = pretty $ mkPrefixAsInfix name+  pretty' (InfixExpr (Parenthesized inner)) = pretty $ fmap InfixExpr inner+  pretty' (InfixExpr x) = pretty x++data GuardExpression+  = GuardWithDo Expression+  | GuardWithAppAndDo Expression+  | GuardExpression Expression++instance CommentExtraction GuardExpression where+  nodeComments (GuardWithDo expr) = nodeComments expr+  nodeComments (GuardWithAppAndDo expr) = nodeComments expr+  nodeComments (GuardExpression expr) = nodeComments expr++instance Pretty GuardExpression where+  pretty' (GuardWithDo expr) = space >> pretty expr+  pretty' (GuardWithAppAndDo expr) = space >> pretty expr+  pretty' (GuardExpression expr) = horizontal <-|> vertical+    where+      horizontal = space >> pretty expr+      vertical = newline >> indentedBlock (pretty expr)++mkGuardExpression :: Expression -> GuardExpression+mkGuardExpression expr@DoBlock {} = GuardWithDo expr+mkGuardExpression expr+  | OperatorApplication {..} <- expr+  , DoBlock {} <- getNode firstOperand = GuardWithAppAndDo expr+  | otherwise = GuardExpression expr
+ src/HIndent/Ast/Expression.hs-boot view
@@ -0,0 +1,25 @@+module HIndent.Ast.Expression+  ( Expression+  , GuardExpression+  , mkExpression+  , mkGuardExpression+  ) where++import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty (Pretty)+import HIndent.Pretty.NodeComments++data Expression++data GuardExpression++instance Pretty Expression++instance Pretty GuardExpression++instance CommentExtraction Expression++instance CommentExtraction GuardExpression++mkExpression :: GHC.HsExpr GHC.GhcPs -> Expression+mkGuardExpression :: Expression -> GuardExpression
+ src/HIndent/Ast/Expression/Bracket.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Expression.Bracket+  ( Bracket+  , mkBracket+  ) where++import HIndent.Ast.Declaration+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Pattern+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Bracket+  = TypedExpression (WithComments Expression)+  | UntypedExpression (WithComments Expression)+  | Pattern (WithComments Pattern)+  | Declaration [WithComments Declaration]+  | Type (WithComments Type)+  | Variable Bool (WithComments PrefixName)++instance CommentExtraction Bracket where+  nodeComments (TypedExpression expr) = nodeComments expr+  nodeComments (UntypedExpression expr) = nodeComments expr+  nodeComments Pattern {} = NodeComments [] [] []+  nodeComments Declaration {} = NodeComments [] [] []+  nodeComments Type {} = NodeComments [] [] []+  nodeComments Variable {} = NodeComments [] [] []++instance Pretty Bracket where+  pretty' (TypedExpression x) = typedBrackets $ pretty x+  pretty' (UntypedExpression x) = brackets $ wrapWithBars $ pretty x+  pretty' (Pattern x) = brackets $ string "p" >> wrapWithBars (pretty x)+  pretty' (Declaration decls) =+    brackets $ string "d| " |=> lined (fmap pretty decls) >> string " |"+  pretty' (Type x) = brackets $ string "t" >> wrapWithBars (pretty x)+  pretty' (Variable True var) = string "'" >> pretty var+  pretty' (Variable False var) = string "''" >> pretty var+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkBracket :: GHC.HsQuote GHC.GhcPs -> Bracket+#else+mkBracket :: GHC.HsBracket GHC.GhcPs -> Bracket+#endif+mkBracket (GHC.ExpBr _ x) =+  UntypedExpression $ mkExpression <$> fromGenLocated x+mkBracket (GHC.PatBr _ x) = Pattern $ mkPattern <$> fromGenLocated x+mkBracket (GHC.DecBrL _ x) =+  Declaration $ fmap (fmap mkDeclaration . fromGenLocated) x+mkBracket (GHC.TypBr _ x) = Type $ mkType <$> fromGenLocated x+mkBracket (GHC.VarBr _ b x) = Variable b $ fromGenLocated $ fmap mkPrefixName x+mkBracket (GHC.DecBrG {}) = error "This AST node should never appear."+#if !MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkBracket (GHC.TExpBr _ x) = TypedExpression $ mkExpression <$> fromGenLocated x+#endif
+ src/HIndent/Ast/Expression/FieldSelector.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Expression.FieldSelector+  ( FieldSelector+  , mkFieldSelector+  ) where++import qualified GHC.Data.FastString as GHC+import qualified GHC.Hs as GHC+import HIndent.Ast.Name.Prefix (PrefixName, fromString)+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.NodeComments (CommentExtraction(..))+import qualified Language.Haskell.Syntax.Basic as GHC++newtype FieldSelector = FieldSelector+  { name :: WithComments PrefixName+  }++instance CommentExtraction FieldSelector where+  nodeComments FieldSelector {} = NodeComments [] [] []++instance Pretty FieldSelector where+  pretty' FieldSelector {..} = pretty name++mkFieldSelector :: GHC.DotFieldOcc GHC.GhcPs -> FieldSelector+mkFieldSelector GHC.DotFieldOcc {..} =+  FieldSelector+    { name =+        fmap+          (fromString . GHC.unpackFS . GHC.field_label)+          (fromGenLocated dfoLabel)+    }
+ src/HIndent/Ast/Expression/ListComprehension.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Expression.ListComprehension+  ( ListComprehension+  , mkListComprehension+  ) where++import Control.Monad (forM_)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import HIndent.Ast.Statement (ExprStatement)+import HIndent.Ast.WithComments (WithComments)+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments (CommentExtraction(..), emptyNodeComments)++data ListComprehension = ListComprehension+  { leading :: WithComments ExprStatement+  , clauses :: NonEmpty (WithComments ExprStatement)+  }++instance CommentExtraction ListComprehension where+  nodeComments _ = emptyNodeComments++instance Pretty ListComprehension where+  pretty' ListComprehension {..} = horizontal <-|> vertical+    where+      horizontal =+        brackets+          $ spaced+              [ pretty leading+              , string "|"+              , hCommaSep $ pretty <$> NonEmpty.toList clauses+              ]+      vertical = do+        string "[ "+        pretty leading+        newline+        forM_ (clausePairs clauses) $ \(prefix, clause) -> do+          string prefix |=> pretty clause+          newline+        string "]"+      clausePairs (q :| qs) = ("| ", q) : fmap (", ", ) qs++mkListComprehension :: [WithComments ExprStatement] -> ListComprehension+mkListComprehension [] =+  error "List comprehension requires at least two statements."+mkListComprehension [_] =+  error "List comprehension requires at least two statements."+mkListComprehension (leading:second:rest) =+  ListComprehension {clauses = second :| rest, ..}
+ src/HIndent/Ast/Expression/OverloadedLabel.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Expression.OverloadedLabel+  ( OverloadedLabel+  , mkOverloadedLabel+  ) where++import qualified GHC.Data.FastString as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype OverloadedLabel =+  OverloadedLabel String++instance CommentExtraction OverloadedLabel where+  nodeComments OverloadedLabel {} = emptyNodeComments++instance Pretty OverloadedLabel where+  pretty' (OverloadedLabel s) = string "#" >> string s++mkOverloadedLabel :: GHC.FastString -> OverloadedLabel+mkOverloadedLabel fs = OverloadedLabel $ GHC.unpackFS fs
+ src/HIndent/Ast/Expression/Pragmatic.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Expression.Pragmatic+  ( ExpressionPragma+  , mkExpressionPragma+  ) where++import qualified GHC.Hs as GHC+import qualified GHC.Types.SourceText as GHC+import HIndent.Ast.NodeComments (NodeComments(..))+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+import HIndent.Ast.WithComments (WithComments, addComments, mkWithComments)+#else+import HIndent.Ast.WithComments (WithComments, fromEpAnn)+#endif+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators (spaced, string)+import HIndent.Pretty.NodeComments (CommentExtraction(..))++newtype ExpressionPragma = SccPragma+  { label :: GHC.StringLiteral+  }++instance CommentExtraction ExpressionPragma where+  nodeComments _ = NodeComments [] [] []++instance Pretty ExpressionPragma where+  pretty' SccPragma {..} = spaced [string "{-# SCC", pretty label, string "#-}"]++mkExpressionPragma :: GHC.HsPragE GHC.GhcPs -> WithComments ExpressionPragma+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExpressionPragma (GHC.HsPragSCC (ann, _) literal) =+  addComments (nodeComments ann) $ mkWithComments SccPragma {label = literal}+#elif MIN_VERSION_ghc_lib_parser(9, 8, 1)+mkExpressionPragma (GHC.HsPragSCC (ann, _) literal) =+  fromEpAnn ann SccPragma {label = literal}+#else+mkExpressionPragma (GHC.HsPragSCC ann _ literal) =+  fromEpAnn ann SccPragma {label = literal}+#endif
+ src/HIndent/Ast/Expression/RangeExpression.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Expression.RangeExpression+  ( RangeExpression(..)+  , mkRangeExpression+  ) where++import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data RangeExpression+  = From (WithComments Expression)+  | FromThen+      { from :: WithComments Expression+      , next :: WithComments Expression+      }+  | FromTo+      { from :: WithComments Expression+      , to :: WithComments Expression+      }+  | FromThenTo+      { from :: WithComments Expression+      , next :: WithComments Expression+      , to :: WithComments Expression+      }++instance CommentExtraction RangeExpression where+  nodeComments From {} = emptyNodeComments+  nodeComments FromThen {} = emptyNodeComments+  nodeComments FromTo {} = emptyNodeComments+  nodeComments FromThenTo {} = emptyNodeComments++instance Pretty RangeExpression where+  pretty' (From f) = brackets $ spaced [pretty f, string ".."]+  pretty' FromThen {..} =+    brackets $ spaced [pretty from >> comma >> pretty next, string ".."]+  pretty' FromTo {..} = brackets $ spaced [pretty from, string "..", pretty to]+  pretty' FromThenTo {..} =+    brackets+      $ spaced [pretty from >> comma >> pretty next, string "..", pretty to]++mkRangeExpression :: GHC.ArithSeqInfo GHC.GhcPs -> RangeExpression+mkRangeExpression (GHC.From f) = From $ mkExpression <$> fromGenLocated f+mkRangeExpression (GHC.FromThen f n) =+  FromThen+    { from = mkExpression <$> fromGenLocated f+    , next = mkExpression <$> fromGenLocated n+    }+mkRangeExpression (GHC.FromTo f t) =+  FromTo+    { from = mkExpression <$> fromGenLocated f+    , to = mkExpression <$> fromGenLocated t+    }+mkRangeExpression (GHC.FromThenTo f n t) =+  FromThenTo+    { from = mkExpression <$> fromGenLocated f+    , next = mkExpression <$> fromGenLocated n+    , to = mkExpression <$> fromGenLocated t+    }
+ src/HIndent/Ast/Expression/RecordConstructionField.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Expression.RecordConstructionField+  ( RecordConstructionFields+  , mkRecordConstructionFields+  ) where++import Data.Maybe (isJust)+import qualified GHC.Hs as GHC+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.Record.Field (ExprField, mkExprField)+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data RecordConstructionFields = RecordConstructionFields+  { fields :: [WithComments ExprField]+  , dotdot :: Bool+  }++instance CommentExtraction RecordConstructionFields where+  nodeComments _ = NodeComments [] [] []++instance Pretty RecordConstructionFields where+  pretty' RecordConstructionFields {..} =+    hvFields (fmap pretty fields ++ [string ".." | dotdot])++mkRecordConstructionFields ::+     GHC.HsRecordBinds GHC.GhcPs -> RecordConstructionFields+mkRecordConstructionFields GHC.HsRecFields {..} =+  RecordConstructionFields+    { fields = fmap (fmap mkExprField . fromGenLocated) rec_flds+    , dotdot = isJust rec_dotdot+    }
+ src/HIndent/Ast/Expression/RecordUpdateField.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Expression.RecordUpdateField+  ( RecordUpdateFields+  , mkRecordUpdateFields+  ) where++import qualified GHC.Hs as GHC+import HIndent.Applicative (whenJust)+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.WithComments+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import HIndent.Printer (Printer)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+import HIndent.Ast.Name.RecordField+  ( FieldName+  , mkFieldNameFromFieldLabelStrings+  , mkFieldNameFromFieldOcc+  )+#elif MIN_VERSION_ghc_lib_parser(9, 6, 1)+import HIndent.Ast.Name.RecordField+  ( FieldName+  , mkFieldNameFromAmbiguousFieldOcc+  , mkFieldNameFromFieldLabelStrings+  )+#else+import HIndent.Ast.Name.RecordField+  ( FieldName+  , mkFieldNameFromFieldLabelStrings+  , mkFieldNameFromFieldOcc+  )+#endif+data RecordUpdateFields = RecordUpdateFields+  { expression :: WithComments Expression+  , fields :: [WithComments Field]+  }++instance CommentExtraction RecordUpdateFields where+  nodeComments _ = NodeComments [] [] []++instance Pretty RecordUpdateFields where+  pretty' RecordUpdateFields {..} = horizontal <-|> vertical+    where+      horizontal =+        spaced+          [ pretty expression+          , hFields $ fmap (`prettyWith` prettyFieldHorizontal) fields+          ]+      vertical = do+        pretty expression+        newline+        indentedBlock+          $ hFields (fmap (`prettyWith` prettyFieldHorizontal) fields)+              <-|> vFields (fmap (`prettyWith` prettyFieldVertical) fields)++mkRecordUpdateFields ::+     WithComments Expression+  -> GHC.LHsRecUpdFields GHC.GhcPs+  -> RecordUpdateFields+mkRecordUpdateFields expression updates =+  RecordUpdateFields {fields = collectFields updates, ..}++data Field = Field+  { fieldName :: WithComments FieldName+  , value :: Maybe (WithComments Expression)+  }++instance CommentExtraction Field where+  nodeComments _ = NodeComments [] [] []++prettyFieldHorizontal :: Field -> Printer ()+prettyFieldHorizontal Field {..} = do+  pretty fieldName+  whenJust value $ \val -> do+    string " = "+    pretty val++prettyFieldVertical :: Field -> Printer ()+prettyFieldVertical Field {..} = do+  pretty fieldName+  whenJust value $ \val -> do+    string " ="+    (space >> pretty val) <-|> (newline >> indentedBlock (pretty val))++collectFieldsWith ::+     CommentExtraction (GHC.Anno label)+  => (label -> FieldName)+  -> [GHC.LocatedA+        (GHC.HsFieldBind (GHC.XRec GHC.GhcPs label) (GHC.LHsExpr GHC.GhcPs))]+  -> [WithComments Field]+collectFieldsWith mkLabel =+  fmap (fmap (mkField (fmap mkLabel . fromGenLocated)) . fromGenLocated)++collectFields :: GHC.LHsRecUpdFields GHC.GhcPs -> [WithComments Field]+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+collectFields GHC.RegularRecUpdFields {..} =+  collectFieldsWith mkFieldNameFromFieldOcc recUpdFields+collectFields GHC.OverloadedRecUpdFields {..} =+  collectFieldsWith mkFieldNameFromFieldLabelStrings olRecUpdFields+#elif MIN_VERSION_ghc_lib_parser(9, 6, 1)+collectFields GHC.RegularRecUpdFields {..} =+  collectFieldsWith mkFieldNameFromAmbiguousFieldOcc recUpdFields+collectFields GHC.OverloadedRecUpdFields {..} =+  collectFieldsWith mkFieldNameFromFieldLabelStrings olRecUpdFields+#else+collectFields = collectFieldsWith mkFieldNameFromFieldOcc . either id id+#endif+mkField ::+     (GHC.XRec GHC.GhcPs label -> WithComments FieldName)+  -> GHC.HsFieldBind (GHC.XRec GHC.GhcPs label) (GHC.LHsExpr GHC.GhcPs)+  -> Field+mkField wrapLabel GHC.HsFieldBind {..} =+  Field+    { fieldName = wrapLabel hfbLHS+    , value =+        if hfbPun+          then Nothing+          else Just $ mkExpression <$> fromGenLocated hfbRHS+    }
+ src/HIndent/Ast/Expression/Splice.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Expression.Splice+  ( Splice+  , mkSplice+  , mkTypedSplice+  ) where++import qualified GHC.Data.FastString as GHC+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+import qualified GHC.Types.SrcLoc as GHC+#endif+data Splice+  = Typed (WithComments Expression)+  | UntypedDollar (WithComments Expression)+  | UntypedBare (WithComments Expression)+  | QuasiQuote PrefixName GHC.FastString++instance CommentExtraction Splice where+  nodeComments (Typed expr) = nodeComments expr+  nodeComments (UntypedDollar expr) = nodeComments expr+  nodeComments (UntypedBare expr) = nodeComments expr+  nodeComments QuasiQuote {} = NodeComments [] [] []++instance Pretty Splice where+  pretty' (Typed x) = string "$$" >> pretty x+  pretty' (UntypedDollar x) = string "$" >> pretty x+  pretty' (UntypedBare x) = pretty x+  pretty' (QuasiQuote l r) =+    brackets $ do+      pretty l+      wrapWithBars+        $ indentedWithFixedLevel 0+        $ sequence_+        $ printers [] ""+        $ GHC.unpackFS r+    where+      printers ps s [] = reverse (string (reverse s) : ps)+      printers ps s ('\n':xs) =+        printers (newline : string (reverse s) : ps) "" xs+      printers ps s (x:xs) = printers ps (x : s) xs+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+mkSplice :: GHC.HsUntypedSplice GHC.GhcPs -> Splice+mkSplice (GHC.HsUntypedSpliceExpr anns x)+  | hasDollarToken anns = UntypedDollar $ mkExpression <$> fromGenLocated x+  | otherwise = UntypedBare $ mkExpression <$> fromGenLocated x+mkSplice (GHC.HsQuasiQuote _ l (GHC.L _ r)) = QuasiQuote (mkPrefixName l) r+#else+mkSplice :: GHC.HsSplice GHC.GhcPs -> Splice+mkSplice (GHC.HsTypedSplice _ _ _ body) =+  Typed $ mkExpression <$> fromGenLocated body+mkSplice (GHC.HsUntypedSplice _ GHC.DollarSplice _ body) =+  UntypedDollar $ mkExpression <$> fromGenLocated body+mkSplice (GHC.HsUntypedSplice _ GHC.BareSplice _ body) =+  UntypedBare $ mkExpression <$> fromGenLocated body+mkSplice (GHC.HsQuasiQuote _ _ l _ r) = QuasiQuote (mkPrefixName l) r+mkSplice GHC.HsSpliced {} = error "This AST node should never appear."+#endif++#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+hasDollarToken :: GHC.XUntypedSpliceExpr GHC.GhcPs -> Bool+hasDollarToken (GHC.EpTok _) = True+hasDollarToken GHC.NoEpTok = False+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+hasDollarToken :: GHC.XUntypedSpliceExpr GHC.GhcPs -> Bool+hasDollarToken anns = any isDollarAnn anns+  where+    isDollarAnn (GHC.AddEpAnn GHC.AnnDollar _) = True+    isDollarAnn _ = False+#else+hasDollarToken :: GHC.XUntypedSpliceExpr GHC.GhcPs -> Bool+hasDollarToken (GHC.EpAnn _ anns _) = any isDollarAnn anns+  where+    isDollarAnn (GHC.AddEpAnn GHC.AnnDollar _) = True+    isDollarAnn _ = False+hasDollarToken GHC.EpAnnNotUsed = False+#endif+mkTypedSplice :: GHC.LHsExpr GHC.GhcPs -> Splice+mkTypedSplice = Typed . fmap mkExpression . fromGenLocated
+ src/HIndent/Ast/FileHeaderPragma.hs view
@@ -0,0 +1,43 @@+module HIndent.Ast.FileHeaderPragma+  ( FileHeaderPragma+  , mkFileHeaderPragma+  ) where++import Data.Bifunctor+import Data.Char+import Data.List (intercalate)+import Data.List.Split+import qualified GHC.Hs as GHC+import HIndent.Ast.NodeComments+import HIndent.Pragma+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype FileHeaderPragma =+  FileHeaderPragma String++instance CommentExtraction FileHeaderPragma where+  nodeComments _ = NodeComments [] [] []++instance Pretty FileHeaderPragma where+  pretty' (FileHeaderPragma x) = string x++mkFileHeaderPragma :: GHC.EpaCommentTok -> Maybe FileHeaderPragma+mkFileHeaderPragma =+  fmap (FileHeaderPragma . uncurry constructPragma) . extractPragma++-- | This function returns a 'Just' value with the pragma+-- extracted from the passed 'EpaCommentTok' if it has one. Otherwise, it+-- returns a 'Nothing'.+extractPragma :: GHC.EpaCommentTok -> Maybe (String, [String])+extractPragma (GHC.EpaBlockComment c) =+  second (fmap strip . splitOn ",") <$> extractPragmaNameAndElement c+  where+    strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace+extractPragma _ = Nothing++-- | Construct a pragma.+constructPragma :: String -> [String] -> String+constructPragma optionOrPragma xs =+  "{-# " ++ fmap toUpper optionOrPragma ++ " " ++ intercalate ", " xs ++ " #-}"
+ src/HIndent/Ast/FileHeaderPragma/Collection.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.FileHeaderPragma.Collection+  ( FileHeaderPragmaCollection+  , mkFileHeaderPragmaCollection+  , hasPragmas+  ) where++import Data.Maybe+import Generics.SYB+import HIndent.Ast.FileHeaderPragma+import HIndent.Ast.NodeComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype FileHeaderPragmaCollection =+  FileHeaderPragmaCollection [FileHeaderPragma]++instance CommentExtraction FileHeaderPragmaCollection where+  nodeComments _ = NodeComments [] [] []++instance Pretty FileHeaderPragmaCollection where+  pretty' (FileHeaderPragmaCollection xs) = lined $ fmap pretty xs++mkFileHeaderPragmaCollection :: GHC.HsModule' -> FileHeaderPragmaCollection+mkFileHeaderPragmaCollection =+  FileHeaderPragmaCollection+    . mapMaybe mkFileHeaderPragma+    . collectBlockComments++hasPragmas :: FileHeaderPragmaCollection -> Bool+hasPragmas (FileHeaderPragmaCollection xs) = not $ null xs++collectBlockComments :: GHC.HsModule' -> [GHC.EpaCommentTok]+collectBlockComments = listify isBlockComment . GHC.getModuleAnn++-- | Checks if the given comment is a block one.+isBlockComment :: GHC.EpaCommentTok -> Bool+isBlockComment GHC.EpaBlockComment {} = True+isBlockComment _ = False
+ src/HIndent/Ast/Guard.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++module HIndent.Ast.Guard+  ( Guard+  , mkExprGuard+  , mkCaseExprGuard+  , mkLambdaExprGuard+  , mkMultiWayIfExprGuard+  , mkCaseCmdGuard+  , mkLambdaCmdGuard+  ) where++import Control.Monad (unless)+import HIndent.Ast.Cmd (Cmd, mkCmd)+import {-# SOURCE #-} HIndent.Ast.Expression+  ( GuardExpression+  , mkExpression+  , mkGuardExpression+  )+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data GuardContext+  = PlainGuard+  | CaseGuard+  | LambdaGuard+  | MultiWayIfGuard+  deriving (Eq)++data Guard+  = ExprGuard+      { guardContext :: GuardContext+      , conditions :: [GHC.GuardLStmt GHC.GhcPs]+      , expr :: WithComments GuardExpression+      }+  | CmdGuard+      { guardContext :: GuardContext+      , conditions :: [GHC.GuardLStmt GHC.GhcPs]+      , cmd :: WithComments Cmd+      }++instance CommentExtraction Guard where+  nodeComments _ = NodeComments [] [] []++instance Pretty Guard where+  pretty' ExprGuard {..}+    | null conditions = do+      space+      string (contextSeparator guardContext)+      pretty expr+    | otherwise = do+      unless (guardContext == MultiWayIfGuard) newline+      (if guardContext == MultiWayIfGuard+         then id+         else indentedBlock) $ do+        string "| " |=> vCommaSep (fmap pretty conditions)+        space+        string (contextSeparator guardContext)+        pretty expr+  pretty' CmdGuard {..}+    | null conditions = do+      space+      string (contextSeparator guardContext)+      let hor = space >> pretty cmd+          ver = newline >> indentedBlock (pretty cmd)+       in hor <-|> ver+    | otherwise = do+      unless (guardContext == MultiWayIfGuard) newline+      (if guardContext == MultiWayIfGuard+         then id+         else indentedBlock) $ do+        string "| " |=> vCommaSep (fmap pretty conditions)+        space+        string (contextSeparator guardContext)+        let hor = space >> pretty cmd+            ver = newline >> indentedBlock (pretty cmd)+         in hor <-|> ver++contextSeparator :: GuardContext -> String+contextSeparator PlainGuard = "="+contextSeparator CaseGuard = "->"+contextSeparator LambdaGuard = "->"+contextSeparator MultiWayIfGuard = "->"++mkExprGuard :: GHC.GRHS GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Guard+mkExprGuard (GHC.GRHS _ conditions resultExpr) =+  ExprGuard+    { guardContext = PlainGuard+    , expr = mkGuardExpression . mkExpression <$> fromGenLocated resultExpr+    , ..+    }++mkCaseExprGuard :: GHC.GRHS GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Guard+mkCaseExprGuard (GHC.GRHS _ conditions resultExpr) =+  ExprGuard+    { guardContext = CaseGuard+    , expr = mkGuardExpression . mkExpression <$> fromGenLocated resultExpr+    , ..+    }++mkLambdaExprGuard :: GHC.GRHS GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Guard+mkLambdaExprGuard (GHC.GRHS _ conditions resultExpr) =+  ExprGuard+    { guardContext = LambdaGuard+    , expr = mkGuardExpression . mkExpression <$> fromGenLocated resultExpr+    , ..+    }++mkMultiWayIfExprGuard :: GHC.GRHS GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Guard+mkMultiWayIfExprGuard (GHC.GRHS _ conditions resultExpr) =+  ExprGuard+    { guardContext = MultiWayIfGuard+    , expr = mkGuardExpression . mkExpression <$> fromGenLocated resultExpr+    , ..+    }++mkCaseCmdGuard :: GHC.GRHS GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Guard+mkCaseCmdGuard (GHC.GRHS _ conditions cmd) =+  CmdGuard {guardContext = CaseGuard, cmd = fmap mkCmd (fromGenLocated cmd), ..}++mkLambdaCmdGuard :: GHC.GRHS GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Guard+mkLambdaCmdGuard (GHC.GRHS _ conditions cmd) =+  CmdGuard+    {guardContext = LambdaGuard, cmd = fmap mkCmd (fromGenLocated cmd), ..}
+ src/HIndent/Ast/Import.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Import+  ( Import+  , mkImport+  , sortByName+  ) where++import Control.Monad+import Data.Function+import Data.List (sortBy)+import qualified GHC.Types.SourceText as GHC+import qualified GHC.Unit as GHC+import HIndent.Applicative+import HIndent.Ast.Import.Entry.Collection+import HIndent.Ast.Module.Name (ModuleName, mkModuleName)+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import qualified HIndent.GhcLibParserWrapper.GHC.Hs.ImpExp as GHC+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data QualificationPosition+  = Pre+  | Post+  deriving (Eq)++data Import = Import+  { moduleName :: WithComments ModuleName+  , isSafe :: Bool+  , isBoot :: Bool+  , qualifiedAs :: Maybe (WithComments ModuleName)+  , qualification :: Maybe QualificationPosition+  , packageName :: Maybe GHC.StringLiteral+  , importEntries :: Maybe (WithComments ImportEntryCollection)+  }++instance CommentExtraction Import where+  nodeComments Import {} = NodeComments [] [] []++instance Pretty Import where+  pretty' Import {..} = do+    string "import "+    when isBoot $ string "{-# SOURCE #-} "+    when isSafe $ string "safe "+    when (qualification == Just Pre) $ string "qualified "+    whenJust packageName $ \name -> pretty name >> space+    pretty moduleName+    when (qualification == Just Post) $ string " qualified"+    case qualifiedAs of+      Just name -> string " as " >> pretty name+      _ -> pure ()+    whenJust importEntries pretty++mkImport :: GHC.ImportDecl GHC.GhcPs -> Import+mkImport decl@GHC.ImportDecl {..} = Import {..}+  where+    moduleName = mkModuleName <$> fromGenLocated ideclName+    isSafe = ideclSafe+    isBoot = ideclSource == GHC.IsBoot+    qualification =+      case ideclQualified of+        GHC.NotQualified -> Nothing+        GHC.QualifiedPre -> Just Pre+        GHC.QualifiedPost -> Just Post+    qualifiedAs = fmap mkModuleName . fromGenLocated <$> ideclAs+    packageName = GHC.getPackageName decl+    importEntries = mkImportEntryCollection decl++sortByName :: [WithComments Import] -> [WithComments Import]+sortByName = fmap sortExplicitImportsInDecl . sortByModuleName++-- | This function sorts import declarations by their module names.+sortByModuleName :: [WithComments Import] -> [WithComments Import]+sortByModuleName = sortBy (compare `on` getNode . moduleName . getNode)++-- | This function sorts explicit imports in the given import declaration+-- by their names.+sortExplicitImportsInDecl :: WithComments Import -> WithComments Import+sortExplicitImportsInDecl = fmap f+  where+    f (Import {importEntries = Just xs, ..}) =+      Import {importEntries = Just sorted, ..}+      where+        sorted = fmap sortEntriesByName xs+    f x = x
+ src/HIndent/Ast/Import/Collection.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Import.Collection+  ( ImportCollection+  , mkImportCollection+  , hasImports+  ) where++import Control.Monad.RWS+import Data.Function+import Data.List (sortBy)+import qualified GHC.Hs as GHC+import GHC.Stack+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Ast.Import+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import HIndent.Config+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import HIndent.Printer++newtype ImportCollection =+  ImportCollection [[WithComments Import]]++instance CommentExtraction ImportCollection where+  nodeComments ImportCollection {} = NodeComments [] [] []++instance Pretty ImportCollection where+  pretty' (ImportCollection xs) =+    importDecls >>= blanklined . fmap outputImportGroup+    where+      outputImportGroup = lined . fmap pretty+      importDecls =+        gets (configSortImports . psConfig) >>= \case+          True -> pure $ fmap sortByName xs+          False -> pure xs++mkImportCollection :: GHC.HsModule' -> ImportCollection+mkImportCollection GHC.HsModule {..} =+  ImportCollection+    $ fmap+        (fmap (fmap mkImport . fromGenLocated))+        (extractImports' hsmodImports)++hasImports :: ImportCollection -> Bool+hasImports (ImportCollection xs) = not $ null xs++-- | Extracts import declarations from the given module. Adjacent import+-- declarations are grouped as a single list.+extractImports' :: [GHC.LImportDecl GHC.GhcPs] -> [[GHC.LImportDecl GHC.GhcPs]]+extractImports' = groupImports . sortImportsByLocation++-- | Combines adjacent import declarations into a single list.+groupImports :: [GHC.LImportDecl GHC.GhcPs] -> [[GHC.LImportDecl GHC.GhcPs]]+groupImports = groupImports' []+  where+    groupImports' ::+         [[GHC.LImportDecl GHC.GhcPs]]+      -> [GHC.LImportDecl GHC.GhcPs]+      -> [[GHC.LImportDecl GHC.GhcPs]]+    groupImports' xs [] = xs+    groupImports' [] (x:xs) = groupImports' [[x]] xs+    groupImports' [[]] (x:xs) = groupImports' [[x]] xs+    groupImports' ([]:x:xs) (y:ys) = groupImports' ([y] : x : xs) ys+    groupImports' ((z:zs):xs) (y:ys)+      | z `isAdjacentTo` y = groupImports' ((y : z : zs) : xs) ys+      | otherwise = groupImports' ([y] : (z : zs) : xs) ys+    a `isAdjacentTo` b =+      GHC.srcSpanEndLine (sp a) + 1 == GHC.srcSpanStartLine (sp b)+        || GHC.srcSpanEndLine (sp b) + 1 == GHC.srcSpanStartLine (sp a)+    sp x =+      case GHC.locA $ GHC.getLoc x of+        GHC.RealSrcSpan x' _ -> x'+        _ -> error "Src span unavailable."++-- | This function sorts imports by their start line numbers.+sortImportsByLocation ::+     [GHC.LImportDecl GHC.GhcPs] -> [GHC.LImportDecl GHC.GhcPs]+sortImportsByLocation = sortBy (flip compare `on` lineIdx)+  where+    lineIdx = startLine . GHC.locA . GHC.getLoc++-- | This function returns the start line of the given 'SrcSpan'. If it is+-- not available, it raises an error.+startLine :: HasCallStack => GHC.SrcSpan -> Int+startLine (GHC.RealSrcSpan x _) = GHC.srcSpanStartLine x+startLine (GHC.UnhelpfulSpan _) = error "The src span is unavailable."
+ src/HIndent/Ast/Import/Entry.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Import.Entry+  ( ImportEntry+  , mkImportEntry+  , sortVariantsAndExplicitImports+  ) where++import Data.Function+import Data.List (sortBy)+import qualified GHC.Hs as GHC+import HIndent.Ast.Name.ImportExport+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data ImportEntry+  = SingleIdentifier (WithComments ImportExportName)+  | WithSpecificConstructors+      { name :: WithComments ImportExportName+      , constructors :: [WithComments ImportExportName]+      }+  | WithAllConstructors (WithComments ImportExportName)++instance CommentExtraction ImportEntry where+  nodeComments _ = NodeComments [] [] []++instance Pretty ImportEntry where+  pretty' (SingleIdentifier wrapped) = pretty wrapped+  pretty' (WithAllConstructors wrapped) = pretty wrapped >> string "(..)"+  pretty' WithSpecificConstructors {..} =+    pretty name >> hFillingTuple (fmap pretty constructors)++mkImportEntry :: GHC.IE GHC.GhcPs -> ImportEntry+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkImportEntry (GHC.IEVar _ name _) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkImportEntry (GHC.IEThingAbs _ name _) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkImportEntry (GHC.IEThingAll _ name _) =+  WithAllConstructors $ mkImportExportName <$> fromGenLocated name+mkImportEntry (GHC.IEThingWith _ name _ constructors _) =+  WithSpecificConstructors+    { name = mkImportExportName <$> fromGenLocated name+    , constructors =+        fmap (fmap mkImportExportName . fromGenLocated) constructors+    }+#else+mkImportEntry (GHC.IEVar _ name) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkImportEntry (GHC.IEThingAbs _ name) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkImportEntry (GHC.IEThingAll _ name) =+  WithAllConstructors $ mkImportExportName <$> fromGenLocated name+mkImportEntry (GHC.IEThingWith _ name _ constructors) =+  WithSpecificConstructors+    { name = mkImportExportName <$> fromGenLocated name+    , constructors =+        fmap (fmap mkImportExportName . fromGenLocated) constructors+    }+#endif+mkImportEntry _ = undefined++sortVariantsAndExplicitImports ::+     [WithComments ImportEntry] -> [WithComments ImportEntry]+sortVariantsAndExplicitImports = fmap sortVariants . sortExplicitImports++-- | This function sorts variants (e.g., data constructors and class+-- methods) in the given explicit import by their names.+sortVariants :: WithComments ImportEntry -> WithComments ImportEntry+sortVariants = fmap f+  where+    f WithSpecificConstructors {..} =+      WithSpecificConstructors+        {constructors = sortBy (compare `on` getNode) constructors, ..}+    f x = x++-- | This function sorts the given explicit imports by their names.+sortExplicitImports :: [WithComments ImportEntry] -> [WithComments ImportEntry]+sortExplicitImports = sortBy (compareImportEntities `on` getNode)++-- | This function compares two import declarations by their module names.+compareImportEntities :: ImportEntry -> ImportEntry -> Ordering+compareImportEntities = compare `on` getNode . getModuleName++-- | This function returns a 'Just' value with the module name extracted+-- from the import declaration. Otherwise, it returns a 'Nothing'.+getModuleName :: ImportEntry -> WithComments ImportExportName+getModuleName (SingleIdentifier wrapped) = wrapped+getModuleName (WithAllConstructors wrapped) = wrapped+getModuleName (WithSpecificConstructors wrapped _) = wrapped
+ src/HIndent/Ast/Import/Entry/Collection.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Import.Entry.Collection+  ( ImportEntryCollection+  , mkImportEntryCollection+  , sortEntriesByName+  ) where++import Control.Monad+import qualified GHC.Hs as GHC+import HIndent.Ast.Import.Entry+import HIndent.Ast.Import.ImportingOrHiding+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data ImportEntryCollection = ImportEntryCollection+  { entries :: [WithComments ImportEntry]+  , kind :: ImportingOrHiding+  }++instance CommentExtraction ImportEntryCollection where+  nodeComments ImportEntryCollection {} = NodeComments [] [] []++instance Pretty ImportEntryCollection where+  pretty' ImportEntryCollection {..} = do+    when (kind == Hiding) $ string " hiding"+    (space >> hTuple (fmap pretty entries))+      <-|> (newline >> indentedBlock (vTuple $ fmap pretty entries))++mkImportEntryCollection ::+     GHC.ImportDecl GHC.GhcPs -> Maybe (WithComments ImportEntryCollection)+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+mkImportEntryCollection GHC.ImportDecl {..} =+  case ideclImportList of+    Nothing -> Nothing+    Just (GHC.Exactly, xs) ->+      Just+        $ fmap (\entries -> ImportEntryCollection {kind = Importing, ..})+        $ fromGenLocated+        $ fmap (fmap (fmap mkImportEntry . fromGenLocated)) xs+    Just (GHC.EverythingBut, xs) ->+      Just+        $ fmap (\entries -> ImportEntryCollection {kind = Hiding, ..})+        $ fromGenLocated+        $ fmap (fmap (fmap mkImportEntry . fromGenLocated)) xs+#else+mkImportEntryCollection GHC.ImportDecl {..} =+  case ideclHiding of+    Nothing -> Nothing+    Just (False, xs) ->+      Just+        $ fmap (\entries -> ImportEntryCollection {kind = Importing, ..})+        $ fromGenLocated+        $ fmap (fmap (fmap mkImportEntry . fromGenLocated)) xs+    Just (True, xs) ->+      Just+        $ fmap (\entries -> ImportEntryCollection {kind = Hiding, ..})+        $ fromGenLocated+        $ fmap (fmap (fmap mkImportEntry . fromGenLocated)) xs+#endif+sortEntriesByName :: ImportEntryCollection -> ImportEntryCollection+sortEntriesByName ImportEntryCollection {..} =+  ImportEntryCollection {entries = sortVariantsAndExplicitImports entries, ..}
+ src/HIndent/Ast/Import/ImportingOrHiding.hs view
@@ -0,0 +1,8 @@+module HIndent.Ast.Import.ImportingOrHiding+  ( ImportingOrHiding(..)+  ) where++data ImportingOrHiding+  = Importing+  | Hiding+  deriving (Eq)
+ src/HIndent/Ast/LocalBinds.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.LocalBinds+  ( LocalBinds+  , mkLocalBinds+  ) where++import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+import qualified GHC.Data.Bag as GHC+#endif+import HIndent.Ast.LocalBinds.ImplicitBindings+  ( ImplicitBindings+  , mkImplicitBindings+  )+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.WithComments (WithComments, fromEpAnn, fromGenLocated)+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import qualified HIndent.Pretty.SigBindFamily as SBF++data LocalBinds+  = Value+      { sigBindFamilies :: [WithComments SBF.SigBindFamily]+      }+  | ImplicitParameters+      { implicitBindings :: ImplicitBindings+      }++instance CommentExtraction LocalBinds where+  nodeComments Value {} = NodeComments [] [] []+  nodeComments ImplicitParameters {} = NodeComments [] [] []++instance Pretty LocalBinds where+  pretty' Value {sigBindFamilies = families} = lined $ fmap pretty families+  pretty' (ImplicitParameters {implicitBindings = binds}) = pretty binds++mkLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Maybe (WithComments LocalBinds)+mkLocalBinds (GHC.HsValBinds ann binds) =+  Just $ fromEpAnn ann $ Value {sigBindFamilies = mkSigBindFamilies binds}+mkLocalBinds (GHC.HsIPBinds ann binds) =+  Just+    $ fromEpAnn ann+    $ ImplicitParameters {implicitBindings = mkImplicitBindings binds}+mkLocalBinds GHC.EmptyLocalBinds {} = Nothing++mkSigBindFamilies ::+     GHC.HsValBindsLR GHC.GhcPs GHC.GhcPs -> [WithComments SBF.SigBindFamily]+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkSigBindFamilies (GHC.ValBinds _ binds sigs) =+  fmap fromGenLocated $ SBF.mkSortedLSigBindFamilyList sigs binds [] [] [] []+#else+mkSigBindFamilies (GHC.ValBinds _ bindBag sigs) =+  fromGenLocated+    <$> SBF.mkSortedLSigBindFamilyList sigs (GHC.bagToList bindBag) [] [] [] []+#endif+mkSigBindFamilies GHC.XValBindsLR {} =+  error "`ghc-lib-parser` never generates this AST node."
+ src/HIndent/Ast/LocalBinds/ImplicitBinding.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.LocalBinds.ImplicitBinding+  ( ImplicitBinding+  , mkImplicitBinding+  ) where++import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.Type.ImplicitParameterName+  ( ImplicitParameterName+  , mkImplicitParameterName+  )+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data ImplicitBinding = ImplicitBinding+  { name :: WithComments ImplicitParameterName+  , expression :: WithComments Expression+  }++instance CommentExtraction ImplicitBinding where+  nodeComments _ = NodeComments [] [] []++instance Pretty ImplicitBinding where+  pretty' ImplicitBinding {..} =+    spaced [pretty name, string "=", pretty expression]++mkImplicitBinding :: GHC.IPBind GHC.GhcPs -> ImplicitBinding+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkImplicitBinding (GHC.IPBind _ lhs rhs) =+  ImplicitBinding+    { name = mkImplicitParameterName <$> fromGenLocated lhs+    , expression = mkExpression <$> fromGenLocated rhs+    }+#else+mkImplicitBinding (GHC.IPBind _ (Left lhs) rhs) =+  ImplicitBinding+    { name = mkImplicitParameterName <$> fromGenLocated lhs+    , expression = mkExpression <$> fromGenLocated rhs+    }+mkImplicitBinding (GHC.IPBind _ (Right _) _) =+  error "`ghc-lib-parser` never generates this AST node."+#endif
+ src/HIndent/Ast/LocalBinds/ImplicitBindings.hs view
@@ -0,0 +1,30 @@+module HIndent.Ast.LocalBinds.ImplicitBindings+  ( ImplicitBindings+  , mkImplicitBindings+  ) where++import HIndent.Ast.LocalBinds.ImplicitBinding+  ( ImplicitBinding+  , mkImplicitBinding+  )+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype ImplicitBindings = ImplicitBindings+  { bindings :: [WithComments ImplicitBinding]+  }++instance CommentExtraction ImplicitBindings where+  nodeComments _ = NodeComments [] [] []++instance Pretty ImplicitBindings where+  pretty' (ImplicitBindings xs) = lined $ fmap pretty xs++mkImplicitBindings :: GHC.HsIPBinds GHC.GhcPs -> ImplicitBindings+mkImplicitBindings (GHC.IPBinds _ xs) =+  ImplicitBindings+    {bindings = fmap (fmap mkImplicitBinding . fromGenLocated) xs}
+ src/HIndent/Ast/Match.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Match+  ( Match+  , mkExprMatch+  , mkCmdMatch+  ) where++import Control.Monad (unless, when)+import qualified GHC.Hs as GHC+import qualified GHC.Types.Fixity as Fixity+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+import qualified GHC.Types.Name.Reader as GHC+#endif+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Applicative (whenJust)+import HIndent.Ast.Declaration.Bind.GuardedRhs+  ( GuardedRhs+  , mkCaseCmdGuardedRhs+  , mkCaseGuardedRhs+  , mkGuardedRhs+  , mkLambdaCmdGuardedRhs+  , mkLambdaGuardedRhs+  )+import HIndent.Ast.Name.Infix (InfixName, mkInfixName)+import HIndent.Ast.Name.Prefix (PrefixName, mkPrefixName)+import HIndent.Ast.NodeComments+import HIndent.Ast.Pattern (Pattern, mkPattern)+import HIndent.Ast.Type.Strictness (Strictness, mkStrictness)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+import HIndent.Ast.WithComments (WithComments, fromGenLocated, prettyWith)+#else+import HIndent.Ast.WithComments+  ( WithComments+  , fromGenLocated+  , mkWithComments+  , prettyWith+  )+#endif+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments (CommentExtraction(..))++data InfixOperands = InfixOperands+  { left :: WithComments Pattern+  , operator :: WithComments InfixName+  , right :: WithComments Pattern+  , rest :: [WithComments Pattern]+  }++instance CommentExtraction InfixOperands where+  nodeComments _ = NodeComments [] [] []++instance Pretty InfixOperands where+  pretty' InfixOperands {..} =+    spaced $ pretty left : pretty operator : pretty right : fmap pretty rest++data Match+  = Lambda+      { needsSpaceAfterLambda :: Bool+      , patterns :: WithComments [WithComments Pattern]+      , rhs :: GuardedRhs+      }+  | Case+      { patterns :: WithComments [WithComments Pattern]+      , rhs :: GuardedRhs+      }+  | FunctionPrefix+      { strictness :: Maybe Strictness+      , name :: WithComments PrefixName+      , patterns :: WithComments [WithComments Pattern]+      , rhs :: GuardedRhs+      }+  | FunctionInfix+      { operands :: WithComments InfixOperands+      , rhs :: GuardedRhs+      }++instance CommentExtraction Match where+  nodeComments _ = NodeComments [] [] []++instance Pretty Match where+  pretty' Lambda {..} = do+    string "\\"+    when needsSpaceAfterLambda space+    prettyWith patterns $ spaced . fmap pretty+    pretty rhs+  pretty' Case {..} = do+    prettyWith patterns $ spaced . fmap pretty+    pretty rhs+  pretty' FunctionPrefix {..} = do+    whenJust strictness pretty+    pretty name+    prettyWith patterns $ \pats ->+      unless (null pats) $ spacePrefixed $ fmap pretty pats+    pretty rhs+  pretty' FunctionInfix {..} = do+    pretty operands+    pretty rhs+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkExprMatch :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Match+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamSingle, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace $ GHC.unLoc m_pats+    , patterns =+        fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+    , rhs = mkLambdaGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt _, ..} =+  Case+    { rhs = mkCaseGuardedRhs m_grhss+    , patterns =+        fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { rhs = mkCaseGuardedRhs m_grhss+    , patterns =+        fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+    }+mkExprMatch GHC.Match {GHC.m_ctxt = ctxt@GHC.FunRhs {}, ..} =+  mkFunctionMatch ctxt patterns (mkGuardedRhs m_grhss)+  where+    patterns =+      fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+mkExprMatch _ = error "`ghc-lib-parser` never generates this AST node."+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExprMatch :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Match+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamSingle, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace m_pats+    , patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkLambdaGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamCase, ..} =+  Case+    { rhs = mkCaseGuardedRhs m_grhss+    , patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamCases, ..} =+  Case+    { patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkCaseGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkCaseGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = ctxt@GHC.FunRhs {}, ..} =+  mkFunctionMatch ctxt patterns (mkGuardedRhs m_grhss)+  where+    patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+mkExprMatch _ = error "`ghc-lib-parser` never generates this AST node."+#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkExprMatch :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Match+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LambdaExpr, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace m_pats+    , patterns = patterns+    , rhs = mkLambdaGuardedRhs m_grhss+    }+  where+    patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LamCaseAlt {}, ..} =+  Case+    { patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkCaseGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkCaseGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = ctxt@GHC.FunRhs {}, ..} =+  mkFunctionMatch ctxt patterns (mkGuardedRhs m_grhss)+  where+    patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+mkExprMatch _ = error "`ghc-lib-parser` never generates this AST node."+#else+mkExprMatch :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Match+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.LambdaExpr, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace m_pats+    , patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkLambdaGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+    , rhs = mkCaseGuardedRhs m_grhss+    }+mkExprMatch GHC.Match {GHC.m_ctxt = ctxt@GHC.FunRhs {}, ..} =+  mkFunctionMatch ctxt patterns (mkGuardedRhs m_grhss)+  where+    patterns = mkWithComments $ fmap (fmap mkPattern . fromGenLocated) m_pats+mkExprMatch _ = error "`ghc-lib-parser` never generates this AST node."+#endif++#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkCmdMatch :: GHC.Match GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Match+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamSingle, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace (GHC.unLoc m_pats)+    , patterns =+        fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+    , rhs = mkLambdaCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt _, ..} =+  Case+    { patterns =+        fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { patterns =+        fmap (fmap (fromGenLocated . fmap mkPattern)) $ fromGenLocated $ m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch _ = error "`ghc-lib-parser` never generates this AST node."+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkCmdMatch :: GHC.Match GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Match+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamSingle, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace m_pats+    , patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkLambdaCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamCase, ..} =+  Case+    { patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LamAlt GHC.LamCases, ..} =+  Case+    { patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch _ = error "`ghc-lib-parser` never generates this AST node."+#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkCmdMatch :: GHC.Match GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Match+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LambdaExpr, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace m_pats+    , patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkLambdaCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LamCaseAlt {}, ..} =+  Case+    { patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkCaseCmdGuardedRhs m_grhss+    }+mkCmdMatch _ = error "`ghc-lib-parser` never generates this AST node."+#else+mkCmdMatch :: GHC.Match GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> Match+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.LambdaExpr, ..} =+  Lambda+    { needsSpaceAfterLambda = lambdaNeedsSpace m_pats+    , patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    , rhs = mkLambdaCmdGuardedRhs m_grhss+    }+mkCmdMatch GHC.Match {GHC.m_ctxt = GHC.CaseAlt, ..} =+  Case+    { rhs = mkCaseCmdGuardedRhs m_grhss+    , patterns = mkWithComments $ fmap mkPattern . fromGenLocated <$> m_pats+    }+mkCmdMatch _ = error "`ghc-lib-parser` never generates this AST node."+#endif+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkFunctionMatch ::+     GHC.HsMatchContext (GHC.GenLocated GHC.SrcSpanAnnN GHC.RdrName)+  -> WithComments [WithComments Pattern]+  -> GuardedRhs+  -> Match+#else+mkFunctionMatch ::+     GHC.HsMatchContext GHC.GhcPs+  -> WithComments [WithComments Pattern]+  -> GuardedRhs+  -> Match+#endif+mkFunctionMatch GHC.FunRhs {mc_fixity = Fixity.Prefix, ..} patterns rhs =+  FunctionPrefix+    { strictness = mkStrictness mc_strictness+    , name = mkPrefixName <$> fromGenLocated mc_fun+    , ..+    }+mkFunctionMatch GHC.FunRhs {mc_fixity = Fixity.Infix, ..} pats rhs =+  FunctionInfix {..}+  where+    operands =+      flip fmap pats $ \case+        left:right:rest ->+          InfixOperands {operator = mkInfixName <$> fromGenLocated mc_fun, ..}+        _ -> error "FunctionInfix match must have at least two patterns."+mkFunctionMatch _ _ _ = error "`ghc-lib-parser` never generates this AST node."++lambdaNeedsSpace :: [GHC.LPat GHC.GhcPs] -> Bool+lambdaNeedsSpace (pat:_) =+  case GHC.unLoc pat of+    GHC.LazyPat {} -> True+    GHC.BangPat {} -> True+    _ -> False+lambdaNeedsSpace _ = False
+ src/HIndent/Ast/MatchGroup.hs view
@@ -0,0 +1,46 @@+module HIndent.Ast.MatchGroup+  ( MatchGroup+  , mkExprMatchGroup+  , mkCmdMatchGroup+  , hasMatches+  ) where++import qualified GHC.Hs as GHC+import HIndent.Ast.Match (Match, mkCmdMatch, mkExprMatch)+import HIndent.Ast.WithComments+  ( WithComments+  , fromGenLocated+  , getComments+  , getNode+  , prettyWith+  )+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators (lined)+import HIndent.Pretty.NodeComments (CommentExtraction(..))++newtype MatchGroup =+  MatchGroup (WithComments [WithComments Match])++instance CommentExtraction MatchGroup where+  nodeComments (MatchGroup alts) = getComments alts++instance Pretty MatchGroup where+  pretty' (MatchGroup alts) = prettyWith alts (lined . fmap pretty)++mkExprMatchGroup ::+     GHC.MatchGroup GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> MatchGroup+mkExprMatchGroup =+  MatchGroup+    . fmap (fmap (fmap mkExprMatch . fromGenLocated))+    . fromGenLocated+    . GHC.mg_alts++mkCmdMatchGroup :: GHC.MatchGroup GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> MatchGroup+mkCmdMatchGroup =+  MatchGroup+    . fmap (fmap (fmap mkCmdMatch . fromGenLocated))+    . fromGenLocated+    . GHC.mg_alts++hasMatches :: MatchGroup -> Bool+hasMatches (MatchGroup alts) = not $ null $ getNode alts
+ src/HIndent/Ast/MatchGroup.hs-boot view
@@ -0,0 +1,17 @@+module HIndent.Ast.MatchGroup+  ( MatchGroup+  , mkCmdMatchGroup+  ) where++import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty (Pretty)+import HIndent.Pretty.NodeComments++data MatchGroup++instance Pretty MatchGroup++instance CommentExtraction MatchGroup++mkCmdMatchGroup ::+     GHC.MatchGroup GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> MatchGroup
+ src/HIndent/Ast/Module.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Module+  ( Module+  , mkModule+  ) where++import Data.Maybe+import HIndent.Ast.Declaration.Collection+import HIndent.Ast.FileHeaderPragma.Collection+import HIndent.Ast.Import.Collection+import HIndent.Ast.Module.Declaration+import HIndent.Ast.NodeComments hiding (fromEpAnn)+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Module = Module+  { pragmas :: FileHeaderPragmaCollection+  , moduleDeclaration :: Maybe ModuleDeclaration+  , imports :: ImportCollection+  , declarations :: DeclarationCollection+  }++instance CommentExtraction Module where+  nodeComments Module {} = NodeComments [] [] []++instance Pretty Module where+  pretty' Module {..}+    | isEmpty = pure ()+    | otherwise = blanklined printers >> newline+    where+      isEmpty =+        not (hasPragmas pragmas)+          && isNothing moduleDeclaration+          && not (hasImports imports)+          && not (hasDeclarations declarations)+      printers =+        catMaybes+          [ toMaybe (hasPragmas pragmas) (pretty pragmas)+          , fmap pretty moduleDeclaration+          , toMaybe (hasImports imports) (pretty imports)+          , toMaybe (hasDeclarations declarations) (pretty declarations)+          ]+      toMaybe cond x =+        if cond+          then Just x+          else Nothing++mkModule :: GHC.HsModule' -> WithComments Module+mkModule m = fromEpAnn (GHC.getModuleAnn m) $ Module {..}+  where+    pragmas = mkFileHeaderPragmaCollection m+    moduleDeclaration = mkModuleDeclaration m+    imports = mkImportCollection m+    declarations = mkDeclarationCollection m
+ src/HIndent/Ast/Module/Declaration.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Module.Declaration+  ( ModuleDeclaration+  , mkModuleDeclaration+  ) where++import HIndent.Applicative+import HIndent.Ast.Module.Export.Collection+import HIndent.Ast.Module.Name+import HIndent.Ast.Module.Warning+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data ModuleDeclaration = ModuleDeclaration+  { name :: WithComments ModuleName+  , warning :: Maybe (WithComments ModuleWarning)+  , exports :: Maybe (WithComments ExportCollection)+  }++instance CommentExtraction ModuleDeclaration where+  nodeComments ModuleDeclaration {} = NodeComments [] [] []++instance Pretty ModuleDeclaration where+  pretty' ModuleDeclaration {..} = do+    prettyWith name $ \n -> do+      string "module "+      pretty n+    whenJust warning $ \x -> do+      space+      pretty x+    whenJust exports $ \x -> do+      newline+      indentedBlock $ pretty x+    string " where"++mkModuleDeclaration :: GHC.HsModule' -> Maybe ModuleDeclaration+mkModuleDeclaration m =+  case GHC.hsmodName m of+    Nothing -> Nothing+    Just name' -> Just ModuleDeclaration {..}+      where+        name = mkModuleName <$> fromGenLocated name'+        warning = mkModuleWarning m+        exports = mkExportCollection m
+ src/HIndent/Ast/Module/Export/Collection.hs view
@@ -0,0 +1,28 @@+module HIndent.Ast.Module.Export.Collection+  ( ExportCollection+  , mkExportCollection+  ) where++import HIndent.Ast.Module.Export.Entry+import HIndent.Ast.NodeComments hiding (fromEpAnn)+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype ExportCollection =+  ExportCollection [WithComments ExportEntry]++instance CommentExtraction ExportCollection where+  nodeComments (ExportCollection _) = NodeComments [] [] []++instance Pretty ExportCollection where+  pretty' (ExportCollection xs) = vTuple $ fmap pretty xs++mkExportCollection :: GHC.HsModule' -> Maybe (WithComments ExportCollection)+mkExportCollection =+  fmap+    (fmap (ExportCollection . fmap (fmap mkExportEntry . fromGenLocated))+       . fromGenLocated)+    . GHC.hsmodExports
+ src/HIndent/Ast/Module/Export/Entry.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Module.Export.Entry+  ( ExportEntry+  , mkExportEntry+  ) where++import GHC.Stack+import HIndent.Ast.Module.Name+import HIndent.Ast.Name.ImportExport+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data ExportEntry+  = SingleIdentifier (WithComments ImportExportName)+  | WithSpecificConstructors+      (WithComments ImportExportName)+      [WithComments ImportExportName]+  | WithAllConstructors (WithComments ImportExportName)+  | ByModule (WithComments ModuleName)++instance CommentExtraction ExportEntry where+  nodeComments SingleIdentifier {} = NodeComments [] [] []+  nodeComments WithSpecificConstructors {} = NodeComments [] [] []+  nodeComments WithAllConstructors {} = NodeComments [] [] []+  nodeComments ByModule {} = NodeComments [] [] []++instance Pretty ExportEntry where+  pretty' (SingleIdentifier s) = pretty s+  pretty' (WithSpecificConstructors s xs) = pretty s >> hTuple (fmap pretty xs)+  pretty' (WithAllConstructors s) = pretty s >> string "(..)"+  pretty' (ByModule s) = string "module " >> pretty s++mkExportEntry :: GHC.IE GHC.GhcPs -> ExportEntry+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkExportEntry (GHC.IEVar _ name _) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkExportEntry (GHC.IEThingAbs _ name _) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkExportEntry (GHC.IEThingAll _ name _) =+  WithAllConstructors $ mkImportExportName <$> fromGenLocated name+mkExportEntry (GHC.IEThingWith _ name _ constructors _) =+  WithSpecificConstructors (mkImportExportName <$> fromGenLocated name)+    $ fmap mkImportExportName . fromGenLocated <$> constructors+#else+mkExportEntry (GHC.IEVar _ name) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkExportEntry (GHC.IEThingAbs _ name) =+  SingleIdentifier $ mkImportExportName <$> fromGenLocated name+mkExportEntry (GHC.IEThingAll _ name) =+  WithAllConstructors $ mkImportExportName <$> fromGenLocated name+mkExportEntry (GHC.IEThingWith _ name _ constructors) =+  WithSpecificConstructors (mkImportExportName <$> fromGenLocated name)+    $ fmap mkImportExportName . fromGenLocated <$> constructors+#endif+mkExportEntry (GHC.IEModuleContents _ name) =+  ByModule $ mkModuleName <$> fromGenLocated name+mkExportEntry GHC.IEGroup {} = neverAppears+mkExportEntry GHC.IEDoc {} = neverAppears+mkExportEntry GHC.IEDocNamed {} = neverAppears++neverAppears :: HasCallStack => a+neverAppears =+  error+    "This AST node should never appear in the GHC AST. If you see this error message, please report a bug to the HIndent maintainers."
+ src/HIndent/Ast/Module/Name.hs view
@@ -0,0 +1,23 @@+module HIndent.Ast.Module.Name+  ( ModuleName+  , mkModuleName+  ) where++import qualified GHC.Unit as GHC+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype ModuleName =+  ModuleName String+  deriving (Eq, Ord)++instance CommentExtraction ModuleName where+  nodeComments _ = NodeComments [] [] []++instance Pretty ModuleName where+  pretty' (ModuleName x) = string x++mkModuleName :: GHC.ModuleName -> ModuleName+mkModuleName = ModuleName . GHC.moduleNameString
+ src/HIndent/Ast/Module/Name.hs-boot view
@@ -0,0 +1,5 @@+module HIndent.Ast.Module.Name+  ( ModuleName+  ) where++data ModuleName
+ src/HIndent/Ast/Module/Warning.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Module.Warning+  ( ModuleWarning+  , mkModuleWarning+  ) where++import qualified GHC.Types.SourceText as GHC+import HIndent.Ast.Declaration.Warning.Kind+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import qualified HIndent.GhcLibParserWrapper.GHC.Unit.Module.Warnings as GHC+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+#if !MIN_VERSION_ghc_lib_parser(9, 10, 0)+import qualified GHC.Types.SrcLoc as GHC+#endif+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+data ModuleWarning = ModuleWarning+  { messages :: [GHC.LocatedE+                   (GHC.WithHsDocIdentifiers GHC.StringLiteral GHC.GhcPs)]+  , kind :: Kind+  }+#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)+data ModuleWarning = ModuleWarning+  { messages :: [GHC.Located+                   (GHC.WithHsDocIdentifiers GHC.StringLiteral GHC.GhcPs)]+  , kind :: Kind+  }+#else+data ModuleWarning = ModuleWarning+  { messages :: [GHC.GenLocated GHC.SrcSpan GHC.StringLiteral]+  , kind :: Kind+  }+#endif+instance CommentExtraction ModuleWarning where+  nodeComments _ = NodeComments [] [] []++instance Pretty ModuleWarning where+  pretty' ModuleWarning {..} =+    spaced [string "{-#", pretty kind, prettyMsgs, string "#-}"]+    where+      prettyMsgs =+        case messages of+          [x] -> pretty x+          xs -> hList $ fmap pretty xs++mkModuleWarning :: GHC.HsModule' -> Maybe (WithComments ModuleWarning)+mkModuleWarning =+  fmap (fromGenLocated . fmap fromWarningTxt) . GHC.getDeprecMessage++fromWarningTxt :: GHC.WarningTxt' -> ModuleWarning+#if MIN_VERSION_ghc_lib_parser(9, 8, 1)+fromWarningTxt (GHC.WarningTxt _ _ messages) = ModuleWarning {..}+  where+    kind = Warning+#else+fromWarningTxt (GHC.WarningTxt _ messages) = ModuleWarning {..}+  where+    kind = Warning+#endif+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+fromWarningTxt (GHC.DeprecatedTxt _ messages) = ModuleWarning {..}+  where+    kind = Deprecated+#else+fromWarningTxt (GHC.DeprecatedTxt _ messages) = ModuleWarning {..}+  where+    kind = Deprecated+#endif
+ src/HIndent/Ast/Name/ImportExport.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Name.ImportExport+  ( ImportExportName+  , mkImportExportName+  ) where++import qualified Data.ByteString.Builder as S+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char (isLower, isUpper)+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.WithComments+import HIndent.Config+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import HIndent.Printer++data ImportExportName+  = Regular (WithComments PrefixName)+  | Pattern (WithComments PrefixName)+  | Type (WithComments PrefixName)++instance CommentExtraction ImportExportName where+  nodeComments Regular {} = NodeComments [] [] []+  nodeComments Pattern {} = NodeComments [] [] []+  nodeComments Type {} = NodeComments [] [] []++instance Pretty ImportExportName where+  pretty' (Regular name) = pretty name+  pretty' (Pattern name) = spaced [string "pattern", pretty name]+  pretty' (Type name) = string "type " >> pretty name++instance Eq ImportExportName where+  a == b = compare a b == EQ++instance Ord ImportExportName where+  compare a b = compareIdentifier (getNameString a) (getNameString b)++getNameString :: ImportExportName -> String+getNameString n =+  L.unpack $ S.toLazyByteString $ runPrinterStyle defaultConfig $ pretty' n++compareIdentifier :: String -> String -> Ordering+compareIdentifier as@(a:_) bs@(b:_) =+  case compareChar a b of+    EQ -> compareSameIdentifierType as bs+    x -> x+compareIdentifier "" "" = EQ+compareIdentifier "" _ = LT+compareIdentifier _ "" = GT++compareSameIdentifierType :: String -> String -> Ordering+compareSameIdentifierType "" "" = EQ+compareSameIdentifierType "" _ = LT+compareSameIdentifierType _ "" = GT+compareSameIdentifierType ('(':as) bs = compareSameIdentifierType as bs+compareSameIdentifierType (')':as) bs = compareSameIdentifierType as bs+compareSameIdentifierType as ('(':bs) = compareSameIdentifierType as bs+compareSameIdentifierType as (')':bs) = compareSameIdentifierType as bs+compareSameIdentifierType (a:as) (b:bs) =+  case compare a b of+    EQ -> compareSameIdentifierType as bs+    x -> x++compareChar :: Char -> Char -> Ordering+compareChar a b =+  case compare (charToLetterType a) (charToLetterType b) of+    EQ -> compare a b+    x -> x++charToLetterType :: Char -> LetterType+charToLetterType c+  | isLower c = Lower+  | isUpper c = Capital+  | otherwise = Symbol++data LetterType+  = Capital+  | Symbol+  | Lower+  deriving (Eq, Ord)+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+mkImportExportName :: GHC.IEWrappedName GHC.GhcPs -> ImportExportName+mkImportExportName (GHC.IEName _ name) =+  Regular $ fromGenLocated $ fmap mkPrefixName name+mkImportExportName (GHC.IEPattern _ name) =+  Pattern $ fromGenLocated $ fmap mkPrefixName name+mkImportExportName (GHC.IEType _ name) =+  Type $ fromGenLocated $ fmap mkPrefixName name+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkImportExportName GHC.IEDefault {} =+  error "IEDefault is not generated by parser"+#endif+#else+mkImportExportName :: GHC.IEWrappedName GHC.RdrName -> ImportExportName+mkImportExportName (GHC.IEName name) =+  Regular $ fromGenLocated $ fmap mkPrefixName name+mkImportExportName (GHC.IEPattern _ name) =+  Pattern $ fromGenLocated $ fmap mkPrefixName name+mkImportExportName (GHC.IEType _ name) =+  Type $ fromGenLocated $ fmap mkPrefixName name+#endif
+ src/HIndent/Ast/Name/Infix.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Name.Infix+  ( InfixName+  , mkInfixName+  , getInfixName+  , unlessSpecialOp+  ) where++import Control.Monad+import Data.Maybe+import qualified GHC.Types.Name as GHC+import qualified GHC.Types.Name.Reader as GHC+import HIndent.Ast.Module.Name+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators hiding (unlessSpecialOp)+import HIndent.Pretty.NodeComments+import HIndent.Printer++data InfixName = InfixName+  { name :: String+  , moduleName :: Maybe ModuleName+  , backtick :: Bool+  }++instance CommentExtraction InfixName where+  nodeComments InfixName {} = NodeComments [] [] []++instance Pretty InfixName where+  pretty' InfixName {..} =+    wrap $ hDotSep $ catMaybes [pretty <$> moduleName, Just $ string name]+    where+      wrap =+        if backtick+          then backticks+          else id++mkInfixName :: GHC.RdrName -> InfixName+mkInfixName (GHC.Unqual name) =+  InfixName (showOutputable name) Nothing (backticksNeeded name)+mkInfixName (GHC.Qual modName name) =+  InfixName+    (showOutputable name)+    (Just $ mkModuleName modName)+    (backticksNeeded name)+mkInfixName (GHC.Orig {}) =+  error "This AST node should not appear in the parser output."+mkInfixName (GHC.Exact name) =+  InfixName+    (showOutputable $ GHC.occName name)+    Nothing+    (backticksNeeded $ GHC.occName name)++getInfixName :: InfixName -> String+getInfixName = name++unlessSpecialOp :: InfixName -> Printer () -> Printer ()+unlessSpecialOp InfixName {..} = unless $ name `elem` ["()", "[]", "->", ":"]++backticksNeeded :: GHC.OccName -> Bool+backticksNeeded = not . GHC.isSymOcc
+ src/HIndent/Ast/Name/Prefix.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Name.Prefix+  ( PrefixName+  , mkPrefixName+  , fromString+  , PrefixAsInfix+  , mkPrefixAsInfix+  , prefixAsInfixFixity+  ) where++import Data.Maybe+import qualified GHC.Types.Fixity as Fixity+import qualified GHC.Types.Name as GHC+import qualified GHC.Types.Name.Reader as GHC+import HIndent.Ast.Module.Name+import HIndent.Ast.NodeComments+import HIndent.Fixity (fixities)+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data PrefixName = PrefixName+  { name :: String+  , moduleName :: Maybe ModuleName+  , parentheses :: Bool+  }++instance CommentExtraction PrefixName where+  nodeComments PrefixName {} = NodeComments [] [] []++instance Pretty PrefixName where+  pretty' PrefixName {..} =+    wrap $ hDotSep $ catMaybes [pretty <$> moduleName, Just $ string name]+    where+      wrap =+        if parentheses+          then parens+          else id++mkPrefixName :: GHC.RdrName -> PrefixName+mkPrefixName (GHC.Unqual name) =+  PrefixName (showOutputable name) Nothing (parensNeeded name)+mkPrefixName (GHC.Qual modName name) =+  PrefixName+    (showOutputable name)+    (Just $ mkModuleName modName)+    (parensNeeded name)+mkPrefixName (GHC.Orig {}) =+  error "This AST node should not appear in the parser output."+mkPrefixName (GHC.Exact name) =+  PrefixName (showOutputable name) Nothing (parensNeeded $ GHC.occName name)++fromString :: String -> PrefixName+fromString name = PrefixName name Nothing False++newtype PrefixAsInfix =+  PrefixAsInfix PrefixName++instance CommentExtraction PrefixAsInfix where+  nodeComments (PrefixAsInfix prefix) = nodeComments prefix++instance Pretty PrefixAsInfix where+  pretty' (PrefixAsInfix PrefixName {..}) =+    wrap $ hDotSep $ catMaybes [pretty <$> moduleName, Just $ string name]+    where+      wrap =+        if parentheses+          then id+          else backticks++mkPrefixAsInfix :: PrefixName -> PrefixAsInfix+mkPrefixAsInfix = PrefixAsInfix++prefixAsInfixFixity :: PrefixAsInfix -> Fixity.Fixity+prefixAsInfixFixity (PrefixAsInfix PrefixName {..}) =+  fromMaybe Fixity.defaultFixity $ lookup name fixities++parensNeeded :: GHC.OccName -> Bool+parensNeeded = GHC.isSymOcc
+ src/HIndent/Ast/Name/RecordField.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Name.RecordField+  ( FieldName+  , mkFieldNameFromFieldOcc+  , mkFieldNameFromAmbiguousFieldOcc+  , mkFieldNameFromFieldLabelStrings+  , mkFieldNameFromLabels+  ) where++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import qualified GHC.Data.FastString as GHC+import qualified GHC.Hs as GHC+import HIndent.Ast.Name.Prefix (PrefixName, fromString, mkPrefixName)+import HIndent.Ast.NodeComments (NodeComments(..))+import HIndent.Ast.WithComments (WithComments, flattenComments, fromGenLocated)+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators (hDotSep)+import HIndent.Pretty.NodeComments+import qualified Language.Haskell.Syntax.Basic as GHC++newtype FieldName =+  FieldName (NonEmpty (WithComments PrefixName))++mkFieldNameFromLabels :: NonEmpty (WithComments PrefixName) -> FieldName+mkFieldNameFromLabels = FieldName++instance CommentExtraction FieldName where+  nodeComments FieldName {} = NodeComments [] [] []++instance Pretty FieldName where+  pretty' (FieldName labels) = hDotSep $ pretty <$> NonEmpty.toList labels++mkFieldNameFromFieldOcc :: GHC.FieldOcc GHC.GhcPs -> FieldName+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkFieldNameFromFieldOcc GHC.FieldOcc {..} =+  FieldName $ pure $ mkPrefixName <$> fromGenLocated foLabel+#else+mkFieldNameFromFieldOcc GHC.FieldOcc {..} =+  FieldName $ pure $ mkPrefixName <$> fromGenLocated rdrNameFieldOcc+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkFieldNameFromAmbiguousFieldOcc :: GHC.FieldOcc GHC.GhcPs -> FieldName+mkFieldNameFromAmbiguousFieldOcc = mkFieldNameFromFieldOcc+#else+mkFieldNameFromAmbiguousFieldOcc :: GHC.AmbiguousFieldOcc GHC.GhcPs -> FieldName+mkFieldNameFromAmbiguousFieldOcc (GHC.Unambiguous GHC.NoExtField name) =+  FieldName $ pure $ mkPrefixName <$> fromGenLocated name+mkFieldNameFromAmbiguousFieldOcc (GHC.Ambiguous GHC.NoExtField name) =+  FieldName $ pure $ mkPrefixName <$> fromGenLocated name+#endif+mkFieldNameFromFieldLabelStrings :: GHC.FieldLabelStrings GHC.GhcPs -> FieldName+mkFieldNameFromFieldLabelStrings (GHC.FieldLabelStrings labels) =+  maybe (error "FieldLabelStrings: expected non-empty label path") FieldName+    $ NonEmpty.nonEmpty+    $ fmap toSegment labels+  where+    toSegment =+      flattenComments+        . fmap+            (fmap (fromString . GHC.unpackFS . GHC.field_label)+               . fromGenLocated+               . GHC.dfoLabel)+        . fromGenLocated
+ src/HIndent/Ast/NodeComments.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.NodeComments+  ( NodeComments(..)+  , fromEpAnn+  ) where++import qualified GHC.Hs as GHC+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Pragma++-- | Comments belonging to an AST node.+data NodeComments = NodeComments+  { commentsBefore :: [GHC.LEpaComment]+  , commentsOnSameLine :: [GHC.LEpaComment]+  , commentsAfter :: [GHC.LEpaComment]+  } deriving (Eq)++instance Semigroup NodeComments where+  x <> y =+    NodeComments+      { commentsBefore = commentsBefore x <> commentsBefore y+      , commentsOnSameLine = commentsOnSameLine x <> commentsOnSameLine y+      , commentsAfter = commentsAfter x <> commentsAfter y+      }++instance Monoid NodeComments where+  mempty =+    NodeComments+      {commentsBefore = [], commentsOnSameLine = [], commentsAfter = []}++fromEpAnn :: GHC.EpAnn a -> NodeComments+fromEpAnn = fromEpAnn' . filterOutEofAndPragmasFromAnn++fromEpAnn' :: GHC.EpAnn a -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+fromEpAnn' GHC.EpAnn {..} = NodeComments {..}+  where+    commentsBefore = GHC.priorComments comments+    commentsOnSameLine =+      filter isCommentOnSameLine $ GHC.getFollowingComments comments+    commentsAfter =+      filter (not . isCommentOnSameLine) $ GHC.getFollowingComments comments+    isCommentOnSameLine (GHC.L comAnn _) =+      GHC.srcSpanEndLine (GHC.epaLocationRealSrcSpan entry)+        == GHC.srcSpanStartLine (GHC.epaLocationRealSrcSpan comAnn)+#else+fromEpAnn' GHC.EpAnn {..} = NodeComments {..}+  where+    commentsBefore = GHC.priorComments comments+    commentsOnSameLine =+      filter isCommentOnSameLine $ GHC.getFollowingComments comments+    commentsAfter =+      filter (not . isCommentOnSameLine) $ GHC.getFollowingComments comments+    isCommentOnSameLine (GHC.L comAnn _) =+      GHC.srcSpanEndLine (GHC.anchor entry)+        == GHC.srcSpanStartLine (GHC.anchor comAnn)+#if !MIN_VERSION_ghc_lib_parser(9, 10, 1)+fromEpAnn' GHC.EpAnnNotUsed = NodeComments [] [] []+#endif+#endif+filterOutEofAndPragmasFromAnn :: GHC.EpAnn ann -> GHC.EpAnn ann+filterOutEofAndPragmasFromAnn GHC.EpAnn {..} =+  GHC.EpAnn {comments = filterOutEofAndPragmasFromComments comments, ..}+#if !MIN_VERSION_ghc_lib_parser(9, 10, 1)+filterOutEofAndPragmasFromAnn GHC.EpAnnNotUsed = GHC.EpAnnNotUsed+#endif+filterOutEofAndPragmasFromComments :: GHC.EpAnnComments -> GHC.EpAnnComments+filterOutEofAndPragmasFromComments comments =+  GHC.EpaCommentsBalanced+    { priorComments = filterOutEofAndPragmas $ GHC.priorComments comments+    , followingComments =+        filterOutEofAndPragmas $ GHC.getFollowingComments comments+    }++filterOutEofAndPragmas ::+     [GHC.GenLocated l GHC.EpaComment] -> [GHC.GenLocated l GHC.EpaComment]+filterOutEofAndPragmas = filter isNeitherEofNorPragmaComment++isNeitherEofNorPragmaComment :: GHC.GenLocated l GHC.EpaComment -> Bool+#if !MIN_VERSION_ghc_lib_parser(9, 10, 1)+isNeitherEofNorPragmaComment (GHC.L _ (GHC.EpaComment GHC.EpaEofComment _)) =+  False+#endif+isNeitherEofNorPragmaComment (GHC.L _ (GHC.EpaComment tok _)) =+  not $ isPragma tok
+ src/HIndent/Ast/Pattern.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Pattern+  ( Pattern+  , PatInsidePatDecl+  , mkPattern+  , mkPatInsidePatDecl+  ) where++import Control.Monad+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE+import qualified GHC.Types.Basic as GHC+import qualified GHC.Types.SrcLoc as GHC+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.Expression.Splice+import HIndent.Ast.Name.Infix hiding (unlessSpecialOp)+import qualified HIndent.Ast.Name.Infix as InfixName+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments hiding (fromEpAnn)+import HIndent.Ast.Pattern.RecordFields+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments (CommentExtraction(..))++data Pattern+  = WildCard+  | Variable (WithComments PrefixName)+  | Lazy (WithComments Pattern)+  | As+      { name :: WithComments PrefixName+      , pat :: WithComments Pattern+      }+  | Parenthesized (WithComments Pattern)+  | Bang (WithComments Pattern)+  | List [WithComments Pattern]+  | Tuple+      { boxed :: Bool+      , patterns :: [WithComments Pattern]+      }+  | Sum+      { pat :: WithComments Pattern+      , position :: Int+      , arity :: Int+      }+  | PrefixConstructor+      { name :: WithComments PrefixName+      , patterns :: [WithComments Pattern]+      }+  | InfixConstructor+      { left :: WithComments Pattern+      , operator :: WithComments InfixName+      , right :: WithComments Pattern+      }+  | RecordConstructor+      { name :: WithComments PrefixName+      , fields :: RecordFieldsPat+      }+  | View+      { expression :: WithComments Expression+      , pat :: WithComments Pattern+      }+  | Splice (WithComments Splice)+  | Literal (GHC.HsLit GHC.GhcPs)+  | Overloaded (GHC.HsOverLit GHC.GhcPs)+  | NPlusK+      { n :: WithComments PrefixName+      , k :: GHC.HsOverLit GHC.GhcPs+      }+  | Signature+      { pat :: WithComments Pattern+      , sig :: WithComments Type+      }+  | Or (NonEmpty (WithComments Pattern))++instance CommentExtraction Pattern where+  nodeComments _ = NodeComments [] [] []++instance Pretty Pattern where+  pretty' WildCard = string "_"+  pretty' (Variable name) = pretty name+  pretty' (Lazy pat) = string "~" >> pretty pat+  pretty' As {..} = pretty name >> string "@" >> pretty pat+  pretty' (Parenthesized pat) = parens $ pretty pat+  pretty' (Bang pat) = string "!" >> pretty pat+  pretty' (List pats) = hList $ pretty <$> pats+  pretty' Tuple {boxed = True, ..} = hTuple $ pretty <$> patterns+  pretty' Tuple {boxed = False, ..} = hUnboxedTuple $ pretty <$> patterns+  pretty' Sum {..} = do+    string "(#"+    forM_ [1 .. arity] $ \idx -> do+      if idx == position+        then string " " >> pretty pat >> string " "+        else string " "+      when (idx < arity) $ string "|"+    string "#)"+  pretty' PrefixConstructor {..} = do+    pretty name+    spacePrefixed $ pretty <$> patterns+  pretty' InfixConstructor {..} = do+    pretty left+    InfixName.unlessSpecialOp (getNode operator) space+    pretty operator+    InfixName.unlessSpecialOp (getNode operator) space+    pretty right+  pretty' RecordConstructor {..} = (pretty name >> space) |=> pretty fields+  pretty' View {..} = spaced [pretty expression, string "->", pretty pat]+  pretty' (Splice splice) = pretty splice+  pretty' (Literal lit) = pretty lit+  pretty' (Overloaded lit) = pretty lit+  pretty' NPlusK {..} = pretty n >> string "+" >> pretty k+  pretty' Signature {..} = spaced [pretty pat, string "::", pretty sig]+  pretty' (Or pats) = inter (string "; ") $ pretty <$> NE.toList pats++mkPattern :: GHC.Pat GHC.GhcPs -> Pattern+mkPattern GHC.WildPat {} = WildCard+mkPattern (GHC.VarPat _ x) = Variable $ mkPrefixName <$> fromGenLocated x+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkPattern GHC.EmbTyPat {} = notGeneratedByParser+mkPattern GHC.InvisPat {} = notGeneratedByParser+#endif+mkPattern (GHC.LazyPat _ x) = Lazy $ mkPattern <$> fromGenLocated x+#if MIN_VERSION_ghc_lib_parser(9, 6, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkPattern (GHC.AsPat _ a _ b) =+  As+    { name = mkPrefixName <$> fromGenLocated a+    , pat = mkPattern <$> fromGenLocated b+    }+#else+mkPattern (GHC.AsPat _ a b) =+  As+    { name = mkPrefixName <$> fromGenLocated a+    , pat = mkPattern <$> fromGenLocated b+    }+#endif+#if MIN_VERSION_ghc_lib_parser(9, 4, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkPattern (GHC.ParPat _ _ inner _) =+  Parenthesized $ mkPattern <$> fromGenLocated inner+#else+mkPattern (GHC.ParPat _ inner) =+  Parenthesized $ mkPattern <$> fromGenLocated inner+#endif+mkPattern (GHC.BangPat _ x) = Bang $ mkPattern <$> fromGenLocated x+mkPattern (GHC.ListPat _ xs) = List $ fmap (fmap mkPattern . fromGenLocated) xs+mkPattern (GHC.TuplePat _ pats GHC.Boxed) =+  Tuple {boxed = True, patterns = fmap (fmap mkPattern . fromGenLocated) pats}+mkPattern (GHC.TuplePat _ pats GHC.Unboxed) =+  Tuple {boxed = False, patterns = fmap (fmap mkPattern . fromGenLocated) pats}+mkPattern (GHC.SumPat _ x position numElem) =+  Sum+    {pat = mkPattern <$> fromGenLocated x, position = position, arity = numElem}+mkPattern GHC.ConPat {..} =+  case pat_args of+    GHC.PrefixCon _ as ->+      PrefixConstructor+        { name = mkPrefixName <$> fromGenLocated pat_con+        , patterns = fmap (fmap mkPattern . fromGenLocated) as+        }+    GHC.RecCon rec ->+      RecordConstructor+        { name = mkPrefixName <$> fromGenLocated pat_con+        , fields = mkRecordFieldsPat rec+        }+    GHC.InfixCon a b ->+      InfixConstructor+        { left = mkPattern <$> fromGenLocated a+        , operator = mkInfixName <$> fromGenLocated pat_con+        , right = mkPattern <$> fromGenLocated b+        }+mkPattern (GHC.ViewPat _ l r) =+  View+    { expression = mkExpression <$> fromGenLocated l+    , pat = mkPattern <$> fromGenLocated r+    }+mkPattern (GHC.SplicePat _ x) = Splice $ mkWithComments $ mkSplice x+mkPattern (GHC.LitPat _ x) = Literal x+mkPattern (GHC.NPat _ x _ _) = Overloaded $ GHC.unLoc x+mkPattern (GHC.NPlusKPat _ n k _ _ _) =+  NPlusK {n = mkPrefixName <$> fromGenLocated n, k = GHC.unLoc k}+mkPattern (GHC.SigPat _ l r) =+  Signature+    { pat = mkPattern <$> fromGenLocated l+    , sig =+        flattenComments+          $ fmap mkType+              <$> fromEpAnn (GHC.hsps_ext r) (fromGenLocated $ GHC.hsps_body r)+    }+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkPattern (GHC.OrPat _ pats) = Or $ fmap (fmap mkPattern . fromGenLocated) pats+#endif+newtype PatInsidePatDecl =+  PatInsidePatDecl Pattern++instance CommentExtraction PatInsidePatDecl where+  nodeComments (PatInsidePatDecl p) = nodeComments p++instance Pretty PatInsidePatDecl where+  pretty' (PatInsidePatDecl InfixConstructor {..}) =+    spaced [pretty left, pretty operator, pretty right]+  pretty' (PatInsidePatDecl p) = pretty p++mkPatInsidePatDecl :: GHC.Pat GHC.GhcPs -> PatInsidePatDecl+mkPatInsidePatDecl = PatInsidePatDecl . mkPattern+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+notGeneratedByParser :: a+notGeneratedByParser = error "This AST node is not generated by the parser."+#endif
+ src/HIndent/Ast/Pattern.hs-boot view
@@ -0,0 +1,17 @@+{-# LANGUAGE FlexibleInstances #-}++module HIndent.Ast.Pattern+  ( Pattern+  , mkPattern+  ) where++import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty.NodeComments+import {-# SOURCE #-} HIndent.Pretty++data Pattern++instance CommentExtraction Pattern+instance Pretty Pattern++mkPattern :: GHC.Pat GHC.GhcPs -> Pattern
+ src/HIndent/Ast/Pattern/RecordFields.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Pattern.RecordFields+  ( RecordFieldsPat+  , mkRecordFieldsPat+  ) where++import Data.Maybe (isJust)+import HIndent.Ast.NodeComments+import HIndent.Ast.Record.Field (PatField, mkPatField)+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data RecordFieldsPat = RecordFieldsPat+  { fields :: [WithComments PatField]+  , dotdot :: Bool+  }++instance CommentExtraction RecordFieldsPat where+  nodeComments RecordFieldsPat {} = NodeComments [] [] []++instance Pretty RecordFieldsPat where+  pretty' (RecordFieldsPat fs dd) =+    case fieldPrinters of+      [] -> string "{}"+      [x] -> braces x+      xs -> hvFields xs+    where+      fieldPrinters = fmap pretty fs ++ [string ".." | dd]++mkRecordFieldsPat ::+     GHC.HsRecFields GHC.GhcPs (GHC.LPat GHC.GhcPs) -> RecordFieldsPat+mkRecordFieldsPat GHC.HsRecFields {..} =+  RecordFieldsPat+    { fields = fmap (fmap mkPatField . fromGenLocated) rec_flds+    , dotdot = isJust rec_dotdot+    }
+ src/HIndent/Ast/Record/Field.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Record.Field+  ( ExprField+  , PatField+  , mkExprField+  , mkPatField+  ) where++import HIndent.Applicative (whenJust)+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.Name.RecordField (FieldName, mkFieldNameFromFieldOcc)+import HIndent.Ast.NodeComments (NodeComments(..))+import {-# SOURCE #-} HIndent.Ast.Pattern (Pattern, mkPattern)+import HIndent.Ast.WithComments (WithComments, fromGenLocated)+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+  ( (<-|>)+  , indentedBlock+  , newline+  , space+  , string+  )+import HIndent.Pretty.NodeComments (CommentExtraction(..))++type ExprField = Field Expression++type PatField = Field Pattern++data Field rhs = Field+  { name :: WithComments FieldName+  , value :: Maybe (WithComments rhs)+  }++instance CommentExtraction (Field rhs) where+  nodeComments Field {} = NodeComments [] [] []++instance Pretty ExprField where+  pretty' Field {..} = do+    pretty name+    whenJust value $ \val -> do+      string " ="+      (space >> pretty val) <-|> (newline >> indentedBlock (pretty val))++instance Pretty PatField where+  pretty' Field {..} = do+    pretty name+    whenJust value $ \val -> do+      string " = "+      pretty val+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkExprField ::+     GHC.HsFieldBind (GHC.LFieldOcc GHC.GhcPs) (GHC.LHsExpr GHC.GhcPs)+  -> ExprField+mkExprField GHC.HsFieldBind {..} =+  Field+    { name = mkFieldNameFromFieldOcc <$> fromGenLocated hfbLHS+    , value =+        if hfbPun+          then Nothing+          else Just (mkExpression <$> fromGenLocated hfbRHS)+    }+#else+mkExprField ::+     GHC.HsRecField' (GHC.FieldOcc GHC.GhcPs) (GHC.LHsExpr GHC.GhcPs)+  -> ExprField+mkExprField GHC.HsRecField {..} =+  Field+    { name = mkFieldNameFromFieldOcc <$> fromGenLocated hsRecFieldLbl+    , value =+        if hsRecPun+          then Nothing+          else Just (mkExpression <$> fromGenLocated hsRecFieldArg)+    }+#endif++#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkPatField ::+     GHC.HsFieldBind (GHC.LFieldOcc GHC.GhcPs) (GHC.LPat GHC.GhcPs) -> PatField+mkPatField GHC.HsFieldBind {..} =+  Field+    { name = mkFieldNameFromFieldOcc <$> fromGenLocated hfbLHS+    , value =+        if hfbPun+          then Nothing+          else Just (mkPattern <$> fromGenLocated hfbRHS)+    }+#else+mkPatField ::+     GHC.HsRecField' (GHC.FieldOcc GHC.GhcPs) (GHC.LPat GHC.GhcPs) -> PatField+mkPatField GHC.HsRecField {..} =+  Field+    { name = mkFieldNameFromFieldOcc <$> fromGenLocated hsRecFieldLbl+    , value =+        if hsRecPun+          then Nothing+          else Just (mkPattern <$> fromGenLocated hsRecFieldArg)+    }+#endif
+ src/HIndent/Ast/Role.hs view
@@ -0,0 +1,30 @@+module HIndent.Ast.Role+  ( Role+  , mkRole+  ) where++import qualified GHC.Core.TyCon as GHC+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Role+  = Nominal+  | Representational+  | Phantom++instance CommentExtraction Role where+  nodeComments Nominal = NodeComments [] [] []+  nodeComments Representational = NodeComments [] [] []+  nodeComments Phantom = NodeComments [] [] []++instance Pretty Role where+  pretty' Nominal = string "nominal"+  pretty' Representational = string "representational"+  pretty' Phantom = string "phantom"++mkRole :: GHC.Role -> Role+mkRole GHC.Nominal = Nominal+mkRole GHC.Representational = Representational+mkRole GHC.Phantom = Phantom
+ src/HIndent/Ast/Statement.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Statement+  ( ExprStatement+  , CmdStatement+  , mkExprStatement+  , mkCmdStatement+  ) where++import qualified GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Ast.Cmd (Cmd, mkCmd)+import {-# SOURCE #-} HIndent.Ast.Expression (Expression, mkExpression)+import HIndent.Ast.LocalBinds (LocalBinds, mkLocalBinds)+import HIndent.Ast.Pattern (Pattern, mkPattern)+import HIndent.Ast.WithComments (WithComments, fromGenLocated, prettyWith)+import {-# SOURCE #-} HIndent.Pretty (Pretty(..), pretty)+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments (CommentExtraction(..), emptyNodeComments)++type ExprStatement = Statement Expression++type CmdStatement = Statement Cmd++data Statement a+  = Expression (WithComments a)+  | Binding+      { lhsPattern :: WithComments Pattern+      , rhs :: WithComments a+      }+  | LetBinding (WithComments LocalBinds)+  | Parallel [[WithComments (Statement a)]]+  | Transform+      { steps :: [WithComments (Statement a)]+      , using :: WithComments a+      }+  | Recursive+      { block :: WithComments [WithComments (Statement a)]+      }++instance CommentExtraction (Statement a) where+  nodeComments _ = emptyNodeComments++instance Pretty a => Pretty (Statement a) where+  pretty' (Expression expr) = pretty expr+  pretty' Binding {..} = do+    pretty lhsPattern+    string " <-"+    hor <-|> ver+    where+      hor = space >> pretty rhs+      ver = newline >> indentedBlock (pretty rhs)+  pretty' (LetBinding binds) = string "let " |=> pretty binds+  pretty' (Parallel blocks)+    | any ((> 1) . length) blocks =+      vBarSep $ fmap (vCommaSep . fmap pretty) blocks+    | otherwise = hvBarSep $ fmap (hvCommaSep . fmap pretty) blocks+  pretty' Transform {..} =+    vCommaSep $ fmap pretty steps ++ [string "then " >> pretty using]+  pretty' Recursive {..} =+    string "rec " |=> prettyWith block (lined . fmap pretty)++mkExprStatement ::+     GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> ExprStatement+mkExprStatement (GHC.LastStmt _ expr _ _) =+  Expression $ mkExpression <$> fromGenLocated expr+mkExprStatement (GHC.BindStmt _ pat expr) =+  Binding+    { lhsPattern = mkPattern <$> fromGenLocated pat+    , rhs = mkExpression <$> fromGenLocated expr+    }+mkExprStatement (GHC.BodyStmt _ body _ _) =+  Expression $ mkExpression <$> fromGenLocated body+mkExprStatement (GHC.LetStmt _ binds) =+  case mkLocalBinds binds of+    Just localBinds -> LetBinding localBinds+    Nothing ->+      error+        "`ghc-lib-parser` never generates a `LetStmt` without bindings in the parsed AST."+mkExprStatement (GHC.ParStmt _ blocks _ _) =+  Parallel+    $ fmap+        (\(GHC.ParStmtBlock _ stmts _ _) ->+           fmap (fmap mkExprStatement . fromGenLocated) stmts)+        blocks+mkExprStatement GHC.TransStmt {..} =+  Transform+    { steps = fmap (fmap mkExprStatement . fromGenLocated) trS_stmts+    , using = mkExpression <$> fromGenLocated trS_using+    }+mkExprStatement GHC.RecStmt {..} =+  Recursive+    { block =+        fmap+          (fmap (fmap mkExprStatement . fromGenLocated))+          (fromGenLocated recS_stmts)+    }+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkExprStatement GHC.ApplicativeStmt {} =+  error "`ghc-lib-parser` never generates this AST node."+#endif+mkExprStatement GHC.XStmtLR {} =+  error "`ghc-lib-parser` never generates this AST node."++mkCmdStatement ::+     GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs) -> CmdStatement+mkCmdStatement (GHC.LastStmt _ cmd _ _) =+  Expression $ mkCmd <$> fromGenLocated cmd+mkCmdStatement (GHC.BindStmt _ pat cmd) =+  Binding+    { lhsPattern = mkPattern <$> fromGenLocated pat+    , rhs = mkCmd <$> fromGenLocated cmd+    }+mkCmdStatement (GHC.BodyStmt _ cmd _ _) =+  Expression $ mkCmd <$> fromGenLocated cmd+mkCmdStatement (GHC.LetStmt _ binds) =+  case mkLocalBinds binds of+    Just localBinds -> LetBinding localBinds+    Nothing ->+      error+        "`ghc-lib-parser` never generates a `LetStmt` without bindings in the parsed AST."+mkCmdStatement GHC.ParStmt {} =+  error "`ghc-lib-parser` never generates this AST node."+mkCmdStatement GHC.TransStmt {} =+  error "`ghc-lib-parser` never generates this AST node."+mkCmdStatement GHC.RecStmt {} =+  error "`ghc-lib-parser` never generates this AST node."+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkCmdStatement GHC.ApplicativeStmt {} =+  error "`ghc-lib-parser` never generates this AST node."+#endif+mkCmdStatement GHC.XStmtLR {} =+  error "`ghc-lib-parser` never generates this AST node."
+ src/HIndent/Ast/Type.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoFieldSelectors #-}++module HIndent.Ast.Type+  ( Type+  , VerticalFuncType+  , DeclSigType+  , InstDeclType+  , mkType+  , mkTypeFromHsSigType+  , mkTypeFromLHsWcType+  , mkVerticalFuncType+  , mkDeclSigType+  , mkInstDeclType+  ) where++import Control.Monad.RWS (gets)+import HIndent.Ast.Declaration.Data.Record.Field+import HIndent.Ast.Expression.Splice+import HIndent.Ast.Name.Infix+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Type.Bang+import HIndent.Ast.Type.Forall+  ( Forall+  , mkForallFromOuter+  , mkForallFromTelescope+  )+import HIndent.Ast.Type.ImplicitParameterName+  ( ImplicitParameterName+  , mkImplicitParameterName+  )+import HIndent.Ast.Type.Literal+import HIndent.Ast.Type.Multiplicity+import HIndent.Ast.WithComments+import HIndent.Config+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import HIndent.Pretty.Types+import HIndent.Printer++data Type+  = UniversalType+      { telescope :: WithComments Forall+      , body :: WithComments Type+      }+  | ConstrainedType+      { context :: WithComments Context+      , body :: WithComments Type+      }+  | Variable+      { isPromoted :: Bool+      , name :: WithComments PrefixName+      }+  | Application+      { function :: WithComments Type+      , argument :: WithComments Type+      }+  | KindApplication+      { base :: WithComments Type+      , kind :: WithComments Type+      }+  | Function+      { multiplicity :: Multiplicity+      , from :: WithComments Type+      , to :: WithComments Type+      }+  | List+      { elementType :: WithComments Type+      }+  | Tuple+      { isUnboxed :: Bool+      , elements :: [WithComments Type]+      }+  | Sum+      { elements :: [WithComments Type]+      }+  | InfixType+      { left :: WithComments Type+      , operator :: WithComments InfixName+      , right :: WithComments Type+      }+  | Parenthesized+      { inner :: WithComments Type+      }+  | ImplicitParameter+      { ipName :: WithComments ImplicitParameterName+      , paramType :: WithComments Type+      }+  | Star+  | KindSig+      { annotated :: WithComments Type+      , kind :: WithComments Type+      }+  | Splice+      { splice :: Splice+      }+  | StrictType+      { bang :: Bang+      , baseType :: WithComments Type+      }+  | RecordType+      { fields :: [WithComments RecordField]+      }+  | PromotedList+      { elements :: [WithComments Type]+      }+  | PromotedTuple+      { elements :: [WithComments Type]+      }+  | Literal+      { literal :: Literal+      }+  | Wildcard++instance CommentExtraction Type where+  nodeComments (UniversalType {}) = NodeComments [] [] []+  nodeComments (ConstrainedType {}) = NodeComments [] [] []+  nodeComments (Variable {}) = NodeComments [] [] []+  nodeComments (Application {}) = NodeComments [] [] []+  nodeComments (KindApplication {}) = NodeComments [] [] []+  nodeComments (Function {}) = NodeComments [] [] []+  nodeComments (List (getNode -> List {})) = NodeComments [] [] []+  nodeComments (List x) = nodeComments x+  nodeComments (Tuple _ xs) = mconcat $ nodeComments <$> xs+  nodeComments (Sum xs) = mconcat $ nodeComments <$> xs+  nodeComments (InfixType {}) = NodeComments [] [] []+  nodeComments (Parenthesized (getNode -> Parenthesized {})) =+    NodeComments [] [] []+  nodeComments (Parenthesized x) = nodeComments x+  nodeComments (ImplicitParameter {}) = NodeComments [] [] []+  nodeComments Star = NodeComments [] [] []+  nodeComments (KindSig {}) = NodeComments [] [] []+  nodeComments (Splice {}) = NodeComments [] [] []+  nodeComments (StrictType {}) = NodeComments [] [] []+  nodeComments (RecordType xs) = mconcat $ nodeComments <$> xs+  nodeComments (PromotedList xs) = mconcat $ nodeComments <$> xs+  nodeComments (PromotedTuple xs) = mconcat $ nodeComments <$> xs+  nodeComments (Literal {}) = NodeComments [] [] []+  nodeComments Wildcard = NodeComments [] [] []++instance Pretty Type where+  pretty' UniversalType {..} = (pretty telescope >> space) |=> pretty body+  pretty' ConstrainedType {..} = hor <-|> ver+    where+      hor = spaced [pretty context, string "=>", pretty body]+      ver = do+        pretty context+        lined [string " =>", indentedBlock $ pretty body]+  pretty' Variable {isPromoted = False, ..} = pretty name+  pretty' Variable {isPromoted = True, ..} = string "'" >> pretty name+  pretty' Application {..} = hor <-|> ver+    where+      hor = spaced [pretty function, pretty argument]+      ver = verticalApp function argument+      verticalApp left right = do+        case getNode left of+          Application {function = l', argument = r'} ->+            verticalApp l' r' >> newline >> indentedBlock (pretty right)+          _ -> pretty left >> newline >> indentedBlock (pretty right)+  pretty' KindApplication {..} = pretty base >> string " @" >> pretty kind+  pretty' Function {..} =+    (pretty from+       >> if isUnrestricted multiplicity+            then string " -> "+            else space >> pretty multiplicity >> string " -> ")+      |=> pretty to+  pretty' List {..} = brackets $ pretty elementType+  pretty' Tuple {isUnboxed = True, elements = []} = string "(# #)"+  pretty' Tuple {isUnboxed = False, elements = []} = string "()"+  pretty' Tuple {isUnboxed = True, ..} = hvUnboxedTuple' $ fmap pretty elements+  pretty' Tuple {isUnboxed = False, ..} = hvTuple' $ fmap pretty elements+  pretty' Sum {..} = hvUnboxedSum' $ fmap pretty elements+  pretty' InfixType {..} = do+    lineBreak <- gets (configLineBreaks . psConfig)+    if getInfixName (getNode operator) `elem` lineBreak+      then do+        pretty left+        newline+        pretty operator+        space+        pretty right+      else spaced [pretty left, pretty operator, pretty right]+  pretty' Parenthesized {..} = parens $ pretty inner+  pretty' ImplicitParameter {..} =+    spaced [pretty ipName, string "::", pretty paramType]+  pretty' Star = string "*"+  pretty' KindSig {..} = spaced [pretty annotated, string "::", pretty kind]+  pretty' Splice {..} = pretty splice+  pretty' StrictType {..} = pretty bang >> pretty baseType+  pretty' RecordType {..} = hvFields $ fmap pretty fields+  pretty' PromotedList {elements = []} = string "'[]"+  pretty' PromotedList {..} = hvPromotedList $ fmap pretty elements+  pretty' PromotedTuple {..} = hPromotedTuple $ fmap pretty elements+  pretty' Literal {..} = pretty literal+  pretty' Wildcard = string "_"++mkType :: GHC.HsType GHC.GhcPs -> Type+mkType (GHC.HsForAllTy _ tele body) =+  UniversalType+    { telescope = mkForallFromTelescope tele+    , body = mkType <$> fromGenLocated body+    }+mkType GHC.HsQualTy {..} =+  ConstrainedType+    { context = mkWithComments $ Context hst_ctxt+    , body = mkType <$> fromGenLocated hst_body+    }+mkType (GHC.HsTyVar _ GHC.IsPromoted x) =+  Variable {isPromoted = True, name = mkPrefixName <$> fromGenLocated x}+mkType (GHC.HsTyVar _ GHC.NotPromoted x) =+  Variable {isPromoted = False, name = mkPrefixName <$> fromGenLocated x}+mkType (GHC.HsAppTy _ l r) =+  Application+    { function = mkType <$> fromGenLocated l+    , argument = mkType <$> fromGenLocated r+    }+#if MIN_VERSION_ghc_lib_parser(9, 8, 1) && !MIN_VERSION_ghc_lib_parser(9, 10, 1)+mkType (GHC.HsAppKindTy _ l _ r) =+  KindApplication+    {base = mkType <$> fromGenLocated l, kind = mkType <$> fromGenLocated r}+#else+mkType (GHC.HsAppKindTy _ l r) =+  KindApplication+    {base = mkType <$> fromGenLocated l, kind = mkType <$> fromGenLocated r}+#endif+mkType (GHC.HsFunTy _ arr a b) =+  Function+    { multiplicity = mkMultiplicity arr+    , from = mkType <$> fromGenLocated a+    , to = mkType <$> fromGenLocated b+    }+mkType (GHC.HsListTy _ xs) = List {elementType = mkType <$> fromGenLocated xs}+mkType (GHC.HsTupleTy _ sort xs) =+  Tuple+    { isUnboxed =+        case sort of+          GHC.HsUnboxedTuple -> True+          _ -> False+    , elements = fmap (fmap mkType . fromGenLocated) xs+    }+mkType (GHC.HsSumTy _ xs) =+  Sum {elements = fmap (fmap mkType . fromGenLocated) xs}+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+mkType (GHC.HsOpTy _ _ l op r) =+  InfixType+    { left = mkType <$> fromGenLocated l+    , operator = mkInfixName <$> fromGenLocated op+    , right = mkType <$> fromGenLocated r+    }+#else+mkType (GHC.HsOpTy _ l op r) =+  InfixType+    { left = mkType <$> fromGenLocated l+    , operator = mkInfixName <$> fromGenLocated op+    , right = mkType <$> fromGenLocated r+    }+#endif+mkType (GHC.HsParTy _ inside) =+  Parenthesized {inner = mkType <$> fromGenLocated inside}+mkType (GHC.HsIParamTy _ x ty) =+  ImplicitParameter+    { ipName = mkImplicitParameterName <$> fromGenLocated x+    , paramType = mkType <$> fromGenLocated ty+    }+mkType GHC.HsStarTy {} = Star+mkType (GHC.HsKindSig _ t k) =+  KindSig+    { annotated = mkType <$> fromGenLocated t+    , kind = mkType <$> fromGenLocated k+    }+mkType (GHC.HsSpliceTy _ sp) = Splice {splice = mkSplice sp}+mkType GHC.HsDocTy {} = error "HsDocTy not supported"+mkType (GHC.HsBangTy _ pack x) =+  StrictType {bang = mkBang pack, baseType = mkType <$> fromGenLocated x}+mkType (GHC.HsRecTy _ xs) =+  RecordType {fields = fmap (fromGenLocated . fmap mkRecordField) xs}+mkType (GHC.HsExplicitListTy _ _ xs) =+  PromotedList {elements = fmap (fmap mkType . fromGenLocated) xs}+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkType (GHC.HsExplicitTupleTy _ _ xs) =+  PromotedTuple {elements = fmap (fmap mkType . fromGenLocated) xs}+#else+mkType (GHC.HsExplicitTupleTy _ xs) =+  PromotedTuple {elements = fmap (fmap mkType . fromGenLocated) xs}+#endif+mkType (GHC.HsTyLit _ x) = Literal {literal = mkLiteral x}+mkType GHC.HsWildCardTy {} = Wildcard+mkType GHC.XHsType {} = error "XHsType not generated by parser"++mkTypeFromHsSigType :: GHC.HsSigType GHC.GhcPs -> WithComments Type+mkTypeFromHsSigType GHC.HsSig {..} =+  case mkForallFromOuter sig_bndrs of+    Just telescope ->+      mkWithComments+        $ UniversalType+            {telescope = telescope, body = mkType <$> fromGenLocated sig_body}+    Nothing -> mkType <$> fromGenLocated sig_body++mkTypeFromLHsWcType ::+     GHC.LHsWcType (GHC.NoGhcTc GHC.GhcPs) -> WithComments Type+mkTypeFromLHsWcType GHC.HsWC {..} = mkType <$> fromGenLocated hswc_body++newtype VerticalFuncType =+  VerticalFuncType Type++instance CommentExtraction VerticalFuncType where+  nodeComments (VerticalFuncType t) = nodeComments t++instance Pretty VerticalFuncType where+  pretty' (VerticalFuncType Function {..}) = do+    pretty $ fmap mkVerticalFuncType from+    newline+    if isUnrestricted multiplicity+      then prefixed "-> " $ pretty $ fmap mkVerticalFuncType to+      else do+        pretty multiplicity+        string " -> "+        pretty $ fmap mkVerticalFuncType to+  pretty' (VerticalFuncType t) = pretty t++mkVerticalFuncType :: Type -> VerticalFuncType+mkVerticalFuncType = VerticalFuncType++newtype DeclSigType =+  DeclSigType Type++instance CommentExtraction DeclSigType where+  nodeComments (DeclSigType t) = nodeComments t++instance Pretty DeclSigType where+  pretty' (DeclSigType UniversalType {..}) = do+    pretty telescope+    case getNode body of+      ConstrainedType ctxt b ->+        let hor = space >> pretty ctxt+            ver = newline >> pretty ctxt+         in do+              hor <-|> ver+              newline+              prefixed "=> " $ pretty $ fmap mkVerticalFuncType b+      _ ->+        let hor = space >> pretty (DeclSigType <$> body)+            ver = newline >> pretty (DeclSigType <$> body)+         in hor <-|> ver+  pretty' (DeclSigType ConstrainedType {..}) = hor <-|> ver+    where+      hor = spaced [pretty context, string "=>", pretty body]+      ver = do+        pretty context+        newline+        prefixed "=> " $ pretty $ fmap mkVerticalFuncType body+  pretty' (DeclSigType Function {..}) = hor <-|> ver+    where+      hor = do+        pretty from+        if isUnrestricted multiplicity+          then string " -> "+          else space >> pretty multiplicity >> string " -> "+        pretty to+      ver = do+        pretty $ fmap mkVerticalFuncType from+        newline+        if isUnrestricted multiplicity+          then prefixed "-> " $ pretty $ mkVerticalFuncType <$> to+          else do+            pretty multiplicity+            string " -> "+            pretty $ mkVerticalFuncType <$> to+  pretty' (DeclSigType t) = pretty t++mkDeclSigType :: GHC.HsSigType GHC.GhcPs -> WithComments DeclSigType+mkDeclSigType hsSigType = DeclSigType <$> mkTypeFromHsSigType hsSigType++newtype InstDeclType =+  InstDeclType Type++instance CommentExtraction InstDeclType where+  nodeComments (InstDeclType t) = nodeComments t++instance Pretty InstDeclType where+  pretty' (InstDeclType UniversalType {..}) = do+    pretty telescope+    space+    pretty $ InstDeclType <$> body+  pretty' (InstDeclType ConstrainedType {..}) = hor <-|> ver+    where+      hor = spaced [pretty context, string "=>", pretty body]+      ver = do+        pretty context >> string " =>"+        newline+        indentedWithFixedLevel 9 $ pretty body+  pretty' (InstDeclType t) = pretty t++mkInstDeclType :: GHC.HsSigType GHC.GhcPs -> WithComments InstDeclType+mkInstDeclType hsSigType = InstDeclType <$> mkTypeFromHsSigType hsSigType
+ src/HIndent/Ast/Type.hs-boot view
@@ -0,0 +1,12 @@+module HIndent.Ast.Type where++import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty.NodeComments+import {-# SOURCE #-} HIndent.Pretty++data Type++instance CommentExtraction Type+instance Pretty Type++mkType :: GHC.HsType GHC.GhcPs -> Type
+ src/HIndent/Ast/Type/Bang.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Type.Bang+  ( Bang+  , mkBang+  ) where++import Control.Monad+import Data.Maybe+import HIndent.Ast.NodeComments+import HIndent.Ast.Type.Strictness+import HIndent.Ast.Type.Unpackedness+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Bang =+  Bang (Maybe Unpackedness) (Maybe Strictness)++instance CommentExtraction Bang where+  nodeComments _ = NodeComments [] [] []++instance Pretty Bang where+  pretty' (Bang unpack strictness) = do+    maybe (pure ()) pretty' unpack+    unless (isNothing unpack) space+    maybe (pure ()) pretty' strictness+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkBang :: GHC.HsBang -> Bang+mkBang (GHC.HsBang unpack strictness) =+  Bang (mkUnpackedness unpack) (mkStrictness strictness)+#else+mkBang :: GHC.HsSrcBang -> Bang+mkBang (GHC.HsSrcBang _ unpack strictness) =+  Bang (mkUnpackedness unpack) (mkStrictness strictness)+#endif
+ src/HIndent/Ast/Type/Forall.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Type.Forall+  ( Forall+  , mkForallFromTelescope+  , mkForallFromOuter+  ) where++import HIndent.Ast.NodeComments hiding (fromEpAnn)+import HIndent.Ast.Type.Variable+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Forall+  = Visible [WithComments TypeVariable] -- forall a b c ->+  | Invisible [WithComments TypeVariable] -- forall a b c.++instance CommentExtraction Forall where+  nodeComments _ = NodeComments [] [] []++instance Pretty Forall where+  pretty' (Visible vars) = do+    string "forall "+    spaced $ fmap pretty vars+    string " ->"+  pretty' (Invisible vars) = do+    string "forall "+    spaced $ fmap pretty vars+    dot++mkForallFromTelescope :: GHC.HsForAllTelescope GHC.GhcPs -> WithComments Forall+mkForallFromTelescope GHC.HsForAllVis {..} =+  fromEpAnn hsf_xvis+    $ Visible+    $ fmap (fmap mkTypeVariable . fromGenLocated) hsf_vis_bndrs+mkForallFromTelescope GHC.HsForAllInvis {..} =+  fromEpAnn hsf_xinvis+    $ Invisible+    $ fmap (fmap mkTypeVariable . fromGenLocated) hsf_invis_bndrs++mkForallFromOuter ::+     GHC.HsOuterTyVarBndrs flag GHC.GhcPs -> Maybe (WithComments Forall)+mkForallFromOuter (GHC.HsOuterExplicit ann xs) =+  Just+    $ fromEpAnn ann+    $ Invisible+    $ fmap (fmap mkTypeVariable . fromGenLocated) xs+mkForallFromOuter GHC.HsOuterImplicit {} = Nothing
+ src/HIndent/Ast/Type/ImplicitParameterName.hs view
@@ -0,0 +1,23 @@+module HIndent.Ast.Type.ImplicitParameterName+  ( ImplicitParameterName+  , mkImplicitParameterName+  ) where++import qualified GHC.Data.FastString as GHC+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++newtype ImplicitParameterName =+  ImplicitParameterName String++instance CommentExtraction ImplicitParameterName where+  nodeComments ImplicitParameterName {} = emptyNodeComments++instance Pretty ImplicitParameterName where+  pretty' (ImplicitParameterName s) = string "?" >> string s++mkImplicitParameterName :: GHC.HsIPName -> ImplicitParameterName+mkImplicitParameterName (GHC.HsIPName fs) =+  ImplicitParameterName $ GHC.unpackFS fs
+ src/HIndent/Ast/Type/Literal.hs view
@@ -0,0 +1,30 @@+module HIndent.Ast.Type.Literal+  ( Literal+  , mkLiteral+  ) where++import qualified GHC.Data.FastString as GHC+import HIndent.Ast.NodeComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import Text.Show.Unicode++data Literal+  = Numeric Integer+  | String String+  | Character Char++instance CommentExtraction Literal where+  nodeComments _ = NodeComments [] [] []++instance Pretty Literal where+  pretty' (Numeric n) = string $ show n+  pretty' (String s) = string $ ushow s+  pretty' (Character c) = string $ ushow c++mkLiteral :: GHC.HsTyLit GHC.GhcPs -> Literal+mkLiteral (GHC.HsNumTy _ n) = Numeric n+mkLiteral (GHC.HsStrTy _ s) = String (GHC.unpackFS s)+mkLiteral (GHC.HsCharTy _ c) = Character c
+ src/HIndent/Ast/Type/Multiplicity.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Type.Multiplicity+  ( Multiplicity+  , mkMultiplicity+  , isUnrestricted+  ) where++import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Ast.Type+import HIndent.Ast.WithComments+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Multiplicity+  = MkUnrestricted+  | MkLinear+  | MkExplicit (WithComments Type)++instance CommentExtraction Multiplicity where+  nodeComments MkUnrestricted = NodeComments [] [] []+  nodeComments MkLinear = NodeComments [] [] []+  nodeComments (MkExplicit mult) = nodeComments mult++instance Pretty Multiplicity where+  pretty' MkUnrestricted = pure ()+  pretty' MkLinear = string "%1"+  pretty' (MkExplicit mult) = string "%" >> pretty mult++mkMultiplicity :: GHC.HsArrow GHC.GhcPs -> Multiplicity+mkMultiplicity (GHC.HsUnrestrictedArrow _) = MkUnrestricted+mkMultiplicity (GHC.HsLinearArrow _) = MkLinear+#if MIN_VERSION_ghc_lib_parser(9, 10, 0)+mkMultiplicity (GHC.HsExplicitMult _ mult) =+  MkExplicit (mkType <$> fromGenLocated mult)+#else+mkMultiplicity (GHC.HsExplicitMult _ mult _) =+  MkExplicit (mkType <$> fromGenLocated mult)+#endif+isUnrestricted :: Multiplicity -> Bool+isUnrestricted MkUnrestricted = True+isUnrestricted _ = False
+ src/HIndent/Ast/Type/Strictness.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Type.Strictness+  ( Strictness+  , mkStrictness+  ) where++import qualified GHC.Hs as GHC+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Strictness+  = Lazy+  | Strict+  deriving (Eq)++instance CommentExtraction Strictness where+  nodeComments _ = NodeComments [] [] []++instance Pretty Strictness where+  pretty' Lazy = string "~"+  pretty' Strict = string "!"++mkStrictness :: GHC.SrcStrictness -> Maybe Strictness+mkStrictness GHC.SrcLazy = Just Lazy+mkStrictness GHC.SrcStrict = Just Strict+mkStrictness GHC.NoSrcStrict = Nothing
+ src/HIndent/Ast/Type/Unpackedness.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}++module HIndent.Ast.Type.Unpackedness+  ( Unpackedness+  , mkUnpackedness+  ) where++import qualified GHC.Hs as GHC+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments++data Unpackedness+  = Unpack+  | NoUnpack+  deriving (Eq)++instance CommentExtraction Unpackedness where+  nodeComments _ = NodeComments [] [] []++instance Pretty Unpackedness where+  pretty' Unpack = string "{-# UNPACK #-}"+  pretty' NoUnpack = string "{-# NOUNPACK #-}"++mkUnpackedness :: GHC.SrcUnpackedness -> Maybe Unpackedness+mkUnpackedness GHC.SrcUnpack = Just Unpack+mkUnpackedness GHC.SrcNoUnpack = Just NoUnpack+mkUnpackedness GHC.NoSrcUnpack = Nothing
+ src/HIndent/Ast/Type/Variable.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Ast.Type.Variable+  ( TypeVariable+  , mkTypeVariable+  ) where++import qualified GHC.Hs as GHC+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import {-# SOURCE #-} HIndent.Ast.Type+import HIndent.Ast.WithComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+import qualified HIndent.Ast.Name.Prefix as Prefix+#endif+data TypeVariable = TypeVariable+  { name :: WithComments PrefixName+  , kind :: Maybe (WithComments Type)+  }++instance CommentExtraction TypeVariable where+  nodeComments TypeVariable {} = NodeComments [] [] []++instance Pretty TypeVariable where+  pretty' TypeVariable {kind = Just kind, ..} =+    parens $ pretty name >> string " :: " >> pretty kind+  pretty' TypeVariable {kind = Nothing, ..} = pretty name++mkTypeVariable :: GHC.HsTyVarBndr a GHC.GhcPs -> TypeVariable+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+mkTypeVariable GHC.HsTvb {..} = TypeVariable {..}+  where+    name =+      case tvb_var of+        GHC.HsBndrVar _ n -> fromGenLocated $ fmap mkPrefixName n+        GHC.HsBndrWildCard _ -> mkWithComments (Prefix.fromString "_")+    kind =+      case tvb_kind of+        GHC.HsBndrKind _ k -> Just $ mkType <$> fromGenLocated k+        GHC.HsBndrNoKind _ -> Nothing+#else+mkTypeVariable (GHC.UserTyVar _ _ n) = TypeVariable {..}+  where+    name = fromGenLocated $ fmap mkPrefixName n+    kind = Nothing+mkTypeVariable (GHC.KindedTyVar _ _ n k) = TypeVariable {..}+  where+    name = fromGenLocated $ fmap mkPrefixName n+    kind = Just $ mkType <$> fromGenLocated k+#endif
+ src/HIndent/Ast/WithComments.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module HIndent.Ast.WithComments+  ( WithComments+  , prettyWith+  , fromGenLocated+  , fromEpAnn+  , mkWithComments+  , getNode+  , getComments+  , addComments+  , flattenComments+  ) where++import Control.Monad+import Control.Monad.RWS+import qualified GHC.Hs as GHC+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Ast.NodeComments (NodeComments(..))+import qualified HIndent.Ast.NodeComments as NodeComments+import {-# SOURCE #-} HIndent.Pretty+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import HIndent.Printer++data WithComments a = WithComments+  { comments :: NodeComments+  , node :: a+  } deriving (Foldable, Traversable, Eq)++instance Functor WithComments where+  fmap f WithComments {..} = WithComments comments (f node)++instance CommentExtraction (WithComments a) where+  nodeComments WithComments {..} = comments++instance (Pretty a) => Pretty (WithComments a) where+  pretty' WithComments {..} = pretty' node++-- | Prints comments included in the location information and then the+-- AST node body.+prettyWith :: WithComments a -> (a -> Printer ()) -> Printer ()+prettyWith WithComments {..} f = do+  printCommentsBefore comments+  f node+  printCommentOnSameLine comments+  printCommentsAfter comments++-- | Prints comments that are before the given AST node.+printCommentsBefore :: NodeComments -> Printer ()+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+printCommentsBefore p =+  forM_ (commentsBefore p) $ \(GHC.L loc c) -> do+    let col =+          fromIntegral+            $ GHC.srcSpanStartCol (GHC.epaLocationRealSrcSpan loc) - 1+    indentedWithFixedLevel col $ pretty c+    newline+#else+printCommentsBefore p =+  forM_ (commentsBefore p) $ \(GHC.L loc c) -> do+    let col = fromIntegral $ GHC.srcSpanStartCol (GHC.anchor loc) - 1+    indentedWithFixedLevel col $ pretty c+    newline+#endif+-- | Prints comments that are on the same line as the given AST node.+printCommentOnSameLine :: NodeComments -> Printer ()+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+printCommentOnSameLine (commentsOnSameLine -> (c:cs)) = do+  col <- gets psColumn+  if col == 0+    then indentedWithFixedLevel+           (fromIntegral+              $ GHC.srcSpanStartCol+              $ GHC.epaLocationRealSrcSpan+              $ GHC.getLoc c)+           $ spaced+           $ fmap pretty+           $ c : cs+    else spacePrefixed $ fmap pretty $ c : cs+  eolCommentsArePrinted+#else+printCommentOnSameLine (commentsOnSameLine -> (c:cs)) = do+  col <- gets psColumn+  if col == 0+    then indentedWithFixedLevel+           (fromIntegral $ GHC.srcSpanStartCol $ GHC.anchor $ GHC.getLoc c)+           $ spaced+           $ fmap pretty+           $ c : cs+    else spacePrefixed $ fmap pretty $ c : cs+  eolCommentsArePrinted+#endif+printCommentOnSameLine _ = return ()++-- | Prints comments that are after the given AST node.+printCommentsAfter :: NodeComments -> Printer ()+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+printCommentsAfter p =+  case commentsAfter p of+    [] -> return ()+    xs -> do+      isThereCommentsOnSameLine <- gets psEolComment+      unless isThereCommentsOnSameLine newline+      forM_ xs $ \(GHC.L loc c) -> do+        let col =+              fromIntegral+                $ GHC.srcSpanStartCol (GHC.epaLocationRealSrcSpan loc) - 1+        indentedWithFixedLevel col $ pretty c+        eolCommentsArePrinted+#else+printCommentsAfter p =+  case commentsAfter p of+    [] -> return ()+    xs -> do+      isThereCommentsOnSameLine <- gets psEolComment+      unless isThereCommentsOnSameLine newline+      forM_ xs $ \(GHC.L loc c) -> do+        let col = fromIntegral $ GHC.srcSpanStartCol (GHC.anchor loc) - 1+        indentedWithFixedLevel col $ pretty c+        eolCommentsArePrinted+#endif+fromGenLocated :: (CommentExtraction l) => GHC.GenLocated l a -> WithComments a+fromGenLocated (GHC.L l a) = WithComments (nodeComments l) a++fromEpAnn :: GHC.EpAnn a -> b -> WithComments b+fromEpAnn ann = WithComments (NodeComments.fromEpAnn ann)++mkWithComments :: a -> WithComments a+mkWithComments = WithComments mempty++getNode :: WithComments a -> a+getNode = node++getComments :: WithComments a -> NodeComments+getComments = comments++flattenComments :: WithComments (WithComments a) -> WithComments a+flattenComments (WithComments outerComments (WithComments innerComments node)) =+  WithComments (outerComments <> innerComments) node++addComments :: NodeComments -> WithComments a -> WithComments a+addComments extra (WithComments current node) =+  WithComments (extra <> current) node
+ src/HIndent/ByteString.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Helper functions to manipulate `ByteString`.+module HIndent.ByteString+  ( findPrefix+  , stripPrefix+  , addPrefix+  , unlines'+  , hasTrailingLine+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.List (intersperse)+import Data.Maybe++-- | Returns the prefix that all the given `ByteString`s except for the ones composed of `\n`s have.+--+-- The regex of the prefix is `>?[ \t]*`.+findPrefix :: [ByteString] -> ByteString+findPrefix = takePrefix . findCommonPrefix . dropNewlines++-- | Removes the given prefix from the passed `ByteString`, or raises an error.+stripPrefix :: ByteString -> ByteString -> ByteString+stripPrefix prefix =+  fromMaybe (error "Missing expected prefix") . S.stripPrefix prefix++-- | Add a prefix to all lines in a `ByteString`.+addPrefix :: ByteString -> ByteString -> ByteString+addPrefix prefix = unlines' . map (prefix <>) . S8.lines++-- | Returns the prefix that all the given `ByteString`s have.+findCommonPrefix :: [ByteString] -> ByteString+findCommonPrefix [] = ""+findCommonPrefix ("":_) = ""+findCommonPrefix (p:ps) =+  if all (startsWithChar first) ps+    then S8.cons first (findCommonPrefix (S.tail p : map S.tail ps))+    else ""+  where+    first = S8.head p++-- | `unlines'` for `ByteString`.+unlines' :: [ByteString] -> ByteString+unlines' = S.concat . intersperse "\n"++-- | Returns the prefix from the `ByteString`+--+-- The regex of the prefix is `>?[ \t]*`.+takePrefix :: ByteString -> ByteString+takePrefix txt+  | S8.null txt = ""+  | S8.head txt == '>' = S8.cons '>' $ takeSpaceOrTab $ S8.tail txt+  | otherwise = takeSpaceOrTab txt++-- | Filters out `ByteString`s composed of only `\n`s.+dropNewlines :: [ByteString] -> [ByteString]+dropNewlines = filter (not . S.null . S8.dropWhile (== '\n'))++-- | `takeWhile` for spaces or tabs+takeSpaceOrTab :: ByteString -> ByteString+takeSpaceOrTab = S8.takeWhile isSpaceOrTab++-- | Does the strict bytestring have a trailing newline?+hasTrailingLine :: ByteString -> Bool+hasTrailingLine xs = not (S8.null xs) && S8.last xs == '\n'++-- | Returns if the `ByteString` starts with the given `Char`.+startsWithChar :: Char -> ByteString -> Bool+startsWithChar c x = S8.length x > 0 && S8.head x == c++-- | Returns if the `Char` is either a space or a tab.+isSpaceOrTab :: Char -> Bool+isSpaceOrTab = (`elem` [' ', '\t'])
src/HIndent/CabalFile.hs view
@@ -6,12 +6,15 @@  import Control.Monad import qualified Data.ByteString as BS-import Data.List+import Data.List (isSuffixOf) import Data.Maybe import Data.Traversable import Distribution.ModuleName import Distribution.PackageDescription import Distribution.PackageDescription.Configuration+#if MIN_VERSION_Cabal(3, 14, 0)+import Distribution.Utils.Path (interpretSymbolicPathCWD)+#endif #if MIN_VERSION_Cabal(3, 6, 0) import Distribution.Utils.Path (getSymbolicPath) #endif@@ -20,11 +23,13 @@ #else import Distribution.PackageDescription.Parse #endif-import Language.Haskell.Extension-import qualified Language.Haskell.Exts.Extension as HSE+import HIndent.Language+import HIndent.LanguageExtension hiding (defaultExtensions)+import HIndent.LanguageExtension.Conversion+import HIndent.LanguageExtension.Types+import Language.Haskell.Extension hiding (Extension) import System.Directory import System.FilePath-import Text.Read  data Stanza = MkStanza   { _stanzaBuildInfo :: BuildInfo@@ -33,61 +38,91 @@  -- | Find the relative path of a child path in a parent, if it is a child toRelative :: FilePath -> FilePath -> Maybe FilePath-toRelative parent child = let-  rel = makeRelative parent child-  in if rel == child-       then Nothing-       else Just rel+toRelative parent child =+  let rel = makeRelative parent child+   in if rel == child+        then Nothing+        else Just rel  -- | Create a Stanza from `BuildInfo` and names of modules and paths mkStanza :: BuildInfo -> [ModuleName] -> [FilePath] -> Stanza mkStanza bi mnames fpaths =-  MkStanza bi $ \path -> let-    modpaths = fmap toFilePath $ otherModules bi ++ mnames-    inDir dir =-      case toRelative dir path of-        Nothing -> False-        Just relpath ->-          any (equalFilePath $ dropExtension relpath) modpaths ||-          any (equalFilePath relpath) fpaths-    in any inDir $ hsSourceDirs' bi-      where+  MkStanza bi $ \path ->+    let modpaths = fmap toFilePath $ otherModules bi ++ mnames+        inDir dir =+          case toRelative dir path of+            Nothing -> False+            Just relpath ->+              any (equalFilePath $ dropExtension relpath) modpaths+                || any (equalFilePath relpath) fpaths+     in any inDir $ hsSourceDirs' bi+  where+ #if MIN_VERSION_Cabal(3, 6, 0)-        hsSourceDirs' =  (map getSymbolicPath) . hsSourceDirs+        hsSourceDirs' = (map getSymbolicPath) . hsSourceDirs #else         hsSourceDirs' = hsSourceDirs #endif- -- | Extract `Stanza`s from a package packageStanzas :: PackageDescription -> [Stanza]-packageStanzas pd = let-  libStanza :: Library -> Stanza-  libStanza lib = mkStanza (libBuildInfo lib) (exposedModules lib) []-  exeStanza :: Executable -> Stanza-  exeStanza exe = mkStanza (buildInfo exe) [] [modulePath exe]-  testStanza :: TestSuite -> Stanza-  testStanza ts =-    mkStanza-      (testBuildInfo ts)-      (case testInterface ts of-         TestSuiteLibV09 _ mname -> [mname]-         _ -> [])-      (case testInterface ts of-         TestSuiteExeV10 _ path -> [path]-         _ -> [])-  benchStanza :: Benchmark -> Stanza-  benchStanza bn =-    mkStanza (benchmarkBuildInfo bn) [] $-    case benchmarkInterface bn of-      BenchmarkExeV10 _ path -> [path]-      _ -> []-  in mconcat-       [ maybeToList $ fmap libStanza $ library pd-       , fmap exeStanza $ executables pd-       , fmap testStanza $ testSuites pd-       , fmap benchStanza $ benchmarks pd-       ]-+#if MIN_VERSION_Cabal(3, 14, 0)+packageStanzas pd =+  let libStanza :: Library -> Stanza+      libStanza lib = mkStanza (libBuildInfo lib) (exposedModules lib) []+      exeStanza :: Executable -> Stanza+      exeStanza exe =+        mkStanza (buildInfo exe) [] [interpretSymbolicPathCWD $ modulePath exe]+      testStanza :: TestSuite -> Stanza+      testStanza ts =+        mkStanza+          (testBuildInfo ts)+          (case testInterface ts of+             TestSuiteLibV09 _ mname -> [mname]+             _ -> [])+          (case testInterface ts of+             TestSuiteExeV10 _ path -> [interpretSymbolicPathCWD path]+             _ -> [])+      benchStanza :: Benchmark -> Stanza+      benchStanza bn =+        mkStanza (benchmarkBuildInfo bn) []+          $ case benchmarkInterface bn of+              BenchmarkExeV10 _ path -> [interpretSymbolicPathCWD path]+              _ -> []+   in mconcat+        [ maybeToList $ libStanza <$> library pd+        , exeStanza <$> executables pd+        , testStanza <$> testSuites pd+        , benchStanza <$> benchmarks pd+        ]+#else+packageStanzas pd =+  let libStanza :: Library -> Stanza+      libStanza lib = mkStanza (libBuildInfo lib) (exposedModules lib) []+      exeStanza :: Executable -> Stanza+      exeStanza exe = mkStanza (buildInfo exe) [] [modulePath exe]+      testStanza :: TestSuite -> Stanza+      testStanza ts =+        mkStanza+          (testBuildInfo ts)+          (case testInterface ts of+             TestSuiteLibV09 _ mname -> [mname]+             _ -> [])+          (case testInterface ts of+             TestSuiteExeV10 _ path -> [path]+             _ -> [])+      benchStanza :: Benchmark -> Stanza+      benchStanza bn =+        mkStanza (benchmarkBuildInfo bn) []+          $ case benchmarkInterface bn of+              BenchmarkExeV10 _ path -> [path]+              _ -> []+   in mconcat+        [ maybeToList $ libStanza <$> library pd+        , exeStanza <$> executables pd+        , testStanza <$> testSuites pd+        , benchStanza <$> benchmarks pd+        ]+#endif -- | Find cabal files that are "above" the source path findCabalFiles :: FilePath -> FilePath -> IO (Maybe ([FilePath], FilePath)) findCabalFiles dir rel = do@@ -98,21 +133,20 @@     []       | dir == "/" -> return Nothing     [] -> findCabalFiles (takeDirectory dir) (takeFileName dir </> rel)-    _ -> return $ Just (fmap (\n -> dir </> n) cabalnames, rel)+    _ -> return $ Just (fmap (dir </>) cabalnames, rel)  getGenericPackageDescription :: FilePath -> IO (Maybe GenericPackageDescription) #if MIN_VERSION_Cabal(2, 2, 0) getGenericPackageDescription cabalPath = do-    cabaltext <- BS.readFile cabalPath-    return $ parseGenericPackageDescriptionMaybe cabaltext+  cabaltext <- BS.readFile cabalPath+  return $ parseGenericPackageDescriptionMaybe cabaltext #else getGenericPackageDescription cabalPath = do   cabaltext <- readFile cabalPath   case parsePackageDescription cabaltext of     ParseOk _ gpd -> return $ Just gpd-    _             -> return Nothing+    _ -> return Nothing #endif- -- | Find the `Stanza` that refers to this source path getCabalStanza :: FilePath -> IO (Maybe Stanza) getCabalStanza srcpath = do@@ -127,43 +161,25 @@             Nothing -> return []             Just gpd -> do               return $ packageStanzas $ flattenPackageDescription gpd-      return $-        case filter (\stanza -> stanzaIsSourceFilePath stanza relpath) $-             mconcat stanzass of-          [] -> Nothing-          (stanza:_) -> Just stanza -- just pick the first one+      return+        $ case filter (`stanzaIsSourceFilePath` relpath) $ mconcat stanzass of+            [] -> Nothing+            (stanza:_) -> Just stanza -- just pick the first one     Nothing -> return Nothing --- | Get (Cabal package) language and extensions from the cabal file for this source path+-- | Get language and extensions from the cabal file for this source path getCabalExtensions :: FilePath -> IO (Language, [Extension]) getCabalExtensions srcpath = do   mstanza <- getCabalStanza srcpath-  return $-    case mstanza of-      Nothing -> (Haskell98, [])-      Just (MkStanza bi _) -> do-        (fromMaybe Haskell98 $ defaultLanguage bi, defaultExtensions bi)--convertLanguage :: Language -> HSE.Language-convertLanguage lang = read $ show lang--convertKnownExtension :: KnownExtension -> Maybe HSE.KnownExtension-convertKnownExtension ext =-  case readEither $ show ext of-    Left _ -> Nothing-    Right hext -> Just hext--convertExtension :: Extension -> Maybe HSE.Extension-convertExtension (EnableExtension ke) =-  fmap HSE.EnableExtension $ convertKnownExtension ke-convertExtension (DisableExtension ke) =-  fmap HSE.DisableExtension $ convertKnownExtension ke-convertExtension (UnknownExtension s) = Just $ HSE.UnknownExtension s+  return+    $ case mstanza of+        Nothing -> (Haskell98, [])+        Just (MkStanza bi _) ->+          ( fromMaybe Haskell98 $ defaultLanguage bi+          , mapMaybe fromCabalExtension $ defaultExtensions bi)  -- | Get extensions from the cabal file for this source path-getCabalExtensionsForSourcePath :: FilePath -> IO [HSE.Extension]+getCabalExtensionsForSourcePath :: FilePath -> IO [Extension] getCabalExtensionsForSourcePath srcpath = do   (lang, exts) <- getCabalExtensions srcpath-  return $-    fmap HSE.EnableExtension $-    HSE.toExtensionList (convertLanguage lang) $ mapMaybe convertExtension exts+  return $ exts ++ implicitExtensions (convertLanguage lang)
src/HIndent/CodeBlock.hs view
@@ -7,15 +7,14 @@  import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8-import Data.Monoid  -- | A block of code. data CodeBlock-    = Shebang ByteString-    | HaskellSource Int ByteString+  = Shebang ByteString+  | HaskellSource Int ByteString     -- ^ Includes the starting line (indexed from 0) for error reporting-    | CPPDirectives ByteString-     deriving (Show, Eq)+  | CPPDirectives ByteString+  deriving (Show, Eq)  -- | Break a Haskell code string into chunks, using CPP as a delimiter. -- Lines that start with '#if', '#end', or '#else' are their own chunks, and@@ -32,9 +31,12 @@ -- will become five blocks, one for each CPP line and one for each pair of declarations. cppSplitBlocks :: ByteString -> [CodeBlock] cppSplitBlocks inp =-  modifyLast (inBlock (<> trailing)) .-  groupLines . classifyLines . zip [0 ..] . S8.lines $-  inp+  modifyLast (inBlock (<> trailing))+    . groupLines+    . classifyLines+    . zip [0 ..]+    . S8.lines+    $ inp   where     groupLines :: [CodeBlock] -> [CodeBlock]     groupLines (line1:line2:remainingLines) =@@ -57,7 +59,16 @@     cppLine src =       any         (`S8.isPrefixOf` src)-        ["#if", "#end", "#else", "#define", "#undef", "#elif", "#include", "#error", "#warning"]+        [ "#if"+        , "#end"+        , "#else"+        , "#define"+        , "#undef"+        , "#elif"+        , "#include"+        , "#error"+        , "#warning"+        ]         -- Note: #ifdef and #ifndef are handled by #if     hasEscapedTrailingNewline :: ByteString -> Bool     hasEscapedTrailingNewline src = "\\" `S8.isSuffixOf` src@@ -65,8 +76,8 @@     classifyLines allLines@((lineIndex, src):nextLines)       | cppLine src =         let (cppLines, nextLines') = spanCPPLines allLines-         in CPPDirectives (S8.intercalate "\n" (map snd cppLines)) :-            classifyLines nextLines'+         in CPPDirectives (S8.intercalate "\n" (map snd cppLines))+              : classifyLines nextLines'       | shebangLine src = Shebang src : classifyLines nextLines       | otherwise = HaskellSource lineIndex src : classifyLines nextLines     classifyLines [] = []
+ src/HIndent/CommandlineOptions.hs view
@@ -0,0 +1,95 @@+-- | Types and functions related to HIndent's commandline options.+module HIndent.CommandlineOptions+  ( Action(..)+  , RunMode(..)+  , options+  ) where++import Data.Maybe+import HIndent.Config+import HIndent.LanguageExtension+import HIndent.LanguageExtension.Types+import Options.Applicative hiding (action, style)++-- | HIndent actions.+data Action+  = Validate -- ^ Validate if the code is formatted.+  | Reformat -- ^ Format the code.++-- | HIndent running mode.+data RunMode+  = ShowVersion -- ^ Show HIndent's version.+  | Run Config [Extension] Action [FilePath] -- ^ Format or validate the code.++-- | Program options.+options :: Config -> Parser RunMode+options config =+  flag' ShowVersion (long "version" <> help "Print the version")+    <|> (Run <$> style <*> exts <*> action <*> files)+  where+    style =+      (makeStyle config+         <$> lineLen+         <*> indentSpaces+         <*> trailingNewline+         <*> sortImports)+        <* optional+             (strOption+                (long "style"+                   <> help "Style to print with (historical, now ignored)"+                   <> metavar "STYLE") :: Parser String)+    exts =+      fmap+        getExtensions+        (many+           (strOption+              (short 'X' <> help "Language extension" <> metavar "GHCEXT")))+    indentSpaces =+      option+        auto+        (long "indent-size"+           <> help "Indentation size in spaces"+           <> value (configIndentSpaces config)+           <> showDefault)+        <|> option+              auto+              (long "tab-size"+                 <> help "Same as --indent-size, for compatibility")+    lineLen =+      option+        auto+        (long "line-length"+           <> help "Desired length of lines"+           <> value (configMaxColumns config)+           <> showDefault)+    trailingNewline =+      not+        <$> flag+              (not (configTrailingNewline config))+              (configTrailingNewline config)+              (long "no-force-newline"+                 <> help "Don't force a trailing newline"+                 <> showDefault)+    sortImports =+      flag+        Nothing+        (Just True)+        (long "sort-imports" <> help "Sort imports in groups" <> showDefault)+        <|> flag+              Nothing+              (Just False)+              (long "no-sort-imports" <> help "Don't sort imports")+    action =+      flag+        Reformat+        Validate+        (long "validate"+           <> help "Check if files are formatted without changing them")+    makeStyle s mlen tabs trailing imports =+      s+        { configMaxColumns = mlen+        , configIndentSpaces = tabs+        , configTrailingNewline = trailing+        , configSortImports = fromMaybe (configSortImports s) imports+        }+    files = many (strArgument (metavar "FILENAMES"))
+ src/HIndent/Config.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Things related to HIndent configuration.+module HIndent.Config+  ( Config(..)+  , defaultConfig+  , getConfig+  ) where++import Control.Applicative+import Data.Int+import Data.Maybe+import Data.Yaml+import qualified Data.Yaml as Y+import HIndent.LanguageExtension.Conversion+import HIndent.LanguageExtension.Types+import qualified HIndent.Path.Find as Path+import Path+import qualified Path.IO as Path++-- | Configurations shared among the different styles. Styles may pay+-- attention to or completely disregard this configuration.+data Config = Config+  { configMaxColumns :: !Int64 -- ^ Maximum columns to fit code into ideally.+  , configIndentSpaces :: !Int64 -- ^ How many spaces to indent?+  , configTrailingNewline :: !Bool -- ^ End with a newline.+  , configSortImports :: !Bool -- ^ Sort imports in groups.+  , configLineBreaks :: [String] -- ^ Break line when meets these operators.+  , configExtensions :: [Extension]+      -- ^ Extra language extensions enabled by default.+  }++instance FromJSON Config where+  parseJSON (Y.Object v) =+    Config+      <$> fmap+            (fromMaybe (configMaxColumns defaultConfig))+            (v Y..:? "line-length")+      <*> fmap+            (fromMaybe (configIndentSpaces defaultConfig))+            (v Y..:? "indent-size" <|> v Y..:? "tab-size")+      <*> fmap+            (fromMaybe (configTrailingNewline defaultConfig))+            (v Y..:? "force-trailing-newline")+      <*> fmap+            (fromMaybe (configSortImports defaultConfig))+            (v Y..:? "sort-imports")+      <*> fmap+            (fromMaybe (configLineBreaks defaultConfig))+            (v Y..:? "line-breaks")+      <*> (traverse convertExt . fromMaybe [] =<< v Y..:? "extensions")+    where+      convertExt x =+        case strToExt x of+          Just x' -> pure x'+          Nothing -> error $ "Unknown extension: " ++ show x+  parseJSON _ = fail "Expected Object for Config value"++-- | Default style configuration.+defaultConfig :: Config+defaultConfig =+  Config+    { configMaxColumns = 80+    , configIndentSpaces = 2+    , configTrailingNewline = True+    , configSortImports = True+    , configLineBreaks = []+    , configExtensions = []+    }++-- | Read config from a config file, or return 'defaultConfig'.+getConfig :: IO Config+getConfig = do+  cur <- Path.getCurrentDir+  homeDir <- Path.getHomeDir+  mfile <-+    Path.findFileUp+      cur+      ((== ".hindent.yaml") . toFilePath . filename)+      (Just homeDir)+  case mfile of+    Nothing -> return defaultConfig+    Just file -> do+      result <- Y.decodeFileEither (toFilePath file)+      case result of+        Left e -> error (show e)+        Right config -> return config
+ src/HIndent/Error.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE RecordWildCards #-}++-- | Error types and functions.+module HIndent.Error+  ( ParseError(..)+  , prettyParseError+  ) where++-- | Parse error type with the location.+data ParseError = ParseError+  { errorLine :: Int -- ^ The row of the parse error's location.+  , errorCol :: Int -- ^ The column of the parse error's location.+  , errorFile :: FilePath -- ^ The filename HIndent failed to parse.+  } deriving (Eq, Ord, Show, Read)++-- | Pretty-print `ParseError`.+prettyParseError :: ParseError -> String+prettyParseError ParseError {..} =+  "Parse failed at ("+    <> show errorLine+    <> ", "+    <> show errorCol+    <> ") in "+    <> errorFile+    <> "."
+ src/HIndent/Fixity.hs view
@@ -0,0 +1,67 @@+-- | Operator fixities.+--+-- It is very difficult to take operators' fixities into account as fixity+-- information is not stored in an AST. While `ghc-lib-parser-ex` provides+-- `fixitiesFromModule`, it is almost useless as operators are usually imported+-- from other modules.+--+-- Ormolu is trying to resolve this issue by examing Hackage, but doing the same+-- way in HIndent is not so easy.+module HIndent.Fixity+  ( fixities+  ) where++import GHC.Types.Fixity+import Language.Haskell.GhclibParserEx.Fixity++-- | Operator fixities that HIndent supports.+fixities :: [(String, Fixity)]+fixities = baseFixities <> lensFixities++-- | Fixities of operators defined in lens package.+lensFixities :: [(String, Fixity)]+lensFixities =+  concat+    [ infixr_+        4+        [ ".~"+        , "%~"+        , "+~"+        , "-~"+        , "*~"+        , "//~"+        , "^~"+        , "^^~"+        , "**~"+        , "||~"+        , "<>~"+        , "&&~"+        , "<.~"+        , "?~"+        , "<?~"+        , "%@~"+        , ".@~"+        ]+    , infix_+        4+        [ ".="+        , "%="+        , "+="+        , "-="+        , "*="+        , "//="+        , "^="+        , "^^="+        , "**="+        , "||="+        , "<>="+        , "&&="+        , "<.="+        , "?="+        , "<?="+        , "%@="+        , ".@="+        ]+    , infixr_ 2 ["<^"]+    , infixl_ 1 ["&"]+    ]
+ src/HIndent/GhcLibParserWrapper/GHC/Hs.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++-- | Wrapper for 'GHC.Hs'+module HIndent.GhcLibParserWrapper.GHC.Hs+  ( module GHC.Hs+  , HsModule'+  , getModuleAnn+  , getDeprecMessage+  ) where++import GHC.Hs+import HIndent.GhcLibParserWrapper.GHC.Unit.Module.Warnings+-- | The wrapper for `HsModule`+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+type HsModule' = HsModule GhcPs+#else+type HsModule' = HsModule+#endif+getModuleAnn :: HsModule' -> EpAnn AnnsModule+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+getModuleAnn HsModule {hsmodExt = XModulePs {..}} = hsmodAnn+#else+getModuleAnn HsModule {..} = hsmodAnn+#endif+getDeprecMessage :: HsModule' -> Maybe (LocatedP WarningTxt')+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+getDeprecMessage HsModule {hsmodExt = XModulePs {..}} = hsmodDeprecMessage+#else+getDeprecMessage HsModule {..} = hsmodDeprecMessage+#endif
+ src/HIndent/GhcLibParserWrapper/GHC/Hs/ImpExp.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.GhcLibParserWrapper.GHC.Hs.ImpExp+  ( module GHC.Hs.ImpExp+  , getPackageName+  ) where++import qualified GHC.Hs as GHC+import GHC.Hs.ImpExp+import qualified GHC.Types.SourceText as GHC+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+import qualified GHC.Types.PkgQual as GHC+#endif+getPackageName :: GHC.ImportDecl GHC.GhcPs -> Maybe GHC.StringLiteral+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+getPackageName GHC.ImportDecl {GHC.ideclPkgQual = GHC.RawPkgQual name} =+  Just name+getPackageName GHC.ImportDecl {GHC.ideclPkgQual = GHC.NoRawPkgQual} = Nothing+#else+getPackageName GHC.ImportDecl {..} = ideclPkgQual+#endif
+ src/HIndent/GhcLibParserWrapper/GHC/Parser/Annotation.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-}++module HIndent.GhcLibParserWrapper.GHC.Parser.Annotation+  ( module GHC.Parser.Annotation+  , epaLocationToRealSrcSpan+  ) where++import GHC.Parser.Annotation+import GHC.Types.SrcLoc+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+epaLocationToRealSrcSpan :: EpaLocation' a -> RealSrcSpan+epaLocationToRealSrcSpan = epaLocationRealSrcSpan+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+epaLocationToRealSrcSpan :: EpaLocation' a -> RealSrcSpan+epaLocationToRealSrcSpan = anchor+#else+epaLocationToRealSrcSpan :: Anchor -> RealSrcSpan+epaLocationToRealSrcSpan = anchor+#endif
+ src/HIndent/GhcLibParserWrapper/GHC/Unit/Module/Warnings.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE CPP #-}++module HIndent.GhcLibParserWrapper.GHC.Unit.Module.Warnings+  ( module GHC.Unit.Module.Warnings+  , WarningTxt'+  ) where++import GHC.Unit.Module.Warnings+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+import GHC.Hs++type WarningTxt' = WarningTxt GhcPs+#else+type WarningTxt' = WarningTxt+#endif
+ src/HIndent/Language.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}++-- | Operations for handling languages (e.g., Haskell2010).+module HIndent.Language+  ( convertLanguage+  ) where++import qualified GHC.Driver.Session as GLP+import GHC.Stack+import qualified Language.Haskell.Extension as Cabal++-- | This function converts a value of 'Language' defined in the 'Cabal'+-- package to the same value of 'Language' defined in the 'ghc-lib-parser'+-- package.+--+-- This function raises an error if a 'UnknownLanguage' value is passed.+convertLanguage :: HasCallStack => Cabal.Language -> GLP.Language+convertLanguage Cabal.Haskell98 = GLP.Haskell98+convertLanguage Cabal.Haskell2010 = GLP.Haskell2010+#if MIN_VERSION_Cabal(3, 6, 0)+convertLanguage Cabal.GHC2021 = GLP.GHC2021+#endif+#if MIN_VERSION_Cabal(3, 12, 0)+#if MIN_VERSION_ghc_lib_parser(9, 10, 0)+convertLanguage Cabal.GHC2024 = GLP.GHC2024+#else+convertLanguage Cabal.GHC2024 =+  error+    "GHC2024 language is not supported. Hindent was built with GHC < 9.10. Please rebuild Hindent with GHC 9.10 or later."+#endif+#endif+convertLanguage (Cabal.UnknownLanguage s) = error $ "Unknown language: " ++ s
+ src/HIndent/LanguageExtension.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Operations related to language extensions.+module HIndent.LanguageExtension+  ( implicitExtensions+  , extensionImplies+  , collectLanguageExtensionsFromSource+  , getExtensions+  , defaultExtensions+  ) where++import Data.Char+import Data.List (delete)+import Data.List.Split+import Data.Maybe+import qualified GHC.Driver.Session as GLP+import HIndent.LanguageExtension.Conversion+import HIndent.LanguageExtension.Types+import HIndent.Pragma+import Text.Regex.TDFA+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+import qualified GHC.LanguageExtensions.Type as GLP+#endif+-- | This function returns a list of extensions that the passed language+-- (e.g., GHC2021) enables.+implicitExtensions :: GLP.Language -> [Extension]+implicitExtensions = fmap EnableExtension . GLP.languageExtensions . Just++-- | This function returns a list of extensions that the passed extension+-- enables and disables.+--+-- For example, @GADTs@ enables @GADTSyntax@ and @RebindableSyntax@+-- disables @ImplicitPrelude@.+extensionImplies :: Extension -> [Extension]+extensionImplies (EnableExtension e) =+  toExtension <$> filter (\(a, _, _) -> e == a) GLP.impliedXFlags+  where+    toExtension (_, True, e') = EnableExtension e'+    toExtension (_, False, e') = DisableExtension e'+extensionImplies _ = []++-- | Collect pragmas specified in the source code.+collectLanguageExtensionsFromSource :: String -> [Extension]+collectLanguageExtensionsFromSource =+  (++)+    <$> collectLanguageExtensionsSpecifiedViaLanguagePragma+    <*> collectLanguageExtensionsFromSourceViaOptionsPragma++-- | Consume an extensions list from arguments.+getExtensions :: [String] -> [Extension]+getExtensions = foldr f defaultExtensions+  where+    f "Haskell98" _ = []+    f x a =+      case strToExt x of+        Just x'@EnableExtension {} -> x' : delete x' a+        Just (DisableExtension x') -> delete (EnableExtension x') a+        _ -> error $ "Unknown extension: " ++ x++-- | Collects language extensions enabled or disabled by @{-# LANGUAGE FOO+-- #-}@.+--+-- This function ignores language extensions not supported by Cabal.+collectLanguageExtensionsSpecifiedViaLanguagePragma :: String -> [Extension]+collectLanguageExtensionsSpecifiedViaLanguagePragma =+  concatMap ((mapMaybe (strToExt . stripSpaces) . splitOn ",") . snd)+    . filter ((== "LANGUAGE") . fst)+    . extractPragmasFromCode++-- | Extracts the language extensions specified by @-XFOO@ from @OPTIONS@+-- or @OPTIONS_GHC@ pragmas+collectLanguageExtensionsFromSourceViaOptionsPragma :: String -> [Extension]+collectLanguageExtensionsFromSourceViaOptionsPragma =+  concatMap+    (mapMaybe (strToExt . stripSpaces)+       . extractLanguageExtensionsFromOptions+       . snd)+    . filter ((`elem` ["OPTIONS", "OPTIONS_GHC"]) . fst)+    . extractPragmasFromCode++-- | Extracts the language extensions specified in the '-XFOO' format from+-- the given string+extractLanguageExtensionsFromOptions :: String -> [String]+extractLanguageExtensionsFromOptions options =+  fmap+    trimXOption+    (getAllTextMatches (options =~ "-X[^,[:space:]]+") :: [String])+  where+    trimXOption ('-':'X':xs) = xs+    trimXOption _ = error "Unreachable: the option must have the `-X` prefix."++-- | Removes spaces before and after the string.+stripSpaces :: String -> String+stripSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace++defaultExtensions :: [Extension]+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+defaultExtensions =+  EnableExtension GLP.ListTuplePuns : implicitExtensions GLP.GHC2021+#else+defaultExtensions = implicitExtensions GLP.GHC2021+#endif
+ src/HIndent/LanguageExtension/Conversion.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}++-- | Operations for converting extensions types.+module HIndent.LanguageExtension.Conversion+  ( fromCabalExtension+  , uniqueExtensions+  , convertExtension+  , strToExt+  ) where++import qualified GHC.LanguageExtensions as GLP+import HIndent.LanguageExtension.Types+import qualified Language.Haskell.Extension as Cabal+import qualified Language.Haskell.GhclibParserEx.GHC.Driver.Session as GLP++-- | Converts from an `Extension` defined in the `Cabal` package to an+-- `Extension` defined in HIndent.+--+-- Note that this function returns `Nothing` if `UnknownExtension` is+-- passed or if an extension is not supported by GHC.+fromCabalExtension :: Cabal.Extension -> Maybe Extension+fromCabalExtension (Cabal.EnableExtension x) =+  EnableExtension <$> convertExtension x+fromCabalExtension (Cabal.DisableExtension x) =+  DisableExtension <$> convertExtension x+fromCabalExtension Cabal.UnknownExtension {} = Nothing++-- | This function converts each value of the type 'Extension' defined in+-- 'HIndent.LanguageExtension.Types' in the list to the same value of the+-- type 'Extension' defined in the package 'ghc-lib-parser'.+--+-- If the extension has the 'No' suffix, the extension is removed from the+-- result. If both extensions having and not having the suffix exist in the+-- list, only the most backward one has the effect.+--+-- If converting an extension fails due to neither GHC nor 'ghc-lib-parser'+-- not supporting, or deprecation or removal, the extension is ignored.+uniqueExtensions :: [Extension] -> [GLP.Extension]+uniqueExtensions [] = []+uniqueExtensions ((EnableExtension e):xs) = e : uniqueExtensions xs+uniqueExtensions ((DisableExtension e):xs) =+  uniqueExtensions $ filter (/= EnableExtension e) xs++-- | This function converts a value of 'KnownExtension' defined in the+-- 'Cabal' package to the same value of 'Extension' defined in+-- 'ghc-lib-parser'.+--+-- This function returns a 'Just' value if it succeeds in converting.+-- Otherwise (e.g., 'ghc-lib-parser' does not the passed extension, or it+-- is deprecated or removed), it returns a 'Nothing'.+convertExtension :: Cabal.KnownExtension -> Maybe GLP.Extension+convertExtension = GLP.readExtension . show++-- | Converts the given string to an extension, or returns a 'Nothing' on+-- fail.+strToExt :: String -> Maybe Extension+strToExt ('N':'o':s) = DisableExtension <$> GLP.readExtension s+strToExt s = EnableExtension <$> GLP.readExtension s
+ src/HIndent/LanguageExtension/Types.hs view
@@ -0,0 +1,18 @@+-- | Types related to language extensions+module HIndent.LanguageExtension.Types+  ( Extension(..)+  ) where++import qualified GHC.LanguageExtensions as GLP++-- | Language Extension. Either enabled or disabled.+--+-- The `Cabal` package also has an `Extension` type that can be used to+-- indicate whether an extension is enabled or disabled, but Cabal's one+-- should be avoided as much as possible. The `KnownExtension` of `Cabal`+-- may not have the latest extensions, and if such extensions are used,+-- there will be cases where GHC can build, but HIndent cannot format.+data Extension+  = EnableExtension GLP.Extension+  | DisableExtension GLP.Extension+  deriving (Eq)
+ src/HIndent/ModulePreprocessing.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Module preprocessing before pretty-printing.+module HIndent.ModulePreprocessing+  ( modifyASTForPrettyPrinting+  ) where++import Data.Function+import Data.List (sortBy)+import GHC.Hs+import GHC.Types.SrcLoc+import Generics.SYB hiding (GT, typeOf, typeRep)+import HIndent.Fixity+import HIndent.GhcLibParserWrapper.GHC.Hs+import HIndent.ModulePreprocessing.CommentRelocation+import Language.Haskell.GhclibParserEx.Fixity+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+import qualified GHC.Data.Strict as Strict+import HIndent.GhcLibParserWrapper.GHC.Parser.Annotation+#else+import Control.Applicative+import Data.Maybe+import Type.Reflection+#endif+-- | This function modifies the given module AST for pretty-printing.+--+-- Pretty-printing a module without calling this function for it before may+-- raise an error or not print it correctly.+modifyASTForPrettyPrinting :: HsModule' -> HsModule'+modifyASTForPrettyPrinting m = relocateComments (beforeRelocation m) allComments+  where+    beforeRelocation =+      resetListCompRange+        . resetLGRHSEndPositionInModule+        . removeAllDocDs+        . closeEpAnnOfHsFunTy+        . closeEpAnnOfMatchMExt+        . closePlaceHolderEpAnns+        . closeEpAnnOfFunBindFunId+        . resetModuleNameColumn+        . replaceAllNotUsedAnns+        . removeComments+        . sortExprLStmt+        . fixFixities+    allComments = listify (not . isEofComment . ac_tok . unLoc) m++-- | This function modifies the given module AST to apply fixities of infix+-- operators defined in the 'base' package.+fixFixities :: HsModule' -> HsModule'+fixFixities = applyFixities fixities++-- | This function modifies the range of `HsDo` with `ListComp` so that it+-- includes the whole list comprehension.+--+-- This function is necessary for `ghc-lib-parser>=9.10.1<9.12.1` because `HsDo`+-- no longer includes brackets of list comprehensions in its range.+resetListCompRange :: HsModule' -> HsModule'+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+resetListCompRange = everywhere (mkT resetListCompRange')+  where+    resetListCompRange' :: HsExpr GhcPs -> HsExpr GhcPs+    resetListCompRange' (HsDo al@AnnList {al_brackets = ListSquare (EpTok (EpaSpan (RealSrcSpan open _))) (EpTok (EpaSpan (RealSrcSpan close _)))} ListComp (L EpAnn {..} xs)) =+      HsDo+        al+        ListComp+        (L EpAnn+             { entry =+                 EpaSpan+                   $ RealSrcSpan+                       (mkRealSrcSpan+                          (realSrcSpanStart open)+                          (realSrcSpanEnd close))+                       Strict.Nothing+             , ..+             }+           xs)+    resetListCompRange' x = x+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+resetListCompRange = everywhere (mkT resetListCompRange')+  where+    resetListCompRange' :: HsExpr GhcPs -> HsExpr GhcPs+    resetListCompRange' (HsDo al@AnnList { al_open = Just (AddEpAnn _ (EpaSpan (RealSrcSpan open _)))+                                         , al_close = Just (AddEpAnn _ (EpaSpan (RealSrcSpan close _)))+                                         } ListComp (L EpAnn {..} xs)) =+      HsDo+        al+        ListComp+        (L EpAnn+             { entry =+                 EpaSpan+                   $ RealSrcSpan+                       (mkRealSrcSpan+                          (realSrcSpanStart open)+                          (realSrcSpanEnd close))+                       Strict.Nothing+             , ..+             }+           xs)+    resetListCompRange' x = x+#else+resetListCompRange = id+#endif+-- | This function sets an 'LGRHS's end position to the end position of the+-- last RHS in the 'grhssGRHSs'.+--+-- The source span of an 'L?GRHS' contains the 'where' keyword, which+-- locates comments in the wrong position in the process of comment+-- relocation. This function prevents it by fixing the 'L?GRHS''s source+-- span.+resetLGRHSEndPositionInModule :: HsModule' -> HsModule'+resetLGRHSEndPositionInModule = everywhere (mkT resetLGRHSEndPosition)++-- | This function sorts lists of statements in order their positions.+--+-- For example, the last element of 'HsDo' of 'HsExpr' is the element+-- before a bar, and the elements are not sorted by their locations. This+-- function fixes the orderings.+sortExprLStmt :: HsModule' -> HsModule'+sortExprLStmt m@HsModule {hsmodDecls = xs} = m {hsmodDecls = sorted}+  where+    sorted = everywhere (mkT sortByLoc) xs+    sortByLoc :: [ExprLStmt GhcPs] -> [ExprLStmt GhcPs]+    sortByLoc = sortBy (compare `on` srcSpanToRealSrcSpan . locA . getLoc)++-- | This function removes all comments from the given module not to+-- duplicate them on comment relocation.+removeComments :: HsModule' -> HsModule'+removeComments = everywhere (mkT $ const emptyComments)++-- | This function replaces all 'EpAnnNotUsed's in 'SrcSpanAnn''s with+-- 'EpAnn's to make it possible to locate comments on them.+replaceAllNotUsedAnns :: HsModule' -> HsModule'+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+-- 'EpAnnNotUsed' is not used since 9.10.1.+replaceAllNotUsedAnns = id+#else+replaceAllNotUsedAnns = everywhere app+  where+    app ::+         forall a. Data a+      => (a -> a)+    app sp+      | App g (App y z) <- typeRep @a+      , Just HRefl <- eqTypeRep g (typeRep @SrcSpanAnn')+      , Just HRefl <- eqTypeRep y (typeRep @EpAnn) =+        fromMaybe sp $ do+          let try :: Typeable b => b -> Maybe a+              try ann = do+                HRefl <- eqTypeRep (typeOf ann) z+                pure sp {ann = EpAnn (spanAsAnchor $ locA sp) ann emptyComments}+          try emptyListItem+            <|> try emptyList+            <|> try emptyPragma+            <|> try emptyContext+            <|> try emptyNameAnn+            <|> try NoEpAnns+    app x = x+    emptyListItem = AnnListItem []+    emptyList = AnnList Nothing Nothing Nothing [] []+    emptyPragma = AnnPragma emptyAddEpAnn emptyAddEpAnn []+    emptyContext = AnnContext Nothing [] []+    emptyNameAnn = NameAnnTrailing []+    emptyAddEpAnn = AddEpAnn AnnAnyclass emptyEpaLocation+    emptyEpaLocation = EpaDelta (SameLine 0) []+#endif+-- | This function sets the start column of 'hsmodName' of the given+-- 'HsModule' to 1 to correctly locate comments above the module name.+resetModuleNameColumn :: HsModule' -> HsModule'+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+resetModuleNameColumn m@HsModule {hsmodName = Just (L epa@EpAnn {..} name)} =+  m {hsmodName = Just (L newAnn name)}+  where+    newAnn = epa {entry = realSpanAsAnchor newSpan}+    newSpan =+      mkRealSrcSpan+        (mkRealSrcLoc (srcSpanFile anc) (srcSpanStartLine anc) 1)+        (realSrcSpanEnd anc)+    anc =+      case entry of+        EpaSpan (RealSrcSpan a _) -> a+        _ -> error "resetModuleNameColumn: not a RealSrcSpan"+#else+resetModuleNameColumn m@HsModule {hsmodName = Just (L (SrcSpanAnn epa@EpAnn {..} sp) name)} =+  m {hsmodName = Just (L (SrcSpanAnn newAnn sp) name)}+  where+    newAnn = epa {entry = realSpanAsAnchor newSpan}+    newSpan =+      mkRealSrcSpan+        (mkRealSrcLoc (srcSpanFile anc) (srcSpanStartLine anc) 1)+        (realSrcSpanEnd anc)+    anc = anchor entry+#endif+resetModuleNameColumn m = m++-- | This function replaces the 'EpAnn' of 'fun_id' in 'FunBind' with+-- 'EpAnnNotUsed'.+--+-- The 'fun_id' contains the function's name. However, 'FunRhs' of 'Match'+-- also contains the name, and we use the latter one. This function+-- prevents comments from being located in 'fun_id'.+closeEpAnnOfFunBindFunId :: HsModule' -> HsModule'+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+-- TODO: 'EpAnnNotUsed' is not used since 9.10.1. We need to find another+-- way to close 'EpAnn's.+closeEpAnnOfFunBindFunId = id+#else+closeEpAnnOfFunBindFunId = everywhere (mkT closeEpAnn)+  where+    closeEpAnn :: HsBind GhcPs -> HsBind GhcPs+    closeEpAnn bind@FunBind {fun_id = (L (SrcSpanAnn _ l) name)} =+      bind {fun_id = L (SrcSpanAnn EpAnnNotUsed l) name}+    closeEpAnn x = x+#endif+-- | This function replaces the 'EpAnn' of 'm_ext' in 'Match' with+-- 'EpAnnNotUsed.+--+-- The field contains the annotation of the match LHS. However, the same+-- information is also stored inside the 'Match'. This function removes the+-- duplication not to locate comments on a wrong point.+closeEpAnnOfMatchMExt :: HsModule' -> HsModule'+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+-- TODO: 'EpAnnNotUsed' is not used since 9.10.1. We need to find another+-- way to close 'EpAnn's.+closeEpAnnOfMatchMExt = id+#else+closeEpAnnOfMatchMExt = everywhere closeEpAnn+  where+    closeEpAnn ::+         forall a. Typeable a+      => a+      -> a+    closeEpAnn x+      | App (App g h) _ <- typeRep @a+      , Just HRefl <- eqTypeRep g (typeRep @Match)+      , Just HRefl <- eqTypeRep h (typeRep @GhcPs) = x {m_ext = EpAnnNotUsed}+      | otherwise = x+#endif+-- | This function replaces the 'EpAnn' of the first argument of 'HsFunTy'+-- of 'HsType'.+--+-- 'HsFunTy' should not have any comments. Instead, its LHS and RHS should+-- have them.+closeEpAnnOfHsFunTy :: HsModule' -> HsModule'+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+-- TODO: 'EpAnnNotUsed' is not used since 9.10.1. We need to find another+-- way to close 'EpAnn's.+closeEpAnnOfHsFunTy = id+#else+closeEpAnnOfHsFunTy = everywhere (mkT closeEpAnn)+  where+    closeEpAnn :: HsType GhcPs -> HsType GhcPs+    closeEpAnn (HsFunTy _ p l r) = HsFunTy EpAnnNotUsed p l r+    closeEpAnn x = x+#endif+-- | This function replaces all 'EpAnn's that contain placeholder anchors+-- to locate comments correctly. A placeholder anchor is an anchor pointing+-- on (-1, -1).+closePlaceHolderEpAnns :: HsModule' -> HsModule'+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+-- TODO: 'EpAnnNotUsed' is not used since 9.10.1. We need to find another+-- way to close 'EpAnn's.+closePlaceHolderEpAnns = id+#else+closePlaceHolderEpAnns = everywhere closeEpAnn+  where+    closeEpAnn ::+         forall a. Typeable a+      => a+      -> a+    closeEpAnn x+      | App g _ <- typeRep @a+      , Just HRefl <- eqTypeRep g (typeRep @EpAnn)+      , (EpAnn (Anchor sp _) _ _) <- x+      , srcSpanEndLine sp == -1 && srcSpanEndCol sp == -1 = EpAnnNotUsed+      | otherwise = x+#endif+-- | This function removes all 'DocD's from the given module. They have+-- haddocks, but the same information is stored in 'EpaCommentTok's. Thus,+-- we need to remove the duplication.+removeAllDocDs :: HsModule' -> HsModule'+removeAllDocDs x@HsModule {hsmodDecls = decls} =+  x {hsmodDecls = filter (not . isDocD . unLoc) decls}+  where+    isDocD DocD {} = True+    isDocD _ = False++-- | This function sets the position of the given 'LGRHS' to the end+-- position of the last RHS in it.+--+-- See the documentation of 'resetLGRHSEndPositionInModule' for the reason.+resetLGRHSEndPosition ::+     LGRHS GhcPs (LHsExpr GhcPs) -> LGRHS GhcPs (LHsExpr GhcPs)+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+resetLGRHSEndPosition (L locAnn (GRHS ext@EpAnn {..} stmt body)) =+  let lastPosition =+        maximum+          $ realSrcSpanEnd . epaLocationToRealSrcSpan+              <$> listify collectEpaLocation' body+      newSpan =+        mkRealSrcSpan+          (realSrcSpanStart $ epaLocationToRealSrcSpan entry)+          lastPosition+      newLocAnn = locAnn {entry = realSpanAsAnchor newSpan}+      newAnn = ext {entry = realSpanAsAnchor newSpan}+   in L newLocAnn (GRHS newAnn stmt body)+  where+    collectEpaLocation' :: EpaLocation -> Bool+    collectEpaLocation' (EpaSpan RealSrcSpan {}) = True+    collectEpaLocation' _ = False+#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)+resetLGRHSEndPosition (L (SrcSpanAnn locAnn@EpAnn {} sp) (GRHS ext@EpAnn {..} stmt body)) =+  let lastPosition =+        maximum $ realSrcSpanEnd . anchor <$> listify collectAnchor body+      newSpan = mkRealSrcSpan (realSrcSpanStart $ anchor entry) lastPosition+      newLocAnn = locAnn {entry = realSpanAsAnchor newSpan}+      newAnn = ext {entry = realSpanAsAnchor newSpan}+   in L (SrcSpanAnn newLocAnn sp) (GRHS newAnn stmt body)+  where+    collectAnchor :: Anchor -> Bool+    collectAnchor _ = True+resetLGRHSEndPosition x = x+#else+resetLGRHSEndPosition (L _ (GRHS ext@EpAnn {..} stmt body)) =+  let lastPosition =+        maximum $ realSrcSpanEnd . anchor <$> listify collectAnchor body+      newSpan = mkRealSrcSpan (realSrcSpanStart $ anchor entry) lastPosition+      newLoc = RealSrcSpan newSpan Nothing+      newAnn = ext {entry = realSpanAsAnchor newSpan}+   in L newLoc (GRHS newAnn stmt body)+  where+    collectAnchor :: Anchor -> Bool+    collectAnchor _ = True+resetLGRHSEndPosition x = x+#endif+isEofComment :: EpaCommentTok -> Bool+#if !MIN_VERSION_ghc_lib_parser(9, 10, 1)+isEofComment EpaEofComment = True+#endif+isEofComment _ = False
+ src/HIndent/ModulePreprocessing/CommentRelocation.hs view
@@ -0,0 +1,969 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase #-}++-- | Comment relocation for pretty-printing comments correctly.+--+-- HIndent gathers all comments above a function, an import, a module+-- declaration, etc. For example, HIndent formats the following code+--+-- > f :: Int+-- > f = 1+-- >+-- > -- A comment between f and g+-- >+-- > -- Another comment between f and g+-- >+-- > g :: Int+-- > g = 2+--+-- to+--+-- > f :: Int+-- > f = 1+-- >+-- > -- A comment between f and g+-- > -- Another comment between f and g+-- > g :: Int+-- > g = 2+--+-- AST nodes must have the information of which comments are above, on the+-- same line, and below. However, AST nodes generated by a parser of+-- 'ghc-lib-parser' only contain comments after them. 'relocateComments' is+-- defined to solve the problem.+module HIndent.ModulePreprocessing.CommentRelocation+  ( relocateComments+  ) where++import Control.Exception+import Control.Monad.State+import Data.Foldable+import Data.Function+import Data.List (partition, sortBy)+import GHC.Types.SrcLoc+import Generics.SYB hiding (GT, typeOf, typeRep)+import HIndent.GhcLibParserWrapper.GHC.Hs+import HIndent.GhcLibParserWrapper.GHC.Parser.Annotation+import HIndent.Pragma+import HIndent.Pretty.SigBindFamily+import Type.Reflection+#if MIN_VERSION_GLASGOW_HASKELL(9, 6, 0, 0)+import Control.Monad+#endif+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+import GHC.Data.Bag+#endif+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+import Data.Maybe+#endif+-- | A wrapper type used in everywhereMEpAnnsBackwards' to collect all+-- 'EpAnn's to apply a function with them in order their positions.+data Wrapper =+  forall a. Typeable (EpAnn a) =>+            Wrapper (EpAnn a)++-- | 'State' with comments.+type WithComments = State [LEpaComment]++-- | This function collects all comments from the passed 'HsModule', and+-- modifies all 'EpAnn's so that all 'EpAnn's have 'EpaCommentsBalanced's.+relocateComments :: HsModule' -> [LEpaComment] -> HsModule'+relocateComments = evalState . relocate+  where+    relocate =+      relocatePragmas+        >=> relocateCommentsBeforePragmas+        >=> relocateCommentsInExportList+        >=> relocateCommentsInClass+        >=> relocateCommentsBeforeTopLevelDecls+        >=> relocateCommentsSameLine+        >=> relocateCommentsInDoExpr+        >=> relocateCommentsInCase+        >=> relocateCommentsTopLevelWhereClause+        >=> relocateCommentsAfter+        >=> assertAllCommentsAreConsumed+        >=> moveCommentsFromFunIdToMcFun+    assertAllCommentsAreConsumed x = do+      cs <- get+      assert (null cs) (pure x)+-- | This function locates pragmas to the module's EPA.+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+relocatePragmas :: HsModule GhcPs -> WithComments (HsModule GhcPs)+relocatePragmas m@HsModule {hsmodExt = xmod@XModulePs {hsmodAnn = epa@EpAnn {}}} = do+  newAnn <- insertComments (isPragma . ac_tok . unLoc) insertPriorComments epa+  return m {hsmodExt = xmod {hsmodAnn = newAnn}}+#else+relocatePragmas :: HsModule -> WithComments HsModule+relocatePragmas m@HsModule {hsmodAnn = epa@EpAnn {}} = do+  newAnn <- insertComments (isPragma . ac_tok . unLoc) insertPriorComments epa+  return m {hsmodAnn = newAnn}+#endif+#if !MIN_VERSION_ghc_lib_parser(9, 10, 1)+relocatePragmas m = pure m+#endif+-- | This function locates comments that are located before pragmas to the+-- module's EPA.+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+relocateCommentsBeforePragmas :: HsModule GhcPs -> WithComments (HsModule GhcPs)+relocateCommentsBeforePragmas m@HsModule {hsmodExt = xmod@XModulePs {hsmodAnn = ann}}+  | pragmaExists m = do+    newAnn <- insertCommentsByPos (< startPosOfPragmas) insertPriorComments ann+    pure m {hsmodExt = xmod {hsmodAnn = newAnn}}+  | otherwise = pure m+  where+    startPosOfPragmas =+      let loc =+            maybe (error "No prior comments") getLoc+              $ listToMaybe+              $ priorComments+              $ comments ann+       in case loc of+            EpaSpan (RealSrcSpan sp _) -> sp+            _ -> undefined+#elif MIN_VERSION_ghc_lib_parser(9, 6, 1)+relocateCommentsBeforePragmas :: HsModule GhcPs -> WithComments (HsModule GhcPs)+relocateCommentsBeforePragmas m@HsModule {hsmodExt = xmod@XModulePs {hsmodAnn = ann}}+  | pragmaExists m = do+    newAnn <- insertCommentsByPos (< startPosOfPragmas) insertPriorComments ann+    pure m {hsmodExt = xmod {hsmodAnn = newAnn}}+  | otherwise = pure m+  where+    startPosOfPragmas =+      maybe (error "No prior comments.") (anchor . getLoc)+        $ listToMaybe+        $ priorComments+        $ comments ann+#else+relocateCommentsBeforePragmas :: HsModule -> WithComments HsModule+relocateCommentsBeforePragmas m@HsModule {hsmodAnn = ann}+  | pragmaExists m = do+    newAnn <- insertCommentsByPos (< startPosOfPragmas) insertPriorComments ann+    pure m {hsmodAnn = newAnn}+  | otherwise = pure m+  where+    startPosOfPragmas = anchor $ getLoc $ head $ priorComments $ comments ann+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+-- | This function locates comments that are located before each element of+-- an export list.+relocateCommentsInExportList :: HsModule' -> WithComments HsModule'+relocateCommentsInExportList =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: HsModule' -> [LIE GhcPs]+    elemGetter HsModule {hsmodExports = Just (L _ xs)} = xs+    elemGetter _ = []+    elemSetter xs HsModule {hsmodExports = Just (L sp _), ..} =+      HsModule {hsmodExports = Just (L sp xs), ..}+    elemSetter _ x = x+    annGetter (L ann _) = ann+    annSetter newAnn (L _ x) = L newAnn x+    cond HsModule {hsmodExports = Just (L EpAnn {entry = EpaSpan (RealSrcSpan listAnc _)} _)} (L EpAnn {entry = EpaSpan (RealSrcSpan elemAnc _)} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine elemAnc+        && realSrcSpanStart listAnc < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | Locates comments before each case branch.+relocateCommentsInCase :: HsModule' -> WithComments HsModule'+relocateCommentsInCase =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]+    elemGetter (L _ (HsCase _ _ (MG {mg_alts = L _ xs}))) = xs+    elemGetter _ = []+    elemSetter xs (L sp (HsCase ext expr (MG {mg_alts = L sp' _, ..}))) =+      L sp (HsCase ext expr (MG {mg_alts = L sp' xs, ..}))+    elemSetter _ x = x+    annGetter (L ann _) = ann+    annSetter newAnn (L _ x) = L newAnn x+    cond (L EpAnn {entry = EpaSpan (RealSrcSpan caseAnchor _)} _) (L EpAnn {entry = EpaSpan (RealSrcSpan branchAnchor _)} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine branchAnchor+        && realSrcSpanStart caseAnchor < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | Locates comments before each class element.+relocateCommentsInClass :: HsModule' -> WithComments HsModule'+relocateCommentsInClass =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: LHsDecl GhcPs -> [LSigBindFamily]+    elemGetter (L _ (TyClD _ ClassDecl {..})) =+      mkSortedLSigBindFamilyList tcdSigs tcdMeths tcdATs [] tcdATDefs []+    elemGetter _ = []+    elemSetter xs (L sp (TyClD ext ClassDecl {..})) = L sp (TyClD ext newDecl)+      where+        newDecl =+          ClassDecl+            { tcdSigs = sigs+            , tcdMeths = binds+            , tcdATs = typeFamilies+            , tcdATDefs = tyFamDeflts+            , ..+            }+        (sigs, binds, typeFamilies, _, tyFamDeflts, _) =+          destructLSigBindFamilyList xs+    elemSetter _ x = x+    annGetter (L ann _) = ann+    annSetter newAnn (L _ x) = L newAnn x+    cond (L EpAnn {entry = EpaSpan (RealSrcSpan classAnchor _)} _) (L EpAnn {entry = EpaSpan (RealSrcSpan elemAnchor _)} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine elemAnchor+        && realSrcSpanStart classAnchor < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | Locates comments before each statement in a do expression.+relocateCommentsInDoExpr :: HsModule' -> WithComments HsModule'+relocateCommentsInDoExpr =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: LHsExpr GhcPs -> [ExprLStmt GhcPs]+    elemGetter (L _ (HsDo _ DoExpr {} (L _ xs))) = xs+    elemGetter (L _ (HsDo _ MDoExpr {} (L _ xs))) = xs+    elemGetter _ = []+    elemSetter xs (L sp (HsDo ext flavor@DoExpr {} (L sp' _))) =+      L sp (HsDo ext flavor (L sp' xs))+    elemSetter xs (L sp (HsDo ext flavor@MDoExpr {} (L sp' _))) =+      L sp (HsDo ext flavor (L sp' xs))+    elemSetter _ x = x+    annGetter (L ann _) = ann+    annSetter newAnn (L _ x) = L newAnn x+    cond (L EpAnn {entry = EpaSpan (RealSrcSpan doAnchor _)} _) (L EpAnn {entry = EpaSpan (RealSrcSpan elemAnchor _)} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine elemAnchor+        && realSrcSpanStart doAnchor < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | This function locates comments located before top-level declarations.+relocateCommentsBeforeTopLevelDecls :: HsModule' -> WithComments HsModule'+relocateCommentsBeforeTopLevelDecls = everywhereM (applyM f)+  where+    f epa@EpAnn {..}+      | EpaSpan (RealSrcSpan anc _) <- entry =+        insertCommentsByPos (isBefore anc) insertPriorComments epa+      | otherwise = pure epa+    isBefore anc comAnc =+      srcSpanStartCol anc == 1+        && srcSpanStartCol comAnc == 1+        && srcSpanStartLine comAnc < srcSpanStartLine anc++-- | This function scans the given AST from bottom to top and locates+-- comments that are on the same line as the node.  Comments are stored in+-- the 'followingComments' of 'EpaCommentsBalanced'.+relocateCommentsSameLine :: HsModule' -> WithComments HsModule'+relocateCommentsSameLine = everywhereMEpAnnsBackwards f+  where+    f epa@EpAnn {..}+      | EpaSpan (RealSrcSpan anc _) <- entry =+        insertCommentsByPos (isOnSameLine anc) insertFollowingComments epa+      | otherwise = pure epa+    isOnSameLine anc comAnc =+      srcSpanStartLine comAnc == srcSpanStartLine anc+        && srcSpanStartLine comAnc == srcSpanEndLine anc++-- | This function locates comments above the top-level declarations in+-- a 'where' clause in the topmost declaration.+relocateCommentsTopLevelWhereClause :: HsModule' -> WithComments HsModule'+relocateCommentsTopLevelWhereClause m@HsModule {..} = do+  hsmodDecls' <- mapM relocateCommentsDeclWhereClause hsmodDecls+  pure m {hsmodDecls = hsmodDecls'}+  where+    relocateCommentsDeclWhereClause (L l (ValD ext fb@(FunBind {fun_matches = MG {..}}))) = do+      mg_alts' <- mapM (mapM relocateCommentsMatch) mg_alts+      pure $ L l (ValD ext fb {fun_matches = MG {mg_alts = mg_alts', ..}})+    relocateCommentsDeclWhereClause x = pure x+    relocateCommentsMatch (L l match@Match {m_grhss = gs@GRHSs {grhssLocalBinds = (HsValBinds ext (ValBinds ext' binds sigs))}}) = do+      (binds', sigs') <- relocateCommentsBindsSigs binds sigs+      let localBinds = HsValBinds ext (ValBinds ext' binds' sigs')+      pure $ L l match {m_grhss = gs {grhssLocalBinds = localBinds}}+    relocateCommentsMatch x = pure x+    relocateCommentsBindsSigs ::+         LHsBindsLR GhcPs GhcPs+      -> [LSig GhcPs]+      -> WithComments (LHsBindsLR GhcPs GhcPs, [LSig GhcPs])+    relocateCommentsBindsSigs binds sigs = do+      bindsSigs' <- mapM addCommentsBeforeEpAnn bindsSigs+      pure (filterLBind bindsSigs', filterLSig bindsSigs')+      where+        bindsSigs = mkSortedLSigBindFamilyList sigs binds [] [] [] []+    addCommentsBeforeEpAnn (L epa@EpAnn { entry = EpaSpan (RealSrcSpan anc _)+                                        , ..+                                        } x) = do+      cs <- get+      let (notAbove, above) =+            partitionAboveNotAbove (sortCommentsByLocation cs) anc+          epa' = epa {comments = insertPriorComments comments above}+      put notAbove+      pure $ L epa' x+    addCommentsBeforeEpAnn x = pure x+    partitionAboveNotAbove cs sp =+      fst+        $ foldr'+            (\c@(L l _) ((ls, rs), lastSpan) ->+               case l of+                 EpaSpan (RealSrcSpan anc _) ->+                   if anc `isAbove` lastSpan+                     then ((ls, c : rs), anc)+                     else ((c : ls, rs), lastSpan)+                 _ -> undefined)+            (([], []), sp)+            cs+    isAbove comAnc anc =+      srcSpanStartCol comAnc == srcSpanStartCol anc+        && srcSpanEndLine comAnc + 1 == srcSpanStartLine anc+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+-- | This function locates comments that are located before each element of+-- an export list.+relocateCommentsInExportList :: HsModule' -> WithComments HsModule'+relocateCommentsInExportList =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: HsModule' -> [LIE GhcPs]+    elemGetter HsModule {hsmodExports = Just (L _ xs)} = xs+    elemGetter _ = []+    elemSetter xs HsModule {hsmodExports = Just (L sp _), ..} =+      HsModule {hsmodExports = Just (L sp xs), ..}+    elemSetter _ x = x+    annGetter (L ann _) = ann+    annSetter newAnn (L _ x) = L newAnn x+    cond HsModule {hsmodExports = Just (L EpAnn {entry = EpaSpan (RealSrcSpan listAnc _)} _)} (L EpAnn {entry = EpaSpan (RealSrcSpan elemAnc _)} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine elemAnc+        && realSrcSpanStart listAnc < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | Locates comments before each case branch.+relocateCommentsInCase :: HsModule' -> WithComments HsModule'+relocateCommentsInCase =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]+    elemGetter (L _ (HsCase _ _ (MG {mg_alts = L _ xs}))) = xs+    elemGetter _ = []+    elemSetter xs (L sp (HsCase ext expr (MG {mg_alts = L sp' _, ..}))) =+      L sp (HsCase ext expr (MG {mg_alts = L sp' xs, ..}))+    elemSetter _ x = x+    annGetter (L ann _) = ann+    annSetter newAnn (L _ x) = L newAnn x+    cond (L EpAnn {entry = EpaSpan (RealSrcSpan caseAnchor _)} _) (L EpAnn {entry = EpaSpan (RealSrcSpan branchAnchor _)} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine branchAnchor+        && realSrcSpanStart caseAnchor < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | Locates comments before each class element.+relocateCommentsInClass :: HsModule' -> WithComments HsModule'+relocateCommentsInClass =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: LHsDecl GhcPs -> [LSigBindFamily]+    elemGetter (L _ (TyClD _ ClassDecl {..})) =+      mkSortedLSigBindFamilyList+        tcdSigs+        (bagToList tcdMeths)+        tcdATs+        []+        tcdATDefs+        []+    elemGetter _ = []+    elemSetter xs (L sp (TyClD ext ClassDecl {..})) = L sp (TyClD ext newDecl)+      where+        newDecl =+          ClassDecl+            { tcdSigs = sigs+            , tcdMeths = listToBag binds+            , tcdATs = typeFamilies+            , tcdATDefs = tyFamDeflts+            , ..+            }+        (sigs, binds, typeFamilies, _, tyFamDeflts, _) =+          destructLSigBindFamilyList xs+    elemSetter _ x = x+    annGetter (L ann _) = ann+    annSetter newAnn (L _ x) = L newAnn x+    cond (L EpAnn {entry = EpaSpan (RealSrcSpan classAnchor _)} _) (L EpAnn {entry = EpaSpan (RealSrcSpan elemAnchor _)} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine elemAnchor+        && realSrcSpanStart classAnchor < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | Locates comments before each statement in a do expression.+relocateCommentsInDoExpr :: HsModule' -> WithComments HsModule'+relocateCommentsInDoExpr =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: LHsExpr GhcPs -> [ExprLStmt GhcPs]+    elemGetter (L _ (HsDo _ DoExpr {} (L _ xs))) = xs+    elemGetter (L _ (HsDo _ MDoExpr {} (L _ xs))) = xs+    elemGetter _ = []+    elemSetter xs (L sp (HsDo ext flavor@DoExpr {} (L sp' _))) =+      L sp (HsDo ext flavor (L sp' xs))+    elemSetter xs (L sp (HsDo ext flavor@MDoExpr {} (L sp' _))) =+      L sp (HsDo ext flavor (L sp' xs))+    elemSetter _ x = x+    annGetter (L ann _) = ann+    annSetter newAnn (L _ x) = L newAnn x+    cond (L EpAnn {entry = EpaSpan (RealSrcSpan doAnchor _)} _) (L EpAnn {entry = EpaSpan (RealSrcSpan elemAnchor _)} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine elemAnchor+        && realSrcSpanStart doAnchor < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | This function locates comments located before top-level declarations.+relocateCommentsBeforeTopLevelDecls :: HsModule' -> WithComments HsModule'+relocateCommentsBeforeTopLevelDecls = everywhereM (applyM f)+  where+    f epa@EpAnn {..}+      | EpaSpan (RealSrcSpan anc _) <- entry =+        insertCommentsByPos (isBefore anc) insertPriorComments epa+      | otherwise = pure epa+    isBefore anc comAnc =+      srcSpanStartCol anc == 1+        && srcSpanStartCol comAnc == 1+        && srcSpanStartLine comAnc < srcSpanStartLine anc++-- | This function scans the given AST from bottom to top and locates+-- comments that are on the same line as the node.  Comments are stored in+-- the 'followingComments' of 'EpaCommentsBalanced'.+relocateCommentsSameLine :: HsModule' -> WithComments HsModule'+relocateCommentsSameLine = everywhereMEpAnnsBackwards f+  where+    f epa@EpAnn {..}+      | EpaSpan (RealSrcSpan anc _) <- entry =+        insertCommentsByPos (isOnSameLine anc) insertFollowingComments epa+      | otherwise = pure epa+    isOnSameLine anc comAnc =+      srcSpanStartLine comAnc == srcSpanStartLine anc+        && srcSpanStartLine comAnc == srcSpanEndLine anc++-- | This function locates comments above the top-level declarations in+-- a 'where' clause in the topmost declaration.+relocateCommentsTopLevelWhereClause :: HsModule' -> WithComments HsModule'+relocateCommentsTopLevelWhereClause m@HsModule {..} = do+  hsmodDecls' <- mapM relocateCommentsDeclWhereClause hsmodDecls+  pure m {hsmodDecls = hsmodDecls'}+  where+    relocateCommentsDeclWhereClause (L l (ValD ext fb@(FunBind {fun_matches = MG {..}}))) = do+      mg_alts' <- mapM (mapM relocateCommentsMatch) mg_alts+      pure $ L l (ValD ext fb {fun_matches = MG {mg_alts = mg_alts', ..}})+    relocateCommentsDeclWhereClause x = pure x+    relocateCommentsMatch (L l match@Match {m_grhss = gs@GRHSs {grhssLocalBinds = (HsValBinds ext (ValBinds ext' binds sigs))}}) = do+      (binds', sigs') <- relocateCommentsBindsSigs binds sigs+      let localBinds = HsValBinds ext (ValBinds ext' binds' sigs')+      pure $ L l match {m_grhss = gs {grhssLocalBinds = localBinds}}+    relocateCommentsMatch x = pure x+    relocateCommentsBindsSigs ::+         LHsBindsLR GhcPs GhcPs+      -> [LSig GhcPs]+      -> WithComments (LHsBindsLR GhcPs GhcPs, [LSig GhcPs])+    relocateCommentsBindsSigs binds sigs = do+      bindsSigs' <- mapM addCommentsBeforeEpAnn bindsSigs+      pure (listToBag $ filterLBind bindsSigs', filterLSig bindsSigs')+      where+        bindsSigs =+          mkSortedLSigBindFamilyList sigs (bagToList binds) [] [] [] []+    addCommentsBeforeEpAnn (L epa@EpAnn {..} x)+      | EpaSpan (RealSrcSpan anc _) <- entry = do+        cs <- get+        let (notAbove, above) =+              partitionAboveNotAbove (sortCommentsByLocation cs) anc+            epa' = epa {comments = insertPriorComments comments above}+        put notAbove+        pure $ L epa' x+      | otherwise = undefined+    partitionAboveNotAbove cs sp =+      fst+        $ foldr'+            (\c@(L l _) ((ls, rs), lastSpan) ->+               case l of+                 EpaSpan (RealSrcSpan anc _) ->+                   if anc `isAbove` lastSpan+                     then ((ls, c : rs), anc)+                     else ((c : ls, rs), lastSpan)+                 _ -> undefined)+            (([], []), sp)+            cs+    isAbove comAnc anc =+      srcSpanStartCol comAnc == srcSpanStartCol anc+        && srcSpanEndLine comAnc + 1 == srcSpanStartLine anc+#else+-- | This function locates comments that are located before each element of+-- an export list.+relocateCommentsInExportList :: HsModule' -> WithComments HsModule'+relocateCommentsInExportList =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: HsModule' -> [LIE GhcPs]+    elemGetter HsModule {hsmodExports = Just (L _ xs)} = xs+    elemGetter _ = []+    elemSetter xs HsModule {hsmodExports = Just (L sp _), ..} =+      HsModule {hsmodExports = Just (L sp xs), ..}+    elemSetter _ x = x+    annGetter (L SrcSpanAnn {..} _) = ann+    annSetter newAnn (L SrcSpanAnn {..} x) = L SrcSpanAnn {ann = newAnn, ..} x+    cond HsModule {hsmodExports = Just (L SrcSpanAnn {ann = EpAnn {entry = Anchor {anchor = listAnc}}} _)} (L SrcSpanAnn {ann = EpAnn {entry = Anchor {anchor = elemAnc}}} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine elemAnc+        && realSrcSpanStart listAnc < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | Locates comments before each case branch.+relocateCommentsInCase :: HsModule' -> WithComments HsModule'+relocateCommentsInCase =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]+    elemGetter (L _ (HsCase _ _ (MG {mg_alts = L _ xs}))) = xs+    elemGetter _ = []+    elemSetter xs (L sp (HsCase ext expr (MG {mg_alts = L sp' _, ..}))) =+      L sp (HsCase ext expr (MG {mg_alts = L sp' xs, ..}))+    elemSetter _ x = x+    annGetter (L SrcSpanAnn {..} _) = ann+    annSetter newAnn (L SrcSpanAnn {..} x) = L SrcSpanAnn {ann = newAnn, ..} x+    cond (L SrcSpanAnn {ann = EpAnn {entry = Anchor {anchor = caseAnchor}}} _) (L SrcSpanAnn {ann = EpAnn {entry = Anchor {anchor = branchAnchor}}} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine branchAnchor+        && realSrcSpanStart caseAnchor < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | Locates comments before each class element.+relocateCommentsInClass :: HsModule' -> WithComments HsModule'+relocateCommentsInClass =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: LHsDecl GhcPs -> [LSigBindFamily]+    elemGetter (L _ (TyClD _ ClassDecl {..})) =+      mkSortedLSigBindFamilyList+        tcdSigs+        (bagToList tcdMeths)+        tcdATs+        []+        tcdATDefs+        []+    elemGetter _ = []+    elemSetter xs (L sp (TyClD ext ClassDecl {..})) = L sp (TyClD ext newDecl)+      where+        newDecl =+          ClassDecl+            { tcdSigs = sigs+            , tcdMeths = listToBag binds+            , tcdATs = typeFamilies+            , tcdATDefs = tyFamDeflts+            , ..+            }+        (sigs, binds, typeFamilies, _, tyFamDeflts, _) =+          destructLSigBindFamilyList xs+    elemSetter _ x = x+    annGetter (L SrcSpanAnn {..} _) = ann+    annSetter newAnn (L SrcSpanAnn {..} x) = L SrcSpanAnn {ann = newAnn, ..} x+    cond (L SrcSpanAnn {ann = EpAnn {entry = Anchor {anchor = classAnchor}}} _) (L SrcSpanAnn {ann = EpAnn {entry = Anchor {anchor = elemAnchor}}} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine elemAnchor+        && realSrcSpanStart classAnchor < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | Locates comments before each statement in a do expression.+relocateCommentsInDoExpr :: HsModule' -> WithComments HsModule'+relocateCommentsInDoExpr =+  relocateCommentsBeforeEachElement+    elemGetter+    elemSetter+    annGetter+    annSetter+    cond+  where+    elemGetter :: LHsExpr GhcPs -> [ExprLStmt GhcPs]+    elemGetter (L _ (HsDo _ DoExpr {} (L _ xs))) = xs+    elemGetter (L _ (HsDo _ MDoExpr {} (L _ xs))) = xs+    elemGetter _ = []+    elemSetter xs (L sp (HsDo ext flavor@DoExpr {} (L sp' _))) =+      L sp (HsDo ext flavor (L sp' xs))+    elemSetter xs (L sp (HsDo ext flavor@MDoExpr {} (L sp' _))) =+      L sp (HsDo ext flavor (L sp' xs))+    elemSetter _ x = x+    annGetter (L SrcSpanAnn {..} _) = ann+    annSetter newAnn (L SrcSpanAnn {..} x) = L SrcSpanAnn {ann = newAnn, ..} x+    cond (L SrcSpanAnn {ann = EpAnn {entry = Anchor {anchor = doAnchor}}} _) (L SrcSpanAnn {ann = EpAnn {entry = Anchor {anchor = elemAnchor}}} _) comAnc =+      srcSpanStartLine comAnc < srcSpanStartLine elemAnchor+        && realSrcSpanStart doAnchor < realSrcSpanStart comAnc+    cond _ _ _ = False++-- | This function locates comments located before top-level declarations.+relocateCommentsBeforeTopLevelDecls :: HsModule' -> WithComments HsModule'+relocateCommentsBeforeTopLevelDecls = everywhereM (applyM f)+  where+    f epa@EpAnn {..} =+      insertCommentsByPos (isBefore $ anchor entry) insertPriorComments epa+    f EpAnnNotUsed = pure EpAnnNotUsed+    isBefore anc comAnc =+      srcSpanStartCol anc == 1+        && srcSpanStartCol comAnc == 1+        && srcSpanStartLine comAnc < srcSpanStartLine anc++-- | This function scans the given AST from bottom to top and locates+-- comments that are on the same line as the node.  Comments are stored in+-- the 'followingComments' of 'EpaCommentsBalanced'.+relocateCommentsSameLine :: HsModule' -> WithComments HsModule'+relocateCommentsSameLine = everywhereMEpAnnsBackwards f+  where+    f epa@EpAnn {..} =+      insertCommentsByPos+        (isOnSameLine $ anchor entry)+        insertFollowingComments+        epa+    f EpAnnNotUsed = pure EpAnnNotUsed+    isOnSameLine anc comAnc =+      srcSpanStartLine comAnc == srcSpanStartLine anc+        && srcSpanStartLine comAnc == srcSpanEndLine anc++-- | This function locates comments above the top-level declarations in+-- a 'where' clause in the topmost declaration.+relocateCommentsTopLevelWhereClause :: HsModule' -> WithComments HsModule'+relocateCommentsTopLevelWhereClause m@HsModule {..} = do+  hsmodDecls' <- mapM relocateCommentsDeclWhereClause hsmodDecls+  pure m {hsmodDecls = hsmodDecls'}+  where+    relocateCommentsDeclWhereClause (L l (ValD ext fb@(FunBind {fun_matches = MG {..}}))) = do+      mg_alts' <- mapM (mapM relocateCommentsMatch) mg_alts+      pure $ L l (ValD ext fb {fun_matches = MG {mg_alts = mg_alts', ..}})+    relocateCommentsDeclWhereClause x = pure x+    relocateCommentsMatch (L l match@Match {m_grhss = gs@GRHSs {grhssLocalBinds = (HsValBinds ext (ValBinds ext' binds sigs))}}) = do+      (binds', sigs') <- relocateCommentsBindsSigs binds sigs+      let localBinds = HsValBinds ext (ValBinds ext' binds' sigs')+      pure $ L l match {m_grhss = gs {grhssLocalBinds = localBinds}}+    relocateCommentsMatch x = pure x+    relocateCommentsBindsSigs ::+         LHsBindsLR GhcPs GhcPs+      -> [LSig GhcPs]+      -> WithComments (LHsBindsLR GhcPs GhcPs, [LSig GhcPs])+    relocateCommentsBindsSigs binds sigs = do+      bindsSigs' <- mapM addCommentsBeforeEpAnn bindsSigs+      pure (listToBag $ filterLBind bindsSigs', filterLSig bindsSigs')+      where+        bindsSigs =+          mkSortedLSigBindFamilyList sigs (bagToList binds) [] [] [] []+    addCommentsBeforeEpAnn (L (SrcSpanAnn epa@EpAnn {..} sp) x) = do+      cs <- get+      let (notAbove, above) =+            partitionAboveNotAbove (sortCommentsByLocation cs) entry+          epa' = epa {comments = insertPriorComments comments above}+      put notAbove+      pure $ L (SrcSpanAnn epa' sp) x+    addCommentsBeforeEpAnn x = pure x+    partitionAboveNotAbove cs sp =+      fst+        $ foldr'+            (\c@(L l _) ((ls, rs), lastSpan) ->+               if anchor l `isAbove` anchor lastSpan+                 then ((ls, c : rs), l)+                 else ((c : ls, rs), lastSpan))+            (([], []), sp)+            cs+    isAbove comAnc anc =+      srcSpanStartCol comAnc == srcSpanStartCol anc+        && srcSpanEndLine comAnc + 1 == srcSpanStartLine anc+#endif+-- | This function scans the given AST from bottom to top and locates+-- comments in the comment pool after each node on it.+relocateCommentsAfter :: HsModule' -> WithComments HsModule'+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+relocateCommentsAfter = everywhereMEpAnnsBackwards f+  where+    f epa@EpAnn {..} =+      insertCommentsByPos+        (isAfter $ epaLocationToRealSrcSpan entry)+        insertFollowingComments+        epa+    isAfter anc comAnc = srcSpanEndLine anc <= srcSpanStartLine comAnc+#else+relocateCommentsAfter = everywhereMEpAnnsBackwards f+  where+    f epa@EpAnn {..} =+      insertCommentsByPos+        (isAfter $ epaLocationToRealSrcSpan entry)+        insertFollowingComments+        epa+    f EpAnnNotUsed = pure EpAnnNotUsed+    isAfter anc comAnc = srcSpanEndLine anc <= srcSpanStartLine comAnc+#endif+-- | Locates comments before each element in a parent.+relocateCommentsBeforeEachElement ::+     forall a b c. Typeable a+  => (a -> [b]) -- ^ Element getter+  -> ([b] -> a -> a) -- ^ Element setter+  -> (b -> EpAnn c) -- ^ Annotation getter+  -> (EpAnn c -> b -> b) -- ^ Annotation setter+  -> (a -> b -> RealSrcSpan -> Bool) -- ^ The function to decide whether to locate comments+  -> HsModule'+  -> WithComments HsModule'+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+relocateCommentsBeforeEachElement elemGetter elemSetter annGetter annSetter cond =+  everywhereM (mkM f)+  where+    f :: a -> WithComments a+    f x = do+      newElems <- mapM insertCommentsBeforeElement (elemGetter x)+      pure $ elemSetter newElems x+      where+        insertCommentsBeforeElement element = do+          newEpa <-+            insertCommentsByPos+              (cond x element)+              insertPriorComments+              (annGetter element)+          pure $ annSetter newEpa element+#else+relocateCommentsBeforeEachElement elemGetter elemSetter annGetter annSetter cond =+  everywhereM (mkM f)+  where+    f :: a -> WithComments a+    f x = do+      newElems <- mapM insertCommentsBeforeElement (elemGetter x)+      pure $ elemSetter newElems x+      where+        insertCommentsBeforeElement element+          | elemAnn@EpAnn {} <- annGetter element = do+            newEpa <-+              insertCommentsByPos (cond x element) insertPriorComments elemAnn+            pure $ annSetter newEpa element+          | otherwise = pure element+#endif+-- | This function applies the given function to all 'EpAnn's.+applyM ::+     forall a. Typeable a+  => (forall b. EpAnn b -> WithComments (EpAnn b))+  -> (a -> WithComments a)+applyM f+  | App g _ <- typeRep @a+  , Just HRefl <- eqTypeRep g (typeRep @EpAnn) = f+  | otherwise = pure++-- | This function drains comments whose positions satisfy the given+-- predicate and inserts them to the given node using the given inserter.+insertCommentsByPos ::+     (RealSrcSpan -> Bool)+  -> (EpAnnComments -> [LEpaComment] -> EpAnnComments)+  -> EpAnn a+  -> WithComments (EpAnn a)+insertCommentsByPos cond =+  insertComments (cond . epaLocationToRealSrcSpan . getLoc)++-- | This function drains comments that satisfy the given predicate and+-- inserts them to the given node using the given inserter.+insertComments ::+     (LEpaComment -> Bool)+  -> (EpAnnComments -> [LEpaComment] -> EpAnnComments)+  -> EpAnn a+  -> WithComments (EpAnn a)+insertComments cond inserter epa@EpAnn {..} = do+  coms <- drainComments cond+  pure $ epa {comments = inserter comments coms}+#if !MIN_VERSION_ghc_lib_parser(9, 10, 1)+insertComments _ _ EpAnnNotUsed = pure EpAnnNotUsed+#endif+-- | This function inserts comments to `priorComments`.+insertPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments+insertPriorComments (EpaComments prior) cs =+  EpaComments (sortCommentsByLocation $ prior ++ cs)+insertPriorComments (EpaCommentsBalanced prior following) cs =+  EpaCommentsBalanced (sortCommentsByLocation $ prior ++ cs) following++-- | This function inserts comments to `followingComments`.+insertFollowingComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments+insertFollowingComments (EpaComments prior) cs = EpaCommentsBalanced prior cs+insertFollowingComments (EpaCommentsBalanced prior following) cs =+  EpaCommentsBalanced prior (sortCommentsByLocation $ following ++ cs)++-- | This function drains comments that satisfy the given predicate.+drainComments :: (LEpaComment -> Bool) -> WithComments [LEpaComment]+drainComments cond = do+  coms <- get+  let (xs, others) = partition cond coms+  put others+  return xs++-- | 'everywhereM' but applies the given function to EPAs in order their+-- positions from backwards.+everywhereMEpAnnsBackwards ::+     Data a+  => (forall b. EpAnn b -> WithComments (EpAnn b))+  -> a+  -> WithComments a+everywhereMEpAnnsBackwards =+  everywhereMEpAnnsInOrder (flip compareEpaByEndPosition)++-- | 'everywhereM' but applies the given function to EPAs in order+-- specified by the given ordering function.+everywhereMEpAnnsInOrder ::+     Data a+  => (forall b c. EpAnn b -> EpAnn c -> Ordering)+  -> (forall b. EpAnn b -> WithComments (EpAnn b))+  -> a+  -> WithComments a+everywhereMEpAnnsInOrder cmp f hm =+  collectEpAnnsInOrderEverywhereMTraverses+    >>= applyFunctionInOrderEpAnnEndPositions+    >>= putModifiedEpAnnsToModule+  where+    collectEpAnnsInOrderEverywhereMTraverses+      -- This function uses 'everywhereM' to collect 'EpAnn's because they+      -- should be collected in the same order as 'putModifiedEpAnnsToModule'+      -- puts them to the AST.+     = reverse <$> execStateT (everywhereM collectEpAnnsST hm) []+      where+        collectEpAnnsST x = do+          modify $ collectEpAnns x+          pure x+        collectEpAnns ::+             forall a. Typeable a+          => a+          -> ([Wrapper] -> [Wrapper])+        collectEpAnns x+          -- If 'a' is 'EpAnn b' ('b' can be any type), wrap 'x' with a 'Wrapper'.+          | App g _ <- typeRep @a+          , Just HRefl <- eqTypeRep g (typeRep @EpAnn) = (Wrapper x :)+          | otherwise = id+    applyFunctionInOrderEpAnnEndPositions ::+         [Wrapper]+      -> WithComments [(Int, Wrapper)] -- ^ The first element of the tuple+                                       -- indicates how many 'Wrapper's were there before 'everywhereM'+                                       -- accessed the second element.+    applyFunctionInOrderEpAnnEndPositions anns =+      forM sorted $ \(i, Wrapper x) -> do+        x' <- f x+        pure (i, Wrapper x')+      where+        indexed = zip [0 :: Int ..] anns+        sorted = sortBy (\(_, Wrapper a) (_, Wrapper b) -> cmp a b) indexed+    putModifiedEpAnnsToModule anns = evalStateT (everywhereM setEpAnn hm) [0 ..]+      where+        setEpAnn ::+             forall a. Typeable a+          => a+          -> StateT [Int] WithComments a+        setEpAnn x+          -- This guard arm checks if 'a' is 'EpAnn b' ('b' can be any type).+          | App g g' <- typeRep @a+          , Just HRefl <- eqTypeRep g (typeRep @EpAnn) = do+            get >>= \case+              [] -> error "No comments."+              (i:is) -> do+                put is+                case lookup i anns of+                  Just (Wrapper y)+                    | App _ h <- typeOf y+                    , Just HRefl <- eqTypeRep g' h -> pure y+                  _ -> error "Unmatches"+          | otherwise = pure x++-- | This function moves comments in `fun_id` of `FunBind` to+-- `mc_fun` of `HsMatchContext`.+--+-- This is a workaround for the issue that `EpAnn`s in `mc_fun` cannot be+-- closed since 9.10.1.+moveCommentsFromFunIdToMcFun :: HsModule' -> WithComments HsModule'+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+moveCommentsFromFunIdToMcFun = pure . everywhere (mkT f)+  where+    f :: HsBind GhcPs -> HsBind GhcPs+    f fb@FunBind { fun_id = L EpAnn {comments = from, ..} fid+                 , fun_matches = MG {mg_alts = L l alts, ..}+                 } =+      fb+        { fun_id = L EpAnn {comments = EpaCommentsBalanced [] [], ..} fid+        , fun_matches = MG {mg_alts = L l alts', ..}+        }+      where+        alts' =+          fmap+            (\(L l' x) ->+               case x of+                 Match {m_ctxt = FunRhs {mc_fun = L funann@EpAnn {} fun, ..}} ->+                   L+                     l'+                     x+                       { m_ctxt =+                           FunRhs {mc_fun = L funann {comments = from} fun, ..}+                       }+                 x'' -> L l' x'')+            alts+    f x = x+#else+moveCommentsFromFunIdToMcFun = pure+#endif+-- | This function sorts comments by its location.+sortCommentsByLocation :: [LEpaComment] -> [LEpaComment]+sortCommentsByLocation = sortBy (compare `on` epaLocationToRealSrcSpan . getLoc)++-- | This function compares given EPAs by their end positions.+compareEpaByEndPosition :: EpAnn a -> EpAnn b -> Ordering+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+compareEpaByEndPosition (EpAnn (EpaSpan a) _ _) (EpAnn (EpaSpan b) _ _) =+  case (a, b) of+    (RealSrcSpan a' _, RealSrcSpan b' _) ->+      compare (realSrcSpanEnd a') (realSrcSpanEnd b')+    (UnhelpfulSpan _, UnhelpfulSpan _) -> EQ+    (_, UnhelpfulSpan _) -> GT+    (UnhelpfulSpan _, _) -> LT+compareEpaByEndPosition (EpAnn a _ _) (EpAnn b _ _) =+  case (a, b) of+    (EpaDelta {}, EpaDelta {}) -> EQ+    (_, EpaDelta {}) -> GT+    (EpaDelta {}, _) -> LT+#else+compareEpaByEndPosition (EpAnn a _ _) (EpAnn b _ _) =+  on compare (realSrcSpanEnd . anchor) a b+compareEpaByEndPosition EpAnnNotUsed EpAnnNotUsed = EQ+compareEpaByEndPosition _ EpAnnNotUsed = GT+compareEpaByEndPosition EpAnnNotUsed _ = LT+#endif
+ src/HIndent/Parse.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE CPP #-}++-- | Parsing and lexical analysis functions.+module HIndent.Parse+  ( parseModule+  , lexCode+  ) where++import Data.Maybe+import qualified GHC.Data.EnumSet as ES+import GHC.Data.FastString+import GHC.Data.StringBuffer+import qualified GHC.LanguageExtensions as GLP+import qualified GHC.Parser as GLP+import GHC.Parser.Lexer hiding (buffer)+import GHC.Stack+import GHC.Types.SrcLoc+import HIndent.GhcLibParserWrapper.GHC.Hs+#if MIN_VERSION_ghc_lib_parser(9,4,1)+import GHC.Utils.Error+import GHC.Utils.Outputable hiding ((<>), empty, text)+#endif+#if MIN_VERSION_ghc_lib_parser(9,8,1)+import GHC.Unit.Module.Warnings+#endif+-- | This function parses the given Haskell source code with the given file+-- path (if any) and parse options.+parseModule ::+     Maybe FilePath -> [GLP.Extension] -> String -> ParseResult HsModule'+parseModule filepath exts src =+  case unP GLP.parseModule initState of+    POk s m -> POk s $ unLoc m+    PFailed s -> PFailed s+  where+    initState = initParserState (parserOptsFromExtensions exts) buffer location+    location =+      mkRealSrcLoc (mkFastString $ fromMaybe "<interactive>" filepath) 1 1+    buffer = stringToStringBuffer src++-- | Lexically analyze the given code.+lexCode :: HasCallStack => String -> [Token]+lexCode code+  | POk _ tokens <-+      lexTokenStream+        (parserOptsFromExtensions [])+        (stringToStringBuffer code)+        (mkRealSrcLoc (mkFastString "<interactive>") 1 1) = fmap unLoc tokens+  | otherwise = error "Failed to lex the code."++-- | This function generates a 'ParserOpts' from te given extension.+--+-- The 'StarIsType' extension is always enabled to compile a code using+-- kinds like '* -> *'.+parserOptsFromExtensions :: [GLP.Extension] -> ParserOpts+#if MIN_VERSION_ghc_lib_parser(9,8,1)+parserOptsFromExtensions opts =+  mkParserOpts+    opts'+    diagOpts+    [] -- There are no supported languages and extensions (this list is used only in error messages)+    False -- Safe imports are off.+    False -- Haddock comments are treated as normal comments.+    True -- Comments are kept in an AST.+    False -- Do not update the internal position of a comment.+  where+    opts' = ES.fromList $ GLP.StarIsType : opts+    diagOpts =+      DiagOpts+        { diag_warning_flags = ES.empty+        , diag_fatal_warning_flags = ES.empty+        , diag_custom_warning_categories = emptyWarningCategorySet+        , diag_fatal_custom_warning_categories = emptyWarningCategorySet+        , diag_warn_is_error = False+        , diag_reverse_errors = False+        , diag_max_errors = Nothing+        , diag_ppr_ctx = defaultSDocContext+        }+#elif MIN_VERSION_ghc_lib_parser(9,4,1)+parserOptsFromExtensions opts =+  mkParserOpts+    opts'+    diagOpts+    [] -- There are no supported languages and extensions (this list is used only in error messages)+    False -- Safe imports are off.+    False -- Haddock comments are treated as normal comments.+    True -- Comments are kept in an AST.+    False -- Do not update the internal position of a comment.+  where+    opts' = ES.fromList $ GLP.StarIsType : opts+    diagOpts =+      DiagOpts+        { diag_warning_flags = ES.empty+        , diag_fatal_warning_flags = ES.empty+        , diag_warn_is_error = False+        , diag_reverse_errors = False+        , diag_max_errors = Nothing+        , diag_ppr_ctx = defaultSDocContext+        }+#else+parserOptsFromExtensions opts =+  mkParserOpts+    ES.empty -- No compiler warnings are enabled.+    opts'+    False -- Safe imports are off.+    False -- Haddock comments are treated as normal comments.+    True -- Comments are kept in an AST.+    False -- Do not update the internal position of a comment.+  where+    opts' = ES.fromList $ GLP.StarIsType : opts+#endif
+ src/HIndent/Path/Find.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DataKinds #-}++-- | Finding files.+-- Lifted from Stack.+module HIndent.Path.Find+  ( findFileUp+  ) where++import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.List (find)+import Path+import Path.IO hiding (findFiles)++-- | Find the location of a file matching the given predicate.+findFileUp ::+     (MonadIO m, MonadThrow m)+  => Path Abs Dir -- ^ Start here.+  -> (Path Abs File -> Bool) -- ^ Predicate to match the file.+  -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory.+  -> m (Maybe (Path Abs File)) -- ^ Absolute file path.+findFileUp = findPathUp snd++-- | Find the location of a path matching the given predicate.+findPathUp ::+     (MonadIO m, MonadThrow m)+  => (([Path Abs Dir], [Path Abs File]) -> [Path Abs t])+              -- ^ Choose path type from pair.+  -> Path Abs Dir -- ^ Start here.+  -> (Path Abs t -> Bool) -- ^ Predicate to match the path.+  -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory.+  -> m (Maybe (Path Abs t)) -- ^ Absolute path.+findPathUp pathType dir p upperBound = do+  entries <- listDir dir+  case find p (pathType entries) of+    Just path -> return (Just path)+    Nothing+      | Just dir == upperBound -> return Nothing+      | parent dir == dir -> return Nothing+      | otherwise -> findPathUp pathType (parent dir) p upperBound
+ src/HIndent/Pragma.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}++-- | Pragma-related functions.+module HIndent.Pragma+  ( extractPragmasFromCode+  , extractPragmaNameAndElement+  , pragmaExists+  , isPragma+  ) where++import Data.Bifunctor+import Data.Char+import Data.Generics+import Data.List (intercalate)+import Data.List.Split+import Data.Maybe+import GHC.Hs+import GHC.Parser.Lexer+import HIndent.GhcLibParserWrapper.GHC.Hs+import HIndent.Parse+import Text.Regex.TDFA hiding (empty)++-- | Extracts all pragmas from the given source code.+--+-- FIXME: The function is slow because it lexicographically analyzes the+-- given source code. An alternative way is to use regular expressions.+-- However, this method cannot determine if what appears to be a pragma is+-- really a pragma, or requires complex regular expressions. For example,+-- @{-\n\n{-# LANGUAGE CPP #-}\n\n-}@ is not a pragma, but is likely to be+-- recognized as such.+extractPragmasFromCode :: String -> [(String, String)] -- ^ [(Pragma's name (e.g., @"LANGUAGE"@), Pragma's element (e.g., @"CPP, DerivingVia"@))]+extractPragmasFromCode =+  mapMaybe extractPragmaNameAndElement . mapMaybe extractBlockComment . lexCode+  where+    extractBlockComment (ITblockComment c _) = Just c+    extractBlockComment _ = Nothing++-- | Extracts the pragma's name and its element from the given pragma.+--+-- This function returns a 'Nothing' if it fails to extract them.+extractPragmaNameAndElement :: String -> Maybe (String, String) -- ^ [(Pragma's name (e.g., @"LANGUAGE"@), Pragma's element (e.g., @"CPP, DerivingVia"@))]+extractPragmaNameAndElement l+  | (_, _, _, [name, element]) <-+      match pragmaRegex l :: (String, String, String, [String]) =+    Just (name, element)+extractPragmaNameAndElement _ = Nothing++-- | This function returns a 'True' if the passed 'EpaCommentTok' is+-- a pragma. Otherwise, it returns a 'False'.+isPragma :: EpaCommentTok -> Bool+isPragma (EpaBlockComment c) = match pragmaRegex c+isPragma _ = False++-- | A regex to match against a pragma.+pragmaRegex :: Regex+pragmaRegex =+  makeRegexOpts+    compOption+    execOption+    "^{-#[[:space:]]*([^[:space:]]+)[[:space:]]+([^#]+)#-}"++-- | The option for matching against a pragma.+execOption :: ExecOption+execOption = ExecOption {captureGroups = True}++-- | The option for matching against a pragma.+--+-- 'multiline' is set to 'False' to match against multiline pragmas, e.g.,+-- @{-# LANGUAGE CPP\nOverloadedStrings #-}@.+compOption :: CompOption+compOption =+  CompOption+    { caseSensitive = True+    , multiline = False+    , rightAssoc = True+    , newSyntax = True+    , lastStarGreedy = True+    }++-- | This function returns a 'True' if the module has pragmas.+-- Otherwise, it returns a 'False'.+pragmaExists :: HsModule' -> Bool+pragmaExists = not . null . collectPragmas++-- | This function collects pragma comments from the+-- given module and modifies them into 'String's.+--+-- A pragma's name is converted to the @SHOUT_CASE@ (e.g., @lAnGuAgE@ ->+-- @LANGUAGE@).+collectPragmas :: HsModule' -> [String]+collectPragmas =+  fmap (uncurry constructPragma)+    . mapMaybe extractPragma+    . listify isBlockComment+    . getModuleAnn++-- | This function returns a 'Just' value with the pragma+-- extracted from the passed 'EpaCommentTok' if it has one. Otherwise, it+-- returns a 'Nothing'.+extractPragma :: EpaCommentTok -> Maybe (String, [String])+extractPragma (EpaBlockComment c) =+  second (fmap strip . splitOn ",") <$> extractPragmaNameAndElement c+  where+    strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace+extractPragma _ = Nothing++-- | Construct a pragma.+constructPragma :: String -> [String] -> String+constructPragma optionOrPragma xs =+  "{-# " ++ fmap toUpper optionOrPragma ++ " " ++ intercalate ", " xs ++ " #-}"++-- | Checks if the given comment is a block one.+isBlockComment :: EpaCommentTok -> Bool+isBlockComment EpaBlockComment {} = True+isBlockComment _ = False
src/HIndent/Pretty.hs view
@@ -1,2151 +1,445 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}---- | Pretty printing.--module HIndent.Pretty-  (pretty)-  where--import           Control.Applicative-import           Control.Monad.State.Strict hiding (state)-import qualified Data.ByteString.Builder as S-import           Data.Foldable (for_, forM_, traverse_)-import           Data.Int-import           Data.List-import           Data.Maybe-import           Data.Monoid ((<>))-import           Data.Typeable-import           HIndent.Types-import qualified Language.Haskell.Exts as P-import           Language.Haskell.Exts.SrcLoc-import           Language.Haskell.Exts.Syntax-import           Prelude hiding (exp)------------------------------------------------------------------------------------- * Pretty printing class---- | Pretty printing class.-class (Annotated ast,Typeable ast) => Pretty ast where-  prettyInternal :: ast NodeInfo -> Printer ()---- | Pretty print including comments.-pretty :: (Pretty ast,Show (ast NodeInfo))-       => ast NodeInfo -> Printer ()-pretty a = do-  mapM_-    (\c' -> do-       case c' of-         CommentBeforeLine _ c -> do-           case c of-             EndOfLine s -> write ("--" ++ s)-             MultiLine s -> write ("{-" ++ s ++ "-}")-           newline-         _ -> return ())-    comments-  prettyInternal a-  mapM_-    (\(i, c') -> do-       case c' of-         CommentSameLine spn c -> do-           col <- gets psColumn-           if col == 0-             then do-               -- write comment keeping original indentation-               let col' = fromIntegral $ srcSpanStartColumn spn - 1-               column col' $ writeComment c-             else do-               space-               writeComment c-         CommentAfterLine spn c -> do-           when (i == 0) newline-           -- write comment keeping original indentation-           let col = fromIntegral $ srcSpanStartColumn spn - 1-           column col $ writeComment c-         _ -> return ())-    (zip [0 :: Int ..] comments)-  where-    comments = nodeInfoComments (ann a)-    writeComment =-      \case-        EndOfLine cs -> do-          write ("--" ++ cs)-          modify-            (\s ->-                s-                { psEolComment = True-                })-        MultiLine cs -> do-          write ("{-" ++ cs ++ "-}")-          modify-            (\s ->-                s-                { psEolComment = True-                })---- | Pretty print using HSE's own printer. The 'P.Pretty' class here--- is HSE's.-pretty' :: (Pretty ast,P.Pretty (ast SrcSpanInfo))-        => ast NodeInfo -> Printer ()-pretty' = write . P.prettyPrint . fmap nodeInfoSpan------------------------------------------------------------------------------------- * Combinators---- | Increase indentation level by n spaces for the given printer.-indented :: Int64 -> Printer a -> Printer a-indented i p =-  do level <- gets psIndentLevel-     modify (\s -> s {psIndentLevel = level + i})-     m <- p-     modify (\s -> s {psIndentLevel = level})-     return m--indentedBlock :: Printer a -> Printer a-indentedBlock p =-  do indentSpaces <- getIndentSpaces-     indented indentSpaces p---- | Print all the printers separated by spaces.-spaced :: [Printer ()] -> Printer ()-spaced = inter space---- | Print all the printers separated by commas.-commas :: [Printer ()] -> Printer ()-commas = inter (write ", ")---- | Print all the printers separated by sep.-inter :: Printer () -> [Printer ()] -> Printer ()-inter sep ps =-  foldr-    (\(i,p) next ->-        depend-          (do p-              if i < length ps-                then sep-                else return ())-          next)-    (return ())-    (zip [1 ..] ps)---- | Print all the printers separated by newlines.-lined :: [Printer ()] -> Printer ()-lined ps = sequence_ (intersperse newline ps)---- | Print all the printers separated newlines and optionally a line--- prefix.-prefixedLined :: String -> [Printer ()] -> Printer ()-prefixedLined pref ps' =-  case ps' of-    [] -> return ()-    (p:ps) ->-      do p-         indented (fromIntegral-                     (length pref *-                      (-1)))-                  (mapM_ (\p' ->-                            do newline-                               depend (write pref) p')-                         ps)---- | Set the (newline-) indent level to the given column for the given--- printer.-column :: Int64 -> Printer a -> Printer a-column i p =-  do level <- gets psIndentLevel-     modify (\s -> s {psIndentLevel = i})-     m <- p-     modify (\s -> s {psIndentLevel = level})-     return m---- | Output a newline.-newline :: Printer ()-newline =-  do write "\n"-     modify (\s -> s {psNewline = True})---- | Set the context to a case context, where RHS is printed with -> .-withCaseContext :: Bool -> Printer a -> Printer a-withCaseContext bool pr =-  do original <- gets psInsideCase-     modify (\s -> s {psInsideCase = bool})-     result <- pr-     modify (\s -> s {psInsideCase = original})-     return result---- | Get the current RHS separator, either = or -> .-rhsSeparator :: Printer ()-rhsSeparator =-  do inCase <- gets psInsideCase-     if inCase-        then write "->"-        else write "="---- | Make the latter's indentation depend upon the end column of the--- former.-depend :: Printer () -> Printer b -> Printer b-depend maker dependent =-  do state' <- get-     maker-     st <- get-     col <- gets psColumn-     if psLine state' /= psLine st || psColumn state' /= psColumn st-        then column col dependent-        else dependent---- | Wrap.-wrap :: String -> String -> Printer a -> Printer a-wrap open close p = depend (write open) $ p <* write close---- | Wrap in parens.-parens :: Printer a -> Printer a-parens = wrap "(" ")"---- | Wrap in braces.-braces :: Printer a -> Printer a-braces = wrap "{" "}"---- | Wrap in brackets.-brackets :: Printer a -> Printer a-brackets = wrap "[" "]"---- | Write a space.-space :: Printer ()-space = write " "---- | Write a comma.-comma :: Printer ()-comma = write ","---- | Write an integral.-int :: Integer -> Printer ()-int = write . show---- | Write out a string, updating the current position information.-write :: String -> Printer ()-write x =-  do eol <- gets psEolComment-     hardFail <- gets psFitOnOneLine-     let addingNewline = eol && x /= "\n"-     when addingNewline newline-     state <- get-     let writingNewline = x == "\n"-         out :: String-         out =-           if psNewline state && not writingNewline-              then (replicate (fromIntegral (psIndentLevel state))-                               ' ') <>-                   x-              else x-         psColumn' =-            if additionalLines > 0-               then fromIntegral (length (concat (take 1 (reverse srclines))))-               else psColumn state + fromIntegral (length out)-     when-       hardFail-       (guard-          (additionalLines == 0 &&-           (psColumn' <= configMaxColumns (psConfig state))))-     modify (\s ->-               s {psOutput = psOutput state <> S.stringUtf8 out-                 ,psNewline = False-                 ,psLine = psLine state + fromIntegral additionalLines-                 ,psEolComment= False-                 ,psColumn = psColumn'})-  where srclines = lines x-        additionalLines =-          length (filter (== '\n') x)---- | Write a string.-string :: String -> Printer ()-string = write---- | Indent spaces, e.g. 2.-getIndentSpaces :: Printer Int64-getIndentSpaces =-  gets (configIndentSpaces . psConfig)---- | Play with a printer and then restore the state to what it was--- before.-sandbox :: Printer a -> Printer (a,PrintState)-sandbox p =-  do orig <- get-     a <- p-     new <- get-     put orig-     return (a,new)---- | Render a type with a context, or not.-withCtx :: (Pretty ast,Show (ast NodeInfo))-        => Maybe (ast NodeInfo) -> Printer b -> Printer b-withCtx Nothing m = m-withCtx (Just ctx) m =-  do pretty ctx-     write " =>"-     newline-     m---- | Maybe render an overlap definition.-maybeOverlap ::  Maybe (Overlap NodeInfo) -> Printer ()-maybeOverlap =-  maybe (return ())-        (\p ->-           pretty p >>-           space)---- | Swing the second printer below and indented with respect to the first.-swing :: Printer () -> Printer b -> Printer ()-swing a b =-  do orig <- gets psIndentLevel-     a-     mst <- fitsOnOneLine (do space-                              b)-     case mst of-       Just st -> put st-       Nothing -> do newline-                     indentSpaces <- getIndentSpaces-                     _ <- column (orig + indentSpaces) b-                     return ()---- | Swing the second printer below and indented with respect to the first by--- the specified amount.-swingBy :: Int64 -> Printer() -> Printer b -> Printer b-swingBy i a b =-  do orig <- gets psIndentLevel-     a-     newline-     column (orig + i) b------------------------------------------------------------------------------------- * Instances--instance Pretty Context where-  prettyInternal ctx@(CxTuple _ asserts) = do-    mst <- fitsOnOneLine (parens (inter (comma >> space) (map pretty asserts)))-    case mst of-      Nothing -> context ctx-      Just st -> put st-  prettyInternal ctx = context ctx--instance Pretty Pat where-  prettyInternal x =-    case x of-      PLit _ sign l -> pretty sign >> pretty l-      PNPlusK _ n k ->-        depend (do pretty n-                   write "+")-               (int k)-      PInfixApp _ a op b ->-        case op of-          Special{} ->-            depend (pretty a)-                   (depend (prettyInfixOp op)-                           (pretty b))-          _ ->-            depend (do pretty a-                       space)-                   (depend (do prettyInfixOp op-                               space)-                           (pretty b))-      PApp _ f args ->-        depend (do pretty f-                   unless (null args) space)-               (spaced (map pretty args))-      PTuple _ boxed pats ->-        depend (write (case boxed of-                         Unboxed -> "(# "-                         Boxed -> "("))-               (do commas (map pretty pats)-                   write (case boxed of-                            Unboxed -> " #)"-                            Boxed -> ")"))-      PList _ ps ->-        brackets (commas (map pretty ps))-      PParen _ e -> parens (pretty e)-      PRec _ qname fields -> do-        let horVariant = do-              pretty qname-              space-              braces $ commas $ map pretty fields-            verVariant =-              depend (pretty qname >> space) $ do-                case fields of-                  [] -> write "{}"-                  [field] -> braces $ pretty field-                  _ -> do-                    depend (write "{") $-                      prefixedLined "," $ map (depend space . pretty) fields-                    newline-                    write "}"-        horVariant `ifFitsOnOneLineOrElse` verVariant-      PAsPat _ n p ->-        depend (do pretty n-                   write "@")-               (pretty p)-      PWildCard _ -> write "_"-      PIrrPat _ p ->-        depend (write "~")-               (pretty p)-      PatTypeSig _ p ty ->-        depend (do pretty p-                   write " :: ")-               (pretty ty)-      PViewPat _ e p ->-        depend (do pretty e-                   write " -> ")-               (pretty p)-      PQuasiQuote _ name str -> quotation name (string str)-      PBangPat _ p ->-        depend (write "!")-               (pretty p)-      PRPat{} -> pretty' x-      PXTag{} -> pretty' x-      PXETag{} -> pretty' x-      PXPcdata{} -> pretty' x-      PXPatTag{} -> pretty' x-      PXRPats{} -> pretty' x-      PVar{} -> pretty' x-      PSplice _ s -> pretty s---- | Pretty infix application of a name (identifier or symbol).-prettyInfixName :: Name NodeInfo -> Printer ()-prettyInfixName (Ident _ n) = do write "`"; string n; write "`";-prettyInfixName (Symbol _ s) = string s---- | Pretty print a name for being an infix operator.-prettyInfixOp ::  QName NodeInfo -> Printer ()-prettyInfixOp x =-  case x of-    Qual _ mn n ->-      case n of-        Ident _ i -> do write "`"; pretty mn; write "."; string i; write "`";-        Symbol _ s -> do pretty mn; write "."; string s;-    UnQual _ n -> prettyInfixName n-    Special _ s -> pretty s--prettyQuoteName :: Name NodeInfo -> Printer ()-prettyQuoteName x =-  case x of-    Ident _ i -> string i-    Symbol _ s -> string ("(" ++ s ++ ")")--instance Pretty Type where-  prettyInternal = typ--instance Pretty Exp where-  prettyInternal = exp---- | Render an expression.-exp :: Exp NodeInfo -> Printer ()--- | Do after lambda should swing.-exp (Lambda _ pats (Do l stmts)) =-  do-     mst <--          fitsOnOneLine-            (do write "\\"-                spaced (map pretty pats)-                write " -> "-                pretty (Do l stmts))-     case mst of-       Nothing -> swing (do write "\\"-                            spaced (map pretty pats)-                            write " -> do")-                         (lined (map pretty stmts))-       Just st -> put st--- | Space out tuples.-exp (Tuple _ boxed exps) = do-  let horVariant = parensHorB boxed $ inter (write ", ") (map pretty exps)-      verVariant = parensVerB boxed $ prefixedLined "," (map (depend space . pretty) exps)-  mst <- fitsOnOneLine horVariant-  case mst of-    Nothing -> verVariant-    Just st -> put st-  where-    parensHorB Boxed = parens-    parensHorB Unboxed = wrap "(# " " #)"-    parensVerB Boxed = parens-    parensVerB Unboxed = wrap "(#" "#)"--- | Space out tuples.-exp (TupleSection _ boxed mexps) = do-  let horVariant = parensHorB boxed $ inter (write ", ") (map (maybe (return ()) pretty) mexps)-      verVariant =-        parensVerB boxed $ prefixedLined "," (map (maybe (return ()) (depend space . pretty)) mexps)-  mst <- fitsOnOneLine horVariant-  case mst of-    Nothing -> verVariant-    Just st -> put st-  where-    parensHorB Boxed = parens-    parensHorB Unboxed = wrap "(# " " #)"-    parensVerB Boxed = parens-    parensVerB Unboxed = wrap "(#" "#)"-exp (UnboxedSum{}) = error "FIXME: No implementation for UnboxedSum."--- | Infix apps, same algorithm as ChrisDone at the moment.-exp e@(InfixApp _ a op b) =-  infixApp e a op b Nothing--- | If bodies are indented 4 spaces. Handle also do-notation.-exp (If _ if' then' else') =-  do depend (write "if ")-            (pretty if')-     newline-     indentSpaces <- getIndentSpaces-     indented indentSpaces-              (do branch "then " then'-                  newline-                  branch "else " else')-     -- Special handling for do.-  where branch str e =-          case e of-            Do _ stmts ->-              do write str-                 write "do"-                 newline-                 indentSpaces <- getIndentSpaces-                 indented indentSpaces (lined (map pretty stmts))-            _ ->-              depend (write str)-                     (pretty e)--- | Render on one line, or otherwise render the op with the arguments--- listed line by line.-exp (App _ op arg) = do-  let flattened = flatten op ++ [arg]-  mst <- fitsOnOneLine (spaced (map pretty flattened))-  case mst of-    Nothing -> do-      let (f:args) = flattened-      col <- gets psColumn-      spaces <- getIndentSpaces-      pretty f-      col' <- gets psColumn-      let diff = col' - col - if col == 0 then spaces else 0-      if diff + 1 <= spaces-        then space-        else newline-      spaces' <- getIndentSpaces-      indented spaces' (lined (map pretty args))-    Just st -> put st-  where-    flatten (App label' op' arg') = flatten op' ++ [amap (addComments label') arg']-    flatten x = [x]-    addComments n1 n2 =-      n2-      { nodeInfoComments = nub (nodeInfoComments n2 ++ nodeInfoComments n1)-      }--- | Space out commas in list.-exp (List _ es) =-  do mst <- fitsOnOneLine p-     case mst of-       Nothing -> do-         depend-           (write "[")-           (prefixedLined "," (map (depend space . pretty) es))-         newline-         write "]"-       Just st -> put st-  where p =-          brackets (inter (write ", ")-                          (map pretty es))-exp (RecUpdate _ exp' updates) = recUpdateExpr (pretty exp') updates-exp (RecConstr _ qname updates) = recUpdateExpr (pretty qname) updates-exp (Let _ binds e) =-  depend (write "let ")-         (do pretty binds-             newline-             indented (-3) (depend (write "in ")-                                   (pretty e)))-exp (ListComp _ e qstmt) = do-  let horVariant = brackets $ do-        pretty e-        write " | "-        commas $ map pretty qstmt-      verVariant = do-        write "[ "-        pretty e-        newline-        depend (write "| ") $ prefixedLined ", " $ map pretty qstmt-        newline-        write "]"-  horVariant `ifFitsOnOneLineOrElse` verVariant--exp (ParComp _ e qstmts) = do-  let horVariant = brackets $ do-        pretty e-        for_ qstmts $ \qstmt -> do-          write " | "-          commas $ map pretty qstmt-      verVariant = do-        depend (write "[ ") $ pretty e-        newline-        for_ qstmts $ \qstmt -> do-          depend (write "| ") $ prefixedLined ", " $ map pretty qstmt-          newline-        write "]"-  horVariant `ifFitsOnOneLineOrElse` verVariant--exp (TypeApp _ t) = do-  write "@"-  pretty t-exp (NegApp _ e) =-  depend (write "-")-         (pretty e)-exp (Lambda _ ps e) = do-  write "\\"-  spaced [ do case (i, x) of-                (0, PIrrPat {}) -> space-                (0, PBangPat {}) -> space-                _ -> return ()-              pretty x-         | (i, x) <- zip [0 :: Int ..] ps-         ]-  swing (write " ->") $ pretty e-exp (Paren _ e) = parens (pretty e)-exp (Case _ e alts) =-  do depend (write "case ")-            (do pretty e-                write " of")-     if null alts-       then write " {}"-       else do newline-               indentedBlock (lined (map (withCaseContext True . pretty) alts))-exp (Do _ stmts) =-  depend (write "do ")-         (lined (map pretty stmts))-exp (MDo _ stmts) =-  depend (write "mdo ")-         (lined (map pretty stmts))-exp (LeftSection _ e op) =-  parens (depend (do pretty e-                     space)-                 (pretty op))-exp (RightSection _ e op) =-  parens (depend (do pretty e-                     space)-                 (pretty op))-exp (EnumFrom _ e) =-  brackets (do pretty e-               write " ..")-exp (EnumFromTo _ e f) =-  brackets (depend (do pretty e-                       write " .. ")-                   (pretty f))-exp (EnumFromThen _ e t) =-  brackets (depend (do pretty e-                       write ",")-                   (do pretty t-                       write " .."))-exp (EnumFromThenTo _ e t f) =-  brackets (depend (do pretty e-                       write ",")-                   (depend (do pretty t-                               write " .. ")-                           (pretty f)))-exp (ExpTypeSig _ e t) =-  depend (do pretty e-             write " :: ")-         (pretty t)-exp (VarQuote _ x) =-  depend (write "'")-         (pretty x)-exp (TypQuote _ x) =-  depend (write "''")-         (pretty x)-exp (BracketExp _ b) = pretty b-exp (SpliceExp _ s) = pretty s-exp (QuasiQuote _ n s) = quotation n (string s)-exp (LCase _ alts) =-  do write "\\case"-     if null alts-       then write " {}"-       else do newline-               indentedBlock (lined (map (withCaseContext True . pretty) alts))-exp (MultiIf _ alts) =-  withCaseContext-    True-    (depend-       (write "if ")-       (lined-          (map-             (\p -> do-                write "| "-                prettyG p)-             alts)))-  where-    prettyG (GuardedRhs _ stmts e) = do-      indented-        1-        (do (lined (map-                         (\(i,p) -> do-                            unless (i == 1)-                                   space-                            pretty p-                            unless (i == length stmts)-                                   (write ","))-                         (zip [1..] stmts))))-      swing (write " " >> rhsSeparator) (pretty e)-exp (Lit _ lit) = prettyInternal lit-exp (Var _ q) = pretty q-exp (IPVar _ q) = pretty q-exp (Con _ q) = pretty q--exp x@XTag{} = pretty' x-exp x@XETag{} = pretty' x-exp x@XPcdata{} = pretty' x-exp x@XExpTag{} = pretty' x-exp x@XChildTag{} = pretty' x-exp x@CorePragma{} = pretty' x-exp x@SCCPragma{} = pretty' x-exp x@GenPragma{} = pretty' x-exp x@Proc{} = pretty' x-exp x@LeftArrApp{} = pretty' x-exp x@RightArrApp{} = pretty' x-exp x@LeftArrHighApp{} = pretty' x-exp x@RightArrHighApp{} = pretty' x-exp x@ParArray{} = pretty' x-exp x@ParArrayFromTo{} = pretty' x-exp x@ParArrayFromThenTo{} = pretty' x-exp x@ParArrayComp{} = pretty' x-exp (OverloadedLabel _ label) = string ('#' : label)--instance Pretty IPName where- prettyInternal = pretty'--instance Pretty Stmt where-  prettyInternal =-    stmt--instance Pretty QualStmt where-  prettyInternal x =-    case x of-      QualStmt _ s -> pretty s-      ThenTrans _ s -> do-        write "then "-        pretty s-      ThenBy _ s t -> do-        write "then "-        pretty s-        write " by "-        pretty t-      GroupBy _ s -> do-        write "then group by "-        pretty s-      GroupUsing _ s -> do-        write "then group using "-        pretty s-      GroupByUsing _ s t -> do-        write "then group by "-        pretty s-        write " using "-        pretty t--instance Pretty Decl where-  prettyInternal = decl'---- | Render a declaration.-decl ::  Decl NodeInfo -> Printer ()-decl (InstDecl _ moverlap dhead decls) =-  do depend (write "instance ")-            (depend (maybeOverlap moverlap)-                    (depend (pretty dhead)-                            (unless (null (fromMaybe [] decls))-                                    (write " where"))))-     unless (null (fromMaybe [] decls))-            (do newline-                indentedBlock (lined (map pretty (fromMaybe [] decls))))-decl (SpliceDecl _ e) = pretty e-decl (TypeSig _ names ty) =-  depend (do inter (write ", ")-                   (map pretty names)-             write " :: ")-         (pretty ty)-decl (FunBind _ matches) =-  lined (map pretty matches)-decl (ClassDecl _ ctx dhead fundeps decls) =-  do classHead ctx dhead fundeps decls-     unless (null (fromMaybe [] decls))-            (do newline-                indentedBlock (lined (map pretty (fromMaybe [] decls))))-decl (TypeDecl _ typehead typ') = do-  write "type "-  pretty typehead-  ifFitsOnOneLineOrElse-    (depend (write " = ") (pretty typ'))-    (do newline-        indentedBlock (depend (write " = ") (pretty typ')))-decl (TypeFamDecl _ declhead result injectivity) = do-  write "type family "-  pretty declhead-  case result of-    Just r -> do-      space-      let sep = case r of-                  KindSig _ _ -> "::"-                  TyVarSig _ _ -> "="-      write sep-      space-      pretty r-    Nothing -> return ()-  case injectivity of-    Just i -> do-      space-      pretty i-    Nothing -> return ()-decl (ClosedTypeFamDecl _ declhead result injectivity instances) = do-  write "type family "-  pretty declhead-  for_ result $ \r -> do-    space-    let sep = case r of-                KindSig _ _ -> "::"-                TyVarSig _ _ -> "="-    write sep-    space-    pretty r-  for_ injectivity $ \i -> do-    space-    pretty i-  space-  write "where"-  newline-  indentedBlock (lined (map pretty instances))-decl (DataDecl _ dataornew ctx dhead condecls mderivs) =-  do depend (do pretty dataornew-                space)-            (withCtx ctx-                     (do pretty dhead-                         case condecls of-                           [] -> return ()-                           [x] -> singleCons x-                           xs -> multiCons xs))-     indentSpaces <- getIndentSpaces-     forM_ mderivs $ \deriv -> newline >> column indentSpaces (pretty deriv)-  where singleCons x =-          do write " ="-             indentSpaces <- getIndentSpaces-             column indentSpaces-                    (do newline-                        pretty x)-        multiCons xs =-          do newline-             indentSpaces <- getIndentSpaces-             column indentSpaces-                    (depend (write "=")-                            (prefixedLined "|"-                                           (map (depend space . pretty) xs)))--decl (GDataDecl _ dataornew ctx dhead mkind condecls mderivs) =-  do depend (pretty dataornew >> space)-       (withCtx ctx-         (do pretty dhead-             case mkind of-               Nothing -> return ()-               Just kind -> do write " :: "-                               pretty kind-             write " where"))-     indentedBlock $ do-       case condecls of-         [] -> return ()-         _ -> do-           newline-           lined (map pretty condecls)-       forM_ mderivs $ \deriv -> newline >> pretty deriv--decl (InlineSig _ inline active name) = do-  write "{-# "--  unless inline $ write "NO"-  write "INLINE "-  case active of-    Nothing -> return ()-    Just (ActiveFrom _ x) -> write ("[" ++ show x ++ "] ")-    Just (ActiveUntil _ x) -> write ("[~" ++ show x ++ "] ")-  pretty name--  write " #-}"-decl (MinimalPragma _ (Just formula)) =-  wrap "{-# " " #-}" $ do-    depend (write "MINIMAL ") $ pretty formula-decl (ForImp _ callconv maybeSafety maybeName name ty) = do-  string "foreign import "-  pretty' callconv >> space-  case maybeSafety of-    Just safety -> pretty' safety >> space-    Nothing -> return ()-  case maybeName of-    Just namestr -> string (show namestr) >> space-    Nothing -> return ()-  pretty' name-  tyline <- fitsOnOneLine $ do string " :: "-                               pretty' ty-  case tyline of-    Just line -> put line-    Nothing -> do newline-                  indentedBlock $ do string ":: "-                                     pretty' ty-decl (ForExp _ callconv maybeName name ty) = do-  string "foreign export "-  pretty' callconv >> space-  case maybeName of-    Just namestr -> string (show namestr) >> space-    Nothing -> return ()-  pretty' name-  tyline <- fitsOnOneLine $ do string " :: "-                               pretty' ty-  case tyline of-    Just line -> put line-    Nothing -> do newline-                  indentedBlock $ do string ":: "-                                     pretty' ty-decl x' = pretty' x'--classHead-  :: Maybe (Context NodeInfo)-  -> DeclHead NodeInfo-  -> [FunDep NodeInfo]-  -> Maybe [ClassDecl NodeInfo]-  -> Printer ()-classHead ctx dhead fundeps decls = shortHead `ifFitsOnOneLineOrElse` longHead-  where-    shortHead =-      depend-        (write "class ")-        (withCtx ctx $-         depend-           (pretty dhead)-           (depend (unless (null fundeps) (write " | " >> commas (map pretty fundeps)))-              (unless (null (fromMaybe [] decls)) (write " where"))))-    longHead = do-      depend (write "class ") (withCtx ctx $ pretty dhead)-      newline-      indentedBlock $ do-        unless (null fundeps) $ do-          depend (write "| ") (prefixedLined ", " $ map pretty fundeps)-          newline-        unless (null (fromMaybe [] decls)) (write "where")--instance Pretty TypeEqn where-  prettyInternal (TypeEqn _ in_ out_) = do-    pretty in_-    write " = "-    pretty out_--instance Pretty Deriving where-  prettyInternal (Deriving _ strategy heads) =-    depend (write "deriving" >> space >> writeStrategy) $ do-      let heads' =-            if length heads == 1-              then map stripParens heads-              else heads-      maybeDerives <- fitsOnOneLine $ parens (commas (map pretty heads'))-      case maybeDerives of-        Nothing -> formatMultiLine heads'-        Just derives -> put derives-    where-      writeStrategy = case strategy of-        Nothing -> return ()-        Just st -> pretty st >> space-      stripParens (IParen _ iRule) = stripParens iRule-      stripParens x = x-      formatMultiLine derives = do-        depend (write "( ") $ prefixedLined ", " (map pretty derives)-        newline-        write ")"--instance Pretty DerivStrategy where-  prettyInternal x =-    case x of-      DerivStock _ -> return ()-      DerivAnyclass _ -> write "anyclass"-      DerivNewtype _ -> write "newtype"--instance Pretty Alt where-  prettyInternal x =-    case x of-      Alt _ p galts mbinds ->-        do pretty p-           pretty galts-           case mbinds of-             Nothing -> return ()-             Just binds ->-               do newline-                  indentedBlock (depend (write "where ")-                                (pretty binds))--instance Pretty Asst where-  prettyInternal x =-    case x of-      IParam _ name ty -> do-        pretty name-        write " :: "-        pretty ty-      ParenA _ asst -> parens (pretty asst)-#if MIN_VERSION_haskell_src_exts(1,21,0)-      TypeA _ ty -> pretty ty-#else-      ClassA _ name types -> spaced (pretty name : map pretty types)-      i@InfixA {} -> pretty' i-      EqualP _ a b -> do-        pretty a-        write " ~ "-        pretty b-      AppA _ name tys ->-        spaced (pretty name : map pretty tys)-      WildCardA _ name ->-        case name of-          Nothing -> write "_"-          Just n -> do-            write "_"-            pretty n-#endif--instance Pretty BangType where-  prettyInternal x =-    case x of-      BangedTy _ -> write "!"-      LazyTy _ -> write "~"-      NoStrictAnnot _ -> return ()--instance Pretty Unpackedness where-  prettyInternal (Unpack _) = write "{-# UNPACK #-}"-  prettyInternal (NoUnpack _) = write "{-# NOUNPACK #-}"-  prettyInternal (NoUnpackPragma _) = return ()--instance Pretty Binds where-  prettyInternal x =-    case x of-      BDecls _ ds -> lined (map pretty ds)-      IPBinds _ i -> lined (map pretty i)--instance Pretty ClassDecl where-  prettyInternal x =-    case x of-      ClsDecl _ d -> pretty d-      ClsDataFam _ ctx h mkind ->-        depend-          (write "data ")-          (withCtx-             ctx-             (do pretty h-                 (case mkind of-                    Nothing -> return ()-                    Just kind -> do-                      write " :: "-                      pretty kind)))-      ClsTyFam _ h msig minj ->-        depend-          (write "type ")-          (depend-             (pretty h)-             (depend-                (traverse_-                   (\case-                      KindSig _ kind -> write " :: " >> pretty kind-                      TyVarSig _ tyVarBind -> write " = " >> pretty tyVarBind)-                   msig)-                (traverse_ (\inj -> space >> pretty inj) minj)))-      ClsTyDef _ (TypeEqn _ this that) -> do-        write "type "-        pretty this-        write " = "-        pretty that-      ClsDefSig _ name ty -> do-        write "default "-        pretty name-        write " :: "-        pretty ty--instance Pretty ConDecl where-  prettyInternal x =-    conDecl x--instance Pretty FieldDecl where-  prettyInternal (FieldDecl _ names ty) =-    depend (do commas (map pretty names)-               write " :: ")-           (pretty ty)--instance Pretty FieldUpdate where-  prettyInternal x =-    case x of-      FieldUpdate _ n e ->-        swing (do pretty n-                  write " =")-               (pretty e)-      FieldPun _ n -> pretty n-      FieldWildcard _ -> write ".."--instance Pretty GuardedRhs where-  prettyInternal  =-    guardedRhs--instance Pretty InjectivityInfo where-  prettyInternal x = pretty' x--instance Pretty InstDecl where-  prettyInternal i =-    case i of-      InsDecl _ d -> pretty d-      InsType _ name ty ->-        depend (do write "type "-                   pretty name-                   write " = ")-               (pretty ty)-      _ -> pretty' i--instance Pretty Match where-  prettyInternal = match-    {-case x of-      Match _ name pats rhs' mbinds ->-        do depend (do pretty name-                      space)-                  (spaced (map pretty pats))-           withCaseContext False (pretty rhs')-           case mbinds of-             Nothing -> return ()-             Just binds ->-               do newline-                  indentedBlock (depend (write "where ")-                                        (pretty binds))-      InfixMatch _ pat1 name pats rhs' mbinds ->-        do depend (do pretty pat1-                      space-                      prettyInfixName name)-                  (do space-                      spaced (map pretty pats))-           withCaseContext False (pretty rhs')-           case mbinds of-             Nothing -> return ()-             Just binds ->-               do newline-                  indentedBlock (depend (write "where ")-                                        (pretty binds))-}--instance Pretty PatField where-  prettyInternal x =-    case x of-      PFieldPat _ n p ->-        depend (do pretty n-                   write " = ")-               (pretty p)-      PFieldPun _ n -> pretty n-      PFieldWildcard _ -> write ".."--instance Pretty QualConDecl where-  prettyInternal x =-    case x of-      QualConDecl _ tyvars ctx d ->-        depend (unless (null (fromMaybe [] tyvars))-                       (do write "forall "-                           spaced (map pretty (reverse (fromMaybe [] tyvars)))-                           write ". "))-               (withCtx ctx-                       (pretty d))--instance Pretty GadtDecl where-#if MIN_VERSION_haskell_src_exts(1,21,0)-  prettyInternal (GadtDecl _ name _ _ fields t) =-#else-  prettyInternal (GadtDecl _ name fields t) =-#endif-    horVar `ifFitsOnOneLineOrElse` verVar-    where-      fields' p =-        case fromMaybe [] fields of-          [] -> return ()-          fs -> do-            depend (write "{") $ do-              prefixedLined "," (map (depend space . pretty) fs)-            write "}"-            p-      horVar =-        depend (pretty name >> write " :: ") $ do-          fields' (write " -> ")-          declTy t-      verVar = do-        pretty name-        newline-        indentedBlock $-          depend (write ":: ") $ do-            fields' $ do-              newline-              indented (-3) (write "-> ")-            declTy t--instance Pretty Rhs where-  prettyInternal =-    rhs--instance Pretty Splice where-  prettyInternal x =-    case x of-      IdSplice _ str ->-        do write "$"-           string str-      ParenSplice _ e ->-        depend (write "$")-               (parens (pretty e))--instance Pretty InstRule where-  prettyInternal (IParen _ rule) = parens $ pretty rule-  prettyInternal (IRule _ mvarbinds mctx ihead) =-    do case mvarbinds of-         Nothing -> return ()-         Just xs -> do write "forall "-                       spaced (map pretty xs)-                       write ". "-       case mctx of-         Nothing -> pretty ihead-         Just ctx -> do-           mst <- fitsOnOneLine (do pretty ctx-                                    write " => "-                                    pretty ihead-                                    write " where")-           case mst of-             Nothing -> withCtx mctx (pretty ihead)-             Just {} -> do-               pretty ctx-               write " => "-               pretty ihead--instance Pretty InstHead where-  prettyInternal x =-    case x of-      -- Base cases-      IHCon _ name -> pretty name-      IHInfix _ typ' name ->-        depend (pretty typ')-               (do space-                   prettyInfixOp name)-      -- Recursive application-      IHApp _ ihead typ' ->-        depend (pretty ihead)-               (do space-                   pretty typ')-      -- Wrapping in parens-      IHParen _ h -> parens (pretty h)--instance Pretty DeclHead where-  prettyInternal x =-    case x of-      DHead _ name -> prettyQuoteName name-      DHParen _ h -> parens (pretty h)-      DHInfix _ var name ->-        do pretty var-           space-           prettyInfixName name-      DHApp _ dhead var ->-        depend (pretty dhead)-               (do space-                   pretty var)--instance Pretty Overlap where-  prettyInternal (Overlap _) = write "{-# OVERLAP #-}"-  prettyInternal (Overlapping _) = write "{-# OVERLAPPING #-}"-  prettyInternal (Overlaps _) = write "{-# OVERLAPS #-}"-  prettyInternal (Overlappable _) = write "{-# OVERLAPPABLE #-}"-  prettyInternal (NoOverlap _) = write "{-# NO_OVERLAP #-}"-  prettyInternal (Incoherent _) = write "{-# INCOHERENT #-}"--instance Pretty Sign where-  prettyInternal (Signless _) = return ()-  prettyInternal (Negative _) = write "-"--instance Pretty CallConv where-  prettyInternal = pretty'--instance Pretty Safety where-  prettyInternal = pretty'------------------------------------------------------------------------------------- * Unimplemented or incomplete printers--instance Pretty Module where-  prettyInternal x =-    case x of-      Module _ mayModHead pragmas imps decls ->-        do inter (do newline-                     newline)-                 (mapMaybe (\(isNull,r) ->-                              if isNull-                                 then Nothing-                                 else Just r)-                           [(null pragmas,inter newline (map pretty pragmas))-                           ,(case mayModHead of-                               Nothing -> (True,return ())-                               Just modHead -> (False,pretty modHead))-                           ,(null imps,formatImports imps)-                           ,(null decls-                            ,interOf newline-                                     (map (\case-                                             r@TypeSig{} -> (1,pretty r)-                                             r@InlineSig{} -> (1, pretty r)-                                             r -> (2,pretty r))-                                          decls))])-           newline-        where interOf i ((c,p):ps) =-                case ps of-                  [] -> p-                  _ ->-                    do p-                       replicateM_ c i-                       interOf i ps-              interOf _ [] = return ()-      XmlPage{} -> error "FIXME: No implementation for XmlPage."-      XmlHybrid{} -> error "FIXME: No implementation for XmlHybrid."---- | Format imports, preserving empty newlines between groups.-formatImports :: [ImportDecl NodeInfo] -> Printer ()-formatImports =-  sequence_ .-  intersperse (newline >> newline) .-  map formatImportGroup . groupAdjacentBy atNextLine-  where-    atNextLine import1 import2 =-      let end1 = srcSpanEndLine (srcInfoSpan (nodeInfoSpan (ann import1)))-          start2 = srcSpanStartLine (srcInfoSpan (nodeInfoSpan (ann import2)))-      in start2 - end1 <= 1-    formatImportGroup imps = do-      shouldSortImports <- gets $ configSortImports . psConfig-      let imps1 =-            if shouldSortImports-              then sortImports imps-              else imps-      sequence_ . intersperse newline $ map formatImport imps1-    moduleVisibleName idecl =-      let ModuleName _ name = importModule idecl-      in name-    formatImport = pretty-    sortImports imps = sortOn moduleVisibleName . map sortImportSpecsOnImport $ imps-    sortImportSpecsOnImport imp = imp { importSpecs = fmap sortImportSpecs (importSpecs imp) }-    sortImportSpecs (ImportSpecList l hiding specs) = ImportSpecList l hiding sortedSpecs-      where-        sortedSpecs = sortBy importSpecCompare . map sortCNames $ specs--        sortCNames (IThingWith l2 name cNames) = IThingWith l2 name . sortBy cNameCompare $ cNames-        sortCNames is = is--groupAdjacentBy :: (a -> a -> Bool) -> [a] -> [[a]]-groupAdjacentBy _ [] = []-groupAdjacentBy adj items = xs : groupAdjacentBy adj rest-  where-    (xs, rest) = spanAdjacentBy adj items--spanAdjacentBy :: (a -> a -> Bool) -> [a] -> ([a], [a])-spanAdjacentBy _ [] = ([], [])-spanAdjacentBy _ [x] = ([x], [])-spanAdjacentBy adj (x:xs@(y:_))-  | adj x y =-    let (xs', rest') = spanAdjacentBy adj xs-    in (x : xs', rest')-  | otherwise = ([x], xs)--importSpecCompare :: ImportSpec l -> ImportSpec l -> Ordering-importSpecCompare (IAbs _ _ (Ident _ s1)) (IAbs _ _ (Ident _ s2)) = compare s1 s2-importSpecCompare (IAbs _ _ (Ident _ _)) (IAbs _ _ (Symbol _ _)) = GT-importSpecCompare (IAbs _ _ (Ident _ s1)) (IThingAll _ (Ident _ s2)) = compare s1 s2-importSpecCompare (IAbs _ _ (Ident _ _)) (IThingAll _ (Symbol _ _)) = GT-importSpecCompare (IAbs _ _ (Ident _ s1)) (IThingWith _ (Ident _ s2) _) = compare s1 s2-importSpecCompare (IAbs _ _ (Ident _ _)) (IThingWith _ (Symbol _ _) _) = GT-importSpecCompare (IAbs _ _ (Symbol _ _)) (IAbs _ _ (Ident _ _)) = LT-importSpecCompare (IAbs _ _ (Symbol _ s1)) (IAbs _ _ (Symbol _ s2)) = compare s1 s2-importSpecCompare (IAbs _ _ (Symbol _ _)) (IThingAll _ (Ident _ _)) = LT-importSpecCompare (IAbs _ _ (Symbol _ s1)) (IThingAll _ (Symbol _ s2)) = compare s1 s2-importSpecCompare (IAbs _ _ (Symbol _ _)) (IThingWith _ (Ident _ _) _) = LT-importSpecCompare (IAbs _ _ (Symbol _ s1)) (IThingWith _ (Symbol _ s2) _) = compare s1 s2-importSpecCompare (IAbs _ _ _) (IVar _ _) = LT-importSpecCompare (IThingAll _ (Ident _ s1)) (IAbs _ _ (Ident _ s2)) = compare s1 s2-importSpecCompare (IThingAll _ (Ident _ _)) (IAbs _ _ (Symbol _ _)) = GT-importSpecCompare (IThingAll _ (Ident _ s1)) (IThingAll _ (Ident _ s2)) = compare s1 s2-importSpecCompare (IThingAll _ (Ident _ _)) (IThingAll _ (Symbol _ _)) = GT-importSpecCompare (IThingAll _ (Ident _ s1)) (IThingWith _ (Ident _ s2) _) = compare s1 s2-importSpecCompare (IThingAll _ (Ident _ _)) (IThingWith _ (Symbol _ _) _) = GT-importSpecCompare (IThingAll _ (Symbol _ _)) (IAbs _ _ (Ident _ _)) = LT-importSpecCompare (IThingAll _ (Symbol _ s1)) (IAbs _ _ (Symbol _ s2)) = compare s1 s2-importSpecCompare (IThingAll _ (Symbol _ _)) (IThingAll _ (Ident _ _)) = LT-importSpecCompare (IThingAll _ (Symbol _ s1)) (IThingAll _ (Symbol _ s2)) = compare s1 s2-importSpecCompare (IThingAll _ (Symbol _ _)) (IThingWith _ (Ident _ _) _) = LT-importSpecCompare (IThingAll _ (Symbol _ s1)) (IThingWith _ (Symbol _ s2) _) = compare s1 s2-importSpecCompare (IThingAll _ _) (IVar _ _) = LT-importSpecCompare (IThingWith _ (Ident _ s1) _) (IAbs _ _ (Ident _ s2)) = compare s1 s2-importSpecCompare (IThingWith _ (Ident _ _) _) (IAbs _ _ (Symbol _ _)) = GT-importSpecCompare (IThingWith _ (Ident _ s1) _) (IThingAll _ (Ident _ s2)) = compare s1 s2-importSpecCompare (IThingWith _ (Ident _ _) _) (IThingAll _ (Symbol _ _)) = GT-importSpecCompare (IThingWith _ (Ident _ s1) _) (IThingWith _ (Ident _ s2) _) = compare s1 s2-importSpecCompare (IThingWith _ (Ident _ _) _) (IThingWith _ (Symbol _ _) _) = GT-importSpecCompare (IThingWith _ (Symbol _ _) _) (IAbs _ _ (Ident _ _)) = LT-importSpecCompare (IThingWith _ (Symbol _ s1) _) (IAbs _ _ (Symbol _ s2)) = compare s1 s2-importSpecCompare (IThingWith _ (Symbol _ _) _) (IThingAll _ (Ident _ _)) = LT-importSpecCompare (IThingWith _ (Symbol _ s1) _) (IThingAll _ (Symbol _ s2)) = compare s1 s2-importSpecCompare (IThingWith _ (Symbol _ _) _) (IThingWith _ (Ident _ _) _) = LT-importSpecCompare (IThingWith _ (Symbol _ s1) _) (IThingWith _ (Symbol _ s2) _) = compare s1 s2-importSpecCompare (IThingWith _ _ _) (IVar _ _) = LT-importSpecCompare (IVar _ (Ident _ s1)) (IVar _ (Ident _ s2)) = compare s1 s2-importSpecCompare (IVar _ (Ident _ _)) (IVar _ (Symbol _ _)) = GT-importSpecCompare (IVar _ (Symbol _ _)) (IVar _ (Ident _ _)) = LT-importSpecCompare (IVar _ (Symbol _ s1)) (IVar _ (Symbol _ s2)) = compare s1 s2-importSpecCompare (IVar _ _) _ = GT--cNameCompare :: CName l -> CName l -> Ordering-cNameCompare (VarName _ (Ident _ s1)) (VarName _ (Ident _ s2)) = compare s1 s2-cNameCompare (VarName _ (Ident _ _)) (VarName _ (Symbol _ _)) = GT-cNameCompare (VarName _ (Ident _ s1)) (ConName _ (Ident _ s2)) = compare s1 s2-cNameCompare (VarName _ (Ident _ _)) (ConName _ (Symbol _ _)) = GT-cNameCompare (VarName _ (Symbol _ _)) (VarName _ (Ident _ _)) = LT-cNameCompare (VarName _ (Symbol _ s1)) (VarName _ (Symbol _ s2)) = compare s1 s2-cNameCompare (VarName _ (Symbol _ _)) (ConName _ (Ident _ _)) = LT-cNameCompare (VarName _ (Symbol _ s1)) (ConName _ (Symbol _ s2)) = compare s1 s2-cNameCompare (ConName _ (Ident _ s1)) (VarName _ (Ident _ s2)) = compare s1 s2-cNameCompare (ConName _ (Ident _ _)) (VarName _ (Symbol _ _)) = GT-cNameCompare (ConName _ (Ident _ s1)) (ConName _ (Ident _ s2)) = compare s1 s2-cNameCompare (ConName _ (Ident _ _)) (ConName _ (Symbol _ _)) = GT-cNameCompare (ConName _ (Symbol _ _)) (VarName _ (Ident _ _)) = LT-cNameCompare (ConName _ (Symbol _ s1)) (VarName _ (Symbol _ s2)) = compare s1 s2-cNameCompare (ConName _ (Symbol _ _)) (ConName _ (Ident _ _)) = LT-cNameCompare (ConName _ (Symbol _ s1)) (ConName _ (Symbol _ s2)) = compare s1 s2--instance Pretty Bracket where-  prettyInternal x =-    case x of-      ExpBracket _ p -> quotation "" (pretty p)-      PatBracket _ p -> quotation "p" (pretty p)-      TypeBracket _ ty -> quotation "t" (pretty ty)-      d@(DeclBracket _ _) -> pretty' d--instance Pretty IPBind where-  prettyInternal x =-    case x of-      IPBind _ name expr -> do-        pretty name-        space-        write "="-        space-        pretty expr--instance Pretty BooleanFormula where-  prettyInternal (VarFormula _ i@(Ident _ _)) = pretty' i-  prettyInternal (VarFormula _ (Symbol _ s)) = write "(" >> string s >> write ")"-  prettyInternal (AndFormula _ fs) = do-      maybeFormulas <- fitsOnOneLine $ inter (write ", ") $ map pretty fs-      case maybeFormulas of-        Nothing -> prefixedLined ", " (map pretty fs)-        Just formulas -> put formulas-  prettyInternal (OrFormula _ fs) = do-      maybeFormulas <- fitsOnOneLine $ inter (write " | ") $ map pretty fs-      case maybeFormulas of-        Nothing -> prefixedLined "| " (map pretty fs)-        Just formulas -> put formulas-  prettyInternal (ParenFormula _ f) = parens $ pretty f------------------------------------------------------------------------------------- * Fallback printers--instance Pretty DataOrNew where-  prettyInternal = pretty'--instance Pretty FunDep where-  prettyInternal = pretty'--#if !MIN_VERSION_haskell_src_exts(1,21,0)-instance Pretty Kind where-  prettyInternal = pretty'-#endif--instance Pretty ResultSig where-  prettyInternal (KindSig _ kind) = pretty kind-  prettyInternal (TyVarSig _ tyVarBind) = pretty tyVarBind--instance Pretty Literal where-  prettyInternal (String _ _ rep) = do-    write "\""-    string rep-    write "\""-  prettyInternal (Char _ _ rep) = do-    write "'"-    string rep-    write "'"-  prettyInternal (PrimString _ _ rep) = do-    write "\""-    string rep-    write "\"#"-  prettyInternal (PrimChar _ _ rep) = do-    write "'"-    string rep-    write "'#"-  -- We print the original notation (because HSE doesn't track Hex-  -- vs binary vs decimal notation).-  prettyInternal (Int _l _i originalString) =-    string originalString-  prettyInternal (Frac _l _r originalString) =-    string originalString-  prettyInternal x = pretty' x--instance Pretty Name where-  prettyInternal x = case x of-                          Ident _ _ -> pretty' x -- Identifiers.-                          Symbol _ s -> string s -- Symbols--instance Pretty QName where-  prettyInternal =-    \case-      Qual _ mn n ->-        case n of-          Ident _ i -> do pretty mn; write "."; string i;-          Symbol _ s -> do write "("; pretty mn; write "."; string s; write ")";-      UnQual _ n ->-        case n of-          Ident _ i -> string i-          Symbol _ s -> do write "("; string s; write ")";-      Special _ s@Cons{} -> parens (pretty s)-      Special _ s@FunCon{} -> parens (pretty s)-      Special _ s -> pretty s---instance Pretty SpecialCon where-  prettyInternal s =-    case s of-      UnitCon _ -> write "()"-      ListCon _ -> write "[]"-      FunCon _ -> write "->"-      TupleCon _ Boxed i ->-        string ("(" ++-                replicate (i - 1) ',' ++-                ")")-      TupleCon _ Unboxed i ->-        string ("(# " ++-                replicate (i - 1) ',' ++-                " #)")-      Cons _ -> write ":"-      UnboxedSingleCon _ -> write "(##)"-      ExprHole _ -> write "_"--instance Pretty QOp where-  prettyInternal = pretty'--instance Pretty TyVarBind where-  prettyInternal = pretty'--instance Pretty ModuleHead where-  prettyInternal (ModuleHead _ name mwarnings mexports) =-    do write "module "-       pretty name-       maybe (return ()) pretty mwarnings-       maybe (return ())-             (\exports ->-                do newline-                   indentSpaces <- getIndentSpaces-                   indented indentSpaces (pretty exports))-             mexports-       write " where"--instance Pretty ModulePragma where-  prettyInternal = pretty'--instance Pretty ImportDecl where-  prettyInternal (ImportDecl _ name qualified source safe mpkg mas mspec) = do-    write "import"-    when source $ write " {-# SOURCE #-}"-    when safe $ write " safe"-    when qualified $ write " qualified"-    case mpkg of-      Nothing -> return ()-      Just pkg -> space >> write ("\"" ++ pkg ++ "\"")-    space-    pretty name-    case mas of-      Nothing -> return ()-      Just asName -> do-        space-        write "as "-        pretty asName-    case mspec of-      Nothing -> return ()-      Just spec -> pretty spec--instance Pretty ModuleName where-  prettyInternal (ModuleName _ name) =-    write name--instance Pretty ImportSpecList where-  prettyInternal (ImportSpecList _ hiding spec) = do-    when hiding $ write " hiding"-    let verVar = do-          space-          parens (commas (map pretty spec))-    let horVar = do-          newline-          indentedBlock-            (do depend (write "( ") (prefixedLined ", " (map pretty spec))-                newline-                write ")")-    verVar `ifFitsOnOneLineOrElse` horVar--instance Pretty ImportSpec where-  prettyInternal = pretty'--instance Pretty WarningText where-  prettyInternal (DeprText _ s) =-    write "{-# DEPRECATED " >> string s >> write " #-}"-  prettyInternal (WarnText _ s) =-    write "{-# WARNING " >> string s >> write " #-}"--instance Pretty ExportSpecList where-  prettyInternal (ExportSpecList _ es) = do-    depend (write "(")-           (prefixedLined "," (map pretty es))-    newline-    write ")"--instance Pretty ExportSpec where-  prettyInternal x = string " " >> pretty' x---- Do statements need to handle infix expression indentation specially because--- do x *---    y--- is two invalid statements, not one valid infix op.-stmt :: Stmt NodeInfo -> Printer ()-stmt (Qualifier _ e@(InfixApp _ a op b)) =-  do col <- fmap (psColumn . snd)-                 (sandbox (write ""))-     infixApp e a op b (Just col)-stmt (Generator _ p e) =-  do indentSpaces <- getIndentSpaces-     pretty p-     indented indentSpaces-              (dependOrNewline-                 (write " <-")-                 space-                 e-                 pretty)-stmt x = case x of-           Generator _ p e ->-             depend (do pretty p-                        write " <- ")-                    (pretty e)-           Qualifier _ e -> pretty e-           LetStmt _ binds ->-             depend (write "let ")-                    (pretty binds)-           RecStmt _ es ->-             depend (write "rec ")-                    (lined (map pretty es))---- | Make the right hand side dependent if it fits on one line,--- otherwise send it to the next line.-dependOrNewline-  :: Printer ()-  -> Printer ()-  -> Exp NodeInfo-  -> (Exp NodeInfo -> Printer ())-  -> Printer ()-dependOrNewline left prefix right f =-  do msg <- fitsOnOneLine renderDependent-     case msg of-       Nothing -> do left-                     newline-                     (f right)-       Just st -> put st-  where renderDependent = depend left (do prefix; f right)---- | Handle do and case specially and also space out guards more.-rhs :: Rhs NodeInfo -> Printer ()-rhs (UnGuardedRhs _ (Do _ dos)) =-  do inCase <- gets psInsideCase-     write (if inCase then " -> " else " = ")-     indentSpaces <- getIndentSpaces-     let indentation | inCase = indentSpaces-                     | otherwise = max 2 indentSpaces-     swingBy indentation-             (write "do")-             (lined (map pretty dos))-rhs (UnGuardedRhs _ e) = do-  msg <--    fitsOnOneLine-      (do write " "-          rhsSeparator-          write " "-          pretty e)-  case msg of-    Nothing -> swing (write " " >> rhsSeparator) (pretty e)-    Just st -> put st-rhs (GuardedRhss _ gas) =-  do newline-     n <- getIndentSpaces-     indented n-              (lined (map (\p ->-                             do write "|"-                                pretty p)-                          gas))---- | Implement dangling right-hand-sides.-guardedRhs :: GuardedRhs NodeInfo -> Printer ()--- | Handle do specially.--guardedRhs (GuardedRhs _ stmts (Do _ dos)) =-  do indented 1-              (do prefixedLined-                    ","-                    (map (\p ->-                            do space-                               pretty p)-                         stmts))-     inCase <- gets psInsideCase-     write (if inCase then " -> " else " = ")-     swing (write "do")-            (lined (map pretty dos))-guardedRhs (GuardedRhs _ stmts e) = do-    mst <- fitsOnOneLine printStmts-    case mst of-      Just st -> do-        put st-        mst' <--          fitsOnOneLine-            (do write " "-                rhsSeparator-                write " "-                pretty e)-        case mst' of-          Just st' -> put st'-          Nothing -> swingIt-      Nothing -> do-        printStmts-        swingIt-  where-    printStmts =-      indented-        1-        (do prefixedLined-              ","-              (map-                 (\p -> do-                    space-                    pretty p)-                 stmts))-    swingIt = swing (write " " >> rhsSeparator) (pretty e)--match :: Match NodeInfo -> Printer ()-match (Match _ name pats rhs' mbinds) =-  do depend (do case name of-                  Ident _ _ ->-                    pretty name-                  Symbol _ _ ->-                    do write "("-                       pretty name-                       write ")"-                space)-       (spaced (map pretty pats))-     withCaseContext False (pretty rhs')-     for_ mbinds bindingGroup-match (InfixMatch _ pat1 name pats rhs' mbinds) =-  do depend (do pretty pat1-                space-                prettyInfixName name)-            (do space-                spaced (map pretty pats))-     withCaseContext False (pretty rhs')-     for_ mbinds bindingGroup---- | Format contexts with spaces and commas between class constraints.-context :: Context NodeInfo -> Printer ()-context ctx =-  case ctx of-    CxSingle _ a -> pretty a-    CxTuple _ as -> do-      depend (write "( ") $ prefixedLined ", " (map pretty as)-      newline-      write ")"-    CxEmpty _ -> parens (return ())--typ :: Type NodeInfo -> Printer ()-typ (TyTuple _ Boxed types) = do-  let horVar = parens $ inter (write ", ") (map pretty types)-  let verVar = parens $ prefixedLined "," (map (depend space . pretty) types)-  horVar `ifFitsOnOneLineOrElse` verVar-typ (TyTuple _ Unboxed types) = do-  let horVar = wrap "(# " " #)" $ inter (write ", ") (map pretty types)-  let verVar = wrap "(#" " #)" $ prefixedLined "," (map (depend space . pretty) types)-  horVar `ifFitsOnOneLineOrElse` verVar-typ (TyForall _ mbinds ctx ty) =-  depend (case mbinds of-            Nothing -> return ()-            Just ts ->-              do write "forall "-                 spaced (map pretty ts)-                 write ". ")-         (do indentSpaces <- getIndentSpaces-             withCtx ctx (indented indentSpaces (pretty ty)))-typ (TyFun _ a b) =-  depend (do pretty a-             write " -> ")-         (pretty b)-typ (TyList _ t) = brackets (pretty t)-typ (TyParArray _ t) =-  brackets (do write ":"-               pretty t-               write ":")-typ (TyApp _ f a) = spaced [pretty f, pretty a]-typ (TyVar _ n) = pretty n-typ (TyCon _ p) = pretty p-typ (TyParen _ e) = parens (pretty e)-typ (TyInfix _ a promotedop b) = do-  -- Apply special rules to line-break operators.-  let isLineBreak' op =-        case op of-          PromotedName _ op' -> isLineBreak op'-          UnpromotedName _ op' -> isLineBreak op'-      prettyInfixOp' op =-        case op of-          PromotedName _ op' -> write "'" >> prettyInfixOp op'-          UnpromotedName _ op' -> prettyInfixOp op'-  linebreak <- isLineBreak' promotedop-  if linebreak-    then do pretty a-            newline-            prettyInfixOp' promotedop-            space-            pretty b-    else do pretty a-            space-            prettyInfixOp' promotedop-            space-            pretty b-typ (TyKind _ ty k) =-  parens (do pretty ty-             write " :: "-             pretty k)-typ (TyBang _ bangty unpackty right) =-  do pretty unpackty-     pretty bangty-     pretty right-typ (TyEquals _ left right) =-  do pretty left-     write " ~ "-     pretty right-typ (TyPromoted _ (PromotedList _ _ ts)) =-  do write "'["-     unless (null ts) $ write " "-     commas (map pretty ts)-     write "]"-typ (TyPromoted _ (PromotedTuple _ ts)) =-  do write "'("-     unless (null ts) $ write " "-     commas (map pretty ts)-     write ")"-typ (TyPromoted _ (PromotedCon _ _ tname)) =-  do write "'"-     pretty tname-typ (TyPromoted _ (PromotedString _ _ raw)) = do-  do write "\""-     string raw-     write "\""-typ ty@TyPromoted{} = pretty' ty-typ (TySplice _ splice) = pretty splice-typ (TyWildCard _ name) =-  case name of-    Nothing -> write "_"-    Just n ->-      do write "_"-         pretty n-typ (TyQuasiQuote _ n s) = quotation n (string s)-typ (TyUnboxedSum{}) = error "FIXME: No implementation for TyUnboxedSum."-#if MIN_VERSION_haskell_src_exts(1,21,0)-typ (TyStar _) = write "*"-#endif--prettyTopName :: Name NodeInfo -> Printer ()-prettyTopName x@Ident{} = pretty x-prettyTopName x@Symbol{} = parens $ pretty x---- | Specially format records. Indent where clauses only 2 spaces.-decl' :: Decl NodeInfo -> Printer ()--- | Pretty print type signatures like------ foo :: (Show x, Read x)---     => (Foo -> Bar)---     -> Maybe Int---     -> (Char -> X -> Y)---     -> IO ()----decl' (TypeSig _ names ty') = do-  mst <- fitsOnOneLine (depend (do commas (map prettyTopName names)-                                   write " :: ")-                               (declTy ty'))-  case mst of-    Nothing -> do-      commas (map prettyTopName names)-      indentSpaces <- getIndentSpaces-      if allNamesLength >= indentSpaces-        then do write " ::"-                newline-                indented indentSpaces (depend (write "   ") (declTy ty'))-        else (depend (write " :: ") (declTy ty'))-    Just st -> put st-  where-    nameLength (Ident _ s) = length s-    nameLength (Symbol _ s) = length s + 2-    allNamesLength = fromIntegral $ sum (map nameLength names) + 2 * (length names - 1)--decl' (PatBind _ pat rhs' mbinds) =-  withCaseContext False $-    do pretty pat-       pretty rhs'-       for_ mbinds bindingGroup---- | Handle records specially for a prettier display (see guide).-decl' e = decl e--declTy :: Type NodeInfo -> Printer ()-declTy dty =-  case dty of-    TyForall _ mbinds mctx ty ->-      case mbinds of-        Nothing -> do-          case mctx of-            Nothing -> prettyTy False ty-            Just ctx -> do-              mst <- fitsOnOneLine (do pretty ctx-                                       depend (write " => ") (prettyTy False ty))-              case mst of-                Nothing -> do-                  pretty ctx-                  newline-                  indented (-3) (depend (write "=> ") (prettyTy True ty))-                Just st -> put st-        Just ts -> do-          write "forall "-          spaced (map pretty ts)-          write "."-          case mctx of-            Nothing -> do-              mst <- fitsOnOneLine (space >> prettyTy False ty)-              case mst of-                Nothing -> do-                  newline-                  prettyTy True ty-                Just st -> put st-            Just ctx -> do-              mst <- fitsOnOneLine (space >> pretty ctx)-              case mst of-                Nothing -> do-                  newline-                  pretty ctx-                  newline-                  indented (-3) (depend (write "=> ") (prettyTy True ty))-                Just st -> do-                  put st-                  newline-                  indented (-3) (depend (write "=> ") (prettyTy True ty))-    _ -> prettyTy False dty-  where-    collapseFaps (TyFun _ arg result) = arg : collapseFaps result-    collapseFaps e = [e]-    prettyTy breakLine ty = do-      if breakLine-        then-          case collapseFaps ty of-            [] -> pretty ty-            tys -> prefixedLined "-> " (map pretty tys)-        else do-          mst <- fitsOnOneLine (pretty ty)-          case mst of-            Nothing ->-              case collapseFaps ty of-                [] -> pretty ty-                tys -> prefixedLined "-> " (map pretty tys)-            Just st -> put st---- | Use special record display, used by 'dataDecl' in a record scenario.-qualConDecl :: QualConDecl NodeInfo -> Printer ()-qualConDecl (QualConDecl _ tyvars ctx d) =-  depend (unless (null (fromMaybe [] tyvars))-                 (do write "forall "-                     spaced (map pretty (fromMaybe [] tyvars))-                     write ". "))-         (withCtx ctx (recDecl d))---- | Fields are preceded with a space.-conDecl :: ConDecl NodeInfo -> Printer ()-conDecl (RecDecl _ name fields) = do-   pretty name-   newline-   indentedBlock-    (do depend (write "{")-               (prefixedLined ","-                              (map (depend space . pretty) fields))-        newline-        write "}"-        )-conDecl (ConDecl _ name bangty) = do-  prettyQuoteName name-  unless-    (null bangty)-    (ifFitsOnOneLineOrElse-       (do space-           spaced (map pretty bangty))-       (do newline-           indentedBlock (lined (map pretty bangty))))-conDecl (InfixConDecl _ a f b) =-  inter space [pretty a, pretty f, pretty b]---- | Record decls are formatted like: Foo--- { bar :: X--- }-recDecl :: ConDecl NodeInfo -> Printer ()-recDecl (RecDecl _ name fields) =-  do pretty name-     indentSpaces <- getIndentSpaces-     newline-     column indentSpaces-            (do depend (write "{!")-                       (prefixedLined ","-                                      (map (depend space . pretty) fields))-                newline-                write "}")-recDecl r = prettyInternal r--recUpdateExpr :: Printer () -> [FieldUpdate NodeInfo] -> Printer ()-recUpdateExpr expWriter updates = do-  ifFitsOnOneLineOrElse hor $ do-    expWriter-    newline-    indentedBlock (updatesHor `ifFitsOnOneLineOrElse` updatesVer)-  where-    hor = do-      expWriter-      space-      updatesHor-    updatesHor = braces $ commas $ map pretty updates-    updatesVer = do-      depend (write "{ ") $ prefixedLined ", " $ map pretty updates-      newline-      write "}"------------------------------------------------------------------------------------- Predicates---- | Is the decl a record?-isRecord :: QualConDecl t -> Bool-isRecord (QualConDecl _ _ _ RecDecl{}) = True-isRecord _ = False---- | If the given operator is an element of line breaks in configuration.-isLineBreak :: QName NodeInfo -> Printer Bool-isLineBreak (UnQual _ (Symbol _ s)) = do-  breaks <- gets (configLineBreaks . psConfig)-  return $ s `elem` breaks-isLineBreak _ = return False---- | Does printing the given thing overflow column limit? (e.g. 80)-fitsOnOneLine :: Printer a -> Printer (Maybe PrintState)-fitsOnOneLine p =-  do st <- get-     put st { psFitOnOneLine = True}-     ok <- fmap (const True) p <|> return False-     st' <- get-     put st-     guard $ ok || not (psFitOnOneLine st)-     return (if ok-                then Just st' { psFitOnOneLine = psFitOnOneLine st }-                else Nothing)---- | If first printer fits, use it, else use the second one.-ifFitsOnOneLineOrElse :: Printer a -> Printer a -> Printer a-ifFitsOnOneLineOrElse a b = do-  stOrig <- get-  put stOrig{psFitOnOneLine = True}-  res <- fmap Just a <|> return Nothing-  case res of-    Just r -> do-      modify $ \st -> st{psFitOnOneLine = psFitOnOneLine stOrig}-      return r-    Nothing -> do-      put stOrig-      guard $ not (psFitOnOneLine stOrig)-      b--bindingGroup :: Binds NodeInfo -> Printer ()-bindingGroup binds =-  do newline-     indented 2-              (do write "where"-                  newline-                  indented 2 (pretty binds))--infixApp :: Exp NodeInfo-         -> Exp NodeInfo-         -> QOp NodeInfo-         -> Exp NodeInfo-         -> Maybe Int64-         -> Printer ()-infixApp e a op b indent =-  hor `ifFitsOnOneLineOrElse` ver-  where-    hor =-      spaced-        [ case link of-          OpChainExp e' -> pretty e'-          OpChainLink qop -> pretty qop-        | link <- flattenOpChain e-        ]-    ver = do-      prettyWithIndent a-      beforeRhs <- case a of-                     Do _ _ -> do-                       indentSpaces <- getIndentSpaces-                       column (fromMaybe 0 indent + indentSpaces + 3) (newline >> pretty op) -- 3 = "do "-                       return space-                     _ -> space >> pretty op >> return newline-      case b of-        Lambda{} -> space >> pretty b-        LCase{} -> space >> pretty b-        Do _ stmts -> swing (write " do") $ lined (map pretty stmts)-        _ -> do-          beforeRhs-          case indent of-            Nothing -> do-              col <- fmap (psColumn . snd)-                          (sandbox (write ""))-              -- force indent for top-level template haskell expressions, #473.-              if col == 0-                then do indentSpaces <- getIndentSpaces-                        column indentSpaces (prettyWithIndent b)-                else prettyWithIndent b-            Just col -> do-              indentSpaces <- getIndentSpaces-              column (col + indentSpaces) (prettyWithIndent b)-    prettyWithIndent e' =-      case e' of-        InfixApp _ a' op' b' -> infixApp e' a' op' b' indent-        _ -> pretty e'---- | A link in a chain of operator applications.-data OpChainLink l-  = OpChainExp (Exp l)-  | OpChainLink (QOp l)-  deriving (Show)---- | Flatten a tree of InfixApp expressions into a chain of operator--- links.-flattenOpChain :: Exp l -> [OpChainLink l]-flattenOpChain (InfixApp _ left op right) =-  flattenOpChain left <>-  [OpChainLink op] <>-  flattenOpChain right-flattenOpChain e = [OpChainExp e]---- | Write a Template Haskell quotation or a quasi-quotation.------ >>> quotation "t" (string "Foo")--- > [t|Foo|]-quotation :: String -> Printer () -> Printer ()-quotation quoter body =-  brackets-    (depend-       (do string quoter-           write "|")-       (do body-           write "|"))+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++-- | Pretty printing.+--+-- Some instances define top-level functions to handle CPP.+--+-- Some value constructors never appear in an AST. GHC has three stages for+-- using an AST: parsing, renaming, and type checking, and GHC uses these+-- constructors only in remaining and type checking.+module HIndent.Pretty+  ( Pretty(..)+  , pretty+  , printCommentsAnd+  ) where++import Control.Monad+import Control.Monad.RWS+import qualified GHC.Data.FastString as GHC+import qualified GHC.Hs as GHC+import GHC.Stack+import qualified GHC.Types.SourceText as GHC+import qualified GHC.Types.SrcLoc as GHC+import HIndent.Applicative (whenJust)+import HIndent.Ast.Comment (mkComment)+import HIndent.Ast.Declaration.Bind+import HIndent.Ast.Declaration.Data.Body+import HIndent.Ast.Declaration.Family.Data+import HIndent.Ast.Declaration.Family.Type+import HIndent.Ast.Declaration.Instance.Family.Type.Associated+  ( mkAssociatedType+  )+import HIndent.Ast.Declaration.Instance.Family.Type.Associated.Default+  ( mkAssociatedTypeDefault+  )+import HIndent.Ast.Declaration.Signature+import HIndent.Ast.Expression (mkExpression)+import HIndent.Ast.LocalBinds (mkLocalBinds)+import HIndent.Ast.Name.Prefix+import HIndent.Ast.NodeComments+import HIndent.Ast.Pattern+import HIndent.Ast.Type+import HIndent.Ast.WithComments+import HIndent.Pretty.Combinators+import HIndent.Pretty.NodeComments+import qualified HIndent.Pretty.SigBindFamily as SBF+import HIndent.Pretty.Types+import HIndent.Printer+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+import qualified GHC.Core.DataCon as GHC+#else+import qualified GHC.Unit as GHC+#endif+-- | This function pretty-prints the given AST node with comments.+pretty :: Pretty a => a -> Printer ()+pretty p = do+  printCommentsBefore p+  pretty' p+  printCommentOnSameLine p+  printCommentsAfter p++-- | Prints comments included in the location information and then the+-- AST node body.+printCommentsAnd ::+     (CommentExtraction l)+  => GHC.GenLocated l e+  -> (e -> Printer ())+  -> Printer ()+printCommentsAnd (GHC.L l e) f = do+  printCommentsBefore l+  f e+  printCommentOnSameLine l+  printCommentsAfter l++-- | Prints comments that are before the given AST node.+printCommentsBefore :: CommentExtraction a => a -> Printer ()+printCommentsBefore p =+  forM_ (commentsBefore $ nodeComments p) $ \(GHC.L loc c) -> do+    let col = fromIntegral $ GHC.srcSpanStartCol (getAnc loc) - 1+    indentedWithFixedLevel col $ pretty c+    newline++-- | Prints comments that are on the same line as the given AST node.+printCommentOnSameLine :: CommentExtraction a => a -> Printer ()+printCommentOnSameLine (commentsOnSameLine . nodeComments -> (c:cs)) = do+  col <- gets psColumn+  if col == 0+    then indentedWithFixedLevel+           (fromIntegral $ GHC.srcSpanStartCol $ getAnc $ GHC.getLoc c)+           $ spaced+           $ fmap pretty+           $ c : cs+    else spacePrefixed $ fmap pretty $ c : cs+  eolCommentsArePrinted+printCommentOnSameLine _ = return ()++-- | Prints comments that are after the given AST node.+printCommentsAfter :: CommentExtraction a => a -> Printer ()+printCommentsAfter p =+  case commentsAfter $ nodeComments p of+    [] -> return ()+    xs -> do+      isThereCommentsOnSameLine <- gets psEolComment+      unless isThereCommentsOnSameLine newline+      forM_ xs $ \(GHC.L loc c) -> do+        let col = fromIntegral $ GHC.srcSpanStartCol (getAnc loc) - 1+        indentedWithFixedLevel col $ pretty c+        eolCommentsArePrinted++-- | Pretty print including comments.+--+-- 'FastString' does not implement this class because it may contain @\n@s+-- and each type that may contain a 'FastString' value needs their own+-- handlings.+class CommentExtraction a =>+      Pretty a+  where+  pretty' :: a -> Printer ()++-- Do nothing if there are no pragmas, module headers, imports, or+-- declarations. Otherwise, extra blank lines will be inserted if only+-- comments are present in the source code. See+-- https://github.com/mihaimaruseac/hindent/issues/586#issuecomment-1374992624.+instance (CommentExtraction l, Pretty e) => Pretty (GHC.GenLocated l e) where+  pretty' (GHC.L _ e) = pretty e++instance Pretty+           (GHC.StmtLR+              GHC.GhcPs+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))) where+  pretty' = prettyStmtLRExpr++prettyStmtLRExpr ::+     GHC.StmtLR+       GHC.GhcPs+       GHC.GhcPs+       (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs))+  -> Printer ()+prettyStmtLRExpr (GHC.LastStmt _ x _ _) =+  pretty $ mkExpression <$> fromGenLocated x+prettyStmtLRExpr (GHC.BindStmt _ pat body) = do+  pretty $ mkPattern <$> fromGenLocated pat+  string " <-"+  hor <-|> ver+  where+    hor = do+      space+      pretty $ mkExpression <$> fromGenLocated body+    ver = do+      newline+      indentedBlock $ pretty $ mkExpression <$> fromGenLocated body+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+prettyStmtLRExpr GHC.ApplicativeStmt {} = notGeneratedByParser+#endif+prettyStmtLRExpr (GHC.BodyStmt _ body _ _) =+  pretty $ mkExpression <$> fromGenLocated body+prettyStmtLRExpr (GHC.LetStmt _ l) =+  whenJust (mkLocalBinds l) $ \binds -> string "let " |=> pretty binds+prettyStmtLRExpr (GHC.ParStmt _ xs _ _) = hvBarSep $ fmap pretty xs+prettyStmtLRExpr GHC.TransStmt {..} =+  vCommaSep+    $ fmap pretty trS_stmts+        ++ [ string "then "+               >> pretty (mkExpression <$> fromGenLocated trS_using)+           ]+prettyStmtLRExpr GHC.RecStmt {..} =+  string "rec " |=> printCommentsAnd recS_stmts (lined . fmap pretty)++instance Pretty (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where+  pretty' (GHC.ParStmtBlock _ xs _ _) = hvCommaSep $ fmap pretty xs++instance Pretty SBF.SigBindFamily where+  pretty' (SBF.Sig x) = pretty $ mkSignature x+  pretty' (SBF.Bind x) = pretty $ mkBind x+  pretty' (SBF.Family x)+    | Just fam <- mkTypeFamily x = pretty fam+    | Just fam <- mkDataFamily x = pretty fam+    | otherwise = error "Unreachable"+  pretty' (SBF.TyFamInst x) = pretty $ mkAssociatedType x+  pretty' (SBF.TyFamDeflt x) = pretty $ mkAssociatedTypeDefault x+  pretty' (SBF.DataFamInst x) = pretty $ DataFamInstDeclInsideClassInst x++instance Pretty GHC.EpaComment where+  pretty' GHC.EpaComment {..} = pretty $ mkComment ac_tok++instance Pretty+           (GHC.HsScaled+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where+  pretty' (GHC.HsScaled _ ty) = pretty $ fmap mkType ty+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+instance Pretty GHC.StringLiteral where+  pretty' GHC.StringLiteral {sl_st = GHC.SourceText s} = string $ GHC.unpackFS s+  pretty' GHC.StringLiteral {..} = string $ GHC.unpackFS sl_fs+#else+instance Pretty GHC.StringLiteral where+  pretty' = output+#endif+instance Pretty Context where+  pretty' (Context xs) =+    pretty (HorizontalContext xs) <-|> pretty (VerticalContext xs)+#if MIN_VERSION_ghc_lib_parser(9,4,1)+instance Pretty HorizontalContext where+  pretty' (HorizontalContext xs) =+    constraintsParens+      $ printCommentsAnd xs (hCommaSep . fmap (pretty . fmap mkType))+    where+      constraintsParens =+        case xs of+          (GHC.L _ []) -> parens+          (GHC.L _ [_]) -> id+          _ -> parens++instance Pretty VerticalContext where+  pretty' (VerticalContext full@(GHC.L _ [])) =+    printCommentsAnd full (const $ string "()")+  pretty' (VerticalContext full@(GHC.L _ [x])) =+    printCommentsAnd full (const $ pretty $ mkType <$> x)+  pretty' (VerticalContext xs) =+    printCommentsAnd xs (vTuple . fmap (pretty . fmap mkType))+#else+instance Pretty HorizontalContext where+  pretty' (HorizontalContext xs) =+    constraintsParens $ mapM_ (`printCommentsAnd` (hCommaSep . fmap pretty)) xs+    where+      constraintsParens =+        case xs of+          Nothing -> id+          Just (GHC.L _ []) -> parens+          Just (GHC.L _ [_]) -> id+          Just _ -> parens++instance Pretty VerticalContext where+  pretty' (VerticalContext Nothing) = pure ()+  pretty' (VerticalContext (Just (GHC.L _ []))) = string "()"+  pretty' (VerticalContext (Just full@(GHC.L _ [x]))) =+    printCommentsAnd full (const $ pretty x)+  pretty' (VerticalContext (Just xs)) =+    printCommentsAnd xs (vTuple . fmap pretty)+#endif+instance Pretty+           (GHC.FamEqn+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where+  pretty' GHC.FamEqn {..} = do+    pretty $ fmap mkPrefixName feqn_tycon+    spacePrefixed $ fmap pretty feqn_pats+    string " = "+    pretty $ mkType <$> feqn_rhs++-- | Pretty-print a data instance.+instance Pretty (GHC.FamEqn GHC.GhcPs (GHC.HsDataDefn GHC.GhcPs)) where+  pretty' = pretty' . FamEqnTopLevel+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+instance Pretty FamEqn' where+  pretty' FamEqn' {famEqn = GHC.FamEqn {..}, ..} = do+    spaced+      $ string prefix+          : pretty (fmap mkPrefixName feqn_tycon)+          : fmap pretty feqn_pats+    pretty (mkDataBody feqn_rhs)+    where+      prefix =+        case (famEqnFor, GHC.dd_cons feqn_rhs) of+          (DataFamInstDeclForTopLevel, GHC.NewTypeCon {}) -> "newtype instance"+          (DataFamInstDeclForTopLevel, GHC.DataTypeCons {}) -> "data instance"+          (DataFamInstDeclForInsideClassInst, GHC.NewTypeCon {}) -> "newtype"+          (DataFamInstDeclForInsideClassInst, GHC.DataTypeCons {}) -> "data"+#else+instance Pretty FamEqn' where+  pretty' FamEqn' {famEqn = GHC.FamEqn {..}, ..} = do+    spaced+      $ string prefix+          : pretty (fmap mkPrefixName feqn_tycon)+          : fmap pretty feqn_pats+    pretty (mkDataBody feqn_rhs)+    where+      prefix =+        case (famEqnFor, GHC.dd_ND feqn_rhs) of+          (DataFamInstDeclForTopLevel, GHC.NewType) -> "newtype instance"+          (DataFamInstDeclForTopLevel, GHC.DataType) -> "data instance"+          (DataFamInstDeclForInsideClassInst, GHC.NewType) -> "newtype"+          (DataFamInstDeclForInsideClassInst, GHC.DataType) -> "data"+#endif+-- | HsArg (LHsType GhcPs) (LHsType GhcPs)+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+instance Pretty+           (GHC.HsArg+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where+  pretty' (GHC.HsValArg _ x) = pretty $ mkType <$> x+  pretty' (GHC.HsTypeArg _ x) = string "@" >> pretty (mkType <$> x)+  pretty' GHC.HsArgPar {} = notUsedInParsedStage+#elif MIN_VERSION_ghc_lib_parser(9, 8, 1)+instance Pretty+           (GHC.HsArg+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where+  pretty' (GHC.HsValArg x) = pretty $ mkType <$> x+  pretty' (GHC.HsTypeArg _ x) = string "@" >> pretty (mkType <$> x)+  pretty' GHC.HsArgPar {} = notUsedInParsedStage+#else+instance Pretty+           (GHC.HsArg+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where+  pretty' (GHC.HsValArg x) = pretty $ mkType <$> x+  pretty' (GHC.HsTypeArg _ x) = string "@" >> pretty (mkType <$> x)+  pretty' GHC.HsArgPar {} = notUsedInParsedStage+#endif+#if MIN_VERSION_ghc_lib_parser(9,4,1)+instance Pretty (GHC.WithHsDocIdentifiers GHC.StringLiteral GHC.GhcPs) where+  pretty' GHC.WithHsDocIdentifiers {..} = pretty hsDocString+#endif+-- | 'Pretty' for 'LHsWcType'+instance Pretty+           (GHC.HsWildCardBndrs+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))) where+  pretty' GHC.HsWC {..} = pretty $ mkType <$> hswc_body++instance Pretty TopLevelTyFamInstDecl where+  pretty' (TopLevelTyFamInstDecl GHC.TyFamInstDecl {..}) =+    string "instance " >> pretty tfid_eqn++instance Pretty (GHC.DataFamInstDecl GHC.GhcPs) where+  pretty' = pretty' . DataFamInstDeclTopLevel++instance Pretty DataFamInstDecl' where+  pretty' DataFamInstDecl' {dataFamInstDecl = GHC.DataFamInstDecl {..}, ..} =+    pretty $ FamEqn' dataFamInstDeclFor dfid_eqn++instance Pretty (GHC.HsOverLit GHC.GhcPs) where+  pretty' GHC.OverLit {..} = pretty ol_val++instance Pretty GHC.OverLitVal where+  pretty' (GHC.HsIntegral x) = pretty x+  pretty' (GHC.HsFractional x) = pretty x+  pretty' (GHC.HsIsString _ x) = string $ GHC.unpackFS x+#if MIN_VERSION_ghc_lib_parser(9,8,1)+instance Pretty GHC.IntegralLit where+  pretty' GHC.IL {il_text = GHC.SourceText s} = output s+  pretty' GHC.IL {..} = string $ show il_value+#else+instance Pretty GHC.IntegralLit where+  pretty' GHC.IL {il_text = GHC.SourceText s} = string s+  pretty' GHC.IL {..} = string $ show il_value+#endif+instance Pretty GHC.FractionalLit where+  pretty' = output++instance Pretty (GHC.HsLit GHC.GhcPs) where+  pretty' = prettyHsLit++prettyHsLit :: GHC.HsLit GHC.GhcPs -> Printer ()+prettyHsLit x@(GHC.HsChar _ _) = output x+prettyHsLit x@GHC.HsCharPrim {} = output x+prettyHsLit GHC.HsInt {} = notUsedInParsedStage+prettyHsLit (GHC.HsIntPrim _ x) = string $ show x ++ "#"+prettyHsLit GHC.HsWordPrim {} = notUsedInParsedStage+prettyHsLit GHC.HsInt64Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsWord64Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsInteger {} = notUsedInParsedStage+prettyHsLit GHC.HsRat {} = notUsedInParsedStage+prettyHsLit (GHC.HsFloatPrim _ x) = pretty x >> string "#"+prettyHsLit GHC.HsDoublePrim {} = notUsedInParsedStage+#if MIN_VERSION_ghc_lib_parser(9, 8, 1)+prettyHsLit GHC.HsInt8Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsInt16Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsInt32Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsWord8Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsWord16Prim {} = notUsedInParsedStage+prettyHsLit GHC.HsWord32Prim {} = notUsedInParsedStage+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+prettyHsLit GHC.HsMultilineString {} = notGeneratedByParser+#endif+prettyHsLit x =+  case x of+    GHC.HsString {} -> prettyString+    GHC.HsStringPrim {} -> prettyString+  where+    prettyString =+      case lines $ showOutputable x of+        [] -> pure ()+        [l] -> string l+        (s:ss) ->+          string "" |=> do+            string s+            newline+            indentedWithSpace (-1)+              $ lined+              $ fmap (string . dropWhile (/= '\\')) ss++instance Pretty DoOrMdo where+  pretty' Do = string "do"+  pretty' Mdo = string "mdo"++instance Pretty QualifiedDo where+  pretty' (QualifiedDo (Just m) d) = do+    pretty m+    string "."+    pretty d+  pretty' (QualifiedDo Nothing d) = pretty d+#if MIN_VERSION_ghc_lib_parser(9,6,1)+instance Pretty GHC.FieldLabelString where+  pretty' = output+#endif+-- | Marks an AST node as never appearing in an AST.+--+-- Some AST node types are only defined in `ghc-lib-parser` and not+-- generated by it.+notGeneratedByParser :: HasCallStack => a+notGeneratedByParser = error "`ghc-lib-parser` never generates this AST node."++-- | Marks an AST node as never appearing in the AST.+--+-- Some AST node types are only used in the renaming or type-checking phase.+notUsedInParsedStage :: HasCallStack => a+notUsedInParsedStage =+  error+    "This AST should never appears in an AST. It only appears in the renaming or type checked stages."+#if !MIN_VERSION_ghc_lib_parser(9,4,1)+-- | Marks an AST node as it is used only for Haskell Program Coverage.+forHpc :: HasCallStack => a+forHpc = error "This AST type is for the use of Haskell Program Coverage."+#endif++#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+getAnc :: GHC.EpaLocation' a -> GHC.RealSrcSpan+getAnc (GHC.EpaSpan (GHC.RealSrcSpan x _)) = x+getAnc _ = undefined+#else+getAnc :: GHC.Anchor -> GHC.RealSrcSpan+getAnc = GHC.anchor+#endif
+ src/HIndent/Pretty.hs-boot view
@@ -0,0 +1,75 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}++module HIndent.Pretty+  ( Pretty(..)+  , pretty+  , printCommentsAnd+  ) where++import qualified GHC.Types.SourceText as GHC+import qualified GHC.Types.SrcLoc as GHC+import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC+import HIndent.Pretty.NodeComments+import HIndent.Pretty.SigBindFamily+import HIndent.Pretty.Types+import HIndent.Printer++class CommentExtraction a =>+      Pretty a+  where+  pretty' :: a -> Printer ()++pretty :: Pretty a => a -> Printer ()+printCommentsAnd ::+     (CommentExtraction l)+  => GHC.GenLocated l e+  -> (e -> Printer ())+  -> Printer ()+instance (CommentExtraction l, Pretty e) => Pretty (GHC.GenLocated l e)++instance Pretty GHC.EpaComment++instance Pretty+           (GHC.FamEqn+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs)))++instance Pretty SigBindFamily++instance Pretty GHC.StringLiteral++instance Pretty Context++instance Pretty+           (GHC.HsScaled+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs)))+#if MIN_VERSION_ghc_lib_parser(9, 8, 1)+instance Pretty+           (GHC.HsArg+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs)))+#else+instance Pretty+           (GHC.HsArg+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs))+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs)))+#endif+instance Pretty (GHC.HsLit GHC.GhcPs)++instance Pretty (GHC.HsOverLit GHC.GhcPs)++instance Pretty QualifiedDo++instance Pretty+           (GHC.StmtLR+              GHC.GhcPs+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsExpr GHC.GhcPs)))++instance Pretty+           (GHC.HsWildCardBndrs+              GHC.GhcPs+              (GHC.GenLocated GHC.SrcSpanAnnA (GHC.HsType GHC.GhcPs)))
+ src/HIndent/Pretty/Combinators.hs view
@@ -0,0 +1,22 @@+-- | A module to import all @HIndent.Pretty.Combinators.*@s.+module HIndent.Pretty.Combinators+  ( module HIndent.Pretty.Combinators.Comment+  , module HIndent.Pretty.Combinators.Getter+  , module HIndent.Pretty.Combinators.Indent+  , module HIndent.Pretty.Combinators.Lineup+  , module HIndent.Pretty.Combinators.Op+  , module HIndent.Pretty.Combinators.Outputable+  , module HIndent.Pretty.Combinators.String+  , module HIndent.Pretty.Combinators.Switch+  , module HIndent.Pretty.Combinators.Wrap+  ) where++import HIndent.Pretty.Combinators.Comment+import HIndent.Pretty.Combinators.Getter+import HIndent.Pretty.Combinators.Indent+import HIndent.Pretty.Combinators.Lineup+import HIndent.Pretty.Combinators.Op+import HIndent.Pretty.Combinators.Outputable+import HIndent.Pretty.Combinators.String+import HIndent.Pretty.Combinators.Switch+import HIndent.Pretty.Combinators.Wrap
+ src/HIndent/Pretty/Combinators/Comment.hs view
@@ -0,0 +1,12 @@+-- | Printer combinators for handling comments.+module HIndent.Pretty.Combinators.Comment+  ( eolCommentsArePrinted+  ) where++import Control.Monad.State+import HIndent.Printer++-- | Claims that comments were printed. Next time calling 'string' will+-- print a newline before printing a text.+eolCommentsArePrinted :: Printer ()+eolCommentsArePrinted = modify (\s -> s {psEolComment = True})
+ src/HIndent/Pretty/Combinators/Getter.hs view
@@ -0,0 +1,31 @@+-- | Getters to fetch current status and printer information.+module HIndent.Pretty.Combinators.Getter+  ( startingColumn+  , printerLength+  ) where++import Control.Monad.RWS hiding (state)+import Data.Int+import HIndent.Pretty.Combinators.String+import HIndent.Printer++-- | Returns the column from which a new string is printed. It may be+-- different from 'psColumn' immediately after printing a comment.+startingColumn :: Printer Int64+startingColumn = do+  before <- get+  string ""+  after <- get+  put before+  return $ psColumn after++-- Returns how many characters the printer moved the cursor horizontally.+-- The returned value maybe negative if the printer prints multiple lines+-- and the column of the last position is less than before.+printerLength :: Printer a -> Printer Int64+printerLength p = do+  before <- get+  _ <- p+  after <- get+  put before+  pure $ psColumn after - psColumn before
+ src/HIndent/Pretty/Combinators/Indent.hs view
@@ -0,0 +1,66 @@+-- | Printer combinators related to indent.+module HIndent.Pretty.Combinators.Indent+  ( indentedBlock+  , indentedWithSpace+  , (|=>)+  , indentedWithFixedLevel+  , prefixed+  , getIndentSpaces+  ) where++import Control.Monad.State+import Data.Int+import HIndent.Config+import HIndent.Pretty.Combinators.String+import HIndent.Printer++-- | This function runs the given printer with an additional indent. The+-- indent has 'configIndentSpaces' spaces.+indentedBlock :: Printer a -> Printer a+indentedBlock p = do+  indentSpaces <- getIndentSpaces+  indentedWithSpace indentSpaces p++-- | This function runs the given printer with an additional indent. The+-- indent has the specified number of spaces.+indentedWithSpace :: Int64 -> Printer a -> Printer a+indentedWithSpace i p = do+  level <- gets psIndentLevel+  indentedWithFixedLevel (level + i) p++-- | This function runs the first printer, fixes the indent, and then runs+-- the second one.+--+-- For example,+--+-- > string "foo " |=> lined [string "bar", "baz"]+--+-- will print texts as below.+-- foo bar+--     baz+(|=>) :: Printer () -> Printer a -> Printer a+hd |=> p = do+  hd+  col <- gets psColumn+  indentedWithFixedLevel col p++infixl 1 |=>+-- | This function runs the given printer with the passed indent level.+indentedWithFixedLevel :: Int64 -> Printer a -> Printer a+indentedWithFixedLevel i p = do+  l <- gets psIndentLevel+  modify (\s -> s {psIndentLevel = i})+  m <- p+  modify (\s -> s {psIndentLevel = l})+  return m++-- | Prints the text passed as the first argument before the current+-- position and then the second argument.+prefixed :: String -> Printer () -> Printer ()+prefixed s p = do+  indentedWithSpace (-(fromIntegral $ length s)) $ string s+  p++-- | This function returns the current indent level.+getIndentSpaces :: Printer Int64+getIndentSpaces = gets (configIndentSpaces . psConfig)
+ src/HIndent/Pretty/Combinators/Lineup.hs view
@@ -0,0 +1,264 @@+-- | Printer combinators for lining up multiple elements.+module HIndent.Pretty.Combinators.Lineup+  ( -- * Tuples+    hvTuple+  , hvTuple'+  , hTuple+  , hFillingTuple+  , vTuple+  , vTuple'+  , hPromotedTuple+  , -- * Unboxed tuples+    hvUnboxedTuple'+  , hUnboxedTuple+  , -- * Unboxed sums+    hvUnboxedSum'+  , -- * Records+    hvFields+  , hFields+  , vFields+  , vFields'+  , -- * Lists+    hList+  , vList+  , hvPromotedList+  , -- * Bars+    hvBarSep+  , hBarSep+  , vBarSep+  , -- * Commas+    hvCommaSep+  , hCommaSep+  , vCommaSep+  , -- * Others+    spaced+  , lined+  , blanklined+  , hDotSep+  , spacePrefixed+  , newlinePrefixed+  , prefixedLined+  , inter+  ) where++import Control.Monad+import Data.Foldable (toList)+import Data.List (intersperse)+import HIndent.Pretty.Combinators.Indent+import HIndent.Pretty.Combinators.String+import HIndent.Pretty.Combinators.Switch+import HIndent.Pretty.Combinators.Wrap+import HIndent.Printer++-- | Applies 'hTuple' if the result fits in a line or 'vTuple' otherwise.+hvTuple :: Foldable f => f (Printer ()) -> Printer ()+hvTuple = (<-|>) <$> hTuple <*> vTuple++-- | Applies 'hTuple'' if the result fits in a line or 'vTuple'' otherwise.+hvTuple' :: Foldable f => f (Printer ()) -> Printer ()+hvTuple' = (<-|>) <$> hTuple <*> vTuple'++-- | Runs printers to construct a tuple in a line.+hTuple :: Foldable f => f (Printer ()) -> Printer ()+hTuple = parens . hCommaSep++-- | Runs printers to construct a tuple in a line, but inserts newlines if+-- the result doesn't fit in a line.+--+-- The difference between this function and 'vTuple' is that the number of elements+-- in a row in this function is not limited to 1 while the number of elements in+-- a row in 'vTuple' is limited to 1.+hFillingTuple :: Foldable f => f (Printer ()) -> Printer ()+hFillingTuple = parens . inter (comma >> (space <-|> newline))++-- | Runs printers to construct a tuple where elements are aligned+-- vertically.+vTuple :: Foldable f => f (Printer ()) -> Printer ()+vTuple = vCommaSepWrapped ("(", ")")++-- | Similar to 'vTuple', but the closing parenthesis is in the last+-- element.+vTuple' :: Foldable f => f (Printer ()) -> Printer ()+vTuple' = vCommaSepWrapped' ("(", ")")++-- | Runs printers to construct a promoted tuple in a line.+hPromotedTuple :: Foldable f => f (Printer ()) -> Printer ()+hPromotedTuple = promotedTupleParens . hCommaSep++-- | Runs printers to construct an unboxed tuple. The elements are aligned+-- either in a line or vertically.+hvUnboxedTuple' :: Foldable f => f (Printer ()) -> Printer ()+hvUnboxedTuple' = (<-|>) <$> hUnboxedTuple <*> vUnboxedTuple'++-- | Runs printers to construct an unboxed tuple in a line.+hUnboxedTuple :: Foldable f => f (Printer ()) -> Printer ()+hUnboxedTuple = unboxedParens . hCommaSep++-- | Runs printers to construct an unboxed tuple where the elements are+-- aligned vertically.+vUnboxedTuple' :: Foldable f => f (Printer ()) -> Printer ()+vUnboxedTuple' = vCommaSepWrapped' ("(#", " #)")++-- | Runs printers to construct an unboxed sum. The elements are aligned+-- either in a line or vertically.+--+-- The enclosing parenthesis will be printed on the same line as the last+-- element.+hvUnboxedSum' :: Foldable f => f (Printer ()) -> Printer ()+hvUnboxedSum' = (<-|>) <$> hUnboxedSum <*> vUnboxedSum'++-- | Runs printers to construct an unboxed sum in a line.+hUnboxedSum :: Foldable f => f (Printer ()) -> Printer ()+hUnboxedSum = unboxedParens . hBarSep++-- | Runs printers to construct an unboxed sum where the elements are+-- aligned vertically.+--+-- The enclosing parenthesis will be printed on the same line as the last+-- element.+vUnboxedSum' :: Foldable f => f (Printer ()) -> Printer ()+vUnboxedSum' = vWrappedLineup' '|' ("(#", " #)")++-- | Applies 'hFields' if the result fits in a line or 'vFields' otherwise.+hvFields :: Foldable f => f (Printer ()) -> Printer ()+hvFields = (<-|>) <$> hFields <*> vFields++-- | Runs printers to construct a record in a line.+hFields :: Foldable f => f (Printer ()) -> Printer ()+hFields = braces . hCommaSep++-- | Runs printers to construct a record where elements are aligned+-- vertically.+vFields :: Foldable f => f (Printer ()) -> Printer ()+vFields = vCommaSepWrapped ("{", "}")++-- | Similar to 'vFields', but the closing brace is in the same line as the+-- last element.+vFields' :: Foldable f => f (Printer ()) -> Printer ()+vFields' = vCommaSepWrapped' ("{", "}")++-- | Runs printers to construct a list in a line.+hList :: Foldable f => f (Printer ()) -> Printer ()+hList = brackets . hCommaSep++-- | Runs printers to construct a list where elements are aligned+-- vertically.+vList :: Foldable f => f (Printer ()) -> Printer ()+vList = vCommaSepWrapped ("[", "]")++-- | Runs printers to construct a promoted list where elements are aligned+-- in a line or vertically.+hvPromotedList :: Foldable f => f (Printer ()) -> Printer ()+hvPromotedList = (<-|>) <$> hPromotedList <*> vPromotedList++-- | Runs printers to construct a promoted list in a line.+hPromotedList :: Foldable f => f (Printer ()) -> Printer ()+hPromotedList = promotedListBrackets . hCommaSep++-- | Runs printers to construct a promoted list where elements are aligned+-- vertically.+vPromotedList :: Foldable f => f (Printer ()) -> Printer ()+vPromotedList = vCommaSepWrapped ("'[", " ]")++-- | Runs printers in a line with a space as the separator.+spaced :: Foldable f => f (Printer ()) -> Printer ()+spaced = inter space++-- | Runs printers line by line.+lined :: Foldable f => f (Printer ()) -> Printer ()+lined = inter newline++-- | Runs printers with a blank line as the separator.+blanklined :: Foldable f => f (Printer ()) -> Printer ()+blanklined = inter blankline++-- | Applies 'hBarSep' if the result fits in a line or 'vBarSep' otherwise.+hvBarSep :: Foldable f => f (Printer ()) -> Printer ()+hvBarSep = (<-|>) <$> hBarSep <*> vBarSep++-- | Runs printers in a line with a bar as the separator.+hBarSep :: Foldable f => f (Printer ()) -> Printer ()+hBarSep = inter (string " | ")++-- | Runs printers where each line except the first one has @| @ as+-- a prefix.+vBarSep :: Foldable f => f (Printer ()) -> Printer ()+vBarSep = prefixedLined "| "++-- | Applies 'hCommaSep' if the result fits in a line or 'vCommaSep'+-- otherwise.+hvCommaSep :: Foldable f => f (Printer ()) -> Printer ()+hvCommaSep = (<-|>) <$> hCommaSep <*> vCommaSep++-- | Runs printers in a line with a comma as the separator.+hCommaSep :: Foldable f => f (Printer ()) -> Printer ()+hCommaSep = inter (string ", ")++-- | Runs printers with each line except the first one has @, @ as+-- a prefix.+vCommaSep :: Foldable f => f (Printer ()) -> Printer ()+vCommaSep = prefixedLined ", "++-- | Prints elements separated by comma  in vertical with the given prefix+-- and suffix.+vCommaSepWrapped ::+     Foldable f => (String, String) -> f (Printer ()) -> Printer ()+vCommaSepWrapped = vWrappedLineup ','++-- | Similar to 'vCommaSepWrapped' but the suffix is in the same line as the last+-- element.+vCommaSepWrapped' ::+     Foldable f => (String, String) -> f (Printer ()) -> Printer ()+vCommaSepWrapped' = vWrappedLineup' ','++-- | Runs printers with a dot as the separator.+hDotSep :: Foldable f => f (Printer ()) -> Printer ()+hDotSep = inter (string ".")++-- | Prints each element after a space like.+spacePrefixed :: Foldable f => f (Printer ()) -> Printer ()+spacePrefixed = mapM_ (space >>)++-- | Prints each element after a new line.+newlinePrefixed :: Foldable f => f (Printer ()) -> Printer ()+newlinePrefixed = mapM_ (newline >>)++-- | Runs printers with a prefix. The prefix is printed before the indent.+prefixedLined :: Foldable f => String -> f (Printer ()) -> Printer ()+prefixedLined pref printers =+  case toList printers of+    [] -> return ()+    x:xs -> do+      x+      forM_ xs $ \p -> do+        newline+        prefixed pref p++-- | Prints elements in vertical with the given prefix, suffix, and+-- separator.+vWrappedLineup ::+     Foldable f => Char -> (String, String) -> f (Printer ()) -> Printer ()+vWrappedLineup sep (prefix, suffix) ps =+  string prefix+    >> space |=> do+         prefixedLined [sep, ' '] ps+         newline+         indentedWithSpace (-(fromIntegral (length prefix) + 1)) $ string suffix++-- | Similar to 'vWrappedLineup' but the suffix is in the same line as the+-- last element.+vWrappedLineup' ::+     Foldable f => Char -> (String, String) -> f (Printer ()) -> Printer ()+vWrappedLineup' sep (prefix, suffix) printers =+  case toList printers of+    [x] -> spaced [string prefix, x, string suffix]+    ps ->+      string prefix+        >> space |=> do+             prefixedLined [sep, ' '] ps+             string suffix++-- Inserts the first printer between each element of the list passed as the+-- second argument and runs them.+inter :: Foldable f => Printer () -> f (Printer ()) -> Printer ()+inter separator = sequence_ . intersperse separator . toList
+ src/HIndent/Pretty/Combinators/Op.hs view
@@ -0,0 +1,24 @@+-- | Printer combinators related to operators.+module HIndent.Pretty.Combinators.Op+  ( unlessSpecialOp+  ) where++import Control.Monad+import GHC.Types.Name+import GHC.Types.Name.Reader+import HIndent.Printer++-- | Runs the printer unless HIndent needs to treat the operator specially.+unlessSpecialOp :: RdrName -> Printer () -> Printer ()+unlessSpecialOp name = unless (isSpecialOp name)++-- | Returns if HIndent needs special treatment for the operator.+isSpecialOp :: RdrName -> Bool+isSpecialOp (Unqual name) = isSpecialOpString $ occNameString name+isSpecialOp Qual {} = False+isSpecialOp Orig {} = error "This node is never used in the parsed stage."+isSpecialOp (Exact name) = isSpecialOpString $ occNameString $ nameOccName name++-- | Returns if HIndent needs special treatment for the operator.+isSpecialOpString :: String -> Bool+isSpecialOpString name = name `elem` ["()", "[]", "->", ":"]
+ src/HIndent/Pretty/Combinators/Outputable.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP #-}++-- | Printer combinators for printing values of types implementing+-- 'Outputable'.+module HIndent.Pretty.Combinators.Outputable+  ( output+  , showOutputable+  ) where++import GHC.Driver.Ppr+import GHC.Driver.Session+import GHC.Stack+import GHC.Utils.Outputable+import HIndent.Pretty.Combinators.String+import HIndent.Printer+import Language.Haskell.GhclibParserEx.GHC.Settings.Config++-- | Prints the given value using the type's 'Outputable' implementation.+--+-- The use of this function should be avoided for these reasons:+--+-- * It may raise an error due to 'showPpr' returning a 'String' containing+-- @\n@s. Use 'newline' to print @\n@s.+--+-- * ghc-lib-parser may change a type's implementation of 'Outputable',+-- causing a sudden test failure. It becomes a maintaince burden.+--+-- * All comments of the node's children are ignored.+output :: (HasCallStack, Outputable a) => a -> Printer ()+output = string . showOutputable++-- | Converts the given value to a 'String'.+showOutputable :: Outputable a => a -> String+showOutputable = showPpr dynFlags++-- | 'DynFlags' for calling 'showPpr'+dynFlags :: DynFlags+#if MIN_VERSION_ghc_lib_parser(9,6,1)+dynFlags = defaultDynFlags fakeSettings+#else+dynFlags = defaultDynFlags fakeSettings fakeLlvmConfig+#endif
+ src/HIndent/Pretty/Combinators/String.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-}++-- | Printer combinators related to print strings.+module HIndent.Pretty.Combinators.String+  ( string+  , space+  , newline+  , blankline+  , comma+  , dot+  ) where++import Control.Monad.RWS+import qualified Data.ByteString.Builder as S+import GHC.Stack+import HIndent.Config+import HIndent.Printer+#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+import Control.Monad+#endif+-- | This function prints the given string.+--+-- The string must not include '\n's. Use 'newline' to print them.+string :: HasCallStack => String -> Printer ()+string x+  | '\n' `elem` x =+    error+      $ "You tried to print " ++ show x ++ ". Use `newline` to print '\\n's."+  | otherwise = do+    eol <- gets psEolComment+    hardFail <- gets psFitOnOneLine+    when eol newline+    st <- get+    let indentSpaces =+          if psNewline st+            then replicate (fromIntegral $ psIndentLevel st) ' '+            else ""+        out = indentSpaces <> x+        psColumn' = psColumn st + fromIntegral (length out)+        columnFits = psColumn' <= configMaxColumns (psConfig st)+    when hardFail $ guard columnFits+    modify+      (\s ->+         s+           { psOutput = psOutput st <> S.stringUtf8 out+           , psNewline = False+           , psEolComment = False+           , psColumn = psColumn'+           })++-- | Equivalent to 'string " "'.+space :: Printer ()+space = string " "++-- | Equivalent to 'string ","'.+comma :: Printer ()+comma = string ","++-- | Equivalent to 'string "."'.+dot :: Printer ()+dot = string "."++-- | This function prints a '\n'.+--+-- Always call this function to print it because printing it requires+-- special treatment. Do not call 'string' instead.+newline :: Printer ()+newline = do+  gets psFitOnOneLine >>= guard . not+  modify+    (\s ->+       s+         { psOutput = psOutput s <> S.stringUtf8 "\n"+         , psNewline = True+         , psLine = psLine s + 1+         , psEolComment = False+         , psColumn = 0+         })++-- | Equivalent to 'newline >> newline'.+blankline :: Printer ()+blankline = newline >> newline
+ src/HIndent/Pretty/Combinators/Switch.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE LambdaCase, CPP #-}++-- | Printer combinators for switching printers depending on situations.+module HIndent.Pretty.Combinators.Switch+  ( (<-|>)+  ) where++import Control.Applicative+import Control.Monad.State+import HIndent.Printer+#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+import Control.Monad+#endif+-- | This function runs the first printer if the result of running it fits+-- in a single line. Otherwise, it runs the second printer.+(<-|>) :: Printer a -> Printer a -> Printer a+fit <-|> notFit = do+  before <- get+  put before {psFitOnOneLine = True}+  fmap Just fit <|> return Nothing >>= \case+    Just r -> do+      modify $ \st -> st {psFitOnOneLine = psFitOnOneLine before}+      return r+    Nothing -> do+      put before+      guard $ not $ psFitOnOneLine before+      notFit
+ src/HIndent/Pretty/Combinators/Wrap.hs view
@@ -0,0 +1,85 @@+-- | Printer operators for wrapping texts with a prefix and a suffix.+module HIndent.Pretty.Combinators.Wrap+  ( parens+  , parensIfSymbol+  , bananaBrackets+  , braces+  , doubleQuotes+  , brackets+  , typedBrackets+  , backticks+  , backticksIfNotSymbol+  , wrapWithBars+  , promotedListBrackets+  , promotedTupleParens+  , unboxedParens+  ) where++import GHC.Types.Name+import HIndent.Pretty.Combinators.Indent+import HIndent.Pretty.Combinators.String+import HIndent.Printer++-- | This function wraps the printer with parentheses.+parens :: Printer a -> Printer a+parens = wrap "(" ")"++-- | This function wraps the printer with parentheses if the identifier+-- contains only symbols.+parensIfSymbol :: OccName -> Printer a -> Printer a+parensIfSymbol name+  | isSymOcc name = parens+  | otherwise = id++-- | Wraps with "(|" and "|)"+bananaBrackets :: Printer a -> Printer a+bananaBrackets = wrap "(|" "|)"++-- | This function wraps the printer with braces.+braces :: Printer a -> Printer a+braces = wrap "{" "}"++-- | This function wraps the printer with brackets.+brackets :: Printer a -> Printer a+brackets = wrap "[" "]"++-- | Wraps with @[||@ and @||]@.+typedBrackets :: Printer a -> Printer a+typedBrackets = wrap "[||" "||]"++-- | Wraps with double quotes.+doubleQuotes :: Printer a -> Printer a+doubleQuotes = wrap "\"" "\""++-- | This function wraps the printer with backticks.+backticks :: Printer a -> Printer a+backticks = wrap "`" "`"++-- | This function wraps the printer with backticks if the identifier+-- contains at least one non-symbol character.+backticksIfNotSymbol :: OccName -> Printer a -> Printer a+backticksIfNotSymbol name+  | isSymOcc name = id+  | otherwise = backticks++-- | This function wraps the printer with bars (|).+wrapWithBars :: Printer a -> Printer a+wrapWithBars = wrap "|" "|"++-- | This function wraps the printer with @'[ @ and @]@ for a promoted+-- list.+promotedListBrackets :: Printer a -> Printer a+promotedListBrackets = wrap "'[ " "]"++-- | This function wraps the printer with @'( @ and @)@ for a promoted+-- tuple.+promotedTupleParens :: Printer a -> Printer a+promotedTupleParens = wrap "'( " ")"++-- | Wraps with @(# @ and @ #)@.+unboxedParens :: Printer a -> Printer a+unboxedParens = wrap "(# " " #)"++-- | This function wraps the printer with the prefix and the suffix.+wrap :: String -> String -> Printer a -> Printer a+wrap open close p = string open |=> p <* string close
+ src/HIndent/Pretty/NodeComments.hs view
@@ -0,0 +1,1198 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}++module HIndent.Pretty.NodeComments+  ( CommentExtraction(..)+  , emptyNodeComments+  ) where++import Data.Maybe+import Data.Void+import GHC.Data.BooleanFormula+import GHC.Hs+import GHC.Types.Basic+import GHC.Types.Fixity+import GHC.Types.ForeignCall+import GHC.Types.Name.Reader+import GHC.Types.SourceText+import GHC.Types.SrcLoc+import HIndent.Ast.NodeComments+import HIndent.Pretty.SigBindFamily+import HIndent.Pretty.Types+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+import GHC.Core.DataCon+#else+import GHC.Unit+#endif+#if !MIN_VERSION_ghc_lib_parser(9, 4, 1)+import GHC.Stack+#endif+-- | An interface to extract comments from an AST node.+class CommentExtraction a where+  nodeComments :: a -> NodeComments++instance CommentExtraction l => CommentExtraction (GenLocated l e) where+  nodeComments (L l _) = nodeComments l++instance CommentExtraction (MatchGroup GhcPs a) where+  nodeComments MG {} = emptyNodeComments++instance CommentExtraction DoOrMdo where+  nodeComments = const emptyNodeComments++instance CommentExtraction QualifiedDo where+  nodeComments = const emptyNodeComments++instance CommentExtraction (HsSigType GhcPs) where+  nodeComments HsSig {} = emptyNodeComments++-- | For pattern matching.+instance CommentExtraction+           (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs))) where+  nodeComments HsRecFields {} = emptyNodeComments++-- | For record updates+instance CommentExtraction+           (HsRecFields GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))) where+  nodeComments HsRecFields {} = emptyNodeComments++instance CommentExtraction (GRHSs GhcPs a) where+  nodeComments GRHSs {..} = NodeComments {..}+    where+      commentsBefore = priorComments grhssExt+      commentsOnSameLine = []+      commentsAfter = getFollowingComments grhssExt++instance CommentExtraction (ParStmtBlock GhcPs GhcPs) where+  nodeComments ParStmtBlock {} = emptyNodeComments++instance CommentExtraction RdrName where+  nodeComments Unqual {} = emptyNodeComments+  nodeComments Qual {} = emptyNodeComments+  nodeComments Orig {} = emptyNodeComments+  nodeComments Exact {} = emptyNodeComments++instance CommentExtraction EpaCommentTok where+  nodeComments = const emptyNodeComments++instance CommentExtraction (SpliceDecl GhcPs) where+  nodeComments SpliceDecl {} = emptyNodeComments++instance CommentExtraction SigBindFamily where+  nodeComments (Sig x) = nodeComments x+  nodeComments (Bind x) = nodeComments x+  nodeComments (Family x) = nodeComments x+  nodeComments (TyFamInst x) = nodeComments x+  nodeComments (TyFamDeflt x) = nodeComments x+  nodeComments (DataFamInst x) = nodeComments x++instance CommentExtraction EpaComment where+  nodeComments EpaComment {} = emptyNodeComments++instance CommentExtraction SrcSpan where+  nodeComments RealSrcSpan {} = emptyNodeComments+  nodeComments UnhelpfulSpan {} = emptyNodeComments++-- HsConDeclH98Details+instance CommentExtraction+           (HsConDetails+              Void+              (HsScaled GhcPs (GenLocated SrcSpanAnnA (BangType GhcPs)))+              (GenLocated+                 SrcSpanAnnL+                 [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])) where+  nodeComments PrefixCon {} = emptyNodeComments+  nodeComments RecCon {} = emptyNodeComments+  nodeComments InfixCon {} = emptyNodeComments++instance CommentExtraction (HsScaled GhcPs a) where+  nodeComments HsScaled {} = emptyNodeComments++instance CommentExtraction (BooleanFormula a) where+  nodeComments Var {} = emptyNodeComments+  nodeComments And {} = emptyNodeComments+  nodeComments Or {} = emptyNodeComments+  nodeComments Parens {} = emptyNodeComments++instance CommentExtraction (ImportDecl GhcPs) where+  nodeComments ImportDecl {..} = nodeComments ideclExt++instance CommentExtraction StringLiteral where+  nodeComments StringLiteral {} = emptyNodeComments++instance CommentExtraction (FamilyResultSig GhcPs) where+  nodeComments NoSig {} = emptyNodeComments+  nodeComments KindSig {} = emptyNodeComments+  nodeComments TyVarSig {} = emptyNodeComments++instance CommentExtraction Context where+  nodeComments Context {} = emptyNodeComments++instance CommentExtraction HorizontalContext where+  nodeComments HorizontalContext {} = emptyNodeComments++instance CommentExtraction VerticalContext where+  nodeComments VerticalContext {} = emptyNodeComments++instance CommentExtraction FamEqn' where+  nodeComments FamEqn' {..} = nodeComments famEqn++-- | 'Pretty' for 'LHsSigWcType GhcPs'.+instance CommentExtraction+           (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))) where+  nodeComments HsWC {} = emptyNodeComments++-- | 'Pretty' for 'LHsWcType'+instance CommentExtraction+           (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) where+  nodeComments HsWC {} = emptyNodeComments++instance CommentExtraction CExportSpec where+  nodeComments CExportStatic {} = emptyNodeComments++instance CommentExtraction TopLevelTyFamInstDecl where+  nodeComments (TopLevelTyFamInstDecl x) = nodeComments x++instance CommentExtraction (DataFamInstDecl GhcPs) where+  nodeComments DataFamInstDecl {} = emptyNodeComments++instance CommentExtraction DataFamInstDecl' where+  nodeComments DataFamInstDecl' {..} = nodeComments dataFamInstDecl++instance CommentExtraction (FixitySig GhcPs) where+  nodeComments FixitySig {} = emptyNodeComments++instance CommentExtraction Fixity where+  nodeComments Fixity {} = emptyNodeComments++instance CommentExtraction InlinePragma where+  nodeComments InlinePragma {} = emptyNodeComments++instance CommentExtraction (HsOverLit GhcPs) where+  nodeComments OverLit {} = emptyNodeComments++instance CommentExtraction OverLitVal where+  nodeComments HsIntegral {} = emptyNodeComments+  nodeComments HsFractional {} = emptyNodeComments+  nodeComments HsIsString {} = emptyNodeComments++instance CommentExtraction IntegralLit where+  nodeComments IL {} = emptyNodeComments++instance CommentExtraction FractionalLit where+  nodeComments FL {} = emptyNodeComments++instance CommentExtraction (HsLit GhcPs) where+  nodeComments HsChar {} = emptyNodeComments+  nodeComments HsCharPrim {} = emptyNodeComments+  nodeComments HsString {} = emptyNodeComments+  nodeComments HsStringPrim {} = emptyNodeComments+  nodeComments HsInt {} = emptyNodeComments+  nodeComments HsIntPrim {} = emptyNodeComments+  nodeComments HsWordPrim {} = emptyNodeComments+  nodeComments HsInt64Prim {} = emptyNodeComments+  nodeComments HsWord64Prim {} = emptyNodeComments+  nodeComments HsInteger {} = emptyNodeComments+  nodeComments HsRat {} = emptyNodeComments+  nodeComments HsFloatPrim {} = emptyNodeComments+  nodeComments HsDoublePrim {} = emptyNodeComments+#if MIN_VERSION_ghc_lib_parser(9, 8, 0)+  nodeComments HsInt8Prim {} = emptyNodeComments+  nodeComments HsInt16Prim {} = emptyNodeComments+  nodeComments HsInt32Prim {} = emptyNodeComments+  nodeComments HsWord8Prim {} = emptyNodeComments+  nodeComments HsWord16Prim {} = emptyNodeComments+  nodeComments HsWord32Prim {} = emptyNodeComments+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+  nodeComments HsMultilineString {} = emptyNodeComments+#endif+instance CommentExtraction (HsOuterSigTyVarBndrs GhcPs) where+  nodeComments HsOuterImplicit {} = emptyNodeComments+  nodeComments HsOuterExplicit {..} = nodeComments hso_xexplicit+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+instance CommentExtraction AddEpAnn where+  nodeComments (AddEpAnn _ x) = nodeComments x+#endif+instance CommentExtraction EpaLocation where+  nodeComments = nodeCommentsEpaLocation++nodeCommentsEpaLocation :: EpaLocation -> NodeComments+nodeCommentsEpaLocation EpaSpan {} = emptyNodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsEpaLocation (EpaDelta _ _ x) = mconcat $ fmap nodeComments x+#else+nodeCommentsEpaLocation (EpaDelta _ x) = mconcat $ fmap nodeComments x+#endif+instance CommentExtraction AnnPragma where+  nodeComments = nodeCommentsAnnPragma++nodeCommentsAnnPragma :: AnnPragma -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsAnnPragma AnnPragma {..} =+  mconcat+    [ nodeComments apr_open+    , nodeComments apr_close+    , nodeComments $ fst apr_squares+    , nodeComments $ snd apr_squares+    , nodeComments apr_loc1+    , nodeComments apr_loc2+    , nodeComments apr_type+    , nodeComments apr_module+    ]+#else+nodeCommentsAnnPragma AnnPragma {..} =+  mconcat $ fmap nodeComments $ apr_open : apr_close : apr_rest+#endif+instance CommentExtraction HsRuleAnn where+  nodeComments = nodeCommentsHsRuleAnn++nodeCommentsHsRuleAnn :: HsRuleAnn -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsRuleAnn HsRuleAnn {..} =+  mconcat+    [ maybe+        emptyNodeComments+        (\(a, b) -> mconcat [nodeComments a, nodeComments b])+        ra_tyanns+    , maybe+        emptyNodeComments+        (\(a, b) -> mconcat [nodeComments a, nodeComments b])+        ra_tmanns+    , nodeComments ra_equal+    , nodeComments ra_rest+    ]+#else+nodeCommentsHsRuleAnn HsRuleAnn {..} =+  mconcat $ f ra_tyanns : f ra_tmanns : fmap nodeComments ra_rest+  where+    f (Just (x, y)) = mconcat $ fmap nodeComments [x, y]+    f Nothing = emptyNodeComments+#endif+instance CommentExtraction AnnFieldLabel where+  nodeComments AnnFieldLabel {afDot = Just x} = nodeComments x+  nodeComments AnnFieldLabel {afDot = Nothing} = emptyNodeComments++instance CommentExtraction EpAnnSumPat where+  nodeComments = nodeCommentsEpAnnSumPat++nodeCommentsEpAnnSumPat :: EpAnnSumPat -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsEpAnnSumPat EpAnnSumPat {..} =+  mconcat+    [ nodeComments $ fst sumPatParens+    , nodeComments $ snd sumPatParens+    , mconcat $ fmap nodeComments sumPatVbarsBefore+    , mconcat $ fmap nodeComments sumPatVbarsAfter+    ]+#else+nodeCommentsEpAnnSumPat EpAnnSumPat {..} =+  mconcat+    [ mconcat $ fmap nodeComments sumPatParens+    , mconcat $ fmap nodeComments sumPatVbarsBefore+    , mconcat $ fmap nodeComments sumPatVbarsAfter+    ]+#endif+instance CommentExtraction AnnProjection where+  nodeComments = nodeCommentsAnnProjection++nodeCommentsAnnProjection :: AnnProjection -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsAnnProjection AnnProjection {..} =+  mconcat [nodeComments apOpen, nodeComments apClose]+#else+nodeCommentsAnnProjection AnnProjection {..} =+  mconcat $ fmap nodeComments [apOpen, apClose]+#endif+instance CommentExtraction AnnsIf where+  nodeComments = nodeCommentsAnnsIf++nodeCommentsAnnsIf :: AnnsIf -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsAnnsIf AnnsIf {..} =+  mconcat+    [ nodeComments aiIf+    , nodeComments aiThen+    , nodeComments aiElse+    , maybe emptyNodeComments nodeComments aiThenSemi+    , maybe emptyNodeComments nodeComments aiElseSemi+    ]+#else+nodeCommentsAnnsIf AnnsIf {..} =+  mconcat+    $ fmap nodeComments+    $ aiIf+        : aiThen+        : aiElse+        : (maybeToList aiThenSemi <> maybeToList aiElseSemi)+#endif+instance CommentExtraction EpAnnHsCase where+  nodeComments = nodeCommentsEpAnnHsCase++nodeCommentsEpAnnHsCase :: EpAnnHsCase -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsEpAnnHsCase EpAnnHsCase {..} =+  mconcat [nodeComments hsCaseAnnCase, nodeComments hsCaseAnnOf]+#else+nodeCommentsEpAnnHsCase EpAnnHsCase {..} =+  mconcat+    $ nodeComments hsCaseAnnCase+        : nodeComments hsCaseAnnOf+        : fmap nodeComments hsCaseAnnsRest+#endif+instance CommentExtraction AnnExplicitSum where+  nodeComments = nodeCommentsAnnExplicitSum++nodeCommentsAnnExplicitSum :: AnnExplicitSum -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsAnnExplicitSum AnnExplicitSum {..} =+  mconcat+    [ nodeComments aesOpen+    , mconcat $ fmap nodeComments aesBarsBefore+    , mconcat $ fmap nodeComments aesBarsAfter+    , nodeComments aesClose+    ]+#else+nodeCommentsAnnExplicitSum AnnExplicitSum {..} =+  mconcat+    $ fmap nodeComments+    $ aesOpen : aesBarsBefore <> aesBarsAfter <> [aesClose]+#endif+instance CommentExtraction EpAnnUnboundVar where+  nodeComments = nodeCommentsEpAnnUnboundVar++nodeCommentsEpAnnUnboundVar :: EpAnnUnboundVar -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsEpAnnUnboundVar EpAnnUnboundVar {hsUnboundBackquotes = (a, b), ..} =+  mconcat [nodeComments a, nodeComments b, nodeComments hsUnboundHole]+#else+nodeCommentsEpAnnUnboundVar EpAnnUnboundVar {..} =+  mconcat+    $ fmap+        nodeComments+        [fst hsUnboundBackquotes, snd hsUnboundBackquotes, hsUnboundHole]+#endif+instance CommentExtraction AnnSig where+  nodeComments = nodeCommentsAnnSig++nodeCommentsAnnSig :: AnnSig -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsAnnSig AnnSig {..} =+  mconcat+    [ nodeComments asDcolon+    , maybe emptyNodeComments nodeComments asPattern+    , maybe emptyNodeComments nodeComments asDefault+    ]+#else+nodeCommentsAnnSig AnnSig {..} = mconcat $ fmap nodeComments $ asDcolon : asRest+#endif+instance CommentExtraction (HsBind GhcPs) where+  nodeComments = nodeCommentsHsBind++nodeCommentsHsBind :: HsBind GhcPs -> NodeComments+nodeCommentsHsBind FunBind {..} = nodeComments fun_id+#if MIN_VERSION_ghc_lib_parser(9, 10, 0)+nodeCommentsHsBind PatBind {} = emptyNodeComments+#else+nodeCommentsHsBind PatBind {..} = nodeComments pat_ext+#endif+nodeCommentsHsBind VarBind {} = emptyNodeComments+#if !MIN_VERSION_ghc_lib_parser(9, 4, 1)+nodeCommentsHsBind AbsBinds {} = emptyNodeComments+#endif+nodeCommentsHsBind PatSynBind {} = emptyNodeComments++instance CommentExtraction (Sig GhcPs) where+  nodeComments = nodeCommentsSig++nodeCommentsSig :: Sig GhcPs -> NodeComments+nodeCommentsSig (TypeSig x _ _) = nodeComments x+nodeCommentsSig (PatSynSig x _ _) = nodeComments x+nodeCommentsSig (ClassOpSig x _ _ _) = nodeComments x+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsSig (FixSig ((a, b), _) _) =+  mconcat [nodeComments a, maybe emptyNodeComments nodeComments b]+nodeCommentsSig (InlineSig (a, b, c) _ _) =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+nodeCommentsSig (SpecSig x _ _ _) = nodeComments x+nodeCommentsSig (SpecInstSig ((a, b, c), _) _) =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+nodeCommentsSig (MinimalSig ((a, b), _) _) =+  mconcat [nodeComments a, nodeComments b]+nodeCommentsSig (SCCFunSig ((a, b), _) _ _) =+  mconcat [nodeComments a, nodeComments b]+nodeCommentsSig (CompleteMatchSig ((a, b, c), _) _ _) =+  mconcat+    [nodeComments a, maybe emptyNodeComments nodeComments b, nodeComments c]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsSig (FixSig x _) = mconcat $ fmap nodeComments x+nodeCommentsSig (InlineSig x _ _) = mconcat $ fmap nodeComments x+nodeCommentsSig (SpecSig x _ _ _) = mconcat $ fmap nodeComments x+nodeCommentsSig (SpecInstSig (x, _) _) = mconcat $ fmap nodeComments x+nodeCommentsSig (MinimalSig (x, _) _) = mconcat $ fmap nodeComments x+nodeCommentsSig (SCCFunSig (x, _) _ _) = mconcat $ fmap nodeComments x+nodeCommentsSig (CompleteMatchSig (x, _) _ _) = mconcat $ fmap nodeComments x+#elif MIN_VERSION_ghc_lib_parser(9, 6, 1)+nodeCommentsSig (FixSig x _) = nodeComments x+nodeCommentsSig (InlineSig x _ _) = nodeComments x+nodeCommentsSig (SpecSig x _ _ _) = nodeComments x+nodeCommentsSig (SpecInstSig (x, _) _) = nodeComments x+nodeCommentsSig (MinimalSig (x, _) _) = nodeComments x+nodeCommentsSig (SCCFunSig (x, _) _ _) = nodeComments x+nodeCommentsSig (CompleteMatchSig (x, _) _ _) = nodeComments x+#else+nodeCommentsSig (FixSig x _) = nodeComments x+nodeCommentsSig (InlineSig x _ _) = nodeComments x+nodeCommentsSig (SpecSig x _ _ _) = nodeComments x+nodeCommentsSig IdSig {} = emptyNodeComments+nodeCommentsSig (SpecInstSig x _ _) = nodeComments x+nodeCommentsSig (MinimalSig x _ _) = nodeComments x+nodeCommentsSig (SCCFunSig x _ _ _) = nodeComments x+nodeCommentsSig (CompleteMatchSig x _ _ _) = nodeComments x+#endif+instance CommentExtraction (HsExpr GhcPs) where+  nodeComments = nodeCommentsHsExpr++nodeCommentsHsExpr :: HsExpr GhcPs -> NodeComments+nodeCommentsHsExpr HsVar {} = emptyNodeComments+nodeCommentsHsExpr HsLam {} = emptyNodeComments+nodeCommentsHsExpr HsAppType {} = emptyNodeComments+nodeCommentsHsExpr (ExplicitSum x _ _ _) = nodeComments x+nodeCommentsHsExpr (HsCase x _ _) = nodeComments x+nodeCommentsHsExpr (HsIf x _ _ _) = nodeComments x+nodeCommentsHsExpr (HsDo x _ _) = nodeComments x+nodeCommentsHsExpr (ExplicitList x _) = nodeComments x+nodeCommentsHsExpr HsProjection {..} = nodeComments proj_ext+nodeCommentsHsExpr HsPragE {} = emptyNodeComments+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsExpr (HsTypedBracket (a, b) _) =+  mconcat [nodeComments a, nodeComments b]+nodeCommentsHsExpr HsUntypedBracket {} = emptyNodeComments+#else+nodeCommentsHsExpr (HsTypedBracket x _) = mconcat $ fmap nodeComments x+nodeCommentsHsExpr (HsUntypedBracket x _) = mconcat $ fmap nodeComments x+#endif+nodeCommentsHsExpr HsLet {} = emptyNodeComments+nodeCommentsHsExpr HsPar {} = emptyNodeComments+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsExpr HsRecSel {} = emptyNodeComments+#endif+#elif MIN_VERSION_ghc_lib_parser(9, 4, 1)+nodeCommentsHsExpr HsRecSel {} = emptyNodeComments+nodeCommentsHsExpr (HsTypedBracket x _) = nodeComments x+nodeCommentsHsExpr (HsUntypedBracket x _) = nodeComments x+nodeCommentsHsExpr (HsLet x _ _ _ _) = nodeComments x+nodeCommentsHsExpr (HsPar x _ _ _) = nodeComments x+nodeCommentsHsExpr (HsLamCase x _ _) = nodeComments x+#else+nodeCommentsHsExpr HsTick {} = emptyNodeComments+nodeCommentsHsExpr HsBinTick {} = emptyNodeComments+nodeCommentsHsExpr (HsBracket x _) = nodeComments x+nodeCommentsHsExpr HsRnBracketOut {} = notUsedInParsedStage+nodeCommentsHsExpr HsTcBracketOut {} = notUsedInParsedStage+nodeCommentsHsExpr (HsLet x _ _) = nodeComments x+nodeCommentsHsExpr (HsPar x _) = nodeComments x+nodeCommentsHsExpr (HsLamCase x _) = nodeComments x+nodeCommentsHsExpr HsConLikeOut {} = emptyNodeComments+nodeCommentsHsExpr HsRecFld {} = emptyNodeComments+#endif+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsExpr (HsTypedSplice x _) = nodeComments x+#else+nodeCommentsHsExpr (HsTypedSplice x _) = mconcat $ fmap nodeComments x+#endif+nodeCommentsHsExpr HsUntypedSplice {} = emptyNodeComments+nodeCommentsHsExpr HsOverLabel {} = emptyNodeComments+#elif MIN_VERSION_ghc_lib_parser(9, 6, 1)+nodeCommentsHsExpr (HsTypedSplice (x, y) _) = nodeComments x <> nodeComments y+nodeCommentsHsExpr (HsUntypedSplice x _) = nodeComments x+nodeCommentsHsExpr (HsOverLabel x _ _) = nodeComments x+#else+nodeCommentsHsExpr (HsSpliceE x _) = nodeComments x+nodeCommentsHsExpr (HsOverLabel x _) = nodeComments x+#endif+#if MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsHsExpr HsGetField {} = emptyNodeComments+nodeCommentsHsExpr SectionR {} = emptyNodeComments+nodeCommentsHsExpr SectionL {} = emptyNodeComments+nodeCommentsHsExpr HsApp {} = emptyNodeComments+nodeCommentsHsExpr HsLit {} = emptyNodeComments+nodeCommentsHsExpr HsOverLit {} = emptyNodeComments+nodeCommentsHsExpr HsIPVar {} = emptyNodeComments+nodeCommentsHsExpr (HsUnboundVar x _) = fromMaybe mempty $ fmap nodeComments x+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsExpr (HsStatic x _) = nodeComments x+nodeCommentsHsExpr (HsProc (a, b) _ _) =+  mconcat [nodeComments a, nodeComments b]+nodeCommentsHsExpr (ArithSeq x _ _) = nodeComments x+nodeCommentsHsExpr (ExprWithTySig x _ _) = nodeComments x+nodeCommentsHsExpr RecordUpd {rupd_ext = (s, d)} =+  mconcat+    [ maybe emptyNodeComments nodeComments s+    , maybe emptyNodeComments nodeComments d+    ]+nodeCommentsHsExpr RecordCon {rcon_ext = (s, d)} =+  mconcat+    [ maybe emptyNodeComments nodeComments s+    , maybe emptyNodeComments nodeComments d+    ]+nodeCommentsHsExpr (HsMultiIf (a, b, c) _) =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+nodeCommentsHsExpr (ExplicitTuple (a, b) _ _) =+  mconcat [nodeComments a, nodeComments b]+nodeCommentsHsExpr (NegApp x _ _) = nodeComments x+nodeCommentsHsExpr OpApp {} = emptyNodeComments+#else+nodeCommentsHsExpr (HsStatic x _) = mconcat $ fmap nodeComments x+nodeCommentsHsExpr (HsProc x _ _) = mconcat $ fmap nodeComments x+nodeCommentsHsExpr (ArithSeq x _ _) = mconcat $ fmap nodeComments x+nodeCommentsHsExpr (ExprWithTySig x _ _) = mconcat $ fmap nodeComments x+nodeCommentsHsExpr RecordUpd {..} = mconcat $ fmap nodeComments rupd_ext+nodeCommentsHsExpr RecordCon {..} = mconcat $ fmap nodeComments rcon_ext+nodeCommentsHsExpr (HsMultiIf x _) = mconcat $ fmap nodeComments x+nodeCommentsHsExpr (ExplicitTuple x _ _) = mconcat $ fmap nodeComments x+nodeCommentsHsExpr (NegApp x _ _) = mconcat $ fmap nodeComments x+nodeCommentsHsExpr (OpApp x _ _ _) = mconcat $ fmap nodeComments x+#endif+#else+nodeCommentsHsExpr (HsStatic x _) = nodeComments x+nodeCommentsHsExpr (HsProc x _ _) = nodeComments x+nodeCommentsHsExpr (ArithSeq x _ _) = nodeComments x+nodeCommentsHsExpr (ExprWithTySig x _ _) = nodeComments x+nodeCommentsHsExpr HsGetField {..} = nodeComments gf_ext+nodeCommentsHsExpr RecordUpd {..} = nodeComments rupd_ext+nodeCommentsHsExpr RecordCon {..} = nodeComments rcon_ext+nodeCommentsHsExpr (HsMultiIf x _) = nodeComments x+nodeCommentsHsExpr (ExplicitTuple x _ _) = nodeComments x+nodeCommentsHsExpr (SectionR x _ _) = nodeComments x+nodeCommentsHsExpr (SectionL x _ _) = nodeComments x+nodeCommentsHsExpr (NegApp x _ _) = nodeComments x+nodeCommentsHsExpr (OpApp x _ _ _) = nodeComments x+nodeCommentsHsExpr (HsApp x _ _) = nodeComments x+nodeCommentsHsExpr (HsLit x _) = nodeComments x+nodeCommentsHsExpr (HsOverLit x _) = nodeComments x+nodeCommentsHsExpr (HsIPVar x _) = nodeComments x+nodeCommentsHsExpr (HsUnboundVar x _) = nodeComments x+#endif+#if MIN_VERSION_ghc_lib_parser(9, 10, 2)+nodeCommentsHsExpr HsEmbTy {} = emptyNodeComments+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 2)+nodeCommentsHsExpr HsForAll {} = emptyNodeComments+nodeCommentsHsExpr HsQual {} = emptyNodeComments+nodeCommentsHsExpr HsFunArr {} = emptyNodeComments+#endif+instance CommentExtraction (Match GhcPs a) where+  nodeComments = nodeCommentsMatch++nodeCommentsMatch :: Match GhcPs a -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsMatch Match {} = emptyNodeComments+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsMatch Match {..} = mconcat $ fmap nodeComments m_ext+#else+nodeCommentsMatch Match {..} = nodeComments m_ext+#endif+instance CommentExtraction (StmtLR GhcPs GhcPs a) where+  nodeComments = nodeCommentsStmtLR++nodeCommentsStmtLR :: StmtLR GhcPs GhcPs a -> NodeComments+nodeCommentsStmtLR LastStmt {} = emptyNodeComments+nodeCommentsStmtLR BodyStmt {} = emptyNodeComments+nodeCommentsStmtLR ParStmt {} = emptyNodeComments+nodeCommentsStmtLR RecStmt {..} = nodeComments recS_ext+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) || !MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsStmtLR (BindStmt x _ _) = nodeComments x+nodeCommentsStmtLR (LetStmt x _) = nodeComments x+nodeCommentsStmtLR TransStmt {..} = nodeComments trS_ext+#else+nodeCommentsStmtLR (BindStmt x _ _) = mconcat $ fmap nodeComments x+nodeCommentsStmtLR (LetStmt x _) = mconcat $ fmap nodeComments x+nodeCommentsStmtLR TransStmt {..} = mconcat $ fmap nodeComments trS_ext+#endif+#if !MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsStmtLR ApplicativeStmt {} = emptyNodeComments+#endif+instance CommentExtraction (ConDeclField GhcPs) where+  nodeComments = nodeCommentsConDeclField++nodeCommentsConDeclField :: ConDeclField GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) || !MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsConDeclField ConDeclField {..} = nodeComments cd_fld_ext+#else+nodeCommentsConDeclField ConDeclField {..} =+  mconcat $ fmap nodeComments cd_fld_ext+#endif+instance CommentExtraction (HsDerivingClause GhcPs) where+  nodeComments = nodeCommentsHsDerivingClause++nodeCommentsHsDerivingClause :: HsDerivingClause GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) || !MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsHsDerivingClause HsDerivingClause {..} =+  nodeComments deriv_clause_ext+#else+nodeCommentsHsDerivingClause HsDerivingClause {..} =+  mconcat $ fmap nodeComments deriv_clause_ext+#endif+-- | This instance is for type family declarations inside a class declaration.+instance CommentExtraction (FamilyDecl GhcPs) where+  nodeComments = nodeCommentsFamilyDecl++nodeCommentsFamilyDecl :: FamilyDecl GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsFamilyDecl FamilyDecl {..} = nodeComments fdExt+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsFamilyDecl FamilyDecl {..} = mconcat $ fmap nodeComments fdExt+#else+nodeCommentsFamilyDecl FamilyDecl {..} = nodeComments fdExt+#endif+instance CommentExtraction (HsTyVarBndr a GhcPs) where+  nodeComments = nodeCommentsHsTyVarBndr++nodeCommentsHsTyVarBndr :: HsTyVarBndr a GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsTyVarBndr HsTvb {..} = nodeComments tvb_ext+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsHsTyVarBndr (UserTyVar x _ _) = mconcat $ fmap nodeComments x+nodeCommentsHsTyVarBndr (KindedTyVar x _ _ _) = mconcat $ fmap nodeComments x+#else+nodeCommentsHsTyVarBndr (UserTyVar x _ _) = nodeComments x+nodeCommentsHsTyVarBndr (KindedTyVar x _ _ _) = nodeComments x+#endif+instance CommentExtraction (FamEqn GhcPs a) where+  nodeComments = nodeCommentsFamEqn++nodeCommentsFamEqn :: FamEqn GhcPs a -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsFamEqn FamEqn {feqn_ext = (as, bs, c)} =+  mconcat+    [ mconcat $ fmap nodeComments as+    , mconcat $ fmap nodeComments bs+    , nodeComments c+    ]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsFamEqn FamEqn {..} = mconcat $ fmap nodeComments feqn_ext+#else+nodeCommentsFamEqn FamEqn {..} = nodeComments feqn_ext+#endif+instance CommentExtraction (WarnDecls GhcPs) where+  nodeComments = nodeCommentsWarnDecls++nodeCommentsWarnDecls :: WarnDecls GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsWarnDecls Warnings {wd_ext = ((a, b), _)} =+  mconcat [nodeComments a, nodeComments b]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsWarnDecls Warnings {..} = mconcat $ fmap nodeComments $ fst wd_ext+#elif MIN_VERSION_ghc_lib_parser(9, 6, 1)+nodeCommentsWarnDecls Warnings {..} = nodeComments $ fst wd_ext+#else+nodeCommentsWarnDecls Warnings {..} = nodeComments wd_ext+#endif+instance CommentExtraction (WarnDecl GhcPs) where+  nodeComments = nodeCommentsWarnDecl++nodeCommentsWarnDecl :: WarnDecl GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsWarnDecl (Warning (a, (b, c)) _ _) =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsWarnDecl (Warning (_, x) _ _) = mconcat $ fmap nodeComments x+#else+nodeCommentsWarnDecl (Warning x _ _) = nodeComments x+#endif+instance CommentExtraction (RuleDecls GhcPs) where+  nodeComments = nodeCommentsRuleDecls++nodeCommentsRuleDecls :: RuleDecls GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsRuleDecls HsRules {rds_ext = ((a, b), _)} =+  mconcat [nodeComments a, nodeComments b]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsRuleDecls HsRules {..} = mconcat $ fmap nodeComments $ fst rds_ext+#elif MIN_VERSION_ghc_lib_parser(9, 6, 1)+nodeCommentsRuleDecls HsRules {..} = nodeComments $ fst rds_ext+#else+nodeCommentsRuleDecls HsRules {..} = nodeComments rds_ext+#endif+instance CommentExtraction (RuleDecl GhcPs) where+  nodeComments = nodeCommentsRuleDecl++nodeCommentsRuleDecl :: RuleDecl GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+nodeCommentsRuleDecl HsRule {..} = nodeComments $ fst rd_ext+#else+nodeCommentsRuleDecl HsRule {..} = nodeComments rd_ext+#endif+instance CommentExtraction (DerivDecl GhcPs) where+  nodeComments = nodeCommentsDerivDecl++nodeCommentsDerivDecl :: DerivDecl GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsDerivDecl DerivDecl {deriv_ext = (a, (b, c))} =+  mconcat+    [maybe emptyNodeComments nodeComments a, nodeComments b, nodeComments c]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsDerivDecl DerivDecl {deriv_ext = (x, xs)} =+  mconcat $ maybeToList (fmap nodeComments x) <> fmap nodeComments xs+#else+nodeCommentsDerivDecl DerivDecl {..} = nodeComments deriv_ext+#endif+instance CommentExtraction (StandaloneKindSig GhcPs) where+  nodeComments = nodeCommentsStandaloneKindSig++nodeCommentsStandaloneKindSig :: StandaloneKindSig GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsStandaloneKindSig (StandaloneKindSig x _ _) =+  mconcat [nodeComments $ fst x, nodeComments $ snd x]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsStandaloneKindSig (StandaloneKindSig x _ _) =+  mconcat $ fmap nodeComments x+#else+nodeCommentsStandaloneKindSig (StandaloneKindSig x _ _) = nodeComments x+#endif+instance CommentExtraction (DefaultDecl GhcPs) where+  nodeComments = nodeCommentsDefaultDecl++nodeCommentsDefaultDecl :: DefaultDecl GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsDefaultDecl (DefaultDecl (a, b, c) _ _) =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsDefaultDecl (DefaultDecl x _) = mconcat $ fmap nodeComments x+#else+nodeCommentsDefaultDecl (DefaultDecl x _) = nodeComments x+#endif+instance CommentExtraction (ForeignDecl GhcPs) where+  nodeComments = nodeCommentsForeignDecl++nodeCommentsForeignDecl :: ForeignDecl GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsForeignDecl ForeignImport {fd_i_ext = (a, b, c)} =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+nodeCommentsForeignDecl ForeignExport {fd_e_ext = (a, b, c)} =+  mconcat [nodeComments a, nodeComments b, nodeComments c]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsForeignDecl ForeignImport {..} =+  mconcat $ fmap nodeComments fd_i_ext+nodeCommentsForeignDecl ForeignExport {..} =+  mconcat $ fmap nodeComments fd_e_ext+#else+nodeCommentsForeignDecl ForeignImport {..} = nodeComments fd_i_ext+nodeCommentsForeignDecl ForeignExport {..} = nodeComments fd_e_ext+#endif+instance CommentExtraction (AnnDecl GhcPs) where+  nodeComments = nodeCommentsAnnDecl++nodeCommentsAnnDecl :: AnnDecl GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+nodeCommentsAnnDecl (HsAnnotation (x, _) _ _) = nodeComments x+#else+nodeCommentsAnnDecl (HsAnnotation x _ _ _) = nodeComments x+#endif+instance CommentExtraction (RoleAnnotDecl GhcPs) where+  nodeComments = nodeCommentsRoleAnnotDecl++nodeCommentsRoleAnnotDecl :: RoleAnnotDecl GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsRoleAnnotDecl (RoleAnnotDecl x _ _) =+  mconcat [nodeComments $ fst x, nodeComments $ snd x]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsRoleAnnotDecl (RoleAnnotDecl x _ _) = mconcat $ fmap nodeComments x+#else+nodeCommentsRoleAnnotDecl (RoleAnnotDecl x _ _) = nodeComments x+#endif+instance CommentExtraction (TyFamInstDecl GhcPs) where+  nodeComments = nodeCommentsTyFamInstDecl++nodeCommentsTyFamInstDecl :: TyFamInstDecl GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsTyFamInstDecl TyFamInstDecl {..} =+  mconcat [nodeComments $ fst tfid_xtn, nodeComments $ snd tfid_xtn]+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsTyFamInstDecl TyFamInstDecl {..} =+  mconcat $ fmap nodeComments tfid_xtn+#else+nodeCommentsTyFamInstDecl TyFamInstDecl {..} = nodeComments tfid_xtn+#endif+instance CommentExtraction (PatSynBind GhcPs GhcPs) where+  nodeComments = nodeCommentsPatSynBind++nodeCommentsPatSynBind :: PatSynBind GhcPs GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) || !MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsPatSynBind PSB {..} = nodeComments psb_ext+#else+nodeCommentsPatSynBind PSB {..} = mconcat $ fmap nodeComments psb_ext+#endif+instance CommentExtraction InlineSpec where+  nodeComments = nodeCommentsInlineSpec++nodeCommentsInlineSpec :: InlineSpec -> NodeComments+nodeCommentsInlineSpec Inline {} = emptyNodeComments+nodeCommentsInlineSpec Inlinable {} = emptyNodeComments+nodeCommentsInlineSpec NoInline {} = emptyNodeComments+nodeCommentsInlineSpec NoUserInlinePrag {} = emptyNodeComments+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+nodeCommentsInlineSpec Opaque {} = emptyNodeComments+#endif+instance CommentExtraction (DerivStrategy GhcPs) where+  nodeComments = nodeCommentsDerivStrategy++nodeCommentsDerivStrategy :: DerivStrategy GhcPs -> NodeComments+nodeCommentsDerivStrategy (ViaStrategy x) = nodeComments x+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsDerivStrategy (StockStrategy x) = nodeComments x+nodeCommentsDerivStrategy (AnyclassStrategy x) = nodeComments x+nodeCommentsDerivStrategy (NewtypeStrategy x) = nodeComments x+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsDerivStrategy (StockStrategy x) = mconcat $ fmap nodeComments x+nodeCommentsDerivStrategy (AnyclassStrategy x) = mconcat $ fmap nodeComments x+nodeCommentsDerivStrategy (NewtypeStrategy x) = mconcat $ fmap nodeComments x+#else+nodeCommentsDerivStrategy (StockStrategy x) = nodeComments x+nodeCommentsDerivStrategy (AnyclassStrategy x) = nodeComments x+nodeCommentsDerivStrategy (NewtypeStrategy x) = nodeComments x+#endif+instance CommentExtraction XViaStrategyPs where+  nodeComments = nodeCommentsXViaStrategyPs++nodeCommentsXViaStrategyPs :: XViaStrategyPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1) || !MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsXViaStrategyPs (XViaStrategyPs x _) = nodeComments x+#else+nodeCommentsXViaStrategyPs (XViaStrategyPs x _) = mconcat $ fmap nodeComments x+#endif+instance CommentExtraction (RuleBndr GhcPs) where+  nodeComments = nodeCommentsRuleBndr++nodeCommentsRuleBndr :: RuleBndr GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsRuleBndr (RuleBndr x _) = nodeComments x+nodeCommentsRuleBndr (RuleBndrSig x _ _) = nodeComments x+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsRuleBndr (RuleBndr x _) = mconcat $ fmap nodeComments x+nodeCommentsRuleBndr (RuleBndrSig x _ _) = mconcat $ fmap nodeComments x+#else+nodeCommentsRuleBndr (RuleBndr x _) = nodeComments x+nodeCommentsRuleBndr (RuleBndrSig x _ _) = nodeComments x+#endif+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+instance CommentExtraction FieldLabelString where+  nodeComments = const emptyNodeComments++instance CommentExtraction (HsUntypedSplice GhcPs) where+  nodeComments = nodeCommentsHsUntypedSplice++nodeCommentsHsUntypedSplice :: HsUntypedSplice GhcPs -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsUntypedSplice (HsUntypedSpliceExpr x _) = nodeComments x+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsHsUntypedSplice (HsUntypedSpliceExpr x _) =+  mconcat $ fmap nodeComments x+#else+nodeCommentsHsUntypedSplice (HsUntypedSpliceExpr x _) = nodeComments x+#endif+nodeCommentsHsUntypedSplice HsQuasiQuote {} = emptyNodeComments+#endif+#if MIN_VERSION_ghc_lib_parser(9, 4, 1)+instance CommentExtraction (HsQuote GhcPs) where+  nodeComments ExpBr {} = emptyNodeComments+  nodeComments PatBr {} = emptyNodeComments+  nodeComments DecBrL {} = emptyNodeComments+  nodeComments DecBrG {} = emptyNodeComments+  nodeComments TypBr {} = emptyNodeComments+  nodeComments VarBr {} = emptyNodeComments++instance CommentExtraction (WithHsDocIdentifiers StringLiteral GhcPs) where+  nodeComments WithHsDocIdentifiers {} = emptyNodeComments++instance CommentExtraction (HsFieldBind a b) where+  nodeComments = nodeCommentsHsFieldBind++nodeCommentsHsFieldBind :: HsFieldBind a b -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsHsFieldBind HsFieldBind {..} = maybe mempty nodeComments hfbAnn+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsHsFieldBind HsFieldBind {..} = mconcat $ fmap nodeComments hfbAnn+#else+nodeCommentsHsFieldBind HsFieldBind {..} = nodeComments hfbAnn+#endif+#else+instance CommentExtraction (HsFieldLabel GhcPs) where+  nodeComments HsFieldLabel {..} = nodeComments hflExt+#endif+#if !MIN_VERSION_ghc_lib_parser(9, 4, 1)+instance CommentExtraction (HsBracket GhcPs) where+  nodeComments ExpBr {} = emptyNodeComments+  nodeComments PatBr {} = emptyNodeComments+  nodeComments DecBrL {} = emptyNodeComments+  nodeComments DecBrG {} = emptyNodeComments+  nodeComments TypBr {} = emptyNodeComments+  nodeComments VarBr {} = emptyNodeComments+  nodeComments TExpBr {} = emptyNodeComments++instance CommentExtraction (HsRecField' (FieldOcc GhcPs) a) where+  nodeComments HsRecField {..} = nodeComments hsRecFieldAnn+#endif+#if MIN_VERSION_ghc_lib_parser(9, 6, 1)+instance CommentExtraction XImportDeclPass where+  nodeComments XImportDeclPass {..} = nodeComments ideclAnn++instance CommentExtraction (ForeignImport GhcPs) where+  nodeComments CImport {} = emptyNodeComments++instance CommentExtraction (ForeignExport GhcPs) where+  nodeComments CExport {} = emptyNodeComments+#else+instance CommentExtraction (HsSplice GhcPs) where+  nodeComments (HsTypedSplice x _ _ _) = nodeComments x+  nodeComments (HsUntypedSplice x _ _ _) = nodeComments x+  nodeComments HsQuasiQuote {} = emptyNodeComments+  nodeComments HsSpliced {} = emptyNodeComments++instance CommentExtraction ForeignImport where+  nodeComments CImport {} = emptyNodeComments++instance CommentExtraction ForeignExport where+  nodeComments CExport {} = emptyNodeComments+#endif+#if MIN_VERSION_ghc_lib_parser(9, 8, 1)+instance CommentExtraction+           (HsArg+              GhcPs+              (GenLocated SrcSpanAnnA (HsType GhcPs))+              (GenLocated SrcSpanAnnA (HsType GhcPs))) where+  nodeComments HsValArg {} = emptyNodeComments+  nodeComments HsTypeArg {} = emptyNodeComments+  nodeComments HsArgPar {} = emptyNodeComments++instance CommentExtraction (LHsRecUpdFields GhcPs) where+  nodeComments RegularRecUpdFields {} = emptyNodeComments+  nodeComments OverloadedRecUpdFields {} = emptyNodeComments+#else+instance CommentExtraction+           (HsArg+              (GenLocated SrcSpanAnnA (HsType GhcPs))+              (GenLocated SrcSpanAnnA (HsType GhcPs))) where+  nodeComments HsValArg {} = emptyNodeComments+  nodeComments HsTypeArg {} = emptyNodeComments+  nodeComments HsArgPar {} = emptyNodeComments+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+instance CommentExtraction (EpAnn a) where+  nodeComments (EpAnn ann _ cs) = NodeComments {..}+    where+      commentsBefore = priorComments cs+      commentsOnSameLine = filter isCommentOnSameLine $ getFollowingComments cs+      commentsAfter =+        filter (not . isCommentOnSameLine) $ getFollowingComments cs+      isCommentOnSameLine (L comAnn _) =+        srcSpanEndLine (epaLocationRealSrcSpan ann)+          == srcSpanStartLine (epaLocationRealSrcSpan comAnn)++instance CommentExtraction (EpaLocation' NoComments) where+  nodeComments EpaSpan {} = emptyNodeComments+  nodeComments EpaDelta {} = emptyNodeComments+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+instance CommentExtraction (EpAnn a) where+  nodeComments (EpAnn ann _ cs) = NodeComments {..}+    where+      commentsBefore = priorComments cs+      commentsOnSameLine = filter isCommentOnSameLine $ getFollowingComments cs+      commentsAfter =+        filter (not . isCommentOnSameLine) $ getFollowingComments cs+      isCommentOnSameLine (L comAnn _) =+        srcSpanEndLine (anchor ann) == srcSpanStartLine (anchor comAnn)++instance CommentExtraction (EpaLocation' NoComments) where+  nodeComments EpaSpan {} = emptyNodeComments+  nodeComments EpaDelta {} = emptyNodeComments+#else+instance CommentExtraction Anchor where+  nodeComments Anchor {} = emptyNodeComments++instance CommentExtraction (SrcAnn a) where+  nodeComments (SrcSpanAnn ep _) = nodeComments ep++instance CommentExtraction (EpAnn a) where+  nodeComments (EpAnn ann _ cs) = NodeComments {..}+    where+      commentsBefore = priorComments cs+      commentsOnSameLine = filter isCommentOnSameLine $ getFollowingComments cs+      commentsAfter =+        filter (not . isCommentOnSameLine) $ getFollowingComments cs+      isCommentOnSameLine (L comAnn _) =+        srcSpanEndLine (anchor ann) == srcSpanStartLine (anchor comAnn)+  nodeComments EpAnnNotUsed = emptyNodeComments+#endif++#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+instance CommentExtraction a => CommentExtraction (AnnList a) where+  nodeComments AnnList {..} = mconcat [a, b, c, d, e]+    where+      a = maybe mempty nodeComments al_anchor+      b = nodeComments al_brackets+      c = mconcat $ fmap nodeComments al_semis+      d = nodeComments al_rest+      e = mconcat $ fmap nodeComments al_trailing+#else+instance CommentExtraction AnnList where+  nodeComments AnnList {..} = mconcat [a, b, c, d, e]+    where+      a = maybe mempty nodeComments al_anchor+      b = maybe mempty nodeComments al_open+      c = maybe mempty nodeComments al_close+      d = mconcat $ fmap nodeComments al_rest+      e = mconcat $ fmap nodeComments al_trailing+#endif+instance CommentExtraction AnnParen where+  nodeComments = nodeCommentsAnnParen++nodeCommentsAnnParen :: AnnParen -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsAnnParen (AnnParens open close) =+  mconcat [nodeComments open, nodeComments close]+nodeCommentsAnnParen (AnnParensHash open close) =+  mconcat [nodeComments open, nodeComments close]+nodeCommentsAnnParen (AnnParensSquare open close) =+  mconcat [nodeComments open, nodeComments close]+#else+nodeCommentsAnnParen AnnParen {..} =+  mconcat $ fmap nodeComments [ap_open, ap_close]+#endif+instance CommentExtraction TrailingAnn where+  nodeComments = nodeCommentsTrailingAnn++nodeCommentsTrailingAnn :: TrailingAnn -> NodeComments+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+nodeCommentsTrailingAnn (AddSemiAnn token) = nodeComments token+nodeCommentsTrailingAnn (AddCommaAnn token) = nodeComments token+nodeCommentsTrailingAnn (AddVbarAnn token) = nodeComments token+nodeCommentsTrailingAnn (AddDarrowAnn token) = nodeComments token+#elif MIN_VERSION_ghc_lib_parser(9, 10, 1)+nodeCommentsTrailingAnn AddSemiAnn {..} = nodeComments ta_location+nodeCommentsTrailingAnn AddCommaAnn {..} = nodeComments ta_location+nodeCommentsTrailingAnn AddVbarAnn {..} = nodeComments ta_location+nodeCommentsTrailingAnn AddDarrowAnn {..} = nodeComments ta_location+nodeCommentsTrailingAnn AddDarrowUAnn {..} = nodeComments ta_location+#else+nodeCommentsTrailingAnn (AddSemiAnn token) = nodeComments token+nodeCommentsTrailingAnn (AddCommaAnn token) = nodeComments token+nodeCommentsTrailingAnn (AddVbarAnn token) = nodeComments token+#endif+#if MIN_VERSION_ghc_lib_parser(9, 12, 1)+instance CommentExtraction AnnTransStmt where+  nodeComments AnnTransStmt {..} =+    mconcat+      [ nodeComments ats_then+      , maybe emptyNodeComments nodeComments ats_group+      , maybe emptyNodeComments nodeComments ats_by+      , maybe emptyNodeComments nodeComments ats_using+      ]++instance CommentExtraction (EpToken a) where+  nodeComments NoEpTok = emptyNodeComments+  nodeComments (EpTok x) = nodeComments x++instance CommentExtraction AnnTyVarBndr where+  nodeComments AnnTyVarBndr {..} =+    mconcat+      [ mconcat $ fmap nodeComments atv_opens+      , mconcat $ fmap nodeComments atv_closes+      , nodeComments atv_tv+      , nodeComments atv_dcolon+      ]++instance CommentExtraction (EpUniToken a b) where+  nodeComments NoEpUniTok = emptyNodeComments+  nodeComments (EpUniTok x _) = nodeComments x++instance CommentExtraction AnnPSB where+  nodeComments AnnPSB {..} =+    mconcat+      [ nodeComments ap_pattern+      , maybe emptyNodeComments nodeComments ap_openc+      , maybe emptyNodeComments nodeComments ap_closec+      , maybe emptyNodeComments nodeComments ap_larrow+      , maybe emptyNodeComments nodeComments ap_equal+      ]++instance CommentExtraction NamespaceSpecifier where+  nodeComments NoNamespaceSpecifier = emptyNodeComments+  nodeComments (TypeNamespaceSpecifier x) = nodeComments x+  nodeComments (DataNamespaceSpecifier x) = nodeComments x++instance CommentExtraction AnnFamilyDecl where+  nodeComments AnnFamilyDecl {..} =+    mconcat+      [ mconcat $ fmap nodeComments afd_openp+      , mconcat $ fmap nodeComments afd_closep+      , nodeComments afd_type+      , nodeComments afd_data+      , nodeComments afd_family+      , nodeComments afd_dcolon+      , nodeComments afd_equal+      , nodeComments afd_vbar+      , nodeComments afd_where+      , nodeComments afd_openc+      , nodeComments afd_dotdot+      , nodeComments afd_closec+      ]++instance CommentExtraction AnnListBrackets where+  nodeComments (ListParens s d) = mconcat [nodeComments s, nodeComments d]+  nodeComments (ListBraces s d) = mconcat [nodeComments s, nodeComments d]+  nodeComments (ListSquare s d) = mconcat [nodeComments s, nodeComments d]+  nodeComments (ListBanana s d) = mconcat [nodeComments s, nodeComments d]+  nodeComments ListNone = emptyNodeComments++instance CommentExtraction () where+  nodeComments () = emptyNodeComments++instance CommentExtraction AnnArithSeq where+  nodeComments AnnArithSeq {..} =+    mconcat+      [ nodeComments aas_open+      , maybe emptyNodeComments nodeComments aas_comma+      , nodeComments aas_dotdot+      , nodeComments aas_close+      ]++instance (CommentExtraction a, CommentExtraction b) =>+         CommentExtraction (BracketAnn a b) where+  nodeComments (BracketNoE x) = nodeComments x+  nodeComments (BracketHasE x) = nodeComments x++instance CommentExtraction AnnSpecSig where+  nodeComments AnnSpecSig {..} =+    mconcat+      [ nodeComments ass_open+      , nodeComments ass_close+      , nodeComments ass_dcolon+      , nodeComments ass_act+      ]++instance CommentExtraction ActivationAnn where+  nodeComments ActivationAnn {..} =+    mconcat+      [ nodeComments aa_openc+      , nodeComments aa_closec+      , maybe emptyNodeComments nodeComments aa_tilde+      , maybe emptyNodeComments nodeComments aa_val+      ]+#endif+#if !MIN_VERSION_ghc_lib_parser(9, 4, 1)+-- | Marks an AST node as never appearing in the AST.+--+-- Some AST node types are only used in the renaming or type-checking phase.+notUsedInParsedStage :: HasCallStack => a+notUsedInParsedStage =+  error+    "This AST should never appears in an AST. It only appears in the renaming or type checked stages."+#endif+-- | A 'NodeComment' with no comments.+emptyNodeComments :: NodeComments+emptyNodeComments = NodeComments [] [] []
+ src/HIndent/Pretty/SigBindFamily.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE LambdaCase #-}++-- | A module defining 'SigBindFamily' and other related types and+-- functions.+module HIndent.Pretty.SigBindFamily+  ( SigBindFamily(..)+  , LSigBindFamily+  , mkSortedLSigBindFamilyList+  , mkLSigBindFamilyList+  , destructLSigBindFamilyList+  , filterLSig+  , filterLBind+  ) where++import Data.Function+import Data.List (sortBy)+import Data.Maybe+import GHC.Hs+import GHC.Types.SrcLoc++-- | A sum type containing one of those: function signature, function+-- binding, family declaration (type or data), type family instance, and data family instance.+data SigBindFamily+  = Sig (Sig GhcPs)+  | Bind (HsBindLR GhcPs GhcPs)+  | Family (FamilyDecl GhcPs)+  | TyFamInst (TyFamInstDecl GhcPs)+  | TyFamDeflt (TyFamDefltDecl GhcPs)+  | DataFamInst (DataFamInstDecl GhcPs)++-- | 'SigBindFamily' with the location information.+type LSigBindFamily = GenLocated SrcSpanAnnA SigBindFamily++-- | Creates a list of 'LSigBindFamily' from arguments. The list is sorted+-- by its elements' locations.+mkSortedLSigBindFamilyList ::+     [LSig GhcPs]+  -> [LHsBindLR GhcPs GhcPs]+  -> [LFamilyDecl GhcPs]+  -> [LTyFamInstDecl GhcPs]+  -> [LTyFamDefltDecl GhcPs]+  -> [LDataFamInstDecl GhcPs]+  -> [LSigBindFamily]+mkSortedLSigBindFamilyList sigs binds fams insts deflts datafams =+  sortBy (compare `on` realSrcSpan . locA . getLoc)+    $ mkLSigBindFamilyList sigs binds fams insts deflts datafams++-- | Creates a list of 'LSigBindFamily' from arguments.+mkLSigBindFamilyList ::+     [LSig GhcPs]+  -> [LHsBindLR GhcPs GhcPs]+  -> [LFamilyDecl GhcPs]+  -> [LTyFamInstDecl GhcPs]+  -> [LTyFamDefltDecl GhcPs]+  -> [LDataFamInstDecl GhcPs]+  -> [LSigBindFamily]+mkLSigBindFamilyList sigs binds fams insts deflts datafams =+  fmap (fmap Sig) sigs+    ++ fmap (fmap Bind) binds+    ++ fmap (fmap Family) fams+    ++ fmap (fmap TyFamInst) insts+    ++ fmap (fmap TyFamDeflt) deflts+    ++ fmap (fmap DataFamInst) datafams++-- | Destructs a list of 'LSigBindFamily'+destructLSigBindFamilyList ::+     [LSigBindFamily]+  -> ( [LSig GhcPs]+     , [LHsBindLR GhcPs GhcPs]+     , [LFamilyDecl GhcPs]+     , [LTyFamInstDecl GhcPs]+     , [LTyFamDefltDecl GhcPs]+     , [LDataFamInstDecl GhcPs])+destructLSigBindFamilyList =+  (,,,,,)+    <$> filterLSig+    <*> filterLBind+    <*> filterLFamily+    <*> filterLTyFamInst+    <*> filterLTyFamDeflt+    <*> filterLDataFamInst++-- | Filters out 'Sig's and extract the wrapped values.+filterLSig :: [LSigBindFamily] -> [LSig GhcPs]+filterLSig =+  mapMaybe+    (\case+       (L l (Sig x)) -> Just $ L l x+       _ -> Nothing)++-- | Filters out 'Bind's and extract the wrapped values.+filterLBind :: [LSigBindFamily] -> [LHsBindLR GhcPs GhcPs]+filterLBind =+  mapMaybe+    (\case+       (L l (Bind x)) -> Just $ L l x+       _ -> Nothing)++-- | Filters out 'Family's and extract the wrapped values.+filterLFamily :: [LSigBindFamily] -> [LFamilyDecl GhcPs]+filterLFamily =+  mapMaybe+    (\case+       (L l (Family x)) -> Just $ L l x+       _ -> Nothing)++-- | Filters out 'TyFamInst's and extract the wrapped values.+filterLTyFamInst :: [LSigBindFamily] -> [LTyFamInstDecl GhcPs]+filterLTyFamInst =+  mapMaybe+    (\case+       (L l (TyFamInst x)) -> Just $ L l x+       _ -> Nothing)++-- | Filters out 'TyFamDeflt's and extract the wrapped values.+filterLTyFamDeflt :: [LSigBindFamily] -> [LTyFamDefltDecl GhcPs]+filterLTyFamDeflt =+  mapMaybe+    (\case+       (L l (TyFamDeflt x)) -> Just $ L l x+       _ -> Nothing)++-- | Filters out 'DataFamInst's and extract the wrapped values.+filterLDataFamInst :: [LSigBindFamily] -> [LDataFamInstDecl GhcPs]+filterLDataFamInst =+  mapMaybe+    (\case+       (L l (DataFamInst x)) -> Just $ L l x+       _ -> Nothing)
+ src/HIndent/Pretty/Types.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}++-- | Types to pretty-print certain parts of Haskell codes.+--+-- We define new types to pretty-print AST nodes rather than define+-- functions to print comments easily using the 'Pretty' implementation of+-- 'GenLocated'.+module HIndent.Pretty.Types+  ( DataFamInstDecl'(..)+  , pattern DataFamInstDeclTopLevel+  , pattern DataFamInstDeclInsideClassInst+  , FamEqn'(..)+  , pattern FamEqnTopLevel+  , pattern FamEqnInsideClassInst+  , TopLevelTyFamInstDecl(..)+  , Context(..)+  , HorizontalContext(..)+  , VerticalContext(..)+  , DoOrMdo(..)+  , QualifiedDo(..)+  , DataFamInstDeclFor(..)+  ) where++import GHC.Hs+import {-# SOURCE #-} qualified HIndent.Ast.Module.Name as HIndent+#if !MIN_VERSION_ghc_lib_parser(9,6,1)+import GHC.Unit+#endif+-- | A wrapper of `DataFamInstDecl`.+data DataFamInstDecl' = DataFamInstDecl'+  { dataFamInstDeclFor :: DataFamInstDeclFor -- ^ Where a data family instance is declared.+  , dataFamInstDecl :: DataFamInstDecl GhcPs -- ^ The actual value.+  }++-- | `DataFamInstDecl'` wrapping a `DataFamInstDecl` representing+-- a top-level data family instance.+pattern DataFamInstDeclTopLevel :: DataFamInstDecl GhcPs -> DataFamInstDecl'+pattern DataFamInstDeclTopLevel x = DataFamInstDecl' DataFamInstDeclForTopLevel x++-- | `DataFamInstDecl'` wrapping a `DataFamInstDecl` representing a data+-- family instance inside a class instance.+pattern DataFamInstDeclInsideClassInst :: DataFamInstDecl GhcPs -> DataFamInstDecl'+pattern DataFamInstDeclInsideClassInst x = DataFamInstDecl' DataFamInstDeclForInsideClassInst x++-- | A wrapper for `FamEqn`.+data FamEqn' = FamEqn'+  { famEqnFor :: DataFamInstDeclFor -- ^ Where a data family instance is declared.+  , famEqn :: FamEqn GhcPs (HsDataDefn GhcPs)+  }++-- | `FamEqn'` wrapping a `FamEqn` representing a top-level data family+-- instance.+pattern FamEqnTopLevel :: FamEqn GhcPs (HsDataDefn GhcPs) -> FamEqn'+pattern FamEqnTopLevel x = FamEqn' DataFamInstDeclForTopLevel x++-- | `FamEqn'` wrapping a `FamEqn` representing a data family instance+-- inside a class instance.+pattern FamEqnInsideClassInst :: FamEqn GhcPs (HsDataDefn GhcPs) -> FamEqn'+pattern FamEqnInsideClassInst x = FamEqn' DataFamInstDeclForInsideClassInst x++-- | A top-level type family instance declaration.+newtype TopLevelTyFamInstDecl =+  TopLevelTyFamInstDecl (TyFamInstDecl GhcPs)+#if MIN_VERSION_ghc_lib_parser(9,4,1)+-- | A wrapper type for type class constraints; e.g., (Eq a, Ord a) of (Eq+-- a, Ord a) => [a] -> [a]. Either 'HorizontalContext' or 'VerticalContext'+-- is used internally.+newtype Context =+  Context (LHsContext GhcPs)++-- | A wrapper type for printing a context horizontally.+newtype HorizontalContext =+  HorizontalContext (LHsContext GhcPs)++-- | A wrapper type for printing a context vertically.+newtype VerticalContext =+  VerticalContext (LHsContext GhcPs)+#else+-- | A wrapper type for type class constraints; e.g., (Eq a, Ord a) of (Eq+-- a, Ord a) => [a] -> [a]. Either 'HorizontalContext' or 'VerticalContext'+-- is used internally.+newtype Context =+  Context (Maybe (LHsContext GhcPs))++-- | A wrapper type for printing a context horizontally.+newtype HorizontalContext =+  HorizontalContext (Maybe (LHsContext GhcPs))++-- | A wrapper type for printing a context vertically.+newtype VerticalContext =+  VerticalContext (Maybe (LHsContext GhcPs))+#endif+-- | Values indicating whether `do` or `mdo` is used.+data DoOrMdo+  = Do+  | Mdo++-- | Values indicating whether the `do` is qualified with a module name (and+-- whether `do` or `mdo` is used)+data QualifiedDo =+  QualifiedDo (Maybe HIndent.ModuleName) DoOrMdo++-- | Values indicating where a data family instance is declared.+data DataFamInstDeclFor+  = DataFamInstDeclForTopLevel+  | DataFamInstDeclForInsideClassInst
+ src/HIndent/Printer.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}++-- | Printer types.+module HIndent.Printer+  ( Printer(..)+  , PrintState(..)+  , runPrinterStyle+  ) where++import Control.Applicative+import Control.Monad+import Control.Monad.State.Strict+import Data.ByteString.Builder+import Data.Int (Int64)+import HIndent.Config++-- | A pretty printing monad.+newtype Printer a = Printer+  { runPrinter :: StateT PrintState Maybe a+  } deriving ( Applicative+             , Monad+             , Functor+             , MonadState PrintState+             , MonadPlus+             , Alternative+             )++-- | The state of the pretty printer.+data PrintState = PrintState+  { psIndentLevel :: !Int64+    -- ^ Current indentation level, i.e. every time there's a+    -- new-line, output this many spaces.+  , psOutput :: !Builder+    -- ^ The current output bytestring builder.+  , psNewline :: !Bool+    -- ^ Just outputted a newline?+  , psColumn :: !Int64+    -- ^ Current column.+  , psLine :: !Int64+    -- ^ Current line number.+  , psConfig :: !Config+    -- ^ Configuration of max colums and indentation style.+  , psFitOnOneLine :: !Bool+    -- ^ Bail out if we need to print beyond the current line or+    -- the maximum column.+  , psEolComment :: !Bool+  }++-- | Pretty print the given printable thing.+runPrinterStyle :: Config -> Printer () -> Builder+runPrinterStyle config m =+  maybe (error "Printer failed with mzero call.") psOutput+    $ execStateT (runPrinter m) initState+  where+    initState =+      PrintState+        { psIndentLevel = 0+        , psOutput = mempty+        , psNewline = False+        , psColumn = 0+        , psLine = 1+        , psConfig = config+        , psFitOnOneLine = False+        , psEolComment = False+        }
− src/HIndent/Types.hs 
@@ -1,143 +0,0 @@-{-# OPTIONS_GHC -cpp #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleContexts #-}---- | All types.--module HIndent.Types-  (Printer(..)-  ,PrintState(..)-  ,Config(..)-  ,readExtension-  ,defaultConfig-  ,NodeInfo(..)-  ,NodeComment(..)-  ,SomeComment(..)-  ) where--import           Control.Applicative-import           Control.Monad-import           Control.Monad.State.Strict (MonadState(..),StateT)-import           Control.Monad.Trans.Maybe-import           Data.ByteString.Builder-import           Data.Functor.Identity-import           Data.Int (Int64)-import           Data.Maybe-import           Data.Yaml (FromJSON(..))-import qualified Data.Yaml as Y-import           Language.Haskell.Exts hiding (Style, prettyPrint, Pretty, style, parse)---- | A pretty printing monad.-newtype Printer a =-  Printer {runPrinter :: StateT PrintState (MaybeT Identity) a}-  deriving (Applicative,Monad,Functor,MonadState PrintState,MonadPlus,Alternative)---- | The state of the pretty printer.-data PrintState = PrintState-  { psIndentLevel :: !Int64-    -- ^ Current indentation level, i.e. every time there's a-    -- new-line, output this many spaces.-  , psOutput :: !Builder-    -- ^ The current output bytestring builder.-  , psNewline :: !Bool-    -- ^ Just outputted a newline?-  , psColumn :: !Int64-    -- ^ Current column.-  , psLine :: !Int64-    -- ^ Current line number.-  , psConfig :: !Config-    -- ^ Configuration of max colums and indentation style.-  , psInsideCase :: !Bool-    -- ^ Whether we're in a case statement, used for Rhs printing.-  , psFitOnOneLine :: !Bool-    -- ^ Bail out if we need to print beyond the current line or-    -- the maximum column.-  , psEolComment :: !Bool-  }---- | Configurations shared among the different styles. Styles may pay--- attention to or completely disregard this configuration.-data Config = Config-    { configMaxColumns :: !Int64 -- ^ Maximum columns to fit code into ideally.-    , configIndentSpaces :: !Int64 -- ^ How many spaces to indent?-    , configTrailingNewline :: !Bool -- ^ End with a newline.-    , configSortImports :: !Bool -- ^ Sort imports in groups.-    , configLineBreaks :: [String] -- ^ Break line when meets these operators.-    , configExtensions :: [Extension]-      -- ^ Extra language extensions enabled by default.-    }---- | Parse an extension.--#if __GLASGOW_HASKELL__ >= 808-readExtension :: (Monad m, MonadFail m) => String -> m Extension-#else-readExtension :: Monad m => String -> m Extension-#endif-readExtension x =-  case classifyExtension x -- Foo-       of-    UnknownExtension _ -> fail ("Unknown extension: " ++ x)-    x' -> return x'--instance FromJSON Config where-  parseJSON (Y.Object v) =-    Config <$>-      fmap-        (fromMaybe (configMaxColumns defaultConfig))-        (v Y..:? "line-length") <*>-      fmap-        (fromMaybe (configIndentSpaces defaultConfig))-        (v Y..:? "indent-size" <|> v Y..:? "tab-size") <*>-      fmap-        (fromMaybe (configTrailingNewline defaultConfig))-        (v Y..:? "force-trailing-newline") <*>-      fmap-        (fromMaybe (configSortImports defaultConfig))-        (v Y..:? "sort-imports") <*>-      fmap-        (fromMaybe (configLineBreaks defaultConfig))-        (v Y..:? "line-breaks") <*>-      (traverse readExtension-        =<< fmap (fromMaybe []) (v Y..:? "extensions"))-  parseJSON _ = fail "Expected Object for Config value"---- | Default style configuration.-defaultConfig :: Config-defaultConfig =-    Config-    { configMaxColumns = 80-    , configIndentSpaces = 2-    , configTrailingNewline = True-    , configSortImports = True-    , configLineBreaks = []-    , configExtensions = []-    }---- | Some comment to print.-data SomeComment-  = EndOfLine String-  | MultiLine String-  deriving (Show, Ord, Eq)---- | Comment associated with a node.--- 'SrcSpan' is the original source span of the comment.-data NodeComment-  = CommentSameLine SrcSpan SomeComment-  | CommentAfterLine SrcSpan SomeComment-  | CommentBeforeLine SrcSpan SomeComment-  deriving (Show, Ord, Eq)---- | Information for each node in the AST.-data NodeInfo = NodeInfo-  { nodeInfoSpan :: !SrcSpanInfo -- ^ Location info from the parser.-  , nodeInfoComments :: ![NodeComment] -- ^ Comments attached to this node.-  }-instance Show NodeInfo where-  show (NodeInfo _ []) = ""-  show (NodeInfo _ s) =-    "{- " ++ show s ++ " -}"
− src/main/Benchmark.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BangPatterns #-}---- | Benchmark the pretty printer.--module Main where--import           Control.DeepSeq-import           Criterion-import           Criterion.Main-import qualified Data.ByteString as S-import qualified Data.ByteString.Builder as S-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.UTF8 as UTF8-import           HIndent-import           HIndent.Types-import           Markdone---- | Main benchmarks.-main :: IO ()-main = do-    bytes <- S.readFile "BENCHMARKS.md"-    !forest <- fmap force (parse (tokenize bytes))-    defaultMain (toCriterion forest)---- | Convert the Markdone document to Criterion benchmarks.-toCriterion :: [Markdone] -> [Benchmark]-toCriterion = go-  where-    go (Section name children:next) =-      bgroup (S8.unpack name) (go children) : go next-    go (PlainText desc:CodeFence lang code:next) =-      if lang == "haskell"-        then (bench-                (UTF8.toString desc)-                (nf-                   (either error S.toLazyByteString .-                    reformat-                      HIndent.Types.defaultConfig-                      (Just defaultExtensions)-                      Nothing)-                   code)) :-             go next-        else go next-    go (PlainText {}:next) = go next-    go (CodeFence {}:next) = go next-    go [] = []
− src/main/Main.hs 
@@ -1,127 +0,0 @@-{-# LANGUAGE Unsafe #-}-{-# LANGUAGE OverloadedStrings #-}---- | Main entry point to hindent.------ hindent-module Main (main) where--import           Control.Applicative-import           Control.Exception-import           Control.Monad-import qualified Data.ByteString as S-import qualified Data.ByteString.Builder as S-import qualified Data.ByteString.Lazy.Char8 as L8-import           Data.Maybe-import           Data.Version (showVersion)-import qualified Data.Yaml as Y-import           Foreign.C.Error-import           GHC.IO.Exception-import           HIndent-import           HIndent.CabalFile-import           HIndent.Types-import           Language.Haskell.Exts hiding (Style, style)-import           Path-import qualified Path.Find as Path-import qualified Path.IO as Path-import           Paths_hindent (version)-import qualified System.Directory as IO-import           System.Exit (exitWith)-import qualified System.IO as IO-import           Options.Applicative hiding (action, style)-import           Data.Monoid ((<>))-import qualified Data.Text as T--data Action = Validate | Reformat--data RunMode = ShowVersion | Run Config [Extension] Action [FilePath]---- | Main entry point.-main :: IO ()-main = do-  config <- getConfig-  runMode <- execParser (info (options config <**> helper) (header "hindent - Reformat Haskell source code"))-  case runMode of-    ShowVersion ->-      putStrLn ("hindent " ++ showVersion version)-    Run style exts action paths ->-      if null paths then-         L8.interact-            (either error S.toLazyByteString . reformat style (Just exts) Nothing . L8.toStrict)-      else-        forM_ paths $ \filepath -> do-          cabalexts <- getCabalExtensionsForSourcePath filepath-          text <- S.readFile filepath-          case reformat style (Just $ cabalexts ++ exts) (Just filepath) text of-            Left e -> error e-            Right out ->-              unless (L8.fromStrict text == S.toLazyByteString out) $-                case action of-                  Validate -> do-                    IO.putStrLn $ filepath ++ " is not formatted"-                    exitWith (ExitFailure 1)-                  Reformat -> do-                    tmpDir <- IO.getTemporaryDirectory-                    (fp, h) <- IO.openTempFile tmpDir "hindent.hs"-                    L8.hPutStr h (S.toLazyByteString out)-                    IO.hFlush h-                    IO.hClose h-                    let exdev e =-                          if ioe_errno e == Just ((\(Errno a) -> a) eXDEV)-                            then IO.copyFile fp filepath >> IO.removeFile fp-                            else throw e-                    IO.copyPermissions filepath fp-                    IO.renameFile fp filepath `catch` exdev---- | Read config from a config file, or return 'defaultConfig'.-getConfig :: IO Config-getConfig = do-  cur <- Path.getCurrentDir-  homeDir <- Path.getHomeDir-  mfile <--    Path.findFileUp cur ((== ".hindent.yaml") . toFilePath . filename) (Just homeDir)-  case mfile of-    Nothing -> return defaultConfig-    Just file -> do-      result <- Y.decodeFileEither (toFilePath file)-      case result of-        Left e -> error (show e)-        Right config -> return config---- | Program options.-options ::-  Config -> Parser RunMode-options config =-  flag' ShowVersion ( long "version" <> help "Print the version") <|>-  (Run <$> style <*> exts <*> action <*> files)-  where-    style =-      (makeStyle config <$>-      lineLen <*>-      indentSpaces <*>-      trailingNewline <*>-      sortImports-      ) <*-      optional (strOption-           (long "style" <> help "Style to print with (historical, now ignored)" <> metavar "STYLE") :: Parser String)-    exts = fmap getExtensions (many (T.pack <$> strOption (short 'X' <> help "Language extension" <> metavar "GHCEXT")))-    indentSpaces =-        option auto-           (long "indent-size" <> help "Indentation size in spaces" <> value (configIndentSpaces config) <> showDefault) <|>-           option auto (long "tab-size" <> help "Same as --indent-size, for compatibility")-    lineLen =-        option auto (long "line-length" <> help "Desired length of lines" <> value (configMaxColumns config) <> showDefault )-    trailingNewline = not <$>-        flag (not (configTrailingNewline config)) (configTrailingNewline config) (long "no-force-newline" <> help "Don't force a trailing newline" <> showDefault)-    sortImports =-        flag Nothing (Just True) (long "sort-imports" <> help "Sort imports in groups" <> showDefault) <|>-         flag Nothing (Just False)  (long "no-sort-imports" <> help "Don't sort imports")-    action = flag Reformat Validate (long "validate" <> help "Check if files are formatted without changing them")-    makeStyle s mlen tabs trailing imports =-      s-      { configMaxColumns = mlen-      , configIndentSpaces =  tabs-      , configTrailingNewline =  trailing-      , configSortImports =  fromMaybe (configSortImports s) imports-      }-    files = many (strArgument (metavar "FILENAMES"))
− src/main/Markdone.hs 
@@ -1,130 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}---- | A subset of markdown that only supports @#headings@ and code--- fences.------ All content must be in section headings with proper hierarchy,--- anything else is rejected.--module Markdone where--import           Control.DeepSeq-import           Control.Monad.Catch-import           Control.Monad.State.Strict (State, evalState, get, put)-import           Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8-import           Data.Char-import           Data.Typeable-import           GHC.Generics---- | A markdone token.-data Token-  = Heading !Int-            !ByteString-  | PlainLine !ByteString-  | BeginFence !ByteString-  | EndFence-  deriving (Eq, Show)---- | A markdone document.-data Markdone-  = Section !ByteString-            ![Markdone]-  | CodeFence !ByteString-              !ByteString-  | PlainText !ByteString-  deriving (Eq,Show,Generic)-instance NFData Markdone---- | Parse error.-data MarkdownError = NoFenceEnd | ExpectedSection-  deriving (Typeable,Show)-instance Exception MarkdownError--data TokenizerMode-  = Normal-  | Fenced---- | Tokenize the bytestring.-tokenize :: ByteString -> [Token]-tokenize input = evalState (mapM token (S8.lines input)) Normal-  where-    token :: ByteString -> State TokenizerMode Token-    token line = do-      mode <- get-      case mode of-        Normal ->-          if S8.isPrefixOf "#" line-            then let (hashes,title) = S8.span (== '#') line-                 in return $-                      Heading (S8.length hashes) (S8.dropWhile isSpace title)-            else if S8.isPrefixOf "```" line-                   then do-                     put Fenced-                     return $-                       BeginFence-                         (S8.dropWhile-                            (\c ->-                                c == '`' || c == ' ')-                            line)-                   else return $ PlainLine line-        Fenced ->-          if line == "```"-            then do-              put Normal-              return EndFence-            else return $ PlainLine line---- | Parse into a forest.-parse :: (Functor m,MonadThrow m) => [Token] -> m [Markdone]-parse = go (0 :: Int)-  where-    go level =-      \case-        (Heading n label:rest) ->-          let (children,rest') =-                span-                  (\case-                     Heading nextN _ -> nextN > n-                     _ -> True)-                  rest-          in do childs <- go (level + 1) children-                siblings <- go level rest'-                return (Section label childs : siblings)-        (BeginFence label:rest)-          | level > 0 ->-            let (content,rest') =-                  (span-                     (\case-                        PlainLine {} -> True-                        _ -> False)-                     rest)-            in case rest' of-                 (EndFence:rest'') ->-                   fmap-                     (CodeFence-                        label-                        (S8.intercalate "\n" (map getPlain content)) :)-                     (go level rest'')-                 _ -> throwM NoFenceEnd-        PlainLine p:rest-          | level > 0 ->-            let (content,rest') =-                  (span-                     (\case-                        PlainLine {} -> True-                        _ -> False)-                     (PlainLine p : rest))-            in fmap-                 (PlainText-                    (S8.intercalate-                       "\n"-                       (filter (not . S8.null) (map getPlain content))) :)-                 (go level rest')-        [] -> return []-        _ -> throwM ExpectedSection-    getPlain (PlainLine x) = x-    getPlain _ = ""
− src/main/Path/Find.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE DataKinds #-}---- | Finding files.---- Lifted from Stack.--module Path.Find-  (findFileUp-  ,findDirUp-  ,findFiles-  ,findInParents)-  where--import Control.Exception (evaluate)-import Control.DeepSeq (force)-import Control.Monad-import Control.Monad.Catch-import Control.Monad.IO.Class-import System.IO.Error (isPermissionError)-import Data.List-import Path-import Path.IO hiding (findFiles)-import System.PosixCompat.Files (getSymbolicLinkStatus, isSymbolicLink)---- | Find the location of a file matching the given predicate.-findFileUp :: (MonadIO m,MonadThrow m)-           => Path Abs Dir                -- ^ Start here.-           -> (Path Abs File -> Bool)     -- ^ Predicate to match the file.-           -> Maybe (Path Abs Dir)        -- ^ Do not ascend above this directory.-           -> m (Maybe (Path Abs File))  -- ^ Absolute file path.-findFileUp = findPathUp snd---- | Find the location of a directory matching the given predicate.-findDirUp :: (MonadIO m,MonadThrow m)-          => Path Abs Dir                -- ^ Start here.-          -> (Path Abs Dir -> Bool)      -- ^ Predicate to match the directory.-          -> Maybe (Path Abs Dir)        -- ^ Do not ascend above this directory.-          -> m (Maybe (Path Abs Dir))   -- ^ Absolute directory path.-findDirUp = findPathUp fst---- | Find the location of a path matching the given predicate.-findPathUp :: (MonadIO m,MonadThrow m)-           => (([Path Abs Dir],[Path Abs File]) -> [Path Abs t])-              -- ^ Choose path type from pair.-           -> Path Abs Dir                     -- ^ Start here.-           -> (Path Abs t -> Bool)             -- ^ Predicate to match the path.-           -> Maybe (Path Abs Dir)             -- ^ Do not ascend above this directory.-           -> m (Maybe (Path Abs t))           -- ^ Absolute path.-findPathUp pathType dir p upperBound =-  do entries <- listDir dir-     case find p (pathType entries) of-       Just path -> return (Just path)-       Nothing | Just dir == upperBound -> return Nothing-               | parent dir == dir -> return Nothing-               | otherwise -> findPathUp pathType (parent dir) p upperBound---- | Find files matching predicate below a root directory.------ NOTE: this skips symbolic directory links, to avoid loops. This may--- not make sense for all uses of file finding.------ TODO: write one of these that traverses symbolic links but--- efficiently ignores loops.-findFiles :: Path Abs Dir            -- ^ Root directory to begin with.-          -> (Path Abs File -> Bool) -- ^ Predicate to match files.-          -> (Path Abs Dir -> Bool)  -- ^ Predicate for which directories to traverse.-          -> IO [Path Abs File]      -- ^ List of matching files.-findFiles dir p traversep =-  do (dirs,files) <- catchJust (\ e -> if isPermissionError e-                                         then Just ()-                                         else Nothing)-                               (listDir dir)-                               (\ _ -> return ([], []))-     filteredFiles <- evaluate $ force (filter p files)-     filteredDirs <- filterM (fmap not . isSymLink) dirs-     subResults <--       forM filteredDirs-            (\entry ->-               if traversep entry-                  then findFiles entry p traversep-                  else return [])-     return (concat (filteredFiles : subResults))--isSymLink :: Path Abs t -> IO Bool-isSymLink = fmap isSymbolicLink . getSymbolicLinkStatus . toFilePath---- | @findInParents f path@ applies @f@ to @path@ and its 'parent's until--- it finds a 'Just' or reaches the root directory.-findInParents :: MonadIO m => (Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a)-findInParents f path = do-    mres <- f path-    case mres of-        Just res -> return (Just res)-        Nothing -> do-            let next = parent path-            if next == path-                then return Nothing-                else findInParents f next
− src/main/Test.hs 
@@ -1,177 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Test the pretty printer.-module Main where--import           Data.Algorithm.Diff-import           Data.Algorithm.DiffOutput-import qualified Data.ByteString as S-import qualified Data.ByteString.Builder as S-import           Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Char8 as L8-import qualified Data.ByteString.Lazy.UTF8 as LUTF8-import qualified Data.ByteString.UTF8 as UTF8-import           Data.Function-import           Data.Monoid-import qualified HIndent-import           HIndent.CodeBlock-import           HIndent.Types-import           Markdone-import           Test.Hspec---- | Main benchmarks.-main :: IO ()-main = do-    bytes <- S.readFile "TESTS.md"-    forest <- parse (tokenize bytes)-    hspec $ do-      codeBlocksSpec-      markdoneSpec-      toSpec forest--reformat :: Config -> S.ByteString -> ByteString-reformat cfg code =-  either (("-- " <>) . L8.pack) S.toLazyByteString $-  HIndent.reformat cfg (Just HIndent.defaultExtensions) Nothing code---- | Convert the Markdone document to Spec benchmarks.-toSpec :: [Markdone] -> Spec-toSpec = go-  where-    cfg = HIndent.Types.defaultConfig {configTrailingNewline = False}-    go (Section name children:next) = do-      describe (UTF8.toString name) (go children)-      go next-    go (PlainText desc:CodeFence lang code:next) =-      case lang of-        "haskell" -> do-          it (UTF8.toString desc) $-            shouldBeReadable (reformat cfg code) (L.fromStrict code)-          go next-        "haskell 4" -> do-          let cfg' = cfg {configIndentSpaces = 4}-          it (UTF8.toString desc) $-            shouldBeReadable (reformat cfg' code) (L.fromStrict code)-          go next-        "haskell given" ->-          case skipEmptyLines next of-            CodeFence "haskell expect" codeExpect:next' -> do-              it (UTF8.toString desc) $-                shouldBeReadable (reformat cfg code) (L.fromStrict codeExpect)-              go next'-            _ ->-              error-                "'haskell given' block must be followed by a 'haskell expect' block"-        "haskell pending" -> do-          it (UTF8.toString desc) pending-          go next-        _ -> go next-    go (PlainText {}:next) = go next-    go (CodeFence {}:next) = go next-    go [] = return ()---- | Version of 'shouldBe' that prints strings in a readable way,--- better for our use-case.-shouldBeReadable :: ByteString -> ByteString -> Expectation-shouldBeReadable x y =-  shouldBe (Readable x (Just (diff y x))) (Readable y Nothing)---- | Prints a string without quoting and escaping.-data Readable = Readable-  { readableString :: ByteString-  , readableDiff :: Maybe String-  }--instance Eq Readable where-  (==) = on (==) readableString--instance Show Readable where-  show (Readable x d') =-    "\n" ++-    LUTF8.toString x ++-    (case d' of-       Just d -> "\nThe diff:\n" ++ d-       Nothing -> "")---- | A diff display.-diff :: ByteString -> ByteString -> String-diff x y = ppDiff (on getGroupedDiff (lines . LUTF8.toString) x y)--skipEmptyLines :: [Markdone] -> [Markdone]-skipEmptyLines (PlainText "":rest) = rest-skipEmptyLines other = other--codeBlocksSpec :: Spec-codeBlocksSpec =-  describe "splitting source into code blocks" $ do-    it "should put just Haskell code in its own block" $ do-      let input = "this is totally haskell code\n\nit deserves its own block!\n"-      cppSplitBlocks input `shouldBe` [HaskellSource 0 input]-    it "should put #if/#endif and Haskell code into separate blocks" $ do-      cppSplitBlocks-        "haskell code\n#if DEBUG\ndebug code\n#endif\nmore haskell code\n" `shouldBe`-        [ HaskellSource 0 "haskell code"-        , CPPDirectives "#if DEBUG"-        , HaskellSource 2 "debug code"-        , CPPDirectives "#endif"-        , HaskellSource 4 "more haskell code\n"-        ]-    it "should put the shebang line into its own block" $ do-      cppSplitBlocks-        "#!/usr/bin/env runhaskell\n{-# LANGUAGE OverloadedStrings #-}\n" `shouldBe`-        [ Shebang "#!/usr/bin/env runhaskell"-        , HaskellSource 1 "{-# LANGUAGE OverloadedStrings #-}\n"-        ]-    it "should put a multi-line #define into its own block" $ do-      let input = "#define A \\\n  macro contents \\\n  go here\nhaskell code\n"-      cppSplitBlocks input `shouldBe`-        [ CPPDirectives "#define A \\\n  macro contents \\\n  go here"-        , HaskellSource 3 "haskell code\n"-        ]-    it "should put an unterminated multi-line #define into its own block" $ do-      cppSplitBlocks "#define A \\" `shouldBe` [CPPDirectives "#define A \\"]-      cppSplitBlocks "#define A \\\n" `shouldBe` [CPPDirectives "#define A \\"]-      cppSplitBlocks "#define A \\\n.\\" `shouldBe`-        [CPPDirectives "#define A \\\n.\\"]--markdoneSpec :: Spec-markdoneSpec = do-  describe "markdown tokenizer" $ do-    it "should tokenize plain text" $ do-      let input =-            "this is a line\nthis is another line\n\nthis is a new paragraph\n"-      tokenize input `shouldBe`-        [ PlainLine "this is a line"-        , PlainLine "this is another line"-        , PlainLine ""-        , PlainLine "this is a new paragraph"-        ]-    it "should tokenize headings" $ do-      tokenize "# Heading" `shouldBe` [Heading 1 "Heading"]-    it "should tokenize code fence beginnings with labels" $ do-      tokenize "``` haskell\n" `shouldBe` [BeginFence "haskell"]-      tokenize "```haskell expect\n" `shouldBe` [BeginFence "haskell expect"]-      tokenize "before\n```code\nafter\n" `shouldBe`-        [PlainLine "before", BeginFence "code", PlainLine "after"]-    it "should tokenize full code fences" $ do-      tokenize "```haskell\ncode goes here\n```" `shouldBe`-        [BeginFence "haskell", PlainLine "code goes here", EndFence]-    it "should tokenize lines inside code fences as plain text" $ do-      tokenize "```haskell\n#!/usr/bin/env stack\n```" `shouldBe`-        [BeginFence "haskell", PlainLine "#!/usr/bin/env stack", EndFence]-      tokenize "```haskell\n# not a heading\n```" `shouldBe`-        [BeginFence "haskell", PlainLine "# not a heading", EndFence]-  describe "markdown parser" $ do-    it "should parse a heading followed by text as a section" $ do-      let input =-            [ Heading 1 "This is a heading"-            , PlainLine "This is plain text"-            , PlainLine "split across two lines."-            ]-      output <- parse input-      output `shouldBe`-        [ Section-            "This is a heading"-            [PlainText "This is plain text\nsplit across two lines."]-        ]
+ tests/Main.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Test the pretty printer.+module Main where++import Data.Algorithm.Diff+import Data.Algorithm.DiffOutput+import qualified Data.ByteString as S+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.Lazy.UTF8 as LUTF8+import qualified Data.ByteString.UTF8 as UTF8+import Data.Function+import Data.Version+import qualified HIndent+import HIndent (Config(..))+import HIndent.Internal.Test.Markdone+import qualified System.Info+import Test.Hspec+import Text.Read+import Text.Regex.TDFA++-- | Main benchmarks.+main :: IO ()+main = do+  bytes <- S.readFile "TESTS.md"+  forest <- parse (tokenize bytes)+  hspec $ do+    markdoneSpec+    toSpec forest++reformat :: Config -> S.ByteString -> ByteString+reformat cfg code =+  either (("-- " <>) . L8.pack . HIndent.prettyParseError) L.fromStrict+    $ HIndent.reformat cfg HIndent.defaultExtensions Nothing code++-- | Convert the Markdone document to Spec benchmarks.+toSpec :: [Markdone] -> Spec+toSpec = go+  where+    cfg = HIndent.defaultConfig {configTrailingNewline = False}+    go (Section name children:next) = do+      describe (UTF8.toString name) (go children)+      go next+    go (PlainText desc:CodeFence lang code:next) =+      case lang of+        "haskell" -> do+          it (UTF8.toString desc)+            $ shouldBeReadable (reformat cfg code) (L.fromStrict code)+          go next+        "haskell 4" -> do+          let cfg' = cfg {configIndentSpaces = 4}+          it (UTF8.toString desc)+            $ shouldBeReadable (reformat cfg' code) (L.fromStrict code)+          go next+        "haskell given" ->+          case skipEmptyLines next of+            CodeFence "haskell expect" codeExpect:next' -> do+              it (UTF8.toString desc)+                $ shouldBeReadable (reformat cfg code) (L.fromStrict codeExpect)+              go next'+            _ ->+              error+                "'haskell given' block must be followed by a 'haskell expect' block"+        "haskell pending" -> do+          it (UTF8.toString desc) pending+          go next+        s+          | Just from <- fromVersion $ UTF8.toString s ->+            if compilerVersion >= from+              then do+                it (UTF8.toString desc)+                  $ shouldBeReadable (reformat cfg code) (L.fromStrict code)+                go next+              else do+                it+                  (UTF8.toString desc)+                  (pendingWith $ pendingForVersionMsg from)+                go next+        _ -> go next+    go (PlainText {}:next) = go next+    go (CodeFence {}:next) = go next+    go [] = return ()+    pendingForVersionMsg from =+      "The test is for GHC versions since "+        ++ showVersion from+        ++ " but you are using GHC version "+        ++ showVersion compilerVersion+        ++ "."+    fromVersion :: String -> Maybe Version+    fromVersion s+      | (_, _, _, [x, y, z]) <-+          s =~ fromRegex :: (String, String, String, [String])+      , (Just x', Just y', Just z') <- (readMaybe x, readMaybe y, readMaybe z) =+        Just $ Version [x', y', z'] []+    fromVersion _ = Nothing+    fromRegex :: String+    fromRegex = "haskell since ([0-9]+)\\.([0-9]+)\\.([0-9]+)"++-- | Version of 'shouldBe' that prints strings in a readable way,+-- better for our use-case.+shouldBeReadable :: ByteString -> ByteString -> Expectation+shouldBeReadable x y =+  shouldBe (Readable x (Just (diff y x))) (Readable y Nothing)++-- | Prints a string without quoting and escaping.+data Readable = Readable+  { readableString :: ByteString+  , readableDiff :: Maybe String+  }++instance Eq Readable where+  (==) = on (==) readableString++instance Show Readable where+  show (Readable x d') =+    "\n"+      ++ LUTF8.toString x+      ++ (case d' of+            Just d -> "\nThe diff:\n" ++ d+            Nothing -> "")++-- | A diff display.+diff :: ByteString -> ByteString -> String+diff x y = ppDiff (on getGroupedDiff (lines . LUTF8.toString) x y)++skipEmptyLines :: [Markdone] -> [Markdone]+skipEmptyLines (PlainText "":rest) = rest+skipEmptyLines other = other++markdoneSpec :: Spec+markdoneSpec = do+  describe "markdown tokenizer" $ do+    it "should tokenize plain text" $ do+      let input =+            "this is a line\nthis is another line\n\nthis is a new paragraph\n"+      tokenize input+        `shouldBe` [ PlainLine "this is a line"+                   , PlainLine "this is another line"+                   , PlainLine ""+                   , PlainLine "this is a new paragraph"+                   ]+    it "should tokenize headings" $ do+      tokenize "# Heading" `shouldBe` [Heading 1 "Heading"]+    it "should tokenize code fence beginnings with labels" $ do+      tokenize "``` haskell\n" `shouldBe` [BeginFence "haskell"]+      tokenize "```haskell expect\n" `shouldBe` [BeginFence "haskell expect"]+      tokenize "before\n```code\nafter\n"+        `shouldBe` [PlainLine "before", BeginFence "code", PlainLine "after"]+    it "should tokenize full code fences" $ do+      tokenize "```haskell\ncode goes here\n```"+        `shouldBe` [BeginFence "haskell", PlainLine "code goes here", EndFence]+    it "should tokenize lines inside code fences as plain text" $ do+      tokenize "```haskell\n#!/usr/bin/env stack\n```"+        `shouldBe` [ BeginFence "haskell"+                   , PlainLine "#!/usr/bin/env stack"+                   , EndFence+                   ]+      tokenize "```haskell\n# not a heading\n```"+        `shouldBe` [BeginFence "haskell", PlainLine "# not a heading", EndFence]+  describe "markdown parser" $ do+    it "should parse a heading followed by text as a section" $ do+      let input =+            [ Heading 1 "This is a heading"+            , PlainLine "This is plain text"+            , PlainLine "split across two lines."+            ]+      output <- parse input+      output+        `shouldBe` [ Section+                       "This is a heading"+                       [PlainText "This is plain text\nsplit across two lines."]+                   ]++-- | Returns the version of the compiler used to build this program.+--+-- This function is a wrapper for `compilerVersion` and+-- `fullCompilerVersion` defined in `System.info`. If the `base` package+-- 4.15.0.0 or later is used, the latter function is defined and hence the+-- value is returned, otherwise the former value is returned.+compilerVersion :: Version+#if MIN_VERSION_base(4,15,0)+compilerVersion = System.Info.fullCompilerVersion+#else+compilerVersion = System.Info.compilerVersion+#endif