diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,90 @@ +## Fourmolu 0.2.0.0 + +* More consistent indentation. Previously, with indentation set to n, some constructs such as nested lists and tuples would use an ugly mix of n-space and 2-space indentation. + +* New configuration options (see README or Hackage docs for details): + * `comma-style` + * `record-brace-space` + * `indent-wheres` + * `diff-friendly-import-export` + * `respectful` + * `haddock-style` + +### Upstream changes: + +#### Ormolu 0.1.3.0: + +* Ormolu no longer overwrites already formatted files. [PR + 649](https://github.com/tweag/ormolu/pull/649). + +* Now a space is guaranteed before ticked promoted types. [Issue + 631](https://github.com/tweag/ormolu/issues/631). + +* Made formatting of single-line explicitly bidirectional pattern synonyms + idempotent. [Issue 630](https://github.com/tweag/ormolu/issues/630). + +#### Ormolu 0.1.2.0: + +* Fixed the bug when comments in different styles got glued together after + formatting. [Issue 589](https://github.com/tweag/ormolu/issues/589). + +* Added `-i` as a shortcut for `--mode inplace`. [Issue + 467](https://github.com/tweag/ormolu/issues/467). + +* Improved grouping of top-level declarations. [Issue + 466](https://github.com/tweag/ormolu/issues/466). + +## Fourmolu 0.1.1.0 + +### Upstream changes: + +#### Ormolu 0.1.1.0: + +* Imports in a import lists are now normalized: duplicate imports are + combined/eliminated intelligently. + +* Import declarations that can be merged are now automatically merged. + [Issue 414](https://github.com/tweag/ormolu/issues/414). + +* The magic comments for disabling and enabling Ormolu now can encompass any + fragment of code provided that the remaining code after exclusion of the + disabled part is still syntactically correct. [Issue + 601](https://github.com/tweag/ormolu/issues/601). + +* Improved sorting of operators in imports. [Issue + 602](https://github.com/tweag/ormolu/issues/602). + +* Fixed a bug related to trailing space in multiline comments in certain + cases. [Issue 603](https://github.com/tweag/ormolu/issues/602). + +* Added support for formatting linked lists with `(:)` as line terminator. + [Issue 478](https://github.com/tweag/ormolu/issues/478). + +* Fixed rendering of function arguments in multiline layout. [Issue + 609](https://github.com/tweag/ormolu/issues/609). + +* Blank lines between definitions in `let` and `while` bindings are now + preserved. [Issue 554](https://github.com/tweag/ormolu/issues/554). + +* Fixed the bug when type applications stuck to the `$` of TH splices that + followed them. [Issue 613](https://github.com/tweag/ormolu/issues/613). + +* Improved region formatting so that indented fragments—such as definitions + inside of `where` clauses—can be formatted. [Issue + 572](https://github.com/tweag/ormolu/issues/572). + +* Fixed the bug related to the de-association of pragma comments. [Issue + 619](https://github.com/tweag/ormolu/issues/619). + ## Fourmolu 0.1.0.0 * Allow configuration of indentation size via `fourmolu.yaml` config files. * An operator on a new line is no longer indented when its left operand is a do-block. This prevents the AST from potentially changing when indenting by more than two spaces. -Upstream changes: +### Upstream changes: + +#### Ormolu 0.1.0.0: * Fixed rendering of type signatures concerning several identifiers. [Issue 566](https://github.com/tweag/ormolu/issues/566). diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md deleted file mode 100644 --- a/CONTRIBUTING.md +++ /dev/null @@ -1,64 +0,0 @@ -# Contributing - -Issues (bugs, feature requests or otherwise feedback) may be reported in -[the GitHub issue tracker for this project][issues]. Pull requests are also -welcome. - -When contributing to this repository, please first discuss the change you -wish to make via an issue, unless it's entirely trivial (typo fixes, etc.). -If there is already an issue that describes the change you have in mind, -comment on it indicating that you're going to work on that. This way we can -avoid the situation when several people work on the same thing. - -Please make sure that all non-trivial changes are described in commit -messages and PR descriptions. - -## What to hack on? - -* [Fixing bugs][bugs]. This is the main focus right now. - -### Testing - -Testing has been taken good care of and now it amounts to just adding -examples under `data/examples`. Each example is a pair of files: -`.hs` for input and `-out.hs` for corresponding -expected output. - -Testing is performed as following: - -* Given snippet of source code is parsed and pretty-printed. -* The result of printing is parsed back again and the AST is compared to the - AST obtained from the original file. They should match. -* The output of printer is checked against the expected output. -* Idempotence property is verified: formatting already formatted code - results in exactly the same output. - -Examples can be organized in sub-directories, see the existing ones for -inspiration. - -Please note that we try to keep individual files at most 25 lines long -because otherwise it's hard to figure out want went wrong when a test fails. - -## CI - -We use Circle CI. Some outside contributors may have problems, as in, CI -won't run for PRs opened from forks with “unauthorized” errors. In that case -the best we can do is to add you as a contributor or to restart your build -manually. - -If you have been added as a contributor but the builds still do not start, -try clicking - -``` -User settings -> Account integrations -> Refresh permissions -``` - -in Circle CI app. - -## Formatting - -Use `format.sh` script to format Ormolu with current version of Ormolu. If -Ormolu is not formatted like this, the CI will fail. - -[issues]: https://github.com/tweag/ormolu/issues -[bugs]: https://github.com/tweag/ormolu/issues?q=is%3Aissue+is%3Aopen+label%3Abug diff --git a/DESIGN.md b/DESIGN.md deleted file mode 100644 --- a/DESIGN.md +++ /dev/null @@ -1,407 +0,0 @@ -# Ormolu - -*This document represents our discussions and plans at early stages of -development, it is no longer being updated.* - -* [Analysis of the existing solutions](#analysis-of-the-existing-solutions) - * [Brittany](#brittany) - * [Hindent](#hindent) - * [Stylish Haskell](#stylish-haskell) - * [Haskell formatter](#haskell-formatter) -* [Proposed design](#proposed-design) - * [Parsing](#parsing) - * [CPP](#cpp) - * [Printing](#printing) - * [Configuration](#configuration) - * [Handling of language extensions](#handling-of-language-extensions) - * [Testing](#testing) - * [Functionality of executable](#functionality-of-executable) - * [Why not contribute to/fork Hindent or Brittany?](#why-not-contribute-tofork-hindent-or-brittany) -* [Examples](#examples) - -This document describes design of a new formatter for Haskell source code. -It also includes recommendations for future implementers. - -We set for the following goals (mostly taken from -[brittany](https://github.com/lspitzner/brittany)): -* Preserve the meaning of the formatted functions when no CPP is used; -* Make reasonable use of screen space; -* Use linear space and computation time on the size of the input; -* Preserve comments; -* Be idempotent. - -## Analysis of the existing solutions - -In order to design a new formatter we need to study the existing solutions -so we can borrow the good bits and avoid making the same mistakes. - -### Brittany - -[Brittany][brittany] builds on top of [`ghc-exactprint`][ghc-exactprint]—a -library that uses parser of GHC itself for parsing and thus it guarantees -that at least parsing phase is bug-free (which is admittedly the cause of -majority of bugs in other projects, see below). - -After parsing, Haskell AST and a collection of annotations are available. -The annotations are there because Haskell AST doesn't provide enough -information to reconstruct source code (for example it doesn't include -comments). The AST and the annotations are converted into a `BriDoc` value. -A `BriDoc` value is a document representation like the `Doc` from the -[pretty][pretty-doc] or the [wl-pprint][wl-pprint-doc] libraries. - -Brittany implements its own document type in an attempt to find a -satisfactory rendering of the source code that fits a page-width -constraint. Because of this, a `BriDoc` value represents a collection -of many candidate layouts (i.e. renderings) of the source code. - -This collection is pruned until it contains a single layout. The -structure of the chosen layout is then adjusted to leave it in a -form which can be easily traversed to produce the final rendering. - -Brittany invests the majority of its implementation to manage -the `BriDoc` values. Given that the amount of possible layouts is -exponential, the representation is clever enough to fit them in -linear space. There are multiple ways to build a `BriDoc`, not all -of which fit in linear space. So care is necessary to keep memory -bounded. - -The compexities of the `BriDoc` structure, together with the lack of -documentation, make Brittany at least challenging to maintain. - -### Hindent - -[Hindent][hindent] uses [`haskell-src-exts`][haskell-src-exts] for parsing -like all older projects. `haskell-src-exts` does not use parser of GHC -itself, and is a source of endless parsing bugs. `Hindent` is affected by -these upstream issues as well as Stylish Haskell and Haskell formatter (see -below). This already makes all these projects unusable with some valid -Haskell source code, but let's continue studying Hindent anyway. - -Hindent is quite different from Brittany in the sense that it does not -attempt to build a document representation to render -afterwards, instead it just prints the parsed code straight away. This means -that the 70-80% of what the code does is a printing traversal. - -Hindent code is easier to read and debug. Pretty-printing functions are -very straightforward. If there is a bug (in pretty-printer, not in parser -which Hindent cannot control), it's easy to fix AFAIU. - -Hindent is also notable for its ability to handle CPP and inputs that do not -constitute complete modules. It splits input stream into so-called “code -blocks” recognizing CPP macros and then only pretty-prints “normal code” -without touching CPP directives. After that CPP is inserted between -pretty-printed blocks of source code. The approach fails when CPP breaks -code in such a way that separate blocks do not form valid Haskell -expressions, see -[this](https://github.com/commercialhaskell/hindent/issues/383) for example. - -Looking at the bug tracker there are many bugs. Part of them is because of -the use of `haskell-src-exts`, the other part is because the maintainer -doesn't care (anymore?) and doesn't fix them. Well it's as simple as that, -with any sort of commercial backing the bugs in pretty printer would be -fixed long time ago. - -### Stylish Haskell - -[Stylish Haskell][stylish-haskell] also uses `haskell-src-exts` and suffers -from the same upstream problems. I haven't studied the transformations it -performs, but it looks like it transforms the parsed source code partially -by manipulating AST and partially by manipulating raw text (e.g. to drop -trailing whitspace from each line). CPP Macros are just filtered out -silently as a preprocessing step before feeding the code to -`haskell-src-exts`. - -Stylish Haskell is not so invasive as the other formatters and most reported -bugs are about parsing issues and CPP. As I understand it, people mostly use -it to screw their import lists. - -### Haskell formatter - -[Haskell formatter][haskell-formatter] is an older project that didn't get -much traction. It also uses `haskell-src-ext` and also tries to do -manipulations on the parsed AST. The issue tracker doesn't have many issues -probably because it never got popular enough (only 15 stars on GitHub). All -the issues are about upstream problems with `haskell-src-exts`. - -## Proposed design - -This section describes a solution that combines all the good things from the -projects above. - -### Parsing and CPP - -It is clear that `ghc-exactprint` is better than `haskell-src-exts`, so we -should use that. If we go with `ghc-exactprint` though, we'll need to -specify which parser to use, e.g. the parser that parses whole module or the -one which parsers declarations/expressions/etc. It seems that in general -it's better to use the parser for modules because it should work with all -input files containing complete modules, while with other parsers it's -impossible to guess what they'll be called on. - -### CPP - -We allow CPP directives in the input, but we forgo the goal to preserve the -meaning of the formatted functions in that case. -Instead of supporting CPP better, we hope for a solution to replace CPP to -do conditional compilation. - -There are the following challenges when formatting a module with CPP: - -* GHC parser won't accept anything but a valid, complete module. Therefore, - formatting the Haskell code between CPP directives is not an option. - -* Ignoring the CPP directives and formatting the Haskell code can change - its meaning. An example follows. - -Let's suppose that we want to format the following program: - -``` -$ cat test.hs -{-# LANGUAGE CPP #-} -main = print (g && f1) - where - f1 = h - where - h = True -#ifdef C1 -g = g1 - where - g1 = g2 - where - g2 = False -#else - g = True -#endif - -#ifndef C1 -g = False -#endif - -$ runhaskell test.hs -True -``` - -At the time of this writing, formatting this program with Hindent -or Ormolu produces the same output we would get if the CPP directives -were considered comments: - -``` -$ ormolu --version -ormolu 0.0.5.0 HEAD fc64eada5c4da7a5b07d2872e253671b48aec115 -using ghc-lib-parser 8.10.1.20200412 - -$ ormolu --mode inplace test.hs - -$ cat test.hs -{-# LANGUAGE CPP #-} - -main = print (g && f1) - where - f1 = h - where - h = True -#ifdef C1 -g = g1 - where - g1 = g2 - where - g2 = False -#else - g = True -#endif - -#ifndef C1 -g = False -#endif - -$ runhaskell test.hs -False -``` - -Running the formatter causes the output of the program to change -from `True` to `False` when `C1` is not defined. - -A solution could be to make the formatter more careful with CPP -directives, constraining how directives can be inserted in Haskell -code to avoid changing the meaning by reformatting. But -this would introduce additional complexity, and the problem would -need to be solved repeteadly for every tool out there which wants -to parse Haskell modules. If CPP is replaced with some language -extension or mechanism to do conditional compilation, all tools -will benefit from it. - -### Printing - -Just pretty-printing code (following the approach of Hindent) seems sane. It -is straightforward and when complemented with enough tests (see the section -about testing below), it should work all right. - -Implementation can be just a `Reader` monad producing something like text -builder. The context of `Reader` can store current indentation and -configuration options. - -As the pretty-printing library we can use [`Outputable`][outputable] (and -`SDoc`) from the [`ghc`][ghc] package itself (at least for pretty-printing -basic things like floating point literals and the like). The benefit is that -AST components that we'll want to print are already instances of -`Outputable`, so we'll get correct renderings for free. - -In order to keep the output of the formatter simple, fast and correct, -we introduce the following rule. The pretty-printing code can be in -control of every formatting choice, except for two, which are left to -the programmer: - -1. location of comments (comments are going to be attached to specific - syntactic entities, so moving an entity will move its comment too), -2. line breaking. - -Regarding (2), the idea is that given any syntactic entity, the programmer -has a choice: - -1. write it on one line, or -2. write it on two lines or more. - -If (1), then everything is kept in one line. If (2), i.e. a line break appears -somewhere in the concrete syntax tree (CST), then additional line breaks are -introduced everywhere possible in parent nodes, *but not in any sibling or -children nodes*. - -Examples: - -```haskell --- Stays as is. -data T = A | B - -data T - = A | B --- Is reformatted to: -data T - = A - | B - --- Stays as is. -map :: (a -> b) -> [a] -> [b] - -foldr :: (a -> b -> b) -> - b -> [a] -> [b] --- Is reformatted to: -foldr :: - (a -> b -> b) -> - b -> - [a] -> - [b] - -t = let x = foo bar - baz - in foo bar baz --- Is reformatted to: -t = - let x = - foo - bar - baz - in foo far baz -``` - -Crucially, no effort is made to fit within reasonable line lengths. That's -up to the programmer. Style will still be consistent for everyone in every -other aspect, and that's what counts. - -### Configuration - -We are not allowing to configure any aspect of the formatter. A module -might be used in multiple projects, and we prefer to have it formatted -the same in all of them. - -See this [this -post][hindent-5-blog] by Chris Done (the author of Hindent) which says that -as long as the default style is conventional and good it doesn't really -matter how code gets formatted. Consistency is more important. - -### Handling of language extensions - -Some language extensions affect how parsing is done. We are going to deal -with those in two ways: - -* When language pragmas are present in source file, we must parse them - before we run the main parser (I guess) and they should determine how the - main parsing will be done. -* There also should be configuration file that may enable other language - extensions to be used on all files. -* Later we could try to locate Cabal files and fetch the list of extensions - that are enabled by default from there. - -### Testing - -It should be possible to add tests incrementally as we develop -pretty-printing code and new issues are discovered. For each Haskell -module that we want to test, we perform the following steps: - -1. Given input snippet of source code parse it and pretty print it. -2. Parse the result of pretty-printing again and make sure that AST is the - same as AST of original snippet module span positions. We could make - this part of a self-check in the formatter. -3. Check the output against expected output. Thus all tests should include - two files: input and expected output. -4. Check that running the formatter on the output produces the same output - again (the transformation is idempotent). - -In order to grow our testsuite, we would borrow test cases from test -suites of existing libraries like Brittany and Hindent. -Then we may add test cases for opened issues that Brittany and Hindent have. - -When we're confident enough, we can start “mining” new issues by running -the program on real source code from Hackage till we don't get new issues -anymore. For every issue that we find this way, a test case should be added. - -### Functionality of executable - -* In all cases the program should test if the produced AST is the same as - the one we originally parsed and if it differs, an error should be - displayed suggesting reporting this on our issue tracker. -* Check mode: return non-zero exit code if any transformations would be - applied. -* Modification in place and printing of formatted code to stdout. -* A flag for version/commit information. -* An option to specify location of config file. -* Options to specify parameters that come from config files on command line - instead (currently this is just dynamic options enabled by default, such - as langauge extensions). - -### Why not contribute to/fork HIndent or Brittany? - -We want to simultaneously optimize three goals: - -1. simplicity of implementation, -2. efficiency, -3. predictable and readable output that doesn't overuse vertical spacing. - -Hindent aims for (1) and (2) by still producing something palatable in (3). -Brittany gives up on -(1) but goes a long way towards (3) and presumably does OK on (2). Ormolu -goes for (1), (2) and (3), by outsourcing the hard part of (3) to the user. -Ormolu is less normative than Brittany, and less normative than Hindent, -but arguably stills achieves consistent style. - -Forking or contributing to Hindent is not an option because if we replace -`haskell-src-exts` with `ghc` (or `ghc-exact-print`) then we'll have to work -with a different AST type and all the code in Hindent will become -incompatible and there won't be much code to be re-used in that case. It is -also possible that we'll find a nicer way to write pretty-printer. - -## Examples - -A list of formatting examples can be found [here](data/examples). - -[brittany]: https://hackage.haskell.org/package/brittany -[hindent]: https://hackage.haskell.org/package/hindent -[hindent-5-blog]: https://chrisdone.com/posts/hindent-5 -[stylish-haskell]: https://hackage.haskell.org/package/stylish-haskell -[haskell-formatter]: https://hackage.haskell.org/package/haskell-formatter -[ghc]: https://hackage.haskell.org/package/ghc -[outputable]: https://hackage.haskell.org/package/ghc-8.4.3/docs/Outputable.html -[haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts -[ghc-exactprint]: https://hackage.haskell.org/package/ghc-exactprint -[hindent-printer]: https://github.com/commercialhaskell/hindent/blob/master/src/HIndent/Pretty.hs -[pretty-doc]: http://hackage.haskell.org/package/pretty-1.1.3.6/docs/Text-PrettyPrint.html#t:Doc -[wl-pprint-doc]: http://hackage.haskell.org/package/wl-pprint-1.2.1/docs/Text-PrettyPrint-Leijen.html#t:Doc diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,16 +1,14 @@ -# ~~Ormolu~~ Fourmolu +# Fourmolu [![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) -[![Hackage](https://img.shields.io/hackage/v/ormolu.svg?style=flat)](https://hackage.haskell.org/package/ormolu) -[![Stackage Nightly](http://stackage.org/package/ormolu/badge/nightly)](http://stackage.org/nightly/package/ormolu) -[![Stackage LTS](http://stackage.org/package/ormolu/badge/lts)](http://stackage.org/lts/package/ormolu) -[![Build status](https://badge.buildkite.com/8e3b0951f3652b77e1c422b361904136a539b0522029156354.svg?branch=master)](https://buildkite.com/tweag-1/ormolu) +[![Hackage](https://img.shields.io/hackage/v/fourmolu.svg?style=flat)](https://hackage.haskell.org/package/fourmolu) -~~Ormolu~~ Fourmolu is a formatter for Haskell source code. The project was created with -the following goals in mind: +Fourmolu is a formatter for Haskell source code. It is a fork of [Ormolu](https://github.com/tweag/ormolu), with the intention to continue to merge upstream improvements. +We share all bar one of Ormolu's goals: + * Using GHC's own parser to avoid parsing problems caused by - [`haskell-src-exts`][haskell-src-exts]. + [`haskell-src-exts`](https://hackage.haskell.org/package/haskell-src-exts). * Let some whitespace be programmable. The layout of the input influences the layout choices in the output. This means that the choices between single-line/multi-line layouts in each particular situation are made by @@ -18,154 +16,108 @@ leaves some control to the user while still guaranteeing that the formatted code is stylistically consistent. * Writing code in such a way so it's easy to modify and maintain. -* Implementing one “true” formatting style ~~which admits no configuration~~ requires you to fork the project to configure it (TODO: add a config file). * That formatting style aims to result in minimal diffs while still remaining very close to “conventional” Haskell formatting people use. * Choose a style compatible with modern dialects of Haskell. As new Haskell - extensions enter broad use, we may change the style to accomodate them. + extensions enter broad use, we may change the style to accommodate them. * Idempotence: formatting already formatted code doesn't change it. * Be well-tested and robust to the point that it can be used in large projects without exposing unfortunate, disappointing bugs here and there. - -## Building - -The easiest way to build the project is with Nix: +* ~~Implementing one “true” formatting style which admits no configuration.~~ We allow configuration of various parameters, via CLI options or config files. We encourage any contributions which add further flexibility. -```console -$ nix-build -A ormolu -``` +## Configuration -Or with `cabal-install` from the Nix shell: +Fourmolu looks for a `fourmolu.yaml` file in all parents of the current directory, followed by [the XDG config directory](https://hackage.haskell.org/package/directory/docs/System-Directory.html#v:XdgConfig). A complete configuration file, corresponding to Fourmolu's default options, looks like: -```console -$ nix-shell --run "cabal new-build" +```yaml +indentation: 4 +comma-style: leading # for lists, tuples etc. - can also be 'trailing' +record-brace-space: false # rec {x = 1} vs. rec{x = 1} +indent-wheres: false # 'false' means save space by only half-indenting the 'where' keyword +diff-friendly-import-export: true # 'false' uses Ormolu-style lists +respectful: true # don't be too opinionated about newlines etc. +haddock-style: multi-line # '--' vs. '{-' ``` -Alternatively, `stack` could be used with a `stack.yaml` file as follows. - -```console -$ cat stack.yaml -resolver: lts-14.3 -packages: -- '.' +See [here](fourmolu.yaml) for a config to simulate the behaviour of Ormolu. -$ stack build -``` +These options can also be set on the command line (which takes precedence over config files). Run `fourmolu -h` to see all options. -To use Ormolu directly from GitHub with Nix, this snippet may come in handy: +## Building -```nix -# This overlay adds Ormolu straight from GitHub. -self: super: +Simply run `cabal v2-install fourmolu`, to install the latest release from Hackage. -let source = super.fetchFromGitHub { - owner = "tweag"; - repo = "ormolu"; - rev = "de279d80122b287374d4ed87c7b630db1f157642"; # update as necessary - sha256 = "0qrxfk62ww6b60ha9sqcgl4nb2n5fhf66a65wszjngwkybwlzmrv"; # as well - }; - ormolu = import source { pkgs = self; }; -in { - haskell = super.haskell // { - packages = super.haskell.packages // { - "${ormolu.ormoluCompiler}" = super.haskell.packages.${ormolu.ormoluCompiler}.override { - overrides = ormolu.ormoluOverlay; - }; - }; - }; -} -``` +You can also clone this repository, then build with Cabal or Stack. ## Usage The following will print the formatted output to the standard output. ```console -$ ormolu Module.hs +$ fourmolu Module.hs ``` -Add `--mode inplace` to replace the contents of the input file with the -formatted output. +Add `-i` (or `--mode inplace`) to replace the contents of the input file with the formatted output. ```console -$ ormolu --mode inplace Module.hs +$ fourmolu -i Module.hs ``` Use `find` to format a tree recursively: ```console -$ ormolu --mode inplace $(find . -name '*.hs') +$ fourmolu -i $(find . -name '*.hs') ``` +Fourmolu can be integrated with your editor via the [Haskell Language Server](https://github.com/haskell/haskell-language-server). + ## Magic comments -Ormolu understands two magic comments: +Fourmolu understands two magic comments: ```haskell -{- ORMOLU_DISABLE -} +{- FOURMOLU_DISABLE -} ``` and ```haskell -{- ORMOLU_ENABLE -} +{- FOURMOLU_ENABLE -} ``` This allows us to disable formatting selectively for code between these markers or disable it for the entire file. To achieve the latter, just put -`{- ORMOLU_DISABLE -}` at the very top. Note that the source code should -still be parseable even without the “excluded” part. Because of that the -magic comments cannot be placed arbitrary, but should rather enclose -independent top-level definitions. +`{- FOURMOLU_DISABLE -}` at the very top. Note that for Fourmolu to work the +source code must still be parseable even when the disabled regions are +omitted. Because of that the magic comments cannot be placed arbitrarily, +but rather must enclose independent top-level definitions. +`{- ORMOLU_DISABLE -}` and `{- ORMOLU_ENABLE -}`, respectively, can be used to the same effect. + ## Current limitations * CPP support is experimental. CPP is virtually impossible to handle correctly, so we process them as a sort of unchangeable snippets. This works only in simple cases when CPP conditionals surround top-level - declarations. See the [CPP][design-cpp] section in the design notes for + declarations. See the [CPP](https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp) section in the design notes for a discussion of the dangers. * Input modules should be parsable by Haddock, which is a bit stricter criterion than just being valid Haskell modules. * Various minor idempotence issues, most of them are related to comments. - -## Editor integration - -We know of the following editor integrations: - -* [Emacs][emacs-package] -* [VS Code][vs-code-plugin] -* vim: [neoformat][neoformat], [vim-ormolu][vim-ormolu] - -## Running on Hackage - -It's possible to try Ormolu on arbitrary packages from Hackage. For that -execute (from the root of the cloned repo): - -```console -$ nix-build -A hackage. -``` - -Then inspect `result/log.txt` for possible problems. The derivation will -also contain formatted `.hs` files for inspection and original inputs with -`.hs-original` extension (those are with CPP dropped, exactly what is fed -into Ormolu). +* Fourmolu is in a fairly early stage of development. The implementation should be as stable as Ormolu, as it only makes minimal changes, and is extensively tested. But the default configuration style may change in some minor ways in the near future, as we make more options available. It will always be possible to replicate the old default behaviour with a suitable `fourmolu.yaml`. ## Contributing -See [CONTRIBUTING.md][contributing]. +If there are any options you'd like to see, let us know. If it's not too complicated to implement (and especially if you implement it yourself!) then we'll probably add it. +Run `cabal test` and `./format.sh` before submitting any pull requests. + ## License -See [LICENSE.md][license]. +See [LICENSE.md](LICENSE.md). -Copyright © 2018–present Tweag I/O +Copyright © 2018–2020 Tweag I/O, 2020-present Matt Parsons -[design-cpp]: https://github.com/tweag/ormolu/blob/master/DESIGN.md#cpp -[contributing]: https://github.com/tweag/ormolu/blob/master/CONTRIBUTING.md -[license]: https://github.com/tweag/ormolu/blob/master/LICENSE.md -[haskell-src-exts]: https://hackage.haskell.org/package/haskell-src-exts -[emacs-package]: https://github.com/vyorkin/ormolu.el -[vs-code-plugin]: https://marketplace.visualstudio.com/items?itemName=sjurmillidahl.ormolu-vscode -[vim-ormolu]: https://github.com/sdiehl/vim-ormolu -[neoformat]: https://github.com/sbdchd/neoformat +## Acknowledgements + +The vast majority of work here has been done by the Ormolu developers, and thus they deserve almost all of the credit. This project is simply intended as a haven for those of us who admire their work, but can't quite get on board with some of their decisions when it comes down to the details. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} @@ -8,36 +9,45 @@ import Control.Exception (SomeException, displayException, try) import Control.Monad +import Data.Bool (bool) +import Data.Char (toLower) import Data.Either (lefts) import Data.List (intercalate, sort) +import Data.Maybe (fromMaybe) import qualified Data.Text.IO as TIO import Data.Version (showVersion) import Development.GitRev import Options.Applicative import Ormolu +import Ormolu.Config import Ormolu.Parser (manualExts) import Ormolu.Utils (showOutputable) import Paths_fourmolu (version) +import System.Directory (getCurrentDirectory) import System.Exit (ExitCode (..), exitWith) import System.IO (hPutStrLn, stderr) -- | Entry point of the program. main :: IO () main = withPrettyOrmoluExceptions $ do - Opts {..} <- execParser optsParserInfo - let formatOne' path = do - printerOpts <- - loadConfigFile (cfgDebug optConfig) path $ cfgPrinterOpts optConfig - formatOne optMode optConfig {cfgPrinterOpts = printerOpts} path + opts@Opts {..} <- execParser optsParserInfo + let formatStdIn = do + cur <- getCurrentDirectory + cfg <- mkConfig cur opts + formatOne optMode cfg Nothing case optInputFiles of - [] -> formatOne' Nothing - ["-"] -> formatOne' Nothing - [x] -> formatOne' (Just x) - xs -> do + [] -> formatStdIn + ["-"] -> formatStdIn + [x] -> flip (formatOne optMode) (Just x) =<< mkConfig x opts + xs@(x : _) -> do + cfg <- mkConfig x opts -- It is possible to get IOException, error's and 'OrmoluException's -- from 'formatOne', so we just catch everything. errs <- - lefts <$> mapM (try @SomeException . formatOne' . Just) (sort xs) + lefts + <$> mapM + (try @SomeException . formatOne optMode cfg . Just) + (sort xs) unless (null errs) $ do mapM_ (hPutStrLn stderr . displayException) errs exitWith (ExitFailure 102) @@ -63,15 +73,19 @@ -- 101 is different from all the other exit codes we already use. exitWith (ExitFailure 101) Just inputFile -> do - r <- ormoluFile config inputFile + originalInput <- TIO.readFile inputFile + formattedInput <- ormoluFile config inputFile case mode of Stdout -> - TIO.putStr r - InPlace -> - TIO.writeFile inputFile r + TIO.putStr formattedInput + InPlace -> do + -- Only write when the contents have changed, in order to avoid + -- updating the modified timestamp if the file was already correctly + -- formatted. + when (formattedInput /= originalInput) $ + TIO.writeFile inputFile formattedInput Check -> do - r' <- TIO.readFile inputFile - when (r /= r') $ + when (formattedInput /= originalInput) $ -- 100 is different to all the other exit code that are emitted -- either from an 'OrmoluException' or from 'error' and -- 'notImplemented'. @@ -85,6 +99,8 @@ optMode :: !Mode, -- | Ormolu 'Config' optConfig :: !(Config RegionIndices), + -- | Fourmolu-specific options + optPrinterOpts :: !PrinterOptsPartial, -- | Haskell source files to format or stdin (when the list is empty) optInputFiles :: ![FilePath] } @@ -119,7 +135,7 @@ intercalate "\n" [ unwords - [ "ormolu", + [ "fourmolu", showVersion version, $gitBranch, $gitHash @@ -137,14 +153,20 @@ optsParser :: Parser Opts optsParser = Opts - <$> (option parseMode . mconcat) - [ long "mode", - short 'm', - metavar "MODE", - value Stdout, - help "Mode of operation: 'stdout' (default), 'inplace', or 'check'" - ] + <$> ( (fmap (bool Stdout InPlace) . switch . mconcat) + [ short 'i', + help "A shortcut for --mode inplace" + ] + <|> (option parseMode . mconcat) + [ long "mode", + short 'm', + metavar "MODE", + value Stdout, + help "Mode of operation: 'stdout' (default), 'inplace', or 'check'" + ] + ) <*> configParser + <*> printerOptsParser <*> (many . strArgument . mconcat) [ metavar "FILE", help "Haskell source files to format or stdin (default)" @@ -188,6 +210,56 @@ ) <*> pure defaultPrinterOpts +printerOptsParser :: Parser PrinterOptsPartial +printerOptsParser = do + poIndentation <- + (optional . option auto . mconcat) + [ long "indentation", + metavar "WIDTH", + help "Number of spaces per indentation step (default 4)" + ] + poCommaStyle <- + (optional . option parseCommaStyle . mconcat) + [ long "comma-style", + metavar "STYLE", + help "How to place commas in multi-line lists, records etc: 'leading' (default) or 'trailing'" + ] + poIndentWheres <- + (optional . option parseBool . mconcat) + [ long "indent-wheres", + metavar "BOOL", + help $ + "Whether to indent 'where' bindings past the preceding body" + <> " (rather than half-indenting the 'where' keyword) (default 'false')" + ] + poRecordBraceSpace <- + (optional . option parseBool . mconcat) + [ long "record-brace-space", + metavar "BOOL", + help "Whether to leave a space before an opening record brace (default 'false')" + ] + poDiffFriendlyImportExport <- + (optional . option parseBool . mconcat) + [ long "diff-friendly-import-export", + metavar "BOOL", + help $ + "Whether to make use of extra commas in import/export lists" + <> " (as opposed to Ormolu's style) (default 'true')" + ] + poRespectful <- + (optional . option parseBool . mconcat) + [ long "respectful", + metavar "BOOL", + help "Give the programmer more choice on where to insert blank lines (default 'true')" + ] + poHaddockStyle <- + (optional . option parseHaddockStyle . mconcat) + [ long "haddock-style", + metavar "STYLE", + help "How to print Haddock comments (default 'multi-line')" + ] + pure PrinterOpts {..} + ---------------------------------------------------------------------------- -- Helpers @@ -198,3 +270,57 @@ "inplace" -> Right InPlace "check" -> Right Check s -> Left $ "unknown mode: " ++ s + +-- | Parse 'CommaStyle'. +parseCommaStyle :: ReadM CommaStyle +parseCommaStyle = eitherReader $ \case + "leading" -> Right Leading + "trailing" -> Right Trailing + s -> Left $ "unknown comma style: " ++ s + +-- | Parse 'HaddockStyle'. +parseHaddockStyle :: ReadM HaddockPrintStyle +parseHaddockStyle = eitherReader $ \case + "single-line" -> Right HaddockSingleLine + "multi-line" -> Right HaddockMultiLine + s -> Left $ "unknown haddock style: " ++ s + +-- | Parse a 'Bool'. Unlike 'auto', this is not case sensitive. +parseBool :: ReadM Bool +parseBool = eitherReader $ \x -> case map toLower x of + "false" -> Right False + "true" -> Right True + s -> Left $ "not a boolean value: " ++ s + +-- | Build the full config, by adding 'PrinterOpts' from a file, if found. +mkConfig :: FilePath -> Opts -> IO (Config RegionIndices) +mkConfig path Opts {..} = do + filePrinterOpts <- + loadConfigFile path >>= \case + ConfigLoaded f po -> do + hPutStrLn stderr $ "Loaded config from: " <> f + printDebug $ show po + return $ Just po + ConfigParseError f (_pos, err) -> do + -- we ignore '_pos' due to the note on 'Data.YAML.Aeson.decode1' + hPutStrLn stderr $ + unlines + [ "Failed to load " <> f <> ":", + " " <> err + ] + exitWith $ ExitFailure 400 + ConfigNotFound searchDirs -> do + printDebug + . unlines + $ ("No " ++ show configFileName ++ " found in any of:") : + map (" " ++) searchDirs + return Nothing + return $ + optConfig + { cfgPrinterOpts = + fillMissingPrinterOpts + (optPrinterOpts <> fromMaybe mempty filePrinterOpts) + (cfgPrinterOpts optConfig) + } + where + printDebug = when (cfgDebug optConfig) . hPutStrLn stderr diff --git a/data/examples/declaration/annotation/annotation-four-out.hs b/data/examples/declaration/annotation/annotation-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/annotation/annotation-four-out.hs @@ -0,0 +1,22 @@ +{-# ANN module (5 :: Int) #-} + +{-# ANN + module + ( 5 :: + Int + ) + #-} + +{-# ANN foo "hey" #-} +foo :: Int +foo = 5 + +{-# ANN + Char + (Just 42) + #-} + +data Foo = Foo Int +{-# ANN type Foo ("HLint: ignore") #-} + +{- Comment -} diff --git a/data/examples/declaration/class/associated-data1-four-out.hs b/data/examples/declaration/class/associated-data1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/associated-data1-four-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} + +class Foo a where data FooBar a + +-- | Something. +class Bar a where + -- | Bar bar + data BarBar a + + -- | Bar baz + data + BarBaz + a diff --git a/data/examples/declaration/class/associated-data2-four-out.hs b/data/examples/declaration/class/associated-data2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/associated-data2-four-out.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeFamilies #-} + +module Main where + +-- | Something more. +class Baz a where + -- | Baz bar + data + BazBar + a + b + c + + -- | Baz baz + data + BazBaz + b + a + c diff --git a/data/examples/declaration/class/associated-type-defaults-four-out.hs b/data/examples/declaration/class/associated-type-defaults-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/associated-type-defaults-four-out.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeFamilies #-} + +class Foo a where type FooBar a = Int + +-- | Something. +class Bar a where + -- Define bar + type + BarBar a = + BarBaz a + + -- Define baz + type + BarBaz + a = + BarBar -- Middle comment + a + +class Baz a where + type + BazBar + a + + type + BazBar a = + Bar a diff --git a/data/examples/declaration/class/associated-types1-four-out.hs b/data/examples/declaration/class/associated-types1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/associated-types1-four-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} + +class Foo a where type FooBar a + +-- | Something. +class Bar a where + -- | Bar bar + type BarBar a + + -- | Bar baz + type + BarBaz + a diff --git a/data/examples/declaration/class/associated-types2-four-out.hs b/data/examples/declaration/class/associated-types2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/associated-types2-four-out.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeFamilies #-} + +module Main where + +-- | Something more. +class Baz a where + -- | Baz bar + type + BazBar + a -- Foo + b -- Bar + c + + -- | Baz baz + type + -- After type + BazBaz + b + a + c diff --git a/data/examples/declaration/class/default-implementations-comments-four-out.hs b/data/examples/declaration/class/default-implementations-comments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/default-implementations-comments-four-out.hs @@ -0,0 +1,26 @@ +module Main where + +-- | Baz +class Baz a where + foobar :: a -> a + foobar a = + barbaz (bazbar a) + + -- | Bar baz + barbaz :: + a -> a + + -- | Baz bar + bazbar :: + a -> + a + + -- First comment + barbaz a = + bazbar -- Middle comment + a + + -- Last comment + bazbar a = + barbaz + a diff --git a/data/examples/declaration/class/default-implementations-four-out.hs b/data/examples/declaration/class/default-implementations-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/default-implementations-four-out.hs @@ -0,0 +1,13 @@ +module Main where + +-- | Foo +class Foo a where + foo :: a -> a + foo a = a + +-- | Bar +class Bar a where + bar :: + a -> + Int + bar = const 0 diff --git a/data/examples/declaration/class/default-signatures-four-out.hs b/data/examples/declaration/class/default-signatures-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/default-signatures-four-out.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DefaultSignatures #-} + +module Main where + +-- | Something else. +class Bar a where + -- | Bar + bar :: + String -> + String -> + a + -- Pointless comment + default bar :: + ( Read a + , Semigroup a + ) => + a -> + a -> + a + -- Even more pointless comment + bar + a + b = + read a <> read b diff --git a/data/examples/declaration/class/default-signatures-simple-four-out.hs b/data/examples/declaration/class/default-signatures-simple-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/default-signatures-simple-four-out.hs @@ -0,0 +1,8 @@ +module Main where + +-- | Something. +class Foo a where + -- | Foo + foo :: a -> String + default foo :: Show a => a -> String + foo = show diff --git a/data/examples/declaration/class/dependency-super-classes-four-out.hs b/data/examples/declaration/class/dependency-super-classes-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/dependency-super-classes-four-out.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FunctionalDependencies #-} + +module Main where + +-- | Something. +class (MonadReader r s, MonadWriter w m) => MonadState s m | m -> s where + get :: m s + put :: s -> m () + +-- | 'MonadParsec' +class + ( Stream s -- Token streams + , MonadPlus m -- Potential for failure + ) => + MonadParsec e s m + | m -> e s + where + -- | 'getState' returns state + getState :: + m s + + -- | 'putState' sets state + putState :: + s -> + m () diff --git a/data/examples/declaration/class/empty-classes-four-out.hs b/data/examples/declaration/class/empty-classes-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/empty-classes-four-out.hs @@ -0,0 +1,7 @@ +module Main where + +-- | Foo! +class Foo a + +-- | Bar! +class Bar a diff --git a/data/examples/declaration/class/functional-dependencies-four-out.hs b/data/examples/declaration/class/functional-dependencies-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/functional-dependencies-four-out.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FunctionalDependencies #-} + +module Main where + +-- | Something. +class Foo a b | a -> b + +class Bar a b | a -> b, b -> a where bar :: a + +-- | Something else. +class + Baz a b c d + | a b -> c d -- Foo + , b c -> a d -- Bar + , a c -> b d -- Baz + , a c d -> b + , a b d -> a b c d + where + baz :: a -> b diff --git a/data/examples/declaration/class/multi-parameters1-four-out.hs b/data/examples/declaration/class/multi-parameters1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/multi-parameters1-four-out.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +class Foo a b where foo :: a -> b + +-- | Something. +class Bar a b c d where + bar :: + a -> + b -> + c -> + d + +class -- Before name + Baz where + baz :: Int diff --git a/data/examples/declaration/class/multi-parameters2-four-out.hs b/data/examples/declaration/class/multi-parameters2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/multi-parameters2-four-out.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Main where + +-- | Something else. +class + BarBaz + a -- Foo + b -- Bar + c -- Baz bar + d -- Baz baz + e -- Rest + f + where + barbaz :: + a -> f + bazbar :: + e -> + f diff --git a/data/examples/declaration/class/newlines-after-where-four-out.hs b/data/examples/declaration/class/newlines-after-where-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/newlines-after-where-four-out.hs @@ -0,0 +1,5 @@ +class Num a where + (+) :: a -> a -> a + +class Num a where + (+) :: a -> a -> a diff --git a/data/examples/declaration/class/newlines-and-default-decls-four-out.hs b/data/examples/declaration/class/newlines-and-default-decls-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/newlines-and-default-decls-four-out.hs @@ -0,0 +1,11 @@ +class Foo a where + foo :: a + default foo :: () + foo = () + bar :: a + default bar :: () + bar = () + + qux :: a + default qux :: () + qux = () diff --git a/data/examples/declaration/class/newlines-and-haddocks-four-out.hs b/data/examples/declaration/class/newlines-and-haddocks-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/newlines-and-haddocks-four-out.hs @@ -0,0 +1,23 @@ +class Foo a where + -- | Haddock + foo :: a + + -- | Another Haddock + bar :: a + + baz :: a + -- ^ Post-Haddock + + raz :: a + -- ^ Another Post-Haddock + + -- | One more Haddock + qux :: a + + -- Comment before a Haddock + + -- | And one more Haddock + xyz :: a + + -- | Haddock followed by a blank line + abc :: a diff --git a/data/examples/declaration/class/newlines-between-methods-four-out.hs b/data/examples/declaration/class/newlines-between-methods-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/newlines-between-methods-four-out.hs @@ -0,0 +1,17 @@ +class Num a where + (+) :: a -> a -> a + (-) :: a -> a -> a + (*) :: a -> a -> a + + -- Comment before definition + negate :: a -> a + + -- Comment after definition + + -- Separator + + abs :: a -> a + signum :: a -> a + + -- Comment between unrelated definitions + fromInteger :: Integer -> a diff --git a/data/examples/declaration/class/poly-kinded-classes-four-out.hs b/data/examples/declaration/class/poly-kinded-classes-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/poly-kinded-classes-four-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PolyKinds #-} + +class Foo (a :: k) + +class + Bar + ( a :: -- Variable + * -- Star + ) diff --git a/data/examples/declaration/class/single-parameters-four-out.hs b/data/examples/declaration/class/single-parameters-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/single-parameters-four-out.hs @@ -0,0 +1,26 @@ +module Main where + +-- | Something. +class Foo a where foo :: a + +-- | Something more. +class Bar a where + -- | Bar + bar :: a -> a -> a + +class Baz a where + -- | Baz + baz :: + -- | First argument + ( a + , a + ) -> + -- | Second argument + a -> + -- | Return value + a + +class BarBaz a where + barbaz :: + a -> b + bazbar :: b -> a diff --git a/data/examples/declaration/class/super-classes-four-out.hs b/data/examples/declaration/class/super-classes-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/super-classes-four-out.hs @@ -0,0 +1,11 @@ +class Foo a +class Foo a => Bar a +class + (Foo a, Bar a) => + Baz a +class + ( Foo a -- Foo? + , Bar a -- Bar? + , Baz a -- Baz + ) => + BarBar a diff --git a/data/examples/declaration/class/type-operators1-four-out.hs b/data/examples/declaration/class/type-operators1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/type-operators1-four-out.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} + +class (:$) a b + +class + (:&) + a + b + +class a :* b + +class + a -- Before operator + :+ b -- After operator + +class + ( f + :. g + ) + a diff --git a/data/examples/declaration/class/type-operators2-four-out.hs b/data/examples/declaration/class/type-operators2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/type-operators2-four-out.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} + +class a `Pair` b + +class + a + `Sum` b + +class (f `Product` g) a + +class + ( f + `Sum` g + ) + a diff --git a/data/examples/declaration/class/type-operators3-four-out.hs b/data/examples/declaration/class/type-operators3-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/class/type-operators3-four-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoStarIsType #-} + +class PNum x where + type (a :: x) * (b :: x) + +instance PNum Nat where + type a * b = () diff --git a/data/examples/declaration/data/deriving-four-out.hs b/data/examples/declaration/data/deriving-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/deriving-four-out.hs @@ -0,0 +1,2 @@ +newtype R r a = R (ReaderT r IO a) + deriving (MonadReader r) diff --git a/data/examples/declaration/data/deriving-strategies-four-out.hs b/data/examples/declaration/data/deriving-strategies-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/deriving-strategies-four-out.hs @@ -0,0 +1,14 @@ +module Main where + +-- | Something. +newtype Foo = Foo Int + deriving stock (Eq, Show, Generic) + deriving anyclass + ( ToJSON + , FromJSON + ) + deriving newtype (Num) + deriving (Monoid) via (Sum Int) + deriving + (Semigroup) + via (Sum Int) diff --git a/data/examples/declaration/data/empty-four-out.hs b/data/examples/declaration/data/empty-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/empty-four-out.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE EmptyDataDecls #-} + +data Foo diff --git a/data/examples/declaration/data/existential-four-out.hs b/data/examples/declaration/data/existential-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/existential-four-out.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ExistentialQuantification #-} + +data Foo = forall a. MkFoo a (a -> Bool) + +data Bar = forall a b. a + b => Bar a b diff --git a/data/examples/declaration/data/existential-multiline-four-out.hs b/data/examples/declaration/data/existential-multiline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/existential-multiline-four-out.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ExistentialQuantification #-} + +data Foo + = forall a. MkFoo a (a -> Bool) + | forall a. Eq a => MkBar a + +data Bar + = forall x y. + Bar x y x y + +data Baz + = forall x y. + Baz + x + y + x + y diff --git a/data/examples/declaration/data/fat-multiline-four-out.hs b/data/examples/declaration/data/fat-multiline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/fat-multiline-four-out.hs @@ -0,0 +1,12 @@ +module Main where + +-- | Something. +data Foo + = -- | Foo + Foo + Int + Int + | -- | Bar + Bar + Bool + Bool diff --git a/data/examples/declaration/data/gadt-syntax-four-out.hs b/data/examples/declaration/data/gadt-syntax-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/gadt-syntax-four-out.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE GADTSyntax #-} + +data Foo where MKFoo :: a -> (a -> Bool) -> Foo diff --git a/data/examples/declaration/data/gadt/multiline-four-out.hs b/data/examples/declaration/data/gadt/multiline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/gadt/multiline-four-out.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ExplicitForAll #-} + +module Main where + +-- | Here goes a comment. +data Foo a where + -- | 'Foo' is wonderful. + Foo :: + forall a b. + (Show a, Eq b) => -- foo + -- bar + a -> + b -> + Foo 'Int + -- | But 'Bar' is also not too bad. + Bar :: + Int -> + Maybe Text -> + Foo 'Bool + -- | So is 'Baz'. + Baz :: + forall a. + a -> + Foo 'String + (:~>) :: Foo a -> Foo a -> Foo a diff --git a/data/examples/declaration/data/gadt/multiline-where-four-out.hs b/data/examples/declaration/data/gadt/multiline-where-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/gadt/multiline-where-four-out.hs @@ -0,0 +1,7 @@ +data + Foo + a + b + c + where + Foo :: a -> b -> c -> Foo a b c diff --git a/data/examples/declaration/data/gadt/multiple-declaration-four-out.hs b/data/examples/declaration/data/gadt/multiple-declaration-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/gadt/multiple-declaration-four-out.hs @@ -0,0 +1,15 @@ +data GADT0 a where + GADT01, GADT02 :: Int -> GADT0 a + +data GADT1 a where + GADT11 + , GADT12 :: + Int -> + GADT1 a + +data GADT2 a where + GADT21 + , GADT21 + , GADT22 :: + Int -> + GADT2 a diff --git a/data/examples/declaration/data/gadt/record-four-out.hs b/data/examples/declaration/data/gadt/record-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/gadt/record-four-out.hs @@ -0,0 +1,14 @@ +module Main where + +-- | Something. +data Foo where + Foo :: {fooX :: Int} -> Foo + Bar :: + { fooY :: Int + , fooBar, fooBaz :: Bool + , fooFoo + , barBar + , bazBaz :: + Int + } -> + Foo diff --git a/data/examples/declaration/data/gadt/simple-four-out.hs b/data/examples/declaration/data/gadt/simple-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/gadt/simple-four-out.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ExplicitForAll #-} + +module Main where + +-- | Here goes a comment. +data Foo a where + -- | 'Foo' is wonderful. + Foo :: forall a b. (Show a, Eq b) => a -> b -> Foo 'Int + Bar :: + Int -> + Text -> + -- | But 'Bar' is also not too bad. + Foo 'Bool + Baz :: + forall a. + a -> + -- | So is 'Baz'. + Foo 'String diff --git a/data/examples/declaration/data/gadt/strictness-four-out.hs b/data/examples/declaration/data/gadt/strictness-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/gadt/strictness-four-out.hs @@ -0,0 +1,3 @@ +data Foo a where + Foo1 :: !Int -> {-# UNPACK #-} !Bool -> Foo Int + Foo2 :: {-# UNPACK #-} Maybe Int && Bool -> Foo Int diff --git a/data/examples/declaration/data/infix-four-out.hs b/data/examples/declaration/data/infix-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/infix-four-out.hs @@ -0,0 +1,1 @@ +data Foo a b = a `Foo` b diff --git a/data/examples/declaration/data/kind-annotations-four-out.hs b/data/examples/declaration/data/kind-annotations-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/kind-annotations-four-out.hs @@ -0,0 +1,10 @@ +data Something (n :: Nat) = Something + +data Format (k :: *) (k' :: *) (k'' :: *) + +type Parens1 = Proxy '(a :: A, b :: (B :: *)) +type Parens2 = Proxy '((a :: A), (b :: B)) + +type family Foo a where + Foo '(a :: Int, b :: Bool) = Int + Foo '((a :: Int), (b :: Bool)) = Int diff --git a/data/examples/declaration/data/multiline-arg-parens-four-out.hs b/data/examples/declaration/data/multiline-arg-parens-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/multiline-arg-parens-four-out.hs @@ -0,0 +1,10 @@ +module Main where + +-- | Something. +data Foo + = Foo + Bar + (Set Baz) -- and here we go + -- and that's it + Text + deriving (Eq) diff --git a/data/examples/declaration/data/multiline-four-out.hs b/data/examples/declaration/data/multiline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/multiline-four-out.hs @@ -0,0 +1,12 @@ +module Main where + +-- | Here we have 'Foo'. +data Foo + = -- | One + Foo + | -- | Two + Bar Int + | -- | Three + Baz + deriving + (Eq, Show) diff --git a/data/examples/declaration/data/multiline-names-four-out.hs b/data/examples/declaration/data/multiline-names-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/multiline-names-four-out.hs @@ -0,0 +1,29 @@ +data + Foo + a + b + = Foo a b + +data a :-> b = Arrow (a -> b) + +data (f :* g) a = f a :* g a + +data + ( f + :+ g + ) + a + = L (f a) + | R (g a) + +data a `Arrow` b = Arrow' (a -> b) + +data (f `Product` g) a = f a `Product` g a + +data + ( f + `Sum` g + ) + a + = L' (f a) + | R' (g a) diff --git a/data/examples/declaration/data/newtype-four-out.hs b/data/examples/declaration/data/newtype-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/newtype-four-out.hs @@ -0,0 +1,5 @@ +module Main where + +-- | Something. +newtype Foo = Foo Int + deriving (Eq, Show) diff --git a/data/examples/declaration/data/operators-four-out.hs b/data/examples/declaration/data/operators-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/operators-four-out.hs @@ -0,0 +1,12 @@ +data ErrorMessage' s + = -- | Show the text as is. + Text s + | -- | Pretty print the type. + -- @ShowType :: k -> ErrorMessage@ + forall t. ShowType t + | -- | Put two pieces of error message next + -- to each other. + ErrorMessage' s :<>: ErrorMessage' s + | -- | Stack two pieces of error message on top + -- of each other. + ErrorMessage' s :$$: ErrorMessage' s diff --git a/data/examples/declaration/data/partly-documented-four-out.hs b/data/examples/declaration/data/partly-documented-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/partly-documented-four-out.hs @@ -0,0 +1,5 @@ +data Optimisation + = PETransform + | -- | partial eval and associated transforms + GeneralisedNatHack + deriving (Show, Eq, Generic) diff --git a/data/examples/declaration/data/record-four-out.hs b/data/examples/declaration/data/record-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/record-four-out.hs @@ -0,0 +1,23 @@ +module Main where + +-- | Something. +data Foo = Foo + { -- | X + fooX :: Int + , -- | Y + fooY :: Int + , -- | BarBaz + fooBar, fooBaz :: NonEmpty (Identity Bool) + , -- | GagGog + fooGag + , fooGog :: + NonEmpty + ( Indentity + Bool + ) + , -- | Huh! + fooFoo + , barBar :: + Int + } + deriving (Eq, Show) diff --git a/data/examples/declaration/data/record-multi-const-four-out.hs b/data/examples/declaration/data/record-multi-const-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/record-multi-const-four-out.hs @@ -0,0 +1,17 @@ +module Main where + +-- | Something. +data Foo + = Foo + { -- | X + fooX :: Int + , -- | Y + fooY :: Int + } + | Bar + { -- | X + barX :: Int + , -- | Y + barY :: Int + } + deriving (Eq, Show) diff --git a/data/examples/declaration/data/record-singleline-four-out.hs b/data/examples/declaration/data/record-singleline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/record-singleline-four-out.hs @@ -0,0 +1,5 @@ +module Main where + +-- | Something. +data Foo = Foo {fooX :: Int, fooY :: Int} + deriving (Eq, Show) diff --git a/data/examples/declaration/data/simple-broken-four-out.hs b/data/examples/declaration/data/simple-broken-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/simple-broken-four-out.hs @@ -0,0 +1,9 @@ +module Main where + +-- | Here we go. +data Foo = Foo {unFoo :: Int} + deriving (Eq) + +-- | And once again. +data Bar = Bar {unBar :: Int} + deriving (Eq) diff --git a/data/examples/declaration/data/simple-four-out.hs b/data/examples/declaration/data/simple-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/simple-four-out.hs @@ -0,0 +1,5 @@ +module Main where + +-- | And here we have 'Foo'. +data Foo = Foo | Bar Int | Baz + deriving (Eq, Show) diff --git a/data/examples/declaration/data/strictness-four-out.hs b/data/examples/declaration/data/strictness-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/strictness-four-out.hs @@ -0,0 +1,6 @@ +module Main where + +-- | Something. +data Foo + = Foo1 !Int {-# UNPACK #-} !Bool {-# NOUNPACK #-} !String + | Foo2 {a :: {-# UNPACK #-} Maybe Int && Bool} diff --git a/data/examples/declaration/data/unnamed-field-comment-0-four-out.hs b/data/examples/declaration/data/unnamed-field-comment-0-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-0-four-out.hs @@ -0,0 +1,7 @@ +data Foo + = -- | Bar + Bar + Field1 + -- ^ Field 1 + Field2 + -- ^ Field 2 diff --git a/data/examples/declaration/data/unnamed-field-comment-1-four-out.hs b/data/examples/declaration/data/unnamed-field-comment-1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/unnamed-field-comment-1-four-out.hs @@ -0,0 +1,5 @@ +data X + = B + !Int + -- ^ y + C diff --git a/data/examples/declaration/data/with-comment-four-out.hs b/data/examples/declaration/data/with-comment-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/with-comment-four-out.hs @@ -0,0 +1,4 @@ +data A + = B -- C + | -- D + E diff --git a/data/examples/declaration/data/with-weird-haddock-four-out.hs b/data/examples/declaration/data/with-weird-haddock-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/data/with-weird-haddock-four-out.hs @@ -0,0 +1,4 @@ +data PlusLevel' t + = -- | @n + ℓ@. + Plus Integer (LevelAtom' t) + deriving (Show, Data) diff --git a/data/examples/declaration/default/default-four-out.hs b/data/examples/declaration/default/default-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/default/default-four-out.hs @@ -0,0 +1,7 @@ +default (Int, Foo, Bar) + +default + ( Int + , Foo + , Bar + ) diff --git a/data/examples/declaration/deriving/multiline-four-out.hs b/data/examples/declaration/deriving/multiline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/deriving/multiline-four-out.hs @@ -0,0 +1,22 @@ +deriving instance + Eq + Foo + +deriving stock instance + Show + Foo +deriving anyclass instance + ToJSON + Foo +deriving newtype instance + Data + Foo + +deriving via + Foo + Int + instance + Triple + A + B + C diff --git a/data/examples/declaration/deriving/overlapping-four-out.hs b/data/examples/declaration/deriving/overlapping-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/deriving/overlapping-four-out.hs @@ -0,0 +1,16 @@ +deriving instance + {-# OVERLAPPABLE #-} + Ord + Foo +deriving instance + {-# OVERLAPPING #-} + Num + Foo +deriving instance + {-# OVERLAPS #-} + Read + Foo +deriving instance + {-# INCOHERENT #-} + Show + Foo diff --git a/data/examples/declaration/deriving/singleline-four-out.hs b/data/examples/declaration/deriving/singleline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/deriving/singleline-four-out.hs @@ -0,0 +1,12 @@ +deriving instance Eq Foo + +deriving stock instance Show Foo +deriving anyclass instance ToJSON Foo +deriving newtype instance Data Foo + +deriving instance {-# OVERLAPPABLE #-} Ord Foo +deriving instance {-# OVERLAPPING #-} Num Foo +deriving instance {-# OVERLAPS #-} Read Foo +deriving instance {-# INCOHERENT #-} Show Foo + +deriving via Int instance Triple A B C diff --git a/data/examples/declaration/foreign/foreign-export-four-out.hs b/data/examples/declaration/foreign/foreign-export-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/foreign/foreign-export-four-out.hs @@ -0,0 +1,9 @@ +foreign export ccall foo :: Int -> IO Int + +-- | 'foreignTomFun' is a very important thing +foreign export ccall "tomography" + foreignTomFun :: + StablePtr Storage {- Storage is bad -} -> TomForegin + +foreign export {- We can't use capi here -} ccall "dynamic" + export_nullaryMeth :: (IO HRESULT) -> IO (Ptr ()) diff --git a/data/examples/declaration/foreign/foreign-import-four-out.hs b/data/examples/declaration/foreign/foreign-import-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/foreign/foreign-import-four-out.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CApiFFI #-} + +foreign import ccall safe foo :: Int -> IO Int + +-- | 'bar' is a very important thing +foreign import stdcall "baz" bar :: String -> Int -> IO String + +foreign import stdcall unsafe "boo" + -- Here is a comment about my foreign function + boo :: Int -> Text -> IO Array + +foreign import javascript + baz :: + String -> + Int -> + IO Foo + +foreign import {- We use capi here -} capi "pi.h value pi" c_pi :: CDouble + +foreign import stdcall {- This is a bad place for a comment -} "dynamic" + dyn_gluBeginSurface :: + -- | This 'FunPtr' is extremely dangerous, beware + FunPtr (Ptr GLUnurbs -> IO ()) -> + Ptr GLUnurbs -> + IO () diff --git a/data/examples/declaration/instance/associated-data-four-out.hs b/data/examples/declaration/instance/associated-data-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/associated-data-four-out.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} + +instance Foo Int where data Bar Int = IntBar Int Int + +instance Foo Double where + newtype + Bar + Double + = DoubleBar + Double + Double + +instance Foo [a] where + data Bar [a] + = ListBar [Bar a] + data Baz [a] + = ListBaz diff --git a/data/examples/declaration/instance/associated-types-four-out.hs b/data/examples/declaration/instance/associated-types-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/associated-types-four-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} + +instance Foo Int where type Bar Int = Double + +instance Foo Double where + type + Bar + Double = + [Double] + + type + Baz Double = + [Double] diff --git a/data/examples/declaration/instance/contexts-comments-four-out.hs b/data/examples/declaration/instance/contexts-comments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/contexts-comments-four-out.hs @@ -0,0 +1,17 @@ +instance + ( Read a -- Foo + , Read b + , Read + ( c -- Bar + , d + ) + ) => + Read + ( a -- Baz + , b + , ( c -- Quux + , d + ) + ) + where + readsPrec = undefined diff --git a/data/examples/declaration/instance/contexts-four-out.hs b/data/examples/declaration/instance/contexts-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/contexts-four-out.hs @@ -0,0 +1,18 @@ +instance Eq a => Eq [a] where (==) _ _ = False + +instance + ( Ord a + , Ord b + ) => + Ord (a, b) + where + compare _ _ = GT + +instance + (Show a, Show b) => + Show + ( a + , b + ) + where + showsPrec _ _ = showString "" diff --git a/data/examples/declaration/instance/data-family-instances-four-out.hs b/data/examples/declaration/instance/data-family-instances-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/data-family-instances-four-out.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE TypeFamilies #-} + +data instance Foo Int = FooInt Int + +data instance + Foo + [Int] + = IntListFoo + ( Int + , Int + ) + ( Double + , Double + ) + +data instance Bar Double a + = DoubleBar + Double + (Bar a) diff --git a/data/examples/declaration/instance/data-family-instances-gadt-four-out.hs b/data/examples/declaration/instance/data-family-instances-gadt-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/data-family-instances-gadt-four-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE TypeFamilies #-} + +data instance Bar Int a where + SameBar :: + Bar + Int + Int + CloseBar :: Bar Int Double + OtherBar :: + Bar + Int + a diff --git a/data/examples/declaration/instance/data-family-instances-newtype-four-out.hs b/data/examples/declaration/instance/data-family-instances-newtype-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/data-family-instances-newtype-four-out.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE TypeFamilies #-} + +newtype instance Foo [Double] = DoubleListFoo + { unDoubleListFoo :: Double + } diff --git a/data/examples/declaration/instance/empty-instance-four-out.hs b/data/examples/declaration/instance/empty-instance-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/empty-instance-four-out.hs @@ -0,0 +1,2 @@ +instance Typeable Int +instance Generic Int diff --git a/data/examples/declaration/instance/instance-sigs-four-out.hs b/data/examples/declaration/instance/instance-sigs-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/instance-sigs-four-out.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE InstanceSigs #-} + +instance Eq Int where + (==) :: Int -> Int -> Bool + (==) _ _ = False + +instance Ord Int where + compare :: + Int -> + Int -> + Ordering + compare + _ + _ = + GT diff --git a/data/examples/declaration/instance/instance-sigs-multiple-four-out.hs b/data/examples/declaration/instance/instance-sigs-multiple-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/instance-sigs-multiple-four-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE InstanceSigs #-} + +instance Applicative [] where + pure :: + a -> + [a] + pure a = [a] + (<*>) :: + [a] -> [a] -> [a] + (<*>) _ _ = [] diff --git a/data/examples/declaration/instance/multi-parameter-four-out.hs b/data/examples/declaration/instance/multi-parameter-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/multi-parameter-four-out.hs @@ -0,0 +1,5 @@ +instance MonadReader a ((->) a) where ask = id + +instance MonadState s (State s) where + get = State.get + put = State.put diff --git a/data/examples/declaration/instance/newlines-after-where-four-out.hs b/data/examples/declaration/instance/newlines-after-where-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/newlines-after-where-four-out.hs @@ -0,0 +1,5 @@ +instance Num X where + (+) = undefined + +instance Num Y where + (+) = undefined diff --git a/data/examples/declaration/instance/newlines-between-methods-four-out.hs b/data/examples/declaration/instance/newlines-between-methods-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/newlines-between-methods-four-out.hs @@ -0,0 +1,18 @@ +instance Num a => Num (Diff a) where + D u dudx + D v dvdx = D (u + v) (dudx + dvdx) + D u dudx - D v dvdx = D (u - v) (dudx - dvdx) + D u dudx * D v dvdx = D (u * v) (u * dvdx + v * dudx) + + -- Comment before definition + negate (D u dudx) = D (- u) (- dudx) + negate (Z u dudx) = undefined + + -- Comment after definition + + -- Separator + + abs (D u _) = D (abs u) (signum u) + signum (D u _) = D (signum u) 0 + + -- Comment between unrelated definitions + fromInteger n = D (fromInteger n) 0 diff --git a/data/examples/declaration/instance/overlappable-instances-four-out.hs b/data/examples/declaration/instance/overlappable-instances-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/overlappable-instances-four-out.hs @@ -0,0 +1,14 @@ +instance {-# OVERLAPPABLE #-} Eq Int where (==) _ _ = False + +instance {-# OVERLAPPING #-} Ord Int where + compare _ _ = GT + +instance {-# OVERLAPS #-} Eq Double where + (==) _ _ = False + +instance + {-# INCOHERENT #-} + Ord + Double + where + compare _ _ = GT diff --git a/data/examples/declaration/instance/single-parameter-four-out.hs b/data/examples/declaration/instance/single-parameter-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/single-parameter-four-out.hs @@ -0,0 +1,9 @@ +instance Monoid Int where (<>) x y = x + y + +instance Enum Int where + fromEnum x = x + toEnum = + \x -> + x + +instance Foo Int where foo x = x; bar y = y diff --git a/data/examples/declaration/instance/type-family-instances-four-out.hs b/data/examples/declaration/instance/type-family-instances-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/instance/type-family-instances-four-out.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeFamilies #-} + +type instance Foo Int = Int + +type instance + Foo + [Int] = + ( Int + , Int + ) + +type instance Bar Int [Int] Double = (Int, Double) + +type instance + Bar + [Int] + [Int] + Double = + ( Int + , Double + ) diff --git a/data/examples/declaration/rewrite-rule/basic1-four-out.hs b/data/examples/declaration/rewrite-rule/basic1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/basic1-four-out.hs @@ -0,0 +1,19 @@ +{-# RULES +"fold/build" foldr k z (build g) = g k z + #-} + +{-# RULES +"fusable/aux" + fusable x (aux y) = + faux x y + #-} + +{-# RULES +"map/map" + map + f + (map g xs) = + map + (f . g) + xs + #-} diff --git a/data/examples/declaration/rewrite-rule/basic2-four-out.hs b/data/examples/declaration/rewrite-rule/basic2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/basic2-four-out.hs @@ -0,0 +1,16 @@ +{-# RULES +"++" xs ++ ys = augment (\c n -> foldr c n xs) ys +"concat" xs `concat` ys = augment (\c n -> foldr c n xs) ys + #-} + +{-# RULES +"++" xs ++ ys = augment (\c n -> foldr c n xs) ys +"concat" xs `concat` ys = augment (\c n -> foldr c n xs) ys +"map/Double" fmap f xs = foldr (++) f xs + #-} + +{-# RULES +"fb' >\\ (Request b' fb )" forall fb' b' fb. + fb' >\\ (Request b' fb) = + fb' b' >>= \b -> fb' >\\ fb b + #-} diff --git a/data/examples/declaration/rewrite-rule/empty-four-out.hs b/data/examples/declaration/rewrite-rule/empty-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/empty-four-out.hs @@ -0,0 +1,3 @@ +{-# RULES + + #-} diff --git a/data/examples/declaration/rewrite-rule/forall-0-four-out.hs b/data/examples/declaration/rewrite-rule/forall-0-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/forall-0-four-out.hs @@ -0,0 +1,9 @@ +{-# RULES +"fold/build" forall k z. foldr k z (build g) = g k z + #-} + +{-# RULES +"fusable/aux" forall x y. + fusable x (aux y) = + faux x y + #-} diff --git a/data/examples/declaration/rewrite-rule/forall-1-four-out.hs b/data/examples/declaration/rewrite-rule/forall-1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/forall-1-four-out.hs @@ -0,0 +1,23 @@ +{-# RULES "rd_tyvs" forall a. forall (x :: a). id x = x #-} + +{-# RULES "rd_tyvs'" forall f a. forall (x :: f a). id x = x #-} + +{-# RULES "rd_tyvs''" forall (a :: *). forall (x :: a). id x = x #-} + +{-# RULES +"rd_tyvs_multiline1" forall (a :: *). forall (x :: a). + id x = + x + #-} + +{-# RULES +"rd_tyvs_multiline2" forall + ( a :: + * + ). forall + ( x :: + a + ). + id x = + x + #-} diff --git a/data/examples/declaration/rewrite-rule/phase-four-out.hs b/data/examples/declaration/rewrite-rule/phase-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/phase-four-out.hs @@ -0,0 +1,23 @@ +{-# RULES +"map/map" [2] + map + f + (map g xs) = + map + (f . g) + xs + #-} + +{-# RULES +"map/map" [1] forall x y z. + map + f + (map g xs) = + map + (f . g) + xs + #-} + +{-# RULES +"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys + #-} diff --git a/data/examples/declaration/rewrite-rule/prelude1-four-out.hs b/data/examples/declaration/rewrite-rule/prelude1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/prelude1-four-out.hs @@ -0,0 +1,18 @@ +{-# RULES +"map/map" forall f g xs. map f (map g xs) = map (f . g) xs +"map/append" forall f xs ys. map f (xs ++ ys) = map f xs ++ map f ys + #-} + +{-# RULES +"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs) +"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f +"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f . g) + #-} + +{-# RULES +"map/map" [~2] forall f g xs. + map f (map g xs) = + map (f . g) xs +"f" op True y = False +"g" op True y = False + #-} diff --git a/data/examples/declaration/rewrite-rule/prelude2-four-out.hs b/data/examples/declaration/rewrite-rule/prelude2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/prelude2-four-out.hs @@ -0,0 +1,31 @@ +{-# RULES +"fold/build" forall k z (g :: forall b. (a -> b -> b) -> b -> b). + foldr k z (build g) = + g k z +"foldr/augment" forall k z xs (g :: forall b. (a -> b -> b) -> b -> b). + foldr k z (augment g xs) = + g k (foldr k z xs) +"foldr/id" foldr (:) [] = \x -> x +"foldr/app" [1] forall ys. foldr (:) ys = \xs -> xs ++ ys +-- Only activate this from phase 1, because that's +-- when we disable the rule that expands (++) into foldr + +-- The foldr/cons rule looks nice, but it can give disastrously +-- bloated code when commpiling +-- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ] +-- i.e. when there are very very long literal lists +-- So I've disabled it for now. We could have special cases +-- for short lists, I suppose. +-- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs) + +"foldr/single" forall k z x. foldr k z [x] = k x z +"foldr/nil" forall k z. foldr k z [] = z +"augment/build" forall + (g :: forall b. (a -> b -> b) -> b -> b) + (h :: forall b. (a -> b -> b) -> b -> b). + augment g (build h) = + build (\c n -> g c (h c n)) +"augment/nil" forall (g :: forall b. (a -> b -> b) -> b -> b). + augment g [] = + build g + #-} diff --git a/data/examples/declaration/rewrite-rule/prelude3-four-out.hs b/data/examples/declaration/rewrite-rule/prelude3-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/prelude3-four-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MagicHash #-} + +{-# RULES +"x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True +"x# `neChar#` x#" forall x#. x# `neChar#` x# = False +"x# `gtChar#` x#" forall x#. x# `gtChar#` x# = False +"x# `geChar#` x#" forall x#. x# `geChar#` x# = True +"x# `leChar#` x#" forall x#. x# `leChar#` x# = True +"x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False + #-} diff --git a/data/examples/declaration/rewrite-rule/prelude4-four-out.hs b/data/examples/declaration/rewrite-rule/prelude4-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/prelude4-four-out.hs @@ -0,0 +1,7 @@ +{-# RULES +"unpack" [~1] forall a. unpackCString # a = build (unpackFoldrCString # a) +"unpack-list" [1] forall a. unpackFoldrCString # a (:) [] = unpackCString # a +"unpack-append" forall a n. unpackFoldrCString # a (:) n = unpackAppendCString # a n +-- There's a built-in rule (in PrelRules.lhs) for +-- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n + #-} diff --git a/data/examples/declaration/rewrite-rule/type-signature-four-out.hs b/data/examples/declaration/rewrite-rule/type-signature-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/rewrite-rule/type-signature-four-out.hs @@ -0,0 +1,17 @@ +{-# RULES +"fold/build" forall k z (g :: forall b. (a -> b -> b) -> b -> b). foldr k z (build g) = g k z + #-} + +{-# RULES +"fold/build" forall + k + z + ( g :: + forall b. + (a -> b -> b) -> + b -> + b + ). + foldr k z (build g) = + g k z + #-} diff --git a/data/examples/declaration/role-annotation/multi-line-four-out.hs b/data/examples/declaration/role-annotation/multi-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/role-annotation/multi-line-four-out.hs @@ -0,0 +1,15 @@ +type role + D + phantom + nominal + +type role + E + _ + nominal + +type role + E + _ + nominal + phantom diff --git a/data/examples/declaration/role-annotation/single-line-four-out.hs b/data/examples/declaration/role-annotation/single-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/role-annotation/single-line-four-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RoleAnnotations #-} + +type role Ptr representational + +type role A nominal nominal + +type role B _ phantom +type role C _ _ diff --git a/data/examples/declaration/signature/complete/complete-four-out.hs b/data/examples/declaration/signature/complete/complete-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/complete/complete-four-out.hs @@ -0,0 +1,10 @@ +{-# COMPLETE A, B, C :: Foo #-} + +{-# COMPLETE A, B #-} + +{-# COMPLETE + A + , B + , C :: + Foo + #-} diff --git a/data/examples/declaration/signature/fixity/infix-four-out.hs b/data/examples/declaration/signature/fixity/infix-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/fixity/infix-four-out.hs @@ -0,0 +1,2 @@ +infix 0 +infix 9 <^-^> diff --git a/data/examples/declaration/signature/fixity/infixl-four-out.hs b/data/examples/declaration/signature/fixity/infixl-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/fixity/infixl-four-out.hs @@ -0,0 +1,2 @@ +infixl 8 *** +infixl 0 $, *, +, &&, ** diff --git a/data/examples/declaration/signature/fixity/infixr-four-out.hs b/data/examples/declaration/signature/fixity/infixr-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/fixity/infixr-four-out.hs @@ -0,0 +1,2 @@ +infixr 8 `Foo` +infixr 0 ***, &&& diff --git a/data/examples/declaration/signature/inline/conlike-four-out.hs b/data/examples/declaration/signature/inline/conlike-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/inline/conlike-four-out.hs @@ -0,0 +1,7 @@ +foo :: Int +foo = 5 +{-# INLINE CONLIKE foo #-} + +bar :: Int +bar = 6 +{-# INLINE CONLIKE bar #-} diff --git a/data/examples/declaration/signature/inline/inline-four-out.hs b/data/examples/declaration/signature/inline/inline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/inline/inline-four-out.hs @@ -0,0 +1,15 @@ +foo :: Int -> Int +foo = id +{-# INLINE foo #-} + +{-# INLINE [2] bar #-} +bar :: Int -> Int +bar = id + +baz :: Int -> Int +baz = id +{-# INLINE [~2] baz #-} + +reVector :: Bundle u a -> Bundle v a +{-# INLINE reVector #-} +reVector = M.reVector diff --git a/data/examples/declaration/signature/inline/inlineable-four-out.hs b/data/examples/declaration/signature/inline/inlineable-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/inline/inlineable-four-out.hs @@ -0,0 +1,11 @@ +foo :: Int -> Int +foo = id +{-# INLINEABLE foo #-} + +{-# INLINEABLE [2] bar #-} +bar :: Int -> Int +bar = id + +baz :: Int -> Int +baz = id +{-# INLINEABLE [~2] baz #-} diff --git a/data/examples/declaration/signature/inline/noinline-four-out.hs b/data/examples/declaration/signature/inline/noinline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/inline/noinline-four-out.hs @@ -0,0 +1,11 @@ +foo :: Int -> Int +foo = id +{-# NOINLINE foo #-} + +{-# NOINLINE [2] bar #-} +bar :: Int -> Int +bar = id + +baz :: Int -> Int +baz = id +{-# NOINLINE [~2] baz #-} diff --git a/data/examples/declaration/signature/minimal/minimal-four-out.hs b/data/examples/declaration/signature/minimal/minimal-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/minimal/minimal-four-out.hs @@ -0,0 +1,14 @@ +class Foo a where + {-# MINIMAL (==) | ((/=), foo) #-} + + {-# MINIMAL + a + | ( b, c, d + | e + , f + ) + | g + #-} + + (==) :: a -> a -> Bool + (/=) :: a -> a -> Bool diff --git a/data/examples/declaration/signature/pattern/multiline-four-out.hs b/data/examples/declaration/signature/pattern/multiline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/pattern/multiline-four-out.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE PatternSynonyms #-} + +pattern Arrow :: + Type -> + Type -> + Type + +pattern + Foo + , Bar :: + Type -> Type -> Type + +pattern + TypeSignature + , FunctionBody + , PatternSignature + , WarningPragma :: + [RdrName] -> + HsDecl GhcPs diff --git a/data/examples/declaration/signature/pattern/single-line-four-out.hs b/data/examples/declaration/signature/pattern/single-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/pattern/single-line-four-out.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + +pattern Arrow :: Type -> Type -> Type + +pattern Foo, Bar :: Type -> Type -> Type diff --git a/data/examples/declaration/signature/set-cost-centre/set-cost-centre-four-out.hs b/data/examples/declaration/signature/set-cost-centre/set-cost-centre-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/set-cost-centre/set-cost-centre-four-out.hs @@ -0,0 +1,14 @@ +f x y = g (x + y) + where + g z = z + {-# SCC g #-} +{-# SCC f #-} + +withString x y = x + y +{-# SCC withString "cost_centre_name" #-} + +withString' x y = x + y +{-# SCC + withString' + "cost_centre_name" + #-} diff --git a/data/examples/declaration/signature/specialize/specialize-four-out.hs b/data/examples/declaration/signature/specialize/specialize-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/specialize/specialize-four-out.hs @@ -0,0 +1,24 @@ +foo :: Num a => a -> a +foo = id +{-# SPECIALIZE foo :: Int -> Int #-} +{-# SPECIALIZE INLINE foo :: Float -> Float #-} + +{-# SPECIALIZE NOINLINE [2] bar :: Int -> Int #-} +bar :: Num a => a -> a +bar = id + +baz :: Num a => a -> a +baz = id +{-# SPECIALIZE [~2] baz :: + Int -> + Int + #-} + +{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-} +{-# SPECIALIZE fits13Bits :: + Int -> + Bool + , Integer -> Bool + #-} +fits13Bits :: Integral a => a -> Bool +fits13Bits x = x >= -4096 && x < 4096 diff --git a/data/examples/declaration/signature/specialize/specialize-instance-four-out.hs b/data/examples/declaration/signature/specialize/specialize-instance-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/specialize/specialize-instance-four-out.hs @@ -0,0 +1,13 @@ +data Foo a = Foo a +data VT v m r = VT v m r + +instance (Eq a) => Eq (Foo a) where + {-# SPECIALIZE instance Eq (Foo [(Int, Bar)]) #-} + (==) (Foo a) (Foo b) = (==) a b + +instance (Num r, V.Vector v r, Factored m r) => Num (VT v m r) where + {-# SPECIALIZE instance + ( Factored m Int => Num (VT U.Vector m Int) + ) + #-} + VT x + VT y = VT $ V.zipWith (+) x y diff --git a/data/examples/declaration/signature/type/arguments-four-out.hs b/data/examples/declaration/signature/type/arguments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/type/arguments-four-out.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE RankNTypes #-} + +functionName :: + (C1, C2, C3, C4, C5) => + a -> + b -> + ( forall a. + (C6, C7) => + LongDataTypeName -> + a -> + AnotherLongDataTypeName -> + b -> + c + ) -> + (c -> d) -> + (a, b, c, d) diff --git a/data/examples/declaration/signature/type/context-multi-line-four-out.hs b/data/examples/declaration/signature/type/context-multi-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/type/context-multi-line-four-out.hs @@ -0,0 +1,10 @@ +functionName :: + ( C1 + , C2 + , C3 + ) => + a -> + b -> + c -> + d -> + (a, b, c, d) diff --git a/data/examples/declaration/signature/type/context-single-line-four-out.hs b/data/examples/declaration/signature/type/context-single-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/type/context-single-line-four-out.hs @@ -0,0 +1,7 @@ +functionName :: + (C1, C2, C3) => + a -> + b -> + c -> + d -> + (a, b, c, d) diff --git a/data/examples/declaration/signature/type/infix-promoted-type-constructor-four-out.hs b/data/examples/declaration/signature/type/infix-promoted-type-constructor-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/type/infix-promoted-type-constructor-four-out.hs @@ -0,0 +1,2 @@ +fun1 :: Def ('[Ref s (Stored Uint32), IBool] 'T.:-> IBool) +fun2 :: Def ('[Ref s (Stored Uint32), IBool] ':-> IBool) diff --git a/data/examples/declaration/signature/type/infix-promoted-type-constructor-out.hs b/data/examples/declaration/signature/type/infix-promoted-type-constructor-out.hs --- a/data/examples/declaration/signature/type/infix-promoted-type-constructor-out.hs +++ b/data/examples/declaration/signature/type/infix-promoted-type-constructor-out.hs @@ -1,3 +1,2 @@ fun1 :: Def ('[Ref s (Stored Uint32), IBool] 'T.:-> IBool) - fun2 :: Def ('[Ref s (Stored Uint32), IBool] ':-> IBool) diff --git a/data/examples/declaration/signature/type/long-function-name-four-out.hs b/data/examples/declaration/signature/type/long-function-name-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/type/long-function-name-four-out.hs @@ -0,0 +1,6 @@ +longFunctionName :: + a -> + b -> + c -> + d -> + (a, b, c, d) diff --git a/data/examples/declaration/signature/type/long-multiline-applications-four-out.hs b/data/examples/declaration/signature/type/long-multiline-applications-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/type/long-multiline-applications-four-out.hs @@ -0,0 +1,16 @@ +functionName :: + (C1, C2, C3, C4, C5) => + forall a b c. + a -> + b -> + ( LongDataTypeName + AnotherLongDataTypeName + AnotherLongDataTypeName2 + AnotherLongDataTypeName3 -> + a -> + AnotherLongDataTypeName4 -> + b -> + c + ) -> + (c -> d) -> + (a, b, c, d) diff --git a/data/examples/declaration/signature/type/multi-value-four-out.hs b/data/examples/declaration/signature/type/multi-value-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/type/multi-value-four-out.hs @@ -0,0 +1,15 @@ +foo, bar :: Int +foo = 1 +bar = 2 + +a, b, c :: Int +a = 1 +b = 2 +c = 3 + +foo + , bar + , baz :: + Int +bar = 2 +baz = 3 diff --git a/data/examples/declaration/signature/type/unicode-four-out.hs b/data/examples/declaration/signature/type/unicode-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/type/unicode-four-out.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE UnicodeSyntax #-} + +foo :: forall a. Show a => a -> String +foo = const () diff --git a/data/examples/declaration/signature/type/unrelated-four-out.hs b/data/examples/declaration/signature/type/unrelated-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/type/unrelated-four-out.hs @@ -0,0 +1,4 @@ +clientFunc1 :: SomeType1 +clientFunc2 :: SomeType2 +clientFunc3 :: SomeType3 +clientFunc1 :<|> clientFunc2 :<|> clientFunc3 = hoistClient foo bar baz diff --git a/data/examples/declaration/signature/type/unrelated-out.hs b/data/examples/declaration/signature/type/unrelated-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/type/unrelated-out.hs @@ -0,0 +1,4 @@ +clientFunc1 :: SomeType1 +clientFunc2 :: SomeType2 +clientFunc3 :: SomeType3 +clientFunc1 :<|> clientFunc2 :<|> clientFunc3 = hoistClient foo bar baz diff --git a/data/examples/declaration/signature/type/unrelated.hs b/data/examples/declaration/signature/type/unrelated.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/signature/type/unrelated.hs @@ -0,0 +1,4 @@ +clientFunc1 :: SomeType1 +clientFunc2 :: SomeType2 +clientFunc3 :: SomeType3 +clientFunc1 :<|> clientFunc2 :<|> clientFunc3 = hoistClient foo bar baz diff --git a/data/examples/declaration/splice/bracket-declaration-four-out.hs b/data/examples/declaration/splice/bracket-declaration-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/bracket-declaration-four-out.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} + +[d|data T a where Foo :: T ()|] + +foo = + [d| + foo :: Int -> Char + + bar = 42 + |] + +[d| + data T = T + deriving (Eq, Ord, Enum, Bounded, Show) + |] + +$(do [d|baz = baz|]) + +$(singletons [d|data T = T deriving (Eq, Ord, Enum, Bounded, Show)|]) + +$( singletons + [d| + data T = T + deriving (Eq, Ord, Enum, Bounded, Show) + |] + ) diff --git a/data/examples/declaration/splice/bracket-declaration-out.hs b/data/examples/declaration/splice/bracket-declaration-out.hs --- a/data/examples/declaration/splice/bracket-declaration-out.hs +++ b/data/examples/declaration/splice/bracket-declaration-out.hs @@ -19,8 +19,8 @@ $(singletons [d|data T = T deriving (Eq, Ord, Enum, Bounded, Show)|]) $( singletons - [d| - data T = T - deriving (Eq, Ord, Enum, Bounded, Show) - |] + [d| + data T = T + deriving (Eq, Ord, Enum, Bounded, Show) + |] ) diff --git a/data/examples/declaration/splice/bracket-four-out.hs b/data/examples/declaration/splice/bracket-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/bracket-four-out.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} + +foo = + [| + foo bar + |] + +foo = + [e| + foo bar + |] + +foo = [t|Char|] + +foo = + [|| + foo bar + ||] diff --git a/data/examples/declaration/splice/grouped-splices-four-out.hs b/data/examples/declaration/splice/grouped-splices-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/grouped-splices-four-out.hs @@ -0,0 +1,3 @@ +$(deriveJSON fieldLabelMod ''A) +$(deriveJSON fieldLabelMod ''B) +$(deriveJSON fieldLabelMod ''C) diff --git a/data/examples/declaration/splice/quasiquote-four-out.hs b/data/examples/declaration/splice/quasiquote-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/quasiquote-four-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE QuasiQuotes #-} + +x = [foo| foo bar |] + +x = + [e| foo + bar {- -} + |] + +[d| foo bar + +|] diff --git a/data/examples/declaration/splice/quotes-four-out.hs b/data/examples/declaration/splice/quotes-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/quotes-four-out.hs @@ -0,0 +1,17 @@ +foo = ''R + +bar = 'foo + +bar' = 'foo_bar + +baz = ''(:#) + +baz' = ''(Foo.Bar.:#) + +equals = ''(==) + +unit = ''() + +list = ''[] + +quolified = ''Semigroup.Option diff --git a/data/examples/declaration/splice/splice-decl-four-out.hs b/data/examples/declaration/splice/splice-decl-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/splice-decl-four-out.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + +$(foo bar) + +$foo + +$$(foo bar) + +$$foo + +foo bar + +[|booya|] + +-- TemplateHaskell allows Q () at the top level +do + pure [] diff --git a/data/examples/declaration/splice/typed-splice-four-out.hs b/data/examples/declaration/splice/typed-splice-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/typed-splice-four-out.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} + +x = + $$( foo bar + ) + +x = $$foo diff --git a/data/examples/declaration/splice/untyped-splice-four-out.hs b/data/examples/declaration/splice/untyped-splice-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/splice/untyped-splice-four-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} + +x = $(foo bar) + +x = + $( foo + bar + ) + +x = $foo diff --git a/data/examples/declaration/splice/untyped-splice-out.hs b/data/examples/declaration/splice/untyped-splice-out.hs --- a/data/examples/declaration/splice/untyped-splice-out.hs +++ b/data/examples/declaration/splice/untyped-splice-out.hs @@ -4,7 +4,7 @@ x = $( foo - bar + bar ) x = $foo diff --git a/data/examples/declaration/type-families/closed-type-family/infix-four-out.hs b/data/examples/declaration/type-families/closed-type-family/infix-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/infix-four-out.hs @@ -0,0 +1,11 @@ +type family (x :: N) + (y :: N) :: N where + 'Zero + y = y + 'Succ n + y = 'Succ (n + y) + +type family (x :: N) `LEQ` (y :: N) :: Bool where + 'Zero `LEQ` y = 'True + 'Succ n `LEQ` 'Zero = 'False + 'Succ n `LEQ` 'Succ m = n `LEQ` m + +type family ((x :: N) `Weird` (y :: N)) (z :: N) :: Bool where + 'Zero `Weird` 'Zero 'Zero = 'True diff --git a/data/examples/declaration/type-families/closed-type-family/injective-four-out.hs b/data/examples/declaration/type-families/closed-type-family/injective-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/injective-four-out.hs @@ -0,0 +1,5 @@ +type family Id a = result | result -> a where + Id a = a + +type family G (a :: k) b c = foo | foo -> k b where + G a b c = (a, b) diff --git a/data/examples/declaration/type-families/closed-type-family/multi-line-four-out.hs b/data/examples/declaration/type-families/closed-type-family/multi-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/multi-line-four-out.hs @@ -0,0 +1,25 @@ +type family + Id a = + result | result -> a + where + Id a = + a + +type family + G + (a :: k) + b + c = + foo | foo -> k b + where + G a b c = + (a, b) + +type family + F a :: + * -> * + where + F Int = Double + F Bool = + Char + F a = String diff --git a/data/examples/declaration/type-families/closed-type-family/no-annotation-four-out.hs b/data/examples/declaration/type-families/closed-type-family/no-annotation-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/no-annotation-four-out.hs @@ -0,0 +1,4 @@ +type family F a where + F Int = Double + F Bool = Char + F a = String diff --git a/data/examples/declaration/type-families/closed-type-family/simple-four-out.hs b/data/examples/declaration/type-families/closed-type-family/simple-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/simple-four-out.hs @@ -0,0 +1,7 @@ +module Main where + +-- | Documentation. +type family F a :: * -> * where + F Int = Double + F Bool = Char + F a = String diff --git a/data/examples/declaration/type-families/closed-type-family/with-equal-sign-four-out.hs b/data/examples/declaration/type-families/closed-type-family/with-equal-sign-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/with-equal-sign-four-out.hs @@ -0,0 +1,2 @@ +type family TF a b = result where + TF a b = Int diff --git a/data/examples/declaration/type-families/closed-type-family/with-forall-four-out.hs b/data/examples/declaration/type-families/closed-type-family/with-forall-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/closed-type-family/with-forall-four-out.hs @@ -0,0 +1,3 @@ +type family G a b where + forall x y. G [x] (Proxy y) = Double + forall z. z `G` z = Bool diff --git a/data/examples/declaration/type-families/data-family/no-annotation-four-out.hs b/data/examples/declaration/type-families/data-family/no-annotation-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/data-family/no-annotation-four-out.hs @@ -0,0 +1,4 @@ +module Main where + +-- | Documentation. +data family Array e diff --git a/data/examples/declaration/type-families/data-family/simple-four-out.hs b/data/examples/declaration/type-families/data-family/simple-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/data-family/simple-four-out.hs @@ -0,0 +1,4 @@ +module Main where + +-- | Documentation. +data family GMap k :: Type -> Type diff --git a/data/examples/declaration/type-families/type-family/injective-four-out.hs b/data/examples/declaration/type-families/type-family/injective-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/type-family/injective-four-out.hs @@ -0,0 +1,2 @@ +type family Id a = r | r -> a +type family F a b c = d | d -> a c b diff --git a/data/examples/declaration/type-families/type-family/no-annotation-four-out.hs b/data/examples/declaration/type-families/type-family/no-annotation-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/type-family/no-annotation-four-out.hs @@ -0,0 +1,4 @@ +module Main where + +-- | Documentation. +type family F a b :: Type -> Type diff --git a/data/examples/declaration/type-families/type-family/operator-four-out.hs b/data/examples/declaration/type-families/type-family/operator-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/type-family/operator-four-out.hs @@ -0,0 +1,2 @@ +type family a ! b +type family a . b diff --git a/data/examples/declaration/type-families/type-family/simple-four-out.hs b/data/examples/declaration/type-families/type-family/simple-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-families/type-family/simple-four-out.hs @@ -0,0 +1,4 @@ +module Main where + +-- | Documentation. +type family Elem c :: Type diff --git a/data/examples/declaration/type-synonyms/multi-line-four-out.hs b/data/examples/declaration/type-synonyms/multi-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-synonyms/multi-line-four-out.hs @@ -0,0 +1,18 @@ +type Foo a b c = + Bar c a b + +type Foo + a + b + c = + Bar c a b + +type Foo = + Bar + Baz + Quux + +type API = + "route1" :> ApiRoute1 + :<|> "route2" :> ApiRoute2 -- comment here + :<|> OmitDocs :> "i" :> ASomething API diff --git a/data/examples/declaration/type-synonyms/simple-four-out.hs b/data/examples/declaration/type-synonyms/simple-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-synonyms/simple-four-out.hs @@ -0,0 +1,8 @@ +module Main where + +-- | Documentation. +type Foo a b c = Bar c a b + +type a ~> b = TyFun a b -> Type + +type (a :+: b) c d e = () diff --git a/data/examples/declaration/type-synonyms/with-weird-haddock-four-out.hs b/data/examples/declaration/type-synonyms/with-weird-haddock-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type-synonyms/with-weird-haddock-four-out.hs @@ -0,0 +1,3 @@ +type Elims = + -- | eliminations ordered left-to-right. + [Elim] diff --git a/data/examples/declaration/type/forall-four-out.hs b/data/examples/declaration/type/forall-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/forall-four-out.hs @@ -0,0 +1,4 @@ +type CoerceLocalSig m m' = + forall r a. + LocalSig m r a -> + LocalSig m' r a diff --git a/data/examples/declaration/type/lits-four-out.hs b/data/examples/declaration/type/lits-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/lits-four-out.hs @@ -0,0 +1,6 @@ +type A = "foo" + +type B = + "foo\ + \bar" -> + () diff --git a/data/examples/declaration/type/misc-kind-signatures-four-out.hs b/data/examples/declaration/type/misc-kind-signatures-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/misc-kind-signatures-four-out.hs @@ -0,0 +1,5 @@ +instance DemoteNodeTypes ('[] :: [NodeType]) where + demoteNodeTypes _ = [] + +b :: (Bool :: *) +b = True diff --git a/data/examples/declaration/type/promotion-four-out.hs b/data/examples/declaration/type/promotion-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/promotion-four-out.hs @@ -0,0 +1,16 @@ +type Foo = Cluster '[ 'NodeCore, 'NodeRelay', 'NodeEdge] + +type Query = Query '[] '[] DB '[ 'NotNull 'PGint4] (RowPG RawElementData) + +data T = T' | T'T + +type S0 = ' T' + +type S1 = ' T'T + +type S2 = Proxy ('[ '[], '[]]) +type S4 = Proxy ('( 'Just, ' T'T)) +type S5 = Proxy ('[ 'Just, 'TT'T]) +type S6 = Proxy ('( '(), '())) +type S7 = Proxy ('( 'a, 'b)) +type S8 = Proxy ('[Int, Bool]) diff --git a/data/examples/declaration/type/promotion-out.hs b/data/examples/declaration/type/promotion-out.hs --- a/data/examples/declaration/type/promotion-out.hs +++ b/data/examples/declaration/type/promotion-out.hs @@ -1,5 +1,7 @@ type Foo = Cluster '[ 'NodeCore, 'NodeRelay', 'NodeEdge] +type Query = Query '[] '[] DB '[ 'NotNull 'PGint4] (RowPG RawElementData) + data T = T' | T'T type S0 = ' T' diff --git a/data/examples/declaration/type/promotion.hs b/data/examples/declaration/type/promotion.hs --- a/data/examples/declaration/type/promotion.hs +++ b/data/examples/declaration/type/promotion.hs @@ -1,5 +1,7 @@ type Foo = Cluster '[ 'NodeCore, 'NodeRelay', 'NodeEdge ] +type Query = Query '[] '[] DB '[ 'NotNull 'PGint4] (RowPG RawElementData) + data T = T' | T'T type S0 = ' T' @@ -12,4 +14,3 @@ type S6 = Proxy ( '( '(), '() )) type S7 = Proxy ( '( 'a, 'b )) type S8 = Proxy ( '[ Int, Bool ]) - diff --git a/data/examples/declaration/type/splice-four-out.hs b/data/examples/declaration/type/splice-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/splice-four-out.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TemplateHaskell #-} + +type Foo = $(bar [t|Int|]) diff --git a/data/examples/declaration/type/type-applications-four-out.hs b/data/examples/declaration/type/type-applications-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/type-applications-four-out.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TypeApplications #-} + +type P = K @Bool @(Bool :: *) 'True 'False diff --git a/data/examples/declaration/type/visible-forall-four-out.hs b/data/examples/declaration/type/visible-forall-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/type/visible-forall-four-out.hs @@ -0,0 +1,2 @@ +-- source: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0081-forall-arrow.rst +data T :: forall k -> k -> Type diff --git a/data/examples/declaration/value/function/application-0-four-out.hs b/data/examples/declaration/value/function/application-0-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/application-0-four-out.hs @@ -0,0 +1,17 @@ +foo = + f1 + p1 + p2 + p3 + +foo' = + f2 + p1 + p2 + p3 + +foo'' = + f3 + p1 + p2 + p3 diff --git a/data/examples/declaration/value/function/application-1-four-out.hs b/data/examples/declaration/value/function/application-1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/application-1-four-out.hs @@ -0,0 +1,19 @@ +main = + do + x + y + z + +main = + case foo of + x -> a + foo + a + b + +main = + do + if x then y else z + foo + a + b diff --git a/data/examples/declaration/value/function/arg-breakpoints-four-out.hs b/data/examples/declaration/value/function/arg-breakpoints-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arg-breakpoints-four-out.hs @@ -0,0 +1,3 @@ +foo + bar = + body diff --git a/data/examples/declaration/value/function/arg-breakpoints-out.hs b/data/examples/declaration/value/function/arg-breakpoints-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arg-breakpoints-out.hs @@ -0,0 +1,3 @@ +foo + bar = + body diff --git a/data/examples/declaration/value/function/arg-breakpoints.hs b/data/examples/declaration/value/function/arg-breakpoints.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arg-breakpoints.hs @@ -0,0 +1,3 @@ +foo + bar = + body diff --git a/data/examples/declaration/value/function/arithmetic-sequences-four-out.hs b/data/examples/declaration/value/function/arithmetic-sequences-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arithmetic-sequences-four-out.hs @@ -0,0 +1,16 @@ +foo = [0 ..] +foo' = [0 .. 5] +bar x = + [ 0 + .. x + ] +baz x = + [ 1 + , 3 + .. x + ] +barbaz x = [0, 1 ..] +arst = [0 :: Int ..] +brst = [0, 1 :: Int ..] +crst = [0 :: Int .. 10] +drst = [0, 1 :: Int .. 10] diff --git a/data/examples/declaration/value/function/arrow/multiline-case-four-out.hs b/data/examples/declaration/value/function/arrow/multiline-case-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/multiline-case-four-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Arrows #-} + +f = proc x -> do + x <- + case x of X -> x + -< + y + a -< b diff --git a/data/examples/declaration/value/function/arrow/proc-applications-four-out.hs b/data/examples/declaration/value/function/arrow/proc-applications-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/proc-applications-four-out.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Arrows #-} + +foo x = proc a -> a -< x + +bar f x = + proc + ( y + , z + , w + ) + -> + f -- The value + -< + ( x -- Foo + , w -- Bar + , z -- Baz + ) + +baz x = proc a -> a -<< x diff --git a/data/examples/declaration/value/function/arrow/proc-cases-four-out.hs b/data/examples/declaration/value/function/arrow/proc-cases-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/proc-cases-four-out.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Arrows #-} + +foo f = proc a -> case a of Left b -> f -< b + +bar f g h j = + proc a -> case a of + Left + ( (a, b) + , (c, d) + ) -> f (a <> c) -< b <> d + Right + (Left a) -> + h -< a + Right + (Right b) -> + j -< b diff --git a/data/examples/declaration/value/function/arrow/proc-do-complex-four-out.hs b/data/examples/declaration/value/function/arrow/proc-do-complex-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/proc-do-complex-four-out.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE Arrows #-} + +foo + f + g + h + ma = + proc + ( (a, b) + , (c, d) + , (e, f) + ) + -> do + -- Begin do + (x, y) <- -- GHC parser fails if layed out over multiple lines + f -- Call into f + ( a + , c -- Tuple together arguments + ) + ( b + , d + ) + -< + ( b + 1 -- Funnel into arrow + , d * b + ) + if x `mod` y == 0 -- Basic condition + then case e of -- Only left case is relevant + Left + ( z + , w + ) -> \u -> -- Procs can have lambdas + let v = + u -- Actually never used + ^ 2 + in ( returnA + -< + -- Just do the calculation + (x + y * z) + ) + else do + let u = x -- Let bindings bind expressions, not commands + -- Could pattern match directly on x + i <- case u of + 0 -> (g . h -< u) + n -> + ( ( h . g + -< + y -- First actual use of y + ) + ) + returnA -< () + -- Sometimes execute effects + if i > 0 + then ma -< () + else returnA -< () + returnA + -< + ( i + + x + * y -- Just do the calculation + ) diff --git a/data/examples/declaration/value/function/arrow/proc-do-simple1-four-out.hs b/data/examples/declaration/value/function/arrow/proc-do-simple1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/proc-do-simple1-four-out.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Arrows #-} + +bar f = proc a -> do + b <- f -< a + +barbar f g = proc a -> do + b <- f -< a + returnA -< b + +barbaz f g = proc (a, b) -> do + c <- f -< a + d <- g -< b + +bazbar f = proc a -> do + a <- + f + -< + a diff --git a/data/examples/declaration/value/function/arrow/proc-do-simple2-four-out.hs b/data/examples/declaration/value/function/arrow/proc-do-simple2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/proc-do-simple2-four-out.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Arrows #-} + +foo f = proc a -> do + f -< a + +bazbaz f g h = proc (a, b, c) -> do + x <- + f b -< a + y <- + g b -< b + z <- + h + x + y + -< + ( a + , b + , c + ) + returnA + -< + (x, y, z) diff --git a/data/examples/declaration/value/function/arrow/proc-forms1-four-out.hs b/data/examples/declaration/value/function/arrow/proc-forms1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/proc-forms1-four-out.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE Arrows #-} + +foo0 f g x y = proc _ -> (| f (g -< (x, y)) |) + +foo1 f g h x = + proc (y, z) -> + (| + test + ( h f + . h g + -< + y x + . y z + ) + ( h g + . h f + -< + y z + . y x + ) + |) diff --git a/data/examples/declaration/value/function/arrow/proc-forms2-four-out.hs b/data/examples/declaration/value/function/arrow/proc-forms2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/proc-forms2-four-out.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE Arrows #-} + +bar0 f g h x = + proc (y, z) -> + (| test (h f . (h g) -< (y x) . y z) ((h g) . h f -< y z . (y x)) |) + +bar1 f g x y = proc _ -> (f -< x) &&& (g -< y) + +bar2 f g h x = + proc (y, z) -> + (h f . (h g) -< (y x) . y z) ||| ((h g) . h f -< y z . (y x)) + +bar3 f g h x = + proc (y, z) -> + ( (h f . h g) + -< + (y x) . y z + ) ||| + ( (h g . h f) + -< + y z . (y x) + ) diff --git a/data/examples/declaration/value/function/arrow/proc-ifs-four-out.hs b/data/examples/declaration/value/function/arrow/proc-ifs-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/proc-ifs-four-out.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE Arrows #-} + +foo f = proc a -> if a then f -< 0 else f -< 1 + +bar f g = proc a -> + if f a + then + f + . g + -< + a + else + g + -< + b diff --git a/data/examples/declaration/value/function/arrow/proc-lambdas-four-out.hs b/data/examples/declaration/value/function/arrow/proc-lambdas-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/proc-lambdas-four-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE Arrows #-} + +foo = proc a -> \f b -> a -< f b -- Foo + +bar = + proc x -> \f g h -> + \() -> + \(Left (x, y)) -> -- Tuple value + f (g (h x)) -< y diff --git a/data/examples/declaration/value/function/arrow/proc-lets-four-out.hs b/data/examples/declaration/value/function/arrow/proc-lets-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/proc-lets-four-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Arrows #-} + +foo f = proc a -> let b = a in f -< b + +bar f g = proc a -> + let h = + f + . g a + j = + g + . h + in id -< (h, j) diff --git a/data/examples/declaration/value/function/arrow/proc-parentheses-four-out.hs b/data/examples/declaration/value/function/arrow/proc-parentheses-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/proc-parentheses-four-out.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Arrows #-} + +foo f = proc a -> (f -< a) + +bar f g = proc a -> + ( ( (f) + ( g + ) + ) + -< + ( ( ( ( ( ( g + a + ) + ) + ) + ) + ) + ) + ) diff --git a/data/examples/declaration/value/function/arrow/recursive-procs-four-out.hs b/data/examples/declaration/value/function/arrow/recursive-procs-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/arrow/recursive-procs-four-out.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Arrows #-} + +foo f g = proc (x, y) -> do + rec a <- f y -< x + b <- + g x + -< + y + bar + -< + ( a + , b + ) + rec p <- + f + p + -< + a + rec q <- + g + q + -< + b diff --git a/data/examples/declaration/value/function/awkward-comment-0-four-out.hs b/data/examples/declaration/value/function/awkward-comment-0-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/awkward-comment-0-four-out.hs @@ -0,0 +1,6 @@ +mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a +mergeErrorReply err1 reply -- XXX where to put it? + = + case reply of + Ok x state err2 -> Ok x state (mergeError err1 err2) + Error err2 -> Error (mergeError err1 err2) diff --git a/data/examples/declaration/value/function/awkward-comment-1-four-out.hs b/data/examples/declaration/value/function/awkward-comment-1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/awkward-comment-1-four-out.hs @@ -0,0 +1,9 @@ +doForeign :: Vars -> [Name] -> [Term] -> Idris LExp +doForeign x = x + where + splitArg tm | (_, [_, _, l, r]) <- unApply tm -- pair, two implicits + = + do + let l' = toFDesc l + r' <- irTerm (sMN 0 "__foreignCall") vs env r + return (l', r') diff --git a/data/examples/declaration/value/function/backticks-four-out.hs b/data/examples/declaration/value/function/backticks-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/backticks-four-out.hs @@ -0,0 +1,1 @@ +foo x y = x `bar` y diff --git a/data/examples/declaration/value/function/backticks-lhs-four-out.hs b/data/examples/declaration/value/function/backticks-lhs-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/backticks-lhs-four-out.hs @@ -0,0 +1,7 @@ +x `op1` (Just 0) = True +op1 x (Just _) = False +op1 x Nothing = undefined + +op2 1 y = False +x `op2` y = + True diff --git a/data/examples/declaration/value/function/blank-lines-let-four-out.hs b/data/examples/declaration/value/function/blank-lines-let-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/blank-lines-let-four-out.hs @@ -0,0 +1,6 @@ +foo = + let x = 10 + + y = 11 + z = 12 + in x + y + z diff --git a/data/examples/declaration/value/function/blank-lines-let-out.hs b/data/examples/declaration/value/function/blank-lines-let-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/blank-lines-let-out.hs @@ -0,0 +1,6 @@ +foo = + let x = 10 + + y = 11 + z = 12 + in x + y + z diff --git a/data/examples/declaration/value/function/blank-lines-let.hs b/data/examples/declaration/value/function/blank-lines-let.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/blank-lines-let.hs @@ -0,0 +1,9 @@ +foo = + let + + x = 10 + + y = 11 + z = 12 + + in x + y + z diff --git a/data/examples/declaration/value/function/blank-lines-where-four-out.hs b/data/examples/declaration/value/function/blank-lines-where-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/blank-lines-where-four-out.hs @@ -0,0 +1,6 @@ +foo = x + y + z + where + x = 10 + + y = 11 + z = 12 diff --git a/data/examples/declaration/value/function/blank-lines-where-out.hs b/data/examples/declaration/value/function/blank-lines-where-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/blank-lines-where-out.hs @@ -0,0 +1,6 @@ +foo = x + y + z + where + x = 10 + + y = 11 + z = 12 diff --git a/data/examples/declaration/value/function/blank-lines-where.hs b/data/examples/declaration/value/function/blank-lines-where.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/blank-lines-where.hs @@ -0,0 +1,7 @@ +foo = x + y + z + where + + x = 10 + + y = 11 + z = 12 diff --git a/data/examples/declaration/value/function/block-arguments-four-out.hs b/data/examples/declaration/value/function/block-arguments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/block-arguments-four-out.hs @@ -0,0 +1,34 @@ +f1 = foo do bar + +f2 = foo do + bar + +f3 = foo case True of + True -> bar + False -> baz + +f4 = foo let a = 3 in b + +f5 = + foo + let a = 3 + b = a + in b + +f6 = + foo + if bar + then baz + else not baz + +f7 = foo \x -> y + +f8 = foo \x -> + y + +f9 = foo do { bar } baz + +f10 = foo + do a + do b + do c diff --git a/data/examples/declaration/value/function/builtin-syntax-four-out.hs b/data/examples/declaration/value/function/builtin-syntax-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/builtin-syntax-four-out.hs @@ -0,0 +1,1 @@ +x = return () diff --git a/data/examples/declaration/value/function/case-multi-line-four-out.hs b/data/examples/declaration/value/function/case-multi-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-multi-line-four-out.hs @@ -0,0 +1,27 @@ +foo :: Int -> Int +foo x = case x of + 5 -> 10 + _ -> 12 + +bar :: Int -> Int +bar x = + case x of + 5 -> + if x > 5 + then 10 + else 12 + _ -> 12 + +baz :: Int -> Int +baz x = case x of + 5 -> 10 + _ -> 12 + +quux :: Int -> Int +quux x = case x of + x -> x + +funnyComment = + -- comment + case () of + () -> () diff --git a/data/examples/declaration/value/function/case-multi-line-guards-four-out.hs b/data/examples/declaration/value/function/case-multi-line-guards-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-multi-line-guards-four-out.hs @@ -0,0 +1,16 @@ +withGuards :: Int -> Int +withGuards x = + case x of + x + | x > 10 -> + foo + + bar + x | x > 5 -> 10 + _ -> 20 + +case x of + '-' | not isUrl -> case xs of + _ -> emitc '-' + '*' | not isUrl -> + case xs of + _ -> emitc '*' diff --git a/data/examples/declaration/value/function/case-single-line-four-out.hs b/data/examples/declaration/value/function/case-single-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/case-single-line-four-out.hs @@ -0,0 +1,6 @@ +foo :: Int -> Int +foo x = case x of x -> x + +foo :: IO () +foo = case [1] of [_] -> "singleton"; _ -> "not singleton" +foo = case [1] of { [] -> foo; _ -> bar } `finally` baz diff --git a/data/examples/declaration/value/function/complex-list-four-out.hs b/data/examples/declaration/value/function/complex-list-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/complex-list-four-out.hs @@ -0,0 +1,15 @@ +handleStuff = + handle + [ \ExceptionA -> + something + , \ExceptionB -> + somethingElse + ] + +handleStuff = + handle + [ foo + bar + , baz + qux + ] diff --git a/data/examples/declaration/value/function/comprehension/transform-multi-line1-four-out.hs b/data/examples/declaration/value/function/comprehension/transform-multi-line1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/comprehension/transform-multi-line1-four-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TransformListComp #-} + +foo' xs ys = + [ ( x + , y + ) + | x <- xs + , y <- ys + , then + -- First comment + reverse -- Second comment + ] diff --git a/data/examples/declaration/value/function/comprehension/transform-multi-line2-four-out.hs b/data/examples/declaration/value/function/comprehension/transform-multi-line2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/comprehension/transform-multi-line2-four-out.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TransformListComp #-} + +bar' xs ys = + [ ( x + , y + ) + | x <- xs + , y <- ys + , then + -- First comment + sortWith + by + ( x + + y -- Second comment + ) + ] diff --git a/data/examples/declaration/value/function/comprehension/transform-multi-line3-four-out.hs b/data/examples/declaration/value/function/comprehension/transform-multi-line3-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/comprehension/transform-multi-line3-four-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TransformListComp #-} + +baz' xs ys = + [ ( x + , y + ) + | x <- xs + , y <- ys + , then group using + -- First comment + permutations -- Second comment + ] diff --git a/data/examples/declaration/value/function/comprehension/transform-multi-line4-four-out.hs b/data/examples/declaration/value/function/comprehension/transform-multi-line4-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/comprehension/transform-multi-line4-four-out.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TransformListComp #-} + +quux' xs ys = + [ ( x + , y + ) + | x <- xs + , y <- ys + , then group by + -- First comment + ( x + + y + ) + using + -- Second comment + groupWith -- Third comment + ] diff --git a/data/examples/declaration/value/function/comprehension/transform-single-line-four-out.hs b/data/examples/declaration/value/function/comprehension/transform-single-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/comprehension/transform-single-line-four-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TransformListComp #-} + +foo xs ys = [(x, y) | x <- xs, y <- ys, then reverse] + +bar xs ys = [(x, y) | x <- xs, y <- ys, then sortWith by (x + y)] + +baz xs ys = [(x, y) | x <- xs, y <- ys, then group using permutations] + +quux xs ys = [(x, y) | x <- xs, y <- ys, then group by (x + y) using groupWith] diff --git a/data/examples/declaration/value/function/do-single-multi-four-out.hs b/data/examples/declaration/value/function/do-single-multi-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-single-multi-four-out.hs @@ -0,0 +1,4 @@ +foo = do + ( bar + baz + ) diff --git a/data/examples/declaration/value/function/do-where-four-out.hs b/data/examples/declaration/value/function/do-where-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do-where-four-out.hs @@ -0,0 +1,5 @@ +f :: Maybe Int +f = do + return c + where + c = 0 diff --git a/data/examples/declaration/value/function/do/applications-and-parens-four-out.hs b/data/examples/declaration/value/function/do/applications-and-parens-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do/applications-and-parens-four-out.hs @@ -0,0 +1,9 @@ +warningFor var place = do + guard $ isVariableName var + guard . not $ isInArray var place || isGuarded place + ( if includeGlobals || isLocal var + then warningForLocals + else warningForGlobals + ) + var + place diff --git a/data/examples/declaration/value/function/do/blocks-four-out.hs b/data/examples/declaration/value/function/do/blocks-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do/blocks-four-out.hs @@ -0,0 +1,16 @@ +foo = do bar +foo = do bar; baz +foo = do + bar + baz +foo = do do { foo; bar }; baz + +readInClause = do + do + lookAhead g_Do + parseNote ErrorC 1063 "You need a line feed or semicolon before the 'do'." + <|> do + optional g_Semi + void allspacing + + return things diff --git a/data/examples/declaration/value/function/do/comment-alignment-four-out.hs b/data/examples/declaration/value/function/do/comment-alignment-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do/comment-alignment-four-out.hs @@ -0,0 +1,9 @@ +main = do + case blah of + Nothing -> return () + Just xs -> do + forM_ xs foo + bar + -- and here it goes + unless bobla $ + quux diff --git a/data/examples/declaration/value/function/do/comment-spacing-four-out.hs b/data/examples/declaration/value/function/do/comment-spacing-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do/comment-spacing-four-out.hs @@ -0,0 +1,7 @@ +foo = do + bar + -- foo + baz + + -- foo + quux diff --git a/data/examples/declaration/value/function/do/expr-four-out.hs b/data/examples/declaration/value/function/do/expr-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do/expr-four-out.hs @@ -0,0 +1,10 @@ +quux = something $ do + foo + case x of + 1 -> 10 + 2 -> 20 + bar + if something + then x + else y + baz diff --git a/data/examples/declaration/value/function/do/hang-rhs-arrow-four-out.hs b/data/examples/declaration/value/function/do/hang-rhs-arrow-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do/hang-rhs-arrow-four-out.hs @@ -0,0 +1,9 @@ +foo = do + something <- case bar of + Foo -> return 1 + Bar -> return 2 + somethingElse <- + case boom of + Foo -> return 1 + Bar -> return 2 + quux something somethingElse diff --git a/data/examples/declaration/value/function/do/let-four-out.hs b/data/examples/declaration/value/function/do/let-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do/let-four-out.hs @@ -0,0 +1,18 @@ +main = do + a <- bar + let a = b; c = d + baz d + let e = f + g = h + return c + +-- single line let-where +samples n f = do + gen <- newQCGen + let rands g = g1 : rands g2 where (g1, g2) = split g + return $ rands gen + +trickyLet = do + foo + let x = 5 + in bar x diff --git a/data/examples/declaration/value/function/do/operator-and-parens-four-out.hs b/data/examples/declaration/value/function/do/operator-and-parens-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do/operator-and-parens-four-out.hs @@ -0,0 +1,7 @@ +scientifically :: (Scientific -> a) -> Parser a +scientifically h = do + something + ( I.satisfy (\w -> w == 'e' || w == 'E') + *> fmap (h . Sci.scientific signedCoeff . (e +)) (signed decimal) + ) + <|> return (h $ Sci.scientific signedCoeff e) diff --git a/data/examples/declaration/value/function/do/recursive-do-mdo-four-out.hs b/data/examples/declaration/value/function/do/recursive-do-mdo-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do/recursive-do-mdo-four-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE RecursiveDo #-} + +baz = + mdo + bar a + a <- foo + b <- + bar + 1 + 2 + 3 + return (a + b) diff --git a/data/examples/declaration/value/function/do/recursive-do-rec-four-out.hs b/data/examples/declaration/value/function/do/recursive-do-rec-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/do/recursive-do-rec-four-out.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE RecursiveDo #-} + +foo = do + rec a <- b + 5 + + let d = c + + b <- a * 5 + + something + + c <- a + b + print c + rec something $ do + x <- a + print x + + y <- c + print y diff --git a/data/examples/declaration/value/function/equality-constraints-four-out.hs b/data/examples/declaration/value/function/equality-constraints-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/equality-constraints-four-out.hs @@ -0,0 +1,2 @@ +foo :: (a ~ b) => a -> b -> Int +foo = undefined diff --git a/data/examples/declaration/value/function/explicit-type-four-out.hs b/data/examples/declaration/value/function/explicit-type-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/explicit-type-four-out.hs @@ -0,0 +1,5 @@ +foo = 5 :: Int + +bar = + 5 :: + Int diff --git a/data/examples/declaration/value/function/fancy-forall-0-four-out.hs b/data/examples/declaration/value/function/fancy-forall-0-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/fancy-forall-0-four-out.hs @@ -0,0 +1,10 @@ +wrapError :: + forall outertag innertag t outer inner m a. + ( forall x. Coercible (t m x) (m x) + , forall m'. + HasCatch outertag outer m' => + HasCatch innertag inner (t m') + , HasCatch outertag outer m + ) => + (forall m'. HasCatch innertag inner m' => m' a) -> + m a diff --git a/data/examples/declaration/value/function/fancy-forall-1-four-out.hs b/data/examples/declaration/value/function/fancy-forall-1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/fancy-forall-1-four-out.hs @@ -0,0 +1,10 @@ +magnify :: + forall outertag innertag t outer inner m a. + ( forall x. Coercible (t m x) (m x) + , forall m'. + HasReader outertag outer m' => + HasReader innertag inner (t m') + , HasReader outertag outer m + ) => + (forall m'. HasReader innertag inner m' => m' a) -> + m a diff --git a/data/examples/declaration/value/function/guards-four-out.hs b/data/examples/declaration/value/function/guards-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/guards-four-out.hs @@ -0,0 +1,12 @@ +baz :: Int -> Int +baz x | x < 0 = x +baz x | otherwise = x + +multi_baz :: Int -> Int +multi_baz x | x < 42 = x +multi_baz x | x < 0 = x +multi_baz x | otherwise = x + +quux :: Int -> Int +quux x | x < 0 = x +quux x = x diff --git a/data/examples/declaration/value/function/if-multi-line-four-out.hs b/data/examples/declaration/value/function/if-multi-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-multi-line-four-out.hs @@ -0,0 +1,23 @@ +foo :: Int -> Int +foo x = + if x > 5 + then 10 + else 12 + +bar :: Int -> Int +bar x = + if x > 5 + then + foo x + + 100 + else case x of + 1 -> 10 + _ -> 20 + +baz :: Int -> Bar +baz x = + if x > 5 + then \case + Foo -> bar + else do + undefined diff --git a/data/examples/declaration/value/function/if-single-line-four-out.hs b/data/examples/declaration/value/function/if-single-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-single-line-four-out.hs @@ -0,0 +1,6 @@ +foo :: Int -> Int +foo x = if x > 5 then 10 else 12 + +bar :: Int -> Int +bar x = + if x > 5 then 10 else 12 diff --git a/data/examples/declaration/value/function/if-with-comment-four-out.hs b/data/examples/declaration/value/function/if-with-comment-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/if-with-comment-four-out.hs @@ -0,0 +1,8 @@ +foo = + if undefined + then -- then comment + undefined + else -- else comment + + do + undefined diff --git a/data/examples/declaration/value/function/implicit-params-four-out.hs b/data/examples/declaration/value/function/implicit-params-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/implicit-params-four-out.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE ImplicitParams #-} + +sortBy :: (a -> a -> Bool) -> [a] -> [a] +sortBy = undefined + +sort :: (?cmp :: a -> a -> Bool) => [a] -> [a] +sort = sortBy ?cmp + +sort' :: + ( ?cmp :: + a -> a -> Bool + , ?foo :: Int + ) => + [a] -> + [a] +sort' = sort diff --git a/data/examples/declaration/value/function/implicit-params-out.hs b/data/examples/declaration/value/function/implicit-params-out.hs --- a/data/examples/declaration/value/function/implicit-params-out.hs +++ b/data/examples/declaration/value/function/implicit-params-out.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ImplicitParams #-} sortBy :: (a -> a -> Bool) -> [a] -> [a] +sortBy = undefined sort :: (?cmp :: a -> a -> Bool) => [a] -> [a] sort = sortBy ?cmp diff --git a/data/examples/declaration/value/function/implicit-params.hs b/data/examples/declaration/value/function/implicit-params.hs --- a/data/examples/declaration/value/function/implicit-params.hs +++ b/data/examples/declaration/value/function/implicit-params.hs @@ -1,6 +1,8 @@ {-# LANGUAGE ImplicitParams #-} sortBy :: (a -> a -> Bool) -> [a] -> [a] +sortBy = undefined + sort :: (?cmp :: a -> a -> Bool) => [a] -> [a] sort = sortBy ?cmp diff --git a/data/examples/declaration/value/function/infix/applicative-four-out.hs b/data/examples/declaration/value/function/infix/applicative-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/applicative-four-out.hs @@ -0,0 +1,4 @@ +f = + Foo <$> bar + <*> baz + <*> baz' diff --git a/data/examples/declaration/value/function/infix/comments-four-out.hs b/data/examples/declaration/value/function/infix/comments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/comments-four-out.hs @@ -0,0 +1,8 @@ +main = + bar $ -- bar + baz -- baz + +bar $ + {- foo + -} + bar diff --git a/data/examples/declaration/value/function/infix/do-four-out.hs b/data/examples/declaration/value/function/infix/do-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/do-four-out.hs @@ -0,0 +1,13 @@ +main = + do stuff + `finally` do + recover + +main = do stuff `finally` recover + +main = do { stuff } `finally` recover + +foo = + do + 1 + + 2 diff --git a/data/examples/declaration/value/function/infix/dollar-chains-four-out.hs b/data/examples/declaration/value/function/infix/dollar-chains-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/dollar-chains-four-out.hs @@ -0,0 +1,22 @@ +module Main where + +foo = + fmap escapeLeadingDollar + . dropPaddingSpace + . dropWhileEnd T.null + . fmap (T.stripEnd . T.pack) + . lines + $ unpackHDS docStr + +foo = + when (GHC.xopt Cpp dynFlags && not cfgTolerateCpp) $ + throwIO (OrmoluCppEnabled path) + +foo = + bar $ + baz $ + quux + +x = + case l of { A -> B } $ + case q of r -> s diff --git a/data/examples/declaration/value/function/infix/dollar-chains-out.hs b/data/examples/declaration/value/function/infix/dollar-chains-out.hs --- a/data/examples/declaration/value/function/infix/dollar-chains-out.hs +++ b/data/examples/declaration/value/function/infix/dollar-chains-out.hs @@ -13,9 +13,9 @@ throwIO (OrmoluCppEnabled path) foo = - bar - $ baz - $ quux + bar $ + baz $ + quux x = case l of { A -> B } $ diff --git a/data/examples/declaration/value/function/infix/hanging-four-out.hs b/data/examples/declaration/value/function/infix/hanging-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/hanging-four-out.hs @@ -0,0 +1,23 @@ +f = unFoo . foo bar baz 3 $ do + act + ret + +g = unFoo + . foo + bar + baz + 3 + $ do + act + ret + +update = + do + foobar + `catch` \case + a -> a + +foo = + bar + ++ case foo of + a -> a diff --git a/data/examples/declaration/value/function/infix/hanging-out.hs b/data/examples/declaration/value/function/infix/hanging-out.hs --- a/data/examples/declaration/value/function/infix/hanging-out.hs +++ b/data/examples/declaration/value/function/infix/hanging-out.hs @@ -17,6 +17,7 @@ `catch` \case a -> a -foo = bar - ++ case foo of - a -> a +foo = + bar + ++ case foo of + a -> a diff --git a/data/examples/declaration/value/function/infix/lenses-four-out.hs b/data/examples/declaration/value/function/infix/lenses-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/lenses-four-out.hs @@ -0,0 +1,21 @@ +lenses = + Just $ + M.fromList $ + "type" .= ("user.connection" :: Text) + # "connection" .= uc + # "user" .= case name of + Just n -> Just $ object ["name" .= n] + Nothing -> Nothing + # [] + +foo = + a + & b .~ 2 + & c .~ 3 + +wreq = + let opts = + defaults & auth ?~ awsAuth AWSv4 "key" "secret" + & header "Accept" .~ ["application/json"] + & header "Runscope-Bucket-Auth" .~ ["1example-1111-4yyyy-zzzz-xxxxxxxx"] + in getWith opts diff --git a/data/examples/declaration/value/function/infix/lenses-out.hs b/data/examples/declaration/value/function/infix/lenses-out.hs --- a/data/examples/declaration/value/function/infix/lenses-out.hs +++ b/data/examples/declaration/value/function/infix/lenses-out.hs @@ -1,11 +1,12 @@ lenses = - Just $ M.fromList $ - "type" .= ("user.connection" :: Text) - # "connection" .= uc - # "user" .= case name of - Just n -> Just $ object ["name" .= n] - Nothing -> Nothing - # [] + Just $ + M.fromList $ + "type" .= ("user.connection" :: Text) + # "connection" .= uc + # "user" .= case name of + Just n -> Just $ object ["name" .= n] + Nothing -> Nothing + # [] foo = a diff --git a/data/examples/declaration/value/function/infix/simple-four-out.hs b/data/examples/declaration/value/function/infix/simple-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/simple-four-out.hs @@ -0,0 +1,12 @@ +(*) :: Int -> Int -> Int +x * y = z + +foo :: Int -> Int -> Int +x `foo` y = z + +bar :: Int -> Int -> Int -> Int +(x `bar` y) z = z + +multiline :: Int -> Int -> Int +x + `multiline` y = z diff --git a/data/examples/declaration/value/function/infix/unicode-four-out.hs b/data/examples/declaration/value/function/infix/unicode-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/infix/unicode-four-out.hs @@ -0,0 +1,3 @@ +main = print ('a' → 'a') + where + (→) = (,) diff --git a/data/examples/declaration/value/function/lambda-case-four-out.hs b/data/examples/declaration/value/function/lambda-case-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/lambda-case-four-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE LambdaCase #-} + +foo = bar (\case JKey{} -> True; _ -> False) + +foo :: Int -> Int +foo = \case + 5 -> 10 + i | i > 5 -> 11 + _ -> 12 diff --git a/data/examples/declaration/value/function/lambda-multi-line1-four-out.hs b/data/examples/declaration/value/function/lambda-multi-line1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/lambda-multi-line1-four-out.hs @@ -0,0 +1,15 @@ +foo :: a -> a -> a +foo x = \y -> + x + +bar :: Int -> Int -> Int +bar x = \y -> + if x > y + then 10 + else 12 + +foo = + prop "is inverse to closure" $ + \(f :: StaticPtr (Int -> Int)) + (x :: Int) -> + (unclosure . closure) f x == deRefStaticPtr f x diff --git a/data/examples/declaration/value/function/lambda-multi-line2-four-out.hs b/data/examples/declaration/value/function/lambda-multi-line2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/lambda-multi-line2-four-out.hs @@ -0,0 +1,12 @@ +tricky0 = + flip all (zip ws gs) $ \(wt, gt) -> + canUnify poly_given_ok wt gt || go False wt gt + +tricky1 = + flip all (zip ws gs) $ + \(wt, gt) -> canUnify poly_given_ok wt gt || go False wt gt + +tricky2 = + flip all (zip ws gs) $ + \(wt, gt) -> + canUnify poly_given_ok wt gt || go False wt gt diff --git a/data/examples/declaration/value/function/lambda-single-line-four-out.hs b/data/examples/declaration/value/function/lambda-single-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/lambda-single-line-four-out.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE BangPatterns #-} + +foo :: a -> a -> a +foo x = \y -> x + +bar :: a -> a -> a +bar x = + \y -> x + +baz :: a -> a -> a +baz = \ ~x ~y -> x + +zag :: a -> a -> a +zag = \ !x !y -> x + +spl :: a -> a +spl = \ $([p|x|]) -> x diff --git a/data/examples/declaration/value/function/let-multi-line-four-out.hs b/data/examples/declaration/value/function/let-multi-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/let-multi-line-four-out.hs @@ -0,0 +1,28 @@ +foo :: Int -> Int +foo x = + let z = y + y = x + in z + 100 + +bar :: Int -> Int +bar x = + let z = y + y = x + in z + + 100 + +inlineComment :: Int -> Int +inlineComment = + let {- join -} go = case () of + () -> undefined + in go + +implicitParams :: HasCallStack => Int +implicitParams = + let ?cs = ?callstack + in foo cs + +sitting = + foo $ + let x = 20 + in x diff --git a/data/examples/declaration/value/function/let-multi-line-out.hs b/data/examples/declaration/value/function/let-multi-line-out.hs --- a/data/examples/declaration/value/function/let-multi-line-out.hs +++ b/data/examples/declaration/value/function/let-multi-line-out.hs @@ -14,7 +14,7 @@ inlineComment :: Int -> Int inlineComment = let {- join -} go = case () of - () -> undefined + () -> undefined in go implicitParams :: HasCallStack => Int diff --git a/data/examples/declaration/value/function/let-nested-four-out.hs b/data/examples/declaration/value/function/let-nested-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/let-nested-four-out.hs @@ -0,0 +1,3 @@ +_ = _ + where + _ = [_ | let _ = _] diff --git a/data/examples/declaration/value/function/let-single-line-four-out.hs b/data/examples/declaration/value/function/let-single-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/let-single-line-four-out.hs @@ -0,0 +1,8 @@ +foo :: a -> a +foo x = let x = x in x +foo x = let x = z where z = 2 in x +foo x = let x = z where { z = 2 }; a = 3 in x +foo x = let g :: Int -> Int; g = id in () +let a = b; c = do { foo; bar }; d = baz in b +let a = case True of { True -> foo; False -> bar }; b = foo a in b +foo x = let ?g = id; ?f = g in x diff --git a/data/examples/declaration/value/function/list-comprehensions-four-out.hs b/data/examples/declaration/value/function/list-comprehensions-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-comprehensions-four-out.hs @@ -0,0 +1,24 @@ +foo x = [a | a <- x] + +bar x y = [(a, b) | a <- x, even a, b <- y, a != b] + +barbaz x y z w = + [ (a, b, c, d) -- Foo + | a <- + x -- Bar + , b <- y -- Baz + , any even [a, b] + , c <- + z + * z ^ 2 -- Bar baz + , d <- + w + + w -- Baz bar + , all + even + [ a + , b + , c + , d + ] + ] diff --git a/data/examples/declaration/value/function/list-notation-0-four-out.hs b/data/examples/declaration/value/function/list-notation-0-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-notation-0-four-out.hs @@ -0,0 +1,5 @@ +foo = + testCase "Foo" testFoo : + testCase "Bar" testBar : + testCase "Baz" testBaz : + [] diff --git a/data/examples/declaration/value/function/list-notation-0-out.hs b/data/examples/declaration/value/function/list-notation-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-notation-0-out.hs @@ -0,0 +1,5 @@ +foo = + testCase "Foo" testFoo : + testCase "Bar" testBar : + testCase "Baz" testBaz : + [] diff --git a/data/examples/declaration/value/function/list-notation-0.hs b/data/examples/declaration/value/function/list-notation-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-notation-0.hs @@ -0,0 +1,5 @@ +foo = + testCase "Foo" testFoo : + testCase "Bar" testBar : + testCase "Baz" testBaz : + [] diff --git a/data/examples/declaration/value/function/list-notation-1-four-out.hs b/data/examples/declaration/value/function/list-notation-1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-notation-1-four-out.hs @@ -0,0 +1,8 @@ +instance A.ToJSON UpdateTable where + toJSON a = + A.object $ + "TableName" .= updateTableName a : + "ProvisionedThroughput" .= updateProvisionedThroughput a : + case updateGlobalSecondaryIndexUpdates a of + [] -> [] + l -> ["GlobalSecondaryIndexUpdates" .= l] diff --git a/data/examples/declaration/value/function/list-notation-1-out.hs b/data/examples/declaration/value/function/list-notation-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-notation-1-out.hs @@ -0,0 +1,8 @@ +instance A.ToJSON UpdateTable where + toJSON a = + A.object $ + "TableName" .= updateTableName a : + "ProvisionedThroughput" .= updateProvisionedThroughput a : + case updateGlobalSecondaryIndexUpdates a of + [] -> [] + l -> ["GlobalSecondaryIndexUpdates" .= l] diff --git a/data/examples/declaration/value/function/list-notation-1.hs b/data/examples/declaration/value/function/list-notation-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-notation-1.hs @@ -0,0 +1,7 @@ +instance A.ToJSON UpdateTable where + toJSON a = A.object + $ "TableName" .= updateTableName a + : "ProvisionedThroughput" .= updateProvisionedThroughput a + : case updateGlobalSecondaryIndexUpdates a of + [] -> [] + l -> [ "GlobalSecondaryIndexUpdates" .= l ] diff --git a/data/examples/declaration/value/function/list-notation-2-four-out.hs b/data/examples/declaration/value/function/list-notation-2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-notation-2-four-out.hs @@ -0,0 +1,6 @@ +-- A list of the element and all its parents up to the root node. +getPath tree t = + t : + case Map.lookup (getId t) tree of + Nothing -> [] + Just parent -> getPath tree parent diff --git a/data/examples/declaration/value/function/list-notation-2-out.hs b/data/examples/declaration/value/function/list-notation-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-notation-2-out.hs @@ -0,0 +1,6 @@ +-- A list of the element and all its parents up to the root node. +getPath tree t = + t : + case Map.lookup (getId t) tree of + Nothing -> [] + Just parent -> getPath tree parent diff --git a/data/examples/declaration/value/function/list-notation-2.hs b/data/examples/declaration/value/function/list-notation-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-notation-2.hs @@ -0,0 +1,5 @@ +-- A list of the element and all its parents up to the root node. +getPath tree t = t : + case Map.lookup (getId t) tree of + Nothing -> [] + Just parent -> getPath tree parent diff --git a/data/examples/declaration/value/function/list-notation-3-four-out.hs b/data/examples/declaration/value/function/list-notation-3-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-notation-3-four-out.hs @@ -0,0 +1,12 @@ +foo = + reportSDoc "tc.cc" 30 $ + sep $ do + (prettyTCM q <+> " before compilation") : do + map (prettyTCM . map unArg . clPats) cls + +foo = + reportSDoc "tc.cc" 30 $ + sep $ do + (prettyTCM q <+> " before compilation") : + do + map (prettyTCM . map unArg . clPats) cls diff --git a/data/examples/declaration/value/function/list-notation-3-out.hs b/data/examples/declaration/value/function/list-notation-3-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-notation-3-out.hs @@ -0,0 +1,12 @@ +foo = + reportSDoc "tc.cc" 30 $ + sep $ do + (prettyTCM q <+> " before compilation") : do + map (prettyTCM . map unArg . clPats) cls + +foo = + reportSDoc "tc.cc" 30 $ + sep $ do + (prettyTCM q <+> " before compilation") : + do + map (prettyTCM . map unArg . clPats) cls diff --git a/data/examples/declaration/value/function/list-notation-3.hs b/data/examples/declaration/value/function/list-notation-3.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/list-notation-3.hs @@ -0,0 +1,10 @@ +foo = + reportSDoc "tc.cc" 30 $ sep $ do + (prettyTCM q <+> " before compilation") : do + map (prettyTCM . map unArg . clPats) cls + +foo = + reportSDoc "tc.cc" 30 $ sep $ do + (prettyTCM q <+> " before compilation") : + do + map (prettyTCM . map unArg . clPats) cls diff --git a/data/examples/declaration/value/function/multi-way-if-four-out.hs b/data/examples/declaration/value/function/multi-way-if-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multi-way-if-four-out.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE MultiWayIf #-} + +foo x = if | x == 5 -> 5 + +bar x y = + if + | x > y -> x + | x < y -> + y + | otherwise -> x + +baz = + if + | p -> f + | otherwise -> g + x diff --git a/data/examples/declaration/value/function/multiline-arguments-four-out.hs b/data/examples/declaration/value/function/multiline-arguments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiline-arguments-four-out.hs @@ -0,0 +1,8 @@ +foo :: Int -> Int -> Int -> Int +foo + (Foo g o) + ( Bar + x + y + ) + z = x diff --git a/data/examples/declaration/value/function/multiple-guards-four-out.hs b/data/examples/declaration/value/function/multiple-guards-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiple-guards-four-out.hs @@ -0,0 +1,14 @@ +foo :: Int -> Int +foo x + | x == 5 = 10 + | otherwise = 12 + +bar :: Int -> Int +bar x + | x == 5 = + foo x + + foo 10 + | x == 6 = + foo x + + foo 20 + | otherwise = foo 100 diff --git a/data/examples/declaration/value/function/multiple-matches-four-out.hs b/data/examples/declaration/value/function/multiple-matches-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/multiple-matches-four-out.hs @@ -0,0 +1,3 @@ +foo :: Int -> Int +foo 5 = 10 +foo _ = 12 diff --git a/data/examples/declaration/value/function/negation-four-out.hs b/data/examples/declaration/value/function/negation-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/negation-four-out.hs @@ -0,0 +1,8 @@ +foo :: Int +foo = (-2) + +bar :: Int +bar = -2 + +baz :: Int +baz = - 2 diff --git a/data/examples/declaration/value/function/newline-single-line-body-four-out.hs b/data/examples/declaration/value/function/newline-single-line-body-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/newline-single-line-body-four-out.hs @@ -0,0 +1,10 @@ +function :: Int -> Int +function a = + aReallyLongFunctionNameThatShouldStayOnThisLineToAvoidOverflowing 10000 a + +function' :: String -> String +function' s = case s of + "ThisString" -> + -- And a comment here is okay + "Yay" + _ -> "Boo" diff --git a/data/examples/declaration/value/function/operator-comments-0-four-out.hs b/data/examples/declaration/value/function/operator-comments-0-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-comments-0-four-out.hs @@ -0,0 +1,16 @@ +foo = + bar + ++ + {- some comment -} + case foo of + a -> a + +foo = + bar + ++ {- some comment -} case foo of + a -> a + +foo = + bar + ++ case foo {- some comment -} of + a -> a diff --git a/data/examples/declaration/value/function/operator-comments-1-four-out.hs b/data/examples/declaration/value/function/operator-comments-1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-comments-1-four-out.hs @@ -0,0 +1,16 @@ +foo = + bar + ++ + -- some comment + case foo of + a -> a + +foo = + bar + ++ case foo of -- some comment + a -> a + +foo = + bar + ++ case foo of -- some comment + a -> a diff --git a/data/examples/declaration/value/function/operator-comments-2-four-out.hs b/data/examples/declaration/value/function/operator-comments-2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-comments-2-four-out.hs @@ -0,0 +1,5 @@ +x = + y + ++ f g -- commentA + -- commentB + -- commentC diff --git a/data/examples/declaration/value/function/operator-sections-four-out.hs b/data/examples/declaration/value/function/operator-sections-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operator-sections-four-out.hs @@ -0,0 +1,11 @@ +foo = (0 +) +bar = (<> "hello") +baz = + ( 1 * 2 + + + ) + ( * + 3 ^ 5 + ) + +quux = (,) <$> foo <$> bar diff --git a/data/examples/declaration/value/function/operators-0-four-out.hs b/data/examples/declaration/value/function/operators-0-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-0-four-out.hs @@ -0,0 +1,5 @@ +a = + b & c .~ d + & e + %~ f + g diff --git a/data/examples/declaration/value/function/operators-1-four-out.hs b/data/examples/declaration/value/function/operators-1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-1-four-out.hs @@ -0,0 +1,4 @@ +foo = + f + . g + =<< h . i diff --git a/data/examples/declaration/value/function/operators-2-four-out.hs b/data/examples/declaration/value/function/operators-2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-2-four-out.hs @@ -0,0 +1,4 @@ +foo n + | x || y && z || n ** x + || x && n = + 42 diff --git a/data/examples/declaration/value/function/operators-3-four-out.hs b/data/examples/declaration/value/function/operators-3-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-3-four-out.hs @@ -0,0 +1,3 @@ +foo = + op <> n <+> colon <+> prettySe <+> text "=" + <+> prettySe <> text sc diff --git a/data/examples/declaration/value/function/operators-4-four-out.hs b/data/examples/declaration/value/function/operators-4-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-4-four-out.hs @@ -0,0 +1,3 @@ +foo = + line <> bindingOf <+> text "=" <+> tPretty <+> colon + <+> align <> prettyPs diff --git a/data/examples/declaration/value/function/operators-5-four-out.hs b/data/examples/declaration/value/function/operators-5-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-5-four-out.hs @@ -0,0 +1,5 @@ +foo = + map bar $ + [ baz + ] + ++ quux diff --git a/data/examples/declaration/value/function/operators-6-four-out.hs b/data/examples/declaration/value/function/operators-6-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/operators-6-four-out.hs @@ -0,0 +1,9 @@ +type PermuteRef = + "a" + :> ( "b" :> "c" :> End + :<|> "c" :> "b" :> End + ) + :<|> "b" + :> ( "a" :> "c" :> End + :<|> "c" :> "a" :> End + ) diff --git a/data/examples/declaration/value/function/operators-6-out.hs b/data/examples/declaration/value/function/operators-6-out.hs --- a/data/examples/declaration/value/function/operators-6-out.hs +++ b/data/examples/declaration/value/function/operators-6-out.hs @@ -1,9 +1,9 @@ type PermuteRef = "a" :> ( "b" :> "c" :> End - :<|> "c" :> "b" :> End + :<|> "c" :> "b" :> End ) :<|> "b" :> ( "a" :> "c" :> End - :<|> "c" :> "a" :> End + :<|> "c" :> "a" :> End ) diff --git a/data/examples/declaration/value/function/overindentation-four-out.hs b/data/examples/declaration/value/function/overindentation-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/overindentation-four-out.hs @@ -0,0 +1,11 @@ +reallyincrediblyLongName = + f + a + A + { reallyincrediblyLongName = + f + a + A + { reallyincrediblyLongName + } + } diff --git a/data/examples/declaration/value/function/overloaded-labels-four-out.hs b/data/examples/declaration/value/function/overloaded-labels-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/overloaded-labels-four-out.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE OverloadedLabels #-} + +foo = #field +bar = (#this) (#that) diff --git a/data/examples/declaration/value/function/parallel-comprehensions-complex-four-out.hs b/data/examples/declaration/value/function/parallel-comprehensions-complex-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/parallel-comprehensions-complex-four-out.hs @@ -0,0 +1,35 @@ +baz x y z w = + [ ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + ) + | a <- -- Foo 1 + x -- Foo 2 + , b <- -- Bar 1 + y -- Bar 2 + , a + `mod` b -- Value + == 0 + | c <- -- Baz 1 + z + * z -- Baz 2 + -- Baz 3 + | d <- w -- Other + | e <- x * x -- Foo bar + | f <- -- Foo baz 1 + y + y -- Foo baz 2 + | h <- z + z * w ^ 2 -- Bar foo + | i <- -- Bar bar 1 + a + + b -- Bar bar 2 + -- Bar bar 3 + , j <- -- Bar baz 1 + a + b -- Bar baz 2 + ] diff --git a/data/examples/declaration/value/function/parallel-comprehensions-single-line-four-out.hs b/data/examples/declaration/value/function/parallel-comprehensions-single-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/parallel-comprehensions-single-line-four-out.hs @@ -0,0 +1,3 @@ +foo x y = [(a, b) | a <- x | b <- y] + +bar x y z w = [(a, b, c, d) | a <- x, b <- y, a `mod` b == 0 | c <- z | d <- w] diff --git a/data/examples/declaration/value/function/parens-four-out.hs b/data/examples/declaration/value/function/parens-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/parens-four-out.hs @@ -0,0 +1,1 @@ +f = p (do foo; bar) baz diff --git a/data/examples/declaration/value/function/parenthesis-lhs-four-out.hs b/data/examples/declaration/value/function/parenthesis-lhs-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/parenthesis-lhs-four-out.hs @@ -0,0 +1,9 @@ +(!=!) 2 y = 1 +x !=! y = 2 + +x ?=? [] = 123 +(?=?) x (_ : []) = 456 +x ?=? _ = f x x + where + f x 7 = 789 + x `f` _ = 101 diff --git a/data/examples/declaration/value/function/pattern/as-pattern-four-out.hs b/data/examples/declaration/value/function/pattern/as-pattern-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/as-pattern-four-out.hs @@ -0,0 +1,3 @@ +main = case [1] of + xs@(x : _) -> print (x, xs) + xs@[] -> print xs diff --git a/data/examples/declaration/value/function/pattern/famous-cardano-pattern-four-out.hs b/data/examples/declaration/value/function/pattern/famous-cardano-pattern-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/famous-cardano-pattern-four-out.hs @@ -0,0 +1,8 @@ +( getNodeSettingsR + :<|> getNodeInfoR + :<|> getNextUpdateR + :<|> restartNodeR + ) + :<|> ( getUtxoR + :<|> getConfirmedProposalsR + ) = client nodeV1Api diff --git a/data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs b/data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs --- a/data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs +++ b/data/examples/declaration/value/function/pattern/famous-cardano-pattern-out.hs @@ -4,5 +4,5 @@ :<|> restartNodeR ) :<|> ( getUtxoR - :<|> getConfirmedProposalsR - ) = client nodeV1Api + :<|> getConfirmedProposalsR + ) = client nodeV1Api diff --git a/data/examples/declaration/value/function/pattern/multiline-case-pattern-four-out.hs b/data/examples/declaration/value/function/pattern/multiline-case-pattern-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/multiline-case-pattern-four-out.hs @@ -0,0 +1,15 @@ +readerBench doc name = + runPure $ case (getReader name, getWriter name) of + ( Right (TextReader r, rexts) + , Right (TextWriter w, wexts) + ) -> undefined + +f xs = case xs of + [ a + , b + ] -> a + b + +g xs = case xs of + ( a + : bs + ) -> a + b diff --git a/data/examples/declaration/value/function/pattern/n-plus-k-pattern-four-out.hs b/data/examples/declaration/value/function/pattern/n-plus-k-pattern-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/n-plus-k-pattern-four-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE NPlusKPatterns #-} + +singleline :: Int +singleline (n + 1) = n + +multiline :: Int +multiline + ( n + + 1 + ) = n + +n :: Int +(n + 1) = 3 diff --git a/data/examples/declaration/value/function/pattern/pattern-bind-four-out.hs b/data/examples/declaration/value/function/pattern/pattern-bind-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/pattern-bind-four-out.hs @@ -0,0 +1,9 @@ +foo = bar + where + Foo bar baz = quux + Baz + quux = zoo + +foo = bar + where + Foo bar baz = quux diff --git a/data/examples/declaration/value/function/pattern/quasi-quotes-pattern-four-out.hs b/data/examples/declaration/value/function/pattern/quasi-quotes-pattern-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/quasi-quotes-pattern-four-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE QuasiQuotes #-} + +singleline :: () +singleline [yamlQQ|something|] = () + +multiline :: () +multiline = case y of + [yamlQQ| name: John Doe +age: 23 +|] -> () diff --git a/data/examples/declaration/value/function/pattern/record-patterns-four-out.hs b/data/examples/declaration/value/function/pattern/record-patterns-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/record-patterns-four-out.hs @@ -0,0 +1,19 @@ +foo :: Boom -> Int +foo Boom{..} = 10 + +bar0 :: Boom -> Int +bar0 Boom{boom} = boom + +bar1 :: Boom -> Int +bar1 Boom{boom = b} = b + +baz :: Boom -> Int +baz Boom{boom = b, ..} = b + +quux :: Boom -> Int +quux + Boom + { boom = a + , foom = b + , .. + } = a + b diff --git a/data/examples/declaration/value/function/pattern/sig-pattern-four-out.hs b/data/examples/declaration/value/function/pattern/sig-pattern-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/sig-pattern-four-out.hs @@ -0,0 +1,7 @@ +f = do + x :: a <- g + +f = do + (x, y) :: + (a, b) <- + g diff --git a/data/examples/declaration/value/function/pattern/splice-pattern-four-out.hs b/data/examples/declaration/value/function/pattern/splice-pattern-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/splice-pattern-four-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +singleLine = case () of + $x -> () + $(y "something") -> () + +multiline = case () of + $( x + + y + ) -> () + $( y + "something" + ) -> () diff --git a/data/examples/declaration/value/function/pattern/splice-pattern-out.hs b/data/examples/declaration/value/function/pattern/splice-pattern-out.hs --- a/data/examples/declaration/value/function/pattern/splice-pattern-out.hs +++ b/data/examples/declaration/value/function/pattern/splice-pattern-out.hs @@ -6,8 +6,8 @@ multiline = case () of $( x - + y + + y ) -> () $( y - "something" + "something" ) -> () diff --git a/data/examples/declaration/value/function/pattern/strictness-four-out.hs b/data/examples/declaration/value/function/pattern/strictness-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/strictness-four-out.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE BangPatterns #-} + +!a = () +~b = () diff --git a/data/examples/declaration/value/function/pattern/unboxed-sum-pattern-four-out.hs b/data/examples/declaration/value/function/pattern/unboxed-sum-pattern-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/unboxed-sum-pattern-four-out.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE UnboxedSums #-} + +v = True + where + (# _x #) = (# True #) + +p = True + where + (# _x | #) = (# | True #) + +q = True + where + (# | _x | #) = (# | True | #) + +z = True + where + (# | | _x #) = (# | | True #) + +z_multiline = True + where + (# + | | _x + #) = + (# + | | True + #) diff --git a/data/examples/declaration/value/function/pattern/view-pattern-four-out.hs b/data/examples/declaration/value/function/pattern/view-pattern-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pattern/view-pattern-four-out.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ViewPatterns #-} + +example f (f -> 4) = True + +f (t -> Nothing) = "Nothing" +f (t -> Just _) = "Just" + +g ((f, _), f -> 4) = True + +multiline + ( t -> + Foo + bar + baz + ) = True diff --git a/data/examples/declaration/value/function/pragmas-four-out.hs b/data/examples/declaration/value/function/pragmas-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/pragmas-four-out.hs @@ -0,0 +1,9 @@ +sccfoo = {-# SCC foo #-} 1 +sccbar = + {-# SCC "barbaz" #-} + "hello" + +corefoo = {-# CORE "foo" #-} 1 +corebar = + {-# CORE "bar baz" #-} + "hello" diff --git a/data/examples/declaration/value/function/prefix-four-out.hs b/data/examples/declaration/value/function/prefix-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/prefix-four-out.hs @@ -0,0 +1,1 @@ +foo x y = (+) x y diff --git a/data/examples/declaration/value/function/quasi-quotes-four-out.hs b/data/examples/declaration/value/function/quasi-quotes-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/quasi-quotes-four-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE QuasiQuotes #-} + +singleline :: Value +singleline = [yamlQQ|something|] + +multiline :: Value +multiline = + [yamlQQ| name: John Doe +age: 23 + +something: foo +|] diff --git a/data/examples/declaration/value/function/simple-four-out.hs b/data/examples/declaration/value/function/simple-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/simple-four-out.hs @@ -0,0 +1,2 @@ +bar x = x +baz = x diff --git a/data/examples/declaration/value/function/splice-four-out.hs b/data/examples/declaration/value/function/splice-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/splice-four-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + +bar = $bar + +bar' = $(bar "something") + +baz = $$baz + +baz' = $$(baz "something") diff --git a/data/examples/declaration/value/function/static-pointers-four-out.hs b/data/examples/declaration/value/function/static-pointers-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/static-pointers-four-out.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE StaticPointers #-} + +foo :: StaticPtr Int +foo = static 5 + +bar :: StaticPtr [Int] +bar = + static + [ 1 + , 2 + , 3 + ] + +baz :: StaticPtr Bool +baz = + static + ( fun + 1 + 2 + ) diff --git a/data/examples/declaration/value/function/strings-four-out.hs b/data/examples/declaration/value/function/strings-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/strings-four-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MagicHash #-} + +foo = "foobar" +bar = "foo\&barbaz" +baz = + "foo\ + \bar\ + \baz" diff --git a/data/examples/declaration/value/function/tricky-parens-four-out.hs b/data/examples/declaration/value/function/tricky-parens-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/tricky-parens-four-out.hs @@ -0,0 +1,4 @@ +handleStuff = + ( let foo = foo + in foo + ) diff --git a/data/examples/declaration/value/function/tuple-sections-four-out.hs b/data/examples/declaration/value/function/tuple-sections-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/tuple-sections-four-out.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TupleSections #-} + +foo = (,2) +bar = (,5,) +baz = + (,,5,6,7,,,) diff --git a/data/examples/declaration/value/function/tuples-four-out.hs b/data/examples/declaration/value/function/tuples-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/tuples-four-out.hs @@ -0,0 +1,13 @@ +foo = (1, 2, 3) +bar = + ( 1 + , 2 + , 3 + ) + +handleStuff = + ( let foo = foo + in foo + , let bar = bar + in bar + ) diff --git a/data/examples/declaration/value/function/type-applications-and-splice-four-out.hs b/data/examples/declaration/value/function/type-applications-and-splice-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/type-applications-and-splice-four-out.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +staticKey name = [|sing @ $(symFQN name)|] diff --git a/data/examples/declaration/value/function/type-applications-and-splice-out.hs b/data/examples/declaration/value/function/type-applications-and-splice-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/type-applications-and-splice-out.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +staticKey name = [|sing @ $(symFQN name)|] diff --git a/data/examples/declaration/value/function/type-applications-and-splice.hs b/data/examples/declaration/value/function/type-applications-and-splice.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/type-applications-and-splice.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +staticKey name = [| sing @ $(symFQN name) |] diff --git a/data/examples/declaration/value/function/type-applications-four-out.hs b/data/examples/declaration/value/function/type-applications-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/type-applications-four-out.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeApplications #-} + +foo = f @String a b c + +bar = f @(Maybe Int) a b + +baz = + f @Int @String + a + b + +goo = + hash + @(HASH TPraosStandardCrypto) + @ByteString + "And the lamb lies down on Broadway" diff --git a/data/examples/declaration/value/function/typed-expressions-four-out.hs b/data/examples/declaration/value/function/typed-expressions-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/typed-expressions-four-out.hs @@ -0,0 +1,4 @@ +foo x = x :: Int +bar x = + Just x :: + Maybe String diff --git a/data/examples/declaration/value/function/typed-hole-four-out.hs b/data/examples/declaration/value/function/typed-hole-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/typed-hole-four-out.hs @@ -0,0 +1,5 @@ +foo = 1 `_` 2 + +bar = 1 `_a` 2 + +baz = _ `something` _ diff --git a/data/examples/declaration/value/function/unboxed-string-lit-four-out.hs b/data/examples/declaration/value/function/unboxed-string-lit-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/unboxed-string-lit-four-out.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE MagicHash #-} + +main = new "p"# diff --git a/data/examples/declaration/value/function/unboxed-sums-four-out.hs b/data/examples/declaration/value/function/unboxed-sums-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/unboxed-sums-four-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE UnboxedSums #-} + +foo = (# 1 | #) +bar = (# | | 2 | #) +baz = + (# + | | | 10 | | | | | + #) diff --git a/data/examples/declaration/value/function/unboxed-tuples-four-out.hs b/data/examples/declaration/value/function/unboxed-tuples-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/unboxed-tuples-four-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE UnboxedTuples #-} + +foo = (# 1, 2, 3 #) +bar = + (# + 1 + , 2 + , 3 + #) diff --git a/data/examples/declaration/value/function/where-four-out.hs b/data/examples/declaration/value/function/where-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/where-four-out.hs @@ -0,0 +1,19 @@ +foo :: Int -> Int +foo x = f x where f z = z + +bar :: Int -> Int +bar x = f x + where + f :: Int -> Int + f z = z + +baz :: Int -> Int +baz x = q + where + y = x + z = y + q = z + +emptyWhere :: Int +emptyWhere = 5 + where diff --git a/data/examples/declaration/value/function/where-nested-four-out.hs b/data/examples/declaration/value/function/where-nested-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/function/where-nested-four-out.hs @@ -0,0 +1,12 @@ +foo = bar + where + f1 = f1 + where + f1 = 3 + f2 = f2 + where + f2 = 3 + +foo2 = bar + where + f1 = f1 where { f1 = 3; f1' = 4 }; f2 = f2 where f2 = 3; f2' = 4 diff --git a/data/examples/declaration/value/other/comments-get-before-op-four-out.hs b/data/examples/declaration/value/other/comments-get-before-op-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/other/comments-get-before-op-four-out.hs @@ -0,0 +1,10 @@ +main :: IO () +main = do + migrateSchema + [ migration1 + , migration1 + , migration3 + -- When adding migrations here, don't forget to update + -- 'schemaVersion' in Galley.Data + ] + `finally` Log.close diff --git a/data/examples/declaration/value/other/line-multi-line-four-out.hs b/data/examples/declaration/value/other/line-multi-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/other/line-multi-line-four-out.hs @@ -0,0 +1,6 @@ +x :: [Int] +x = + [ 1 + , 2 + , somethingSomething 3 + ] diff --git a/data/examples/declaration/value/other/line-single-line-four-out.hs b/data/examples/declaration/value/other/line-single-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/other/line-single-line-four-out.hs @@ -0,0 +1,2 @@ +x :: [Int] +x = [1, 2, 3] diff --git a/data/examples/declaration/value/pattern-synonyms/bidirectional-four-out.hs b/data/examples/declaration/value/pattern-synonyms/bidirectional-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/pattern-synonyms/bidirectional-four-out.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} + +pattern Arrow t1 t2 = App "->" [t1, t2] +pattern Arrow{t1, t2} = App "->" [t1, t2] +pattern Arrow + { t1 + , t2 + } = + App "->" [t1, t2] +pattern Int = + App "Int" [] +pattern Maybe{t} = + App + "Maybe" + [t] +pattern Maybe t = + App + "Maybe" + [t] + +pattern a :< b <- + (a, b) diff --git a/data/examples/declaration/value/pattern-synonyms/bidirectional.hs b/data/examples/declaration/value/pattern-synonyms/bidirectional.hs --- a/data/examples/declaration/value/pattern-synonyms/bidirectional.hs +++ b/data/examples/declaration/value/pattern-synonyms/bidirectional.hs @@ -18,4 +18,3 @@ pattern a :< b <- (a , b) - diff --git a/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-four-out.hs b/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-four-out.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE PatternSynonyms #-} + +pattern P a <- C a where P a = C a + +pattern HeadC x <- + x : xs + where + HeadC x = [x] + +pattern HeadC' x <- + x : xs + where + HeadC' x = [x] + +pattern Simple <- + "Simple" + where + Simple = "Complicated" + +pattern a :< b <- + (a, b) + where + a :< b = (a, b) diff --git a/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-out.hs b/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-out.hs --- a/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-out.hs +++ b/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional-out.hs @@ -1,5 +1,7 @@ {-# LANGUAGE PatternSynonyms #-} +pattern P a <- C a where P a = C a + pattern HeadC x <- x : xs where diff --git a/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional.hs b/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional.hs --- a/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional.hs +++ b/data/examples/declaration/value/pattern-synonyms/explicitely-bidirectional.hs @@ -1,5 +1,7 @@ {-# LANGUAGE PatternSynonyms #-} +pattern P a <- C a where P a = C a + pattern HeadC x <- x:xs where HeadC x = [x] @@ -16,4 +18,3 @@ (a , b) where a :< b = (a, b) - diff --git a/data/examples/declaration/value/pattern-synonyms/unidirectional-four-out.hs b/data/examples/declaration/value/pattern-synonyms/unidirectional-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/value/pattern-synonyms/unidirectional-four-out.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE PatternSynonyms #-} + +pattern Head x <- x : xs + +pattern Head' x <- + x : xs + +pattern Head''{x} <- + x : xs + +pattern FirstTwo{x, y} <- + x : (y : xs) + +pattern FirstTwo' + { x + , y + } <- + x : (y : xs) + +pattern Simple <- "Simple" + +pattern WithTypeSig :: String +pattern WithTypeSig <- "WithTypeSig" diff --git a/data/examples/declaration/warning/warning-multiline-four-out.hs b/data/examples/declaration/warning/warning-multiline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/warning/warning-multiline-four-out.hs @@ -0,0 +1,9 @@ +{-# WARNING + test + , foo + [ "These are bad functions" + , "Really bad!" + ] + #-} +test :: IO () +test = pure () diff --git a/data/examples/declaration/warning/warning-single-line-four-out.hs b/data/examples/declaration/warning/warning-single-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/declaration/warning/warning-single-line-four-out.hs @@ -0,0 +1,13 @@ +{-# DEPRECATED test, foo "This is a deprecation" #-} +{-# WARNING test "This is a warning" #-} +test :: IO () +test = pure () + +bar = 3 +{-# DEPRECATED bar "Bar is deprecated" #-} + +{-# DEPRECATED baz "Baz is also deprecated" #-} +baz = 5 + +data Number = Number Dobule +{-# DEPRECATED Number "Use Scientific instead." #-} diff --git a/data/examples/import/comments-inside-imports-four-out.hs b/data/examples/import/comments-inside-imports-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/comments-inside-imports-four-out.hs @@ -0,0 +1,8 @@ +import -- x + Foo + +import qualified -- x + Bar + +import qualified -- x + Baz diff --git a/data/examples/import/comments-per-import-four-out.hs b/data/examples/import/comments-per-import-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/comments-per-import-four-out.hs @@ -0,0 +1,4 @@ +-- (1) +import Bar -- (2) +import Baz -- (3) +import Foo diff --git a/data/examples/import/deduplication-bug-four-out.hs b/data/examples/import/deduplication-bug-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/deduplication-bug-four-out.hs @@ -0,0 +1,6 @@ +import Foo1 (Bar1 (..), Baz1) +import Foo2 (Bar2 (..), Baz2) +import Foo3 (Bar3 (x1, x2, x3)) +import Foo4 (Bar4 (x1, x2)) +import Foo5 (Bar5 (x1)) +import Foo6 (Bar6 (..)) diff --git a/data/examples/import/deduplication-bug-out.hs b/data/examples/import/deduplication-bug-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/deduplication-bug-out.hs @@ -0,0 +1,6 @@ +import Foo1 (Bar1 (..), Baz1) +import Foo2 (Bar2 (..), Baz2) +import Foo3 (Bar3 (x1, x2, x3)) +import Foo4 (Bar4 (x1, x2)) +import Foo5 (Bar5 (x1)) +import Foo6 (Bar6 (..)) diff --git a/data/examples/import/deduplication-bug.hs b/data/examples/import/deduplication-bug.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/deduplication-bug.hs @@ -0,0 +1,6 @@ +import Foo1 (Bar1, Baz1, Bar1(..)) +import Foo2 (Bar2(..), Baz2, Bar2) +import Foo3 (Bar3(x1,x3), Bar3(x1, x2)) +import Foo4 (Bar4(x1), Bar4(x2)) +import Foo5 (Bar5, Bar5(x1)) +import Foo6 (Bar6(x1), Bar6(..)) diff --git a/data/examples/import/explicit-imports-four-out.hs b/data/examples/import/explicit-imports-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-imports-four-out.hs @@ -0,0 +1,12 @@ +import qualified MegaModule as M ( + Either, + Maybe (Just, Nothing), + MaybeT (..), + Monad (return, (>>), (>>=)), + MonadBaseControl, + join, + liftIO, + void, + (<<<), + (>>>), + ) diff --git a/data/examples/import/explicit-imports-out.hs b/data/examples/import/explicit-imports-out.hs --- a/data/examples/import/explicit-imports-out.hs +++ b/data/examples/import/explicit-imports-out.hs @@ -1,12 +1,12 @@ import qualified MegaModule as M - ( (<<<), - (>>>), - Either, + ( Either, Maybe (Just, Nothing), MaybeT (..), - Monad ((>>), (>>=), return), + Monad (return, (>>), (>>=)), MonadBaseControl, join, liftIO, void, + (<<<), + (>>>), ) diff --git a/data/examples/import/explicit-imports-with-comments-four-out.hs b/data/examples/import/explicit-imports-with-comments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-imports-with-comments-four-out.hs @@ -0,0 +1,7 @@ +import qualified MegaModule as M ( + -- (1) + -- (2) + Either, -- (3) + (<<<), + (>>>), + ) diff --git a/data/examples/import/explicit-imports-with-comments-out.hs b/data/examples/import/explicit-imports-with-comments-out.hs --- a/data/examples/import/explicit-imports-with-comments-out.hs +++ b/data/examples/import/explicit-imports-with-comments-out.hs @@ -1,6 +1,7 @@ import qualified MegaModule as M ( -- (1) - (<<<), -- (2) - (>>>), + -- (2) Either, -- (3) + (<<<), + (>>>), ) diff --git a/data/examples/import/explicit-prelude-four-out.hs b/data/examples/import/explicit-prelude-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/explicit-prelude-four-out.hs @@ -0,0 +1,3 @@ +import Aaa +import Zzz +import Prelude diff --git a/data/examples/import/merging-0-four-out.hs b/data/examples/import/merging-0-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/merging-0-four-out.hs @@ -0,0 +1,3 @@ +import Foo +import Foo (bar, foo) +import Foo as F diff --git a/data/examples/import/merging-0-out.hs b/data/examples/import/merging-0-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/merging-0-out.hs @@ -0,0 +1,3 @@ +import Foo +import Foo (bar, foo) +import Foo as F diff --git a/data/examples/import/merging-0.hs b/data/examples/import/merging-0.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/merging-0.hs @@ -0,0 +1,4 @@ +import Foo +import Foo (foo) +import Foo (bar) +import Foo as F diff --git a/data/examples/import/merging-1-four-out.hs b/data/examples/import/merging-1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/merging-1-four-out.hs @@ -0,0 +1,2 @@ +import "bar" Foo (bar) +import "foo" Foo (baz, foo) diff --git a/data/examples/import/merging-1-out.hs b/data/examples/import/merging-1-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/merging-1-out.hs @@ -0,0 +1,2 @@ +import "bar" Foo (bar) +import "foo" Foo (baz, foo) diff --git a/data/examples/import/merging-1.hs b/data/examples/import/merging-1.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/merging-1.hs @@ -0,0 +1,3 @@ +import "foo" Foo (foo) +import "bar" Foo (bar) +import "foo" Foo (baz) diff --git a/data/examples/import/merging-2-four-out.hs b/data/examples/import/merging-2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/merging-2-four-out.hs @@ -0,0 +1,2 @@ +import Foo hiding (bar4, foo2) +import qualified Foo (bar3, foo1) diff --git a/data/examples/import/merging-2-out.hs b/data/examples/import/merging-2-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/merging-2-out.hs @@ -0,0 +1,2 @@ +import Foo hiding (bar4, foo2) +import qualified Foo (bar3, foo1) diff --git a/data/examples/import/merging-2.hs b/data/examples/import/merging-2.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/merging-2.hs @@ -0,0 +1,4 @@ +import qualified Foo (foo1) +import Foo hiding (foo2) +import qualified Foo (bar3) +import Foo hiding (bar4) diff --git a/data/examples/import/misc-four-out.hs b/data/examples/import/misc-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/misc-four-out.hs @@ -0,0 +1,7 @@ +import A hiding ( + foobarbazqux, + ) + +import Name hiding () + +import {-# SOURCE #-} safe qualified Module as M hiding (a, b, c, d, e, f) diff --git a/data/examples/import/misc-out.hs b/data/examples/import/misc-out.hs --- a/data/examples/import/misc-out.hs +++ b/data/examples/import/misc-out.hs @@ -1,11 +1,5 @@ import A hiding ( foobarbazqux, - foobarbazqux, - foobarbazqux, - foobarbazqux, - foobarbazqux, - foobarbazqux, - foobarbazqux, ) import {-# SOURCE #-} safe qualified Module as M hiding (a, b, c, d, e, f) import Name hiding () diff --git a/data/examples/import/nested-explicit-imports-four-out.hs b/data/examples/import/nested-explicit-imports-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/nested-explicit-imports-four-out.hs @@ -0,0 +1,10 @@ +import qualified MegaModule as M ( + Either, + Monad ( + return, + (>>), + (>>=) + ), + (<<<), + (>>>), + ) diff --git a/data/examples/import/nested-explicit-imports-out.hs b/data/examples/import/nested-explicit-imports-out.hs --- a/data/examples/import/nested-explicit-imports-out.hs +++ b/data/examples/import/nested-explicit-imports-out.hs @@ -1,10 +1,10 @@ import qualified MegaModule as M - ( (<<<), - (>>>), - Either, + ( Either, Monad - ( (>>), - (>>=), - return + ( return, + (>>), + (>>=) ), + (<<<), + (>>>), ) diff --git a/data/examples/import/qualified-post-four-out.hs b/data/examples/import/qualified-post-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/qualified-post-four-out.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +import Data.Text qualified (a, b, c) +import Data.Text qualified hiding (a, b, c) +import Data.Text qualified as T diff --git a/data/examples/import/qualified-post-out.hs b/data/examples/import/qualified-post-out.hs --- a/data/examples/import/qualified-post-out.hs +++ b/data/examples/import/qualified-post-out.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ImportQualifiedPost #-} -import Data.Text qualified as T import Data.Text qualified (a, b, c) import Data.Text qualified hiding (a, b, c) +import Data.Text qualified as T diff --git a/data/examples/import/qualified-prelude-four-out.hs b/data/examples/import/qualified-prelude-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/qualified-prelude-four-out.hs @@ -0,0 +1,4 @@ +module P where + +import Prelude hiding (id, (.)) +import qualified Prelude diff --git a/data/examples/import/qualified-prelude-out.hs b/data/examples/import/qualified-prelude-out.hs --- a/data/examples/import/qualified-prelude-out.hs +++ b/data/examples/import/qualified-prelude-out.hs @@ -1,4 +1,4 @@ module P where +import Prelude hiding (id, (.)) import qualified Prelude -import Prelude hiding ((.), id) diff --git a/data/examples/import/simple-four-out.hs b/data/examples/import/simple-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/simple-four-out.hs @@ -0,0 +1,5 @@ +import Data.Text +import Data.Text (a, b, c) +import Data.Text hiding (a, b, c) +import qualified Data.Text (a, b, c) +import qualified Data.Text as T diff --git a/data/examples/import/simple-out.hs b/data/examples/import/simple-out.hs --- a/data/examples/import/simple-out.hs +++ b/data/examples/import/simple-out.hs @@ -1,6 +1,5 @@ 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) +import qualified Data.Text (a, b, c) +import qualified Data.Text as T diff --git a/data/examples/import/simple.hs b/data/examples/import/simple.hs --- a/data/examples/import/simple.hs +++ b/data/examples/import/simple.hs @@ -4,3 +4,5 @@ import qualified Data.Text (a, c, b) import Data.Text (a, b, c) import Data.Text hiding (c, b, a) +import Data.Text (a, b, c, b, a) +import Data.Text hiding (c, b, a, b, c) diff --git a/data/examples/import/sorted-export-list-four-out.hs b/data/examples/import/sorted-export-list-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/sorted-export-list-four-out.hs @@ -0,0 +1,1 @@ +import Linear.Vector (Additive (..), (*^), (^*)) diff --git a/data/examples/import/sorted-export-list-out.hs b/data/examples/import/sorted-export-list-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/sorted-export-list-out.hs @@ -0,0 +1,1 @@ +import Linear.Vector (Additive (..), (*^), (^*)) diff --git a/data/examples/import/sorted-export-list.hs b/data/examples/import/sorted-export-list.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/sorted-export-list.hs @@ -0,0 +1,1 @@ +import Linear.Vector (Additive (..), (*^), (^*)) diff --git a/data/examples/import/sorted-four-out.hs b/data/examples/import/sorted-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/import/sorted-four-out.hs @@ -0,0 +1,3 @@ +import A +import B +import C diff --git a/data/examples/module-header/double-dot-with-names-four-out.hs b/data/examples/module-header/double-dot-with-names-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/double-dot-with-names-four-out.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PatternSynonyms #-} + +module ExportSyntax (A (.., NoA), Q (F, ..), G (T, .., U)) where + +data A = A | B + +pattern NoA = B + +data Q a = Q a + +pattern F a = Q a + +data G = G | H + +pattern T = G + +pattern U = H diff --git a/data/examples/module-header/double-shebangs-four-out.hs b/data/examples/module-header/double-shebangs-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/double-shebangs-four-out.hs @@ -0,0 +1,2 @@ +#!/usr/bin/env stack +#!/usr/bin/env stack diff --git a/data/examples/module-header/empty-four-out.hs b/data/examples/module-header/empty-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/empty-four-out.hs diff --git a/data/examples/module-header/leading-empty-line-four-out.hs b/data/examples/module-header/leading-empty-line-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/leading-empty-line-four-out.hs @@ -0,0 +1,12 @@ +{- | + Module : Text.Megaparsec + Copyright : © 2015–2019 Megaparsec contributors + © 2007 Paolo Martini + © 1999–2001 Daan Leijen + License : FreeBSD + + Maintainer : Mark Karpov + Stability : experimental + Portability : portable +-} +module Main where diff --git a/data/examples/module-header/multiline-empty-four-out.hs b/data/examples/module-header/multiline-empty-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/multiline-empty-four-out.hs @@ -0,0 +1,2 @@ +module Foo ( + ) where diff --git a/data/examples/module-header/multiline-four-out.hs b/data/examples/module-header/multiline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/multiline-four-out.hs @@ -0,0 +1,5 @@ +module Foo ( + foo, + bar, + baz, +) where diff --git a/data/examples/module-header/multiline-with-comments-four-out.hs b/data/examples/module-header/multiline-with-comments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/multiline-with-comments-four-out.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Header. +module My.Module ( + -- * Something + foo, + bar, + + -- * Another thing + (), + {- some other thing -} foo2, -- yet another + foo3, -- third one + baz, + bar2, -- a multiline comment + -- the second line + bar3, + module Foo.Bar.Baz, +) where + +-- Wow diff --git a/data/examples/module-header/multiline2-four-out.hs b/data/examples/module-header/multiline2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/multiline2-four-out.hs @@ -0,0 +1,5 @@ +module Foo ( + foo, + bar, + baz, +) where diff --git a/data/examples/module-header/named-section-four-out.hs b/data/examples/module-header/named-section-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/named-section-four-out.hs @@ -0,0 +1,13 @@ +module Magic ( + -- * Something + -- $explanation + + -- ** Another level + foo, + bar, +) where + +{- $explanation + + Here it goes. +-} diff --git a/data/examples/module-header/preceding-comment-with-haddock-four-out.hs b/data/examples/module-header/preceding-comment-with-haddock-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/preceding-comment-with-haddock-four-out.hs @@ -0,0 +1,8 @@ +{- + Here we go. +-} + +-- | This is the module's Haddock. +module Main (main) where + +main = return () diff --git a/data/examples/module-header/shebang-four-out.hs b/data/examples/module-header/shebang-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/shebang-four-out.hs @@ -0,0 +1,6 @@ +#! /usr/bin/env runhaskell + +import Prelude + +main :: IO () +main = putStrLn "hello world" diff --git a/data/examples/module-header/shebang-with-pragmas-four-out.hs b/data/examples/module-header/shebang-with-pragmas-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/shebang-with-pragmas-four-out.hs @@ -0,0 +1,5 @@ +#!/usr/bin/env stack + +{-# LANGUAGE OverloadedStrings #-} + +main = pure () diff --git a/data/examples/module-header/simple-four-out.hs b/data/examples/module-header/simple-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/simple-four-out.hs @@ -0,0 +1,1 @@ +module Main where diff --git a/data/examples/module-header/simple-with-comments-four-out.hs b/data/examples/module-header/simple-with-comments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/simple-with-comments-four-out.hs @@ -0,0 +1,4 @@ +-- | Here we go. +module Main where + +-- Wow. diff --git a/data/examples/module-header/singleline-empty-four-out.hs b/data/examples/module-header/singleline-empty-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/singleline-empty-four-out.hs @@ -0,0 +1,2 @@ +-- | This demonstrates a BUG. +module Foo () where diff --git a/data/examples/module-header/singleline-four-out.hs b/data/examples/module-header/singleline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/singleline-four-out.hs @@ -0,0 +1,1 @@ +module Foo (foo, bar, baz) where diff --git a/data/examples/module-header/stack-header-0-four-out.hs b/data/examples/module-header/stack-header-0-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/stack-header-0-four-out.hs @@ -0,0 +1,7 @@ +-- stack runhaskell + +{-# LANGUAGE OverloadedStrings #-} + +main = return () + +-- stack runhaskell diff --git a/data/examples/module-header/stack-header-1-four-out.hs b/data/examples/module-header/stack-header-1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/stack-header-1-four-out.hs @@ -0,0 +1,8 @@ +#!/usr/bin/env stack +-- stack runhaskell + +{-# LANGUAGE OverloadedStrings #-} + +main = return () + +-- stack runhaskell diff --git a/data/examples/module-header/stack-header-2-four-out.hs b/data/examples/module-header/stack-header-2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/stack-header-2-four-out.hs @@ -0,0 +1,12 @@ +#!/usr/bin/env stack +{- stack + script + --resolver lts-6.25 + --package turtle + --package "stm async" + --package http-client,http-conduit +-} + +{-# LANGUAGE OverloadedStrings #-} + +main = return () diff --git a/data/examples/module-header/warning-pragma-four-out.hs b/data/examples/module-header/warning-pragma-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/warning-pragma-four-out.hs @@ -0,0 +1,5 @@ +module Test + {-# WARNING + "This module is very internal" + #-} +where diff --git a/data/examples/module-header/warning-pragma-list-multiline-four-out.hs b/data/examples/module-header/warning-pragma-list-multiline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/warning-pragma-list-multiline-four-out.hs @@ -0,0 +1,11 @@ +module Test + {-# DEPRECATED + [ "This module is deprecated." + , "Please use OtherModule instead." + ] + #-} + ( + foo, + bar, + baz, +) where diff --git a/data/examples/module-header/warning-pragma-multiline-four-out.hs b/data/examples/module-header/warning-pragma-multiline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/warning-pragma-multiline-four-out.hs @@ -0,0 +1,5 @@ +module Test + {-# DEPRECATED "This module is unstable" #-} + (foo, bar, baz) where + +import Blah diff --git a/data/examples/module-header/warning-pragma-singleton-list-four-out.hs b/data/examples/module-header/warning-pragma-singleton-list-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/module-header/warning-pragma-singleton-list-four-out.hs @@ -0,0 +1,2 @@ +module Test {-# WARNING "There's only one line here." #-} +where diff --git a/data/examples/other/argument-comment-four-out.hs b/data/examples/other/argument-comment-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/argument-comment-four-out.hs @@ -0,0 +1,16 @@ +foo :: + -- | Documentation + Int -> + Bool +foo _ = True + +foo :: + Foo a => + -- | Foo + Int -> + Int +foo :: + Foo a => + -- | Foo + Int -> + Int diff --git a/data/examples/other/argument-comment-out.hs b/data/examples/other/argument-comment-out.hs --- a/data/examples/other/argument-comment-out.hs +++ b/data/examples/other/argument-comment-out.hs @@ -9,7 +9,6 @@ -- | Foo Int -> Int - foo :: Foo a => -- | Foo diff --git a/data/examples/other/ascii-four-out.hs b/data/examples/other/ascii-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/ascii-four-out.hs @@ -0,0 +1,9 @@ +{- ----------------------------------- + < What about ASCII art in comments? > + ----------------------------------- + \ ^__^ + \ (oo)\_______ + (__)\ )\/\ + ||----w | + || || +-} diff --git a/data/examples/other/comment-after-preceding-haddock-four-out.hs b/data/examples/other/comment-after-preceding-haddock-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-after-preceding-haddock-four-out.hs @@ -0,0 +1,12 @@ +module Main where + +-- | A + +-- B + +type D = E + +-- | This is 'f' + +-- * Comment +f :: a -> b diff --git a/data/examples/other/comment-alignment-four-out.hs b/data/examples/other/comment-alignment-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-alignment-four-out.hs @@ -0,0 +1,9 @@ +class Foo a where + -- | Foo. + foo :: + Int -> + -- | Something + a + + -- | Bar. + bar :: a diff --git a/data/examples/other/comment-before-hanging-four-out.hs b/data/examples/other/comment-before-hanging-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-before-hanging-four-out.hs @@ -0,0 +1,5 @@ +x = Just + -- comment + do + foo + bar diff --git a/data/examples/other/comment-following-preceding-gap-four-out.hs b/data/examples/other/comment-following-preceding-gap-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-following-preceding-gap-four-out.hs @@ -0,0 +1,6 @@ +foo = bar + where + baz = return (quux) -- Foo + + -- Bar + meme = gege diff --git a/data/examples/other/comment-glued-together-four-out.hs b/data/examples/other/comment-glued-together-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-glued-together-four-out.hs @@ -0,0 +1,7 @@ +module Main (main) where + +-- | Foo. + +-- Bar +main :: IO () +main = return () diff --git a/data/examples/other/comment-glued-together-out.hs b/data/examples/other/comment-glued-together-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-glued-together-out.hs @@ -0,0 +1,7 @@ +module Main (main) where + +-- | Foo. + +-- Bar +main :: IO () +main = return () diff --git a/data/examples/other/comment-glued-together.hs b/data/examples/other/comment-glued-together.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-glued-together.hs @@ -0,0 +1,6 @@ +module Main (main) where + +{- | Foo. -} +-- Bar +main :: IO () +main = return () diff --git a/data/examples/other/comment-inside-construct-four-out.hs b/data/examples/other/comment-inside-construct-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-inside-construct-four-out.hs @@ -0,0 +1,9 @@ +xs = + [ outer list item + , + [ inner list first item + , inner list second item + -- inner list last item commented + ] + , outer list item + ] diff --git a/data/examples/other/comment-multiline-after-four-out.hs b/data/examples/other/comment-multiline-after-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-multiline-after-four-out.hs @@ -0,0 +1,7 @@ +foo :: + -- | start index + Int -> + -- | length + Int -> + t a -> + t a diff --git a/data/examples/other/comment-style-transform-four-out.hs b/data/examples/other/comment-style-transform-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-style-transform-four-out.hs @@ -0,0 +1,19 @@ +{- | +Module: Data.Aeson.TH +Copyright: (c) 2011-2016 Bryan O'Sullivan + (c) 2011 MailRank, Inc. +License: BSD3 +Stability: experimental +Portability: portable +-} +module Main where + +{- | + +Here is a snippet: + +@ +x = y + 2 +@ +-} +x = y + 2 diff --git a/data/examples/other/comment-style-transform-out.hs b/data/examples/other/comment-style-transform-out.hs --- a/data/examples/other/comment-style-transform-out.hs +++ b/data/examples/other/comment-style-transform-out.hs @@ -1,17 +1,17 @@ -- | --- Module: Data.Aeson.TH --- Copyright: (c) 2011-2016 Bryan O'Sullivan --- (c) 2011 MailRank, Inc. --- License: BSD3 --- Stability: experimental --- Portability: portable +--Module: Data.Aeson.TH +--Copyright: (c) 2011-2016 Bryan O'Sullivan +-- (c) 2011 MailRank, Inc. +--License: BSD3 +--Stability: experimental +--Portability: portable module Main where -- | -- --- Here is a snippet: +--Here is a snippet: -- --- @ --- x = y + 2 --- @ +--@ +--x = y + 2 +--@ x = y + 2 diff --git a/data/examples/other/comment-trailing-space-four-out.hs b/data/examples/other/comment-trailing-space-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-space-four-out.hs @@ -0,0 +1,9 @@ +data T + = {- + + some multi-line comment + + with empty lines + + -} + A diff --git a/data/examples/other/comment-trailing-space-out.hs b/data/examples/other/comment-trailing-space-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-space-out.hs @@ -0,0 +1,9 @@ +data T + = {- + + some multi-line comment + + with empty lines + + -} + A diff --git a/data/examples/other/comment-trailing-space.hs b/data/examples/other/comment-trailing-space.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-trailing-space.hs @@ -0,0 +1,9 @@ +data T + = {- + + some multi-line comment + + with empty lines + + -} + A diff --git a/data/examples/other/comment-two-blocks-four-out.hs b/data/examples/other/comment-two-blocks-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/comment-two-blocks-four-out.hs @@ -0,0 +1,8 @@ +newNames :: [(String, String)] +newNames = + let (*) = flip (,) + in [ "Control" * "Monad" + -- Foo + + -- Bar + ] diff --git a/data/examples/other/consequetive-pipe-comments-four-out.hs b/data/examples/other/consequetive-pipe-comments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/consequetive-pipe-comments-four-out.hs @@ -0,0 +1,7 @@ +module Main where + +-- | Foo. + +-- | Bar. +bar :: Int +bar = 5 diff --git a/data/examples/other/empty-forall-four-out.hs b/data/examples/other/empty-forall-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/empty-forall-four-out.hs @@ -0,0 +1,18 @@ +-- Empty foralls are handled correctly in different situations. + +data D = forall. D Int + +data G where + G :: forall. Int -> G + +f :: forall. a -> a +f x = x + +type family T x where + forall. T x = x + +{-# RULES +"r" + r a = + () + #-} diff --git a/data/examples/other/empty-haddock-four-out.hs b/data/examples/other/empty-haddock-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/empty-haddock-four-out.hs @@ -0,0 +1,5 @@ +module Main where + +-- | +foo :: Int +foo = 5 diff --git a/data/examples/other/following-comment-last-0-four-out.hs b/data/examples/other/following-comment-last-0-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/following-comment-last-0-four-out.hs @@ -0,0 +1,5 @@ +module Main where + +-- | Another datatype... +data D' +-- ^ ...with two docstrings. diff --git a/data/examples/other/following-comment-last-1-four-out.hs b/data/examples/other/following-comment-last-1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/following-comment-last-1-four-out.hs @@ -0,0 +1,8 @@ +module Main where + +-- | Another datatype... +data D' + deriving (Show) +-- ^ ...with two docstrings. + +-- more diff --git a/data/examples/other/following-comment-last-2-four-out.hs b/data/examples/other/following-comment-last-2-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/following-comment-last-2-four-out.hs @@ -0,0 +1,10 @@ +module Main where + +-- | Another datatype... +data D' + deriving (Show) +-- ^ ...with two docstrings. + +-- more + +data B diff --git a/data/examples/other/following-comment-last-3-four-out.hs b/data/examples/other/following-comment-last-3-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/following-comment-last-3-four-out.hs @@ -0,0 +1,7 @@ +module Main where + +-- | Another datatype... +data D' +{- ^ ...with two docstrings. + even on second line +-} diff --git a/data/examples/other/haddock-sections-four-out.hs b/data/examples/other/haddock-sections-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/haddock-sections-four-out.hs @@ -0,0 +1,9 @@ +{- $weird #anchor# + + Section 1 +-} + +{- $normal + + Section 2 +-} diff --git a/data/examples/other/inline-comment-0-four-out.hs b/data/examples/other/inline-comment-0-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/inline-comment-0-four-out.hs @@ -0,0 +1,3 @@ +x = ({-a-} b, c) + +y = ({-a-} b) diff --git a/data/examples/other/inline-comment-1-four-out.hs b/data/examples/other/inline-comment-1-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/inline-comment-1-four-out.hs @@ -0,0 +1,12 @@ +showPs env ((n, _, Let _ t v) : bs) = + " " ++ show n ++ " : " + ++ showEnv env ({- normalise ctxt env -} t) + ++ " = " + ++ showEnv env ({- normalise ctxt env -} v) + ++ "\n" + ++ showPs env bs +showPs env ((n, _, b) : bs) = + " " ++ show n ++ " : " + ++ showEnv env ({- normalise ctxt env -} (binderTy b)) + ++ "\n" + ++ showPs env bs diff --git a/data/examples/other/list-multiline-four-out.hs b/data/examples/other/list-multiline-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/list-multiline-four-out.hs @@ -0,0 +1,8 @@ +x = + [ [1, 2] + , + [ 2 + , 3 + ] + , [3, 4] + ] diff --git a/data/examples/other/list-multiline-out.hs b/data/examples/other/list-multiline-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/list-multiline-out.hs @@ -0,0 +1,7 @@ +x = + [ [1, 2], + [ 2, + 3 + ], + [3, 4] + ] diff --git a/data/examples/other/list-multiline.hs b/data/examples/other/list-multiline.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/list-multiline.hs @@ -0,0 +1,6 @@ +x = + [ [1, 2] + , [2, + 3] + , [3, 4] + ] diff --git a/data/examples/other/merging-comments-four-out.hs b/data/examples/other/merging-comments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/merging-comments-four-out.hs @@ -0,0 +1,12 @@ +foo xs = baz + where + bar = + catMaybes + [ lookup langKey gets -- 1 + , lookup langKey cookies -- 2 + , lookupText langKey session -- 3 + ] + ++ xs -- 4 + + -- Blah + baz = addTwoLetters (id, Set.empty) bar diff --git a/data/examples/other/multiline-comments-reindent-four-out.hs b/data/examples/other/multiline-comments-reindent-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/multiline-comments-reindent-four-out.hs @@ -0,0 +1,6 @@ +{- + And so here we have a + multiline comment. + + Indeed. +-} diff --git a/data/examples/other/multiline-forall-four-out.hs b/data/examples/other/multiline-forall-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/multiline-forall-four-out.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +-- Multiline foralls are consistent across all declarations + +data D + = forall + ( f :: + * -> * -> * + ) + (x :: *) + (y :: *). + D (f x y) + +data G where + G :: + forall + ( f :: + * -> * -> * + ) + (x :: *) + (y :: *). + f x y -> + G + +f :: + forall + ( f :: + * -> * -> * + ) + (x :: *) + (y :: *). + f x y -> + () +f = const () + +type family T f x y where + forall + ( f :: + * -> * -> * + ) + (x :: *) + (y :: *). + T f x y = + f x y + +{-# RULES +"r" forall + ( f :: + * -> * -> * + ) + (x :: *) + (y :: *). + r (a :: f x y) = + () + #-} diff --git a/data/examples/other/multiple-blank-line-comment-four-out.hs b/data/examples/other/multiple-blank-line-comment-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/multiple-blank-line-comment-four-out.hs @@ -0,0 +1,9 @@ +module A where + +a = + b + [ f + {-, + + -} + ] diff --git a/data/examples/other/overly-indented-four-out.hs b/data/examples/other/overly-indented-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/overly-indented-four-out.hs @@ -0,0 +1,11 @@ +tagCloudField :: + -- | Destination key + String -> + -- | Smallest font size, in percent + Double -> + -- | Biggest font size, in percent + Double -> + -- | Input tags + Tags -> + -- | Context + Context a diff --git a/data/examples/other/pragma-comments-after-four-out.hs b/data/examples/other/pragma-comments-after-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/pragma-comments-after-four-out.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +-- TODO: Fix and delete this pragma +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} diff --git a/data/examples/other/pragma-comments-after-out.hs b/data/examples/other/pragma-comments-after-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/pragma-comments-after-out.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +-- TODO: Fix and delete this pragma +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} diff --git a/data/examples/other/pragma-comments-after.hs b/data/examples/other/pragma-comments-after.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/pragma-comments-after.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- TODO: Fix and delete this pragma +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} diff --git a/data/examples/other/pragma-comments-four-out.hs b/data/examples/other/pragma-comments-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/pragma-comments-four-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} +-- TODO This extension is probably too dangerous, remove it. +{-# LANGUAGE RecordWildCards #-} +-- Avoid warning produced by TH. +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} + +-- | Header comment. +module Foo () where diff --git a/data/examples/other/pragma-four-out.hs b/data/examples/other/pragma-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/pragma-four-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -O2 -H 300 #-} +{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_HADDOCK prune, show-extensions #-} + +-- | Header comment. +module Foo () where diff --git a/data/examples/other/pragma-no-header-four-out.hs b/data/examples/other/pragma-no-header-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/pragma-no-header-four-out.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} diff --git a/data/examples/other/pragma-sorting-four-out.hs b/data/examples/other/pragma-sorting-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/pragma-sorting-four-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- This gap is necessary for stylish Haskell not to re-arrange +-- NoMonoLocalBinds before TypeFamilies +{-# LANGUAGE NoMonoLocalBinds #-} + +module Foo ( + bar, +) where diff --git a/data/examples/other/trailing-whitespace-four-out.hs b/data/examples/other/trailing-whitespace-four-out.hs new file mode 100644 --- /dev/null +++ b/data/examples/other/trailing-whitespace-four-out.hs @@ -0,0 +1,7 @@ +-- Here is a comment with trailing whitespace. +foo = 5 + +{- Block comment with trailing whitespace. + Bo. + -} +bar = 6 diff --git a/fourmolu.cabal b/fourmolu.cabal --- a/fourmolu.cabal +++ b/fourmolu.cabal @@ -1,10 +1,13 @@ cabal-version: 1.18 name: fourmolu -version: 0.1.0.0 +version: 0.2.0.0 license: BSD3 license-file: LICENSE.md -maintainer: Matt Parsons , George Thomas -tested-with: ghc ==8.6.5 ghc ==8.8.3 ghc ==8.10.1 +maintainer: + Matt Parsons + George Thomas + +tested-with: ghc ==8.6.5 ghc ==8.8.4 ghc ==8.10.1 homepage: https://github.com/parsonsmatt/fourmolu bug-reports: https://github.com/parsonsmatt/fourmolu/issues synopsis: A formatter for Haskell source code @@ -50,9 +53,7 @@ data/examples/other/*.hs extra-doc-files: - CONTRIBUTING.md CHANGELOG.md - DESIGN.md README.md source-repository head @@ -120,15 +121,16 @@ base >=4.12 && <5.0, bytestring >=0.2 && <0.11, containers >=0.5 && <0.7, - directory >= 1.3.5 && <1.4, - dlist >=0.8 && <0.9, + directory >=1.3.3 && <1.4, + dlist >=0.8 && <2.0, exceptions >=0.6 && <0.11, filepath >=1.4.2.1 && <1.5, ghc-lib-parser >=8.10 && <8.11, + HsYAML >=0.2 && <0.3, + HsYAML-aeson >=0.2 && <0.3, mtl >=2.0 && <3.0, syb >=0.7 && <0.8, - text >=0.2 && <1.3, - yaml >=0.11.2 && <0.12 + text >=0.2 && <1.3 if flag(dev) ghc-options: @@ -145,17 +147,19 @@ other-modules: Paths_fourmolu default-language: Haskell2010 build-depends: + fourmolu -any, base >=4.12 && <5.0, + directory >=1.3.3 && <1.4, ghc-lib-parser >=8.10 && <8.11, gitrev >=1.3 && <1.4, - optparse-applicative >=0.14 && <0.16, - fourmolu -any, + optparse-applicative >=0.14 && <0.17, text >=0.2 && <1.3 if flag(dev) ghc-options: -Wall -Werror -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances + -optP-Wno-nonportable-include-path else ghc-options: -O2 -Wall -rtsopts diff --git a/src/Ormolu.hs b/src/Ormolu.hs --- a/src/Ormolu.hs +++ b/src/Ormolu.hs @@ -10,8 +10,13 @@ defaultConfig, DynOption (..), PrinterOpts (..), + PrinterOptsPartial, + PrinterOptsTotal, defaultPrinterOpts, loadConfigFile, + ConfigFileLoadResult (..), + configFileName, + fillMissingPrinterOpts, OrmoluException (..), withPrettyOrmoluExceptions, ) diff --git a/src/Ormolu/Config.hs b/src/Ormolu/Config.hs --- a/src/Ormolu/Config.hs +++ b/src/Ormolu/Config.hs @@ -1,7 +1,11 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} -- | Configuration options used by the tool. module Ormolu.Config @@ -10,37 +14,43 @@ RegionDeltas (..), defaultConfig, PrinterOpts (..), + PrinterOptsPartial, + PrinterOptsTotal, defaultPrinterOpts, loadConfigFile, + configFileName, + ConfigFileLoadResult (..), + fillMissingPrinterOpts, + CommaStyle (..), + HaddockPrintStyle (..), regionIndicesToDeltas, DynOption (..), dynOptionToLocatedStr, ) where -import Control.Monad (when) import Data.Aeson ( FromJSON (..), camelTo2, + constructorTagModifier, defaultOptions, fieldLabelModifier, genericParseJSON, - rejectUnknownFields, ) -import Data.List (stripPrefix) -import Data.Maybe (fromMaybe) -import Data.Yaml (decodeFileEither, prettyPrintParseException) +import qualified Data.ByteString.Lazy as BS +import Data.Char (isLower) +import Data.Functor.Identity (Identity (..)) +import Data.YAML (Pos) +import Data.YAML.Aeson (decode1) import GHC.Generics (Generic) import qualified SrcLoc as GHC import System.Directory ( XdgDirectory (XdgConfig), findFile, - getCurrentDirectory, getXdgDirectory, makeAbsolute, ) -import System.FilePath ((), splitPath) -import System.IO (hPutStrLn, stderr) +import System.FilePath (splitPath, ()) -- | Ormolu configuration. data Config region = Config @@ -54,7 +64,7 @@ cfgCheckIdempotence :: !Bool, -- | Region selection cfgRegion :: !region, - cfgPrinterOpts :: PrinterOpts + cfgPrinterOpts :: !PrinterOptsTotal } deriving (Eq, Show, Functor) @@ -93,16 +103,104 @@ cfgPrinterOpts = defaultPrinterOpts } --- | Options controlling formatting output -data PrinterOpts = PrinterOpts +-- | Options controlling formatting output. +data PrinterOpts f = PrinterOpts { -- | Number of spaces to use for indentation - poIndentStep :: Int + poIndentation :: f Int, + -- | Whether to place commas at start or end of lines + poCommaStyle :: f CommaStyle, + -- | Whether to indent `where` blocks + poIndentWheres :: f Bool, + -- | Leave space before opening record brace + poRecordBraceSpace :: f Bool, + -- | Trailing commas with parentheses on separate lines + poDiffFriendlyImportExport :: f Bool, + -- | Be less opinionated about spaces/newlines etc. + poRespectful :: f Bool, + -- | How to print doc comments + poHaddockStyle :: f HaddockPrintStyle } - deriving (Eq, Show) + deriving (Generic) -defaultPrinterOpts :: PrinterOpts -defaultPrinterOpts = PrinterOpts {poIndentStep = 4} +-- | A version of 'PrinterOpts' where any field can be empty. +-- This corresponds to the information in a config file or in CLI options. +type PrinterOptsPartial = PrinterOpts Maybe +deriving instance Eq PrinterOptsPartial + +deriving instance Show PrinterOptsPartial + +instance Semigroup PrinterOptsPartial where + (<>) = fillMissingPrinterOpts + +instance Monoid PrinterOptsPartial where + mempty = PrinterOpts Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | A version of 'PrinterOpts' without empty fields. +type PrinterOptsTotal = PrinterOpts Identity + +deriving instance Eq PrinterOptsTotal + +deriving instance Show PrinterOptsTotal + +defaultPrinterOpts :: PrinterOptsTotal +defaultPrinterOpts = + PrinterOpts + { poIndentation = pure 4, + poCommaStyle = pure Leading, + poIndentWheres = pure False, + poRecordBraceSpace = pure False, + poDiffFriendlyImportExport = pure True, + poRespectful = pure True, + poHaddockStyle = pure HaddockMultiLine + } + +-- | Fill the field values that are 'Nothing' in the first argument +-- with the values of the corresponding fields of the second argument. +fillMissingPrinterOpts :: + forall f. + Applicative f => + PrinterOptsPartial -> + PrinterOpts f -> + PrinterOpts f +fillMissingPrinterOpts p1 p2 = + PrinterOpts + { poIndentation = fillField poIndentation, + poCommaStyle = fillField poCommaStyle, + poIndentWheres = fillField poIndentWheres, + poRecordBraceSpace = fillField poRecordBraceSpace, + poDiffFriendlyImportExport = fillField poDiffFriendlyImportExport, + poRespectful = fillField poRespectful, + poHaddockStyle = fillField poHaddockStyle + } + where + fillField :: (forall g. PrinterOpts g -> g a) -> f a + fillField f = maybe (f p2) pure $ f p1 + +data CommaStyle + = Leading + | Trailing + deriving (Eq, Ord, Show, Generic) + +instance FromJSON CommaStyle where + parseJSON = + genericParseJSON + defaultOptions + { constructorTagModifier = camelTo2 '-' + } + +data HaddockPrintStyle + = HaddockSingleLine + | HaddockMultiLine + deriving (Eq, Ord, Show, Generic) + +instance FromJSON HaddockPrintStyle where + parseJSON = + genericParseJSON + defaultOptions + { constructorTagModifier = drop (length "haddock-") . camelTo2 '-' + } + -- | Convert 'RegionIndices' into 'RegionDeltas'. regionIndicesToDeltas :: -- | Total number of lines in the input @@ -127,54 +225,35 @@ dynOptionToLocatedStr :: DynOption -> GHC.Located String dynOptionToLocatedStr (DynOption o) = GHC.L GHC.noSrcSpan o --- | A version of 'PrinterOpts' where any field can be empty. --- This corresponds to the information in a config file. -data PrinterOptsPartial = PrinterOptsPartial - { popIndentation :: Maybe Int - } - deriving (Eq, Show, Generic) - instance FromJSON PrinterOptsPartial where parseJSON = genericParseJSON defaultOptions - { rejectUnknownFields = True, - fieldLabelModifier = camelTo2 '_' . fromMaybe "" . stripPrefix "pop" + { fieldLabelModifier = camelTo2 '-' . dropWhile isLower } --- | Replace fields with those from a config file, if found. +-- | Read options from a config file, if found. -- Looks recursively in parent folders, then in 'XdgConfig', --- for a file matching /fourmolu.yaml/'. -loadConfigFile :: Bool -> Maybe FilePath -> PrinterOpts -> IO PrinterOpts -loadConfigFile debug maybePath PrinterOpts {..} = do - root <- maybe getCurrentDirectory makeAbsolute maybePath +-- for a file named /fourmolu.yaml/. +loadConfigFile :: FilePath -> IO ConfigFileLoadResult +loadConfigFile path = do + root <- makeAbsolute path xdg <- getXdgDirectory XdgConfig "" - PrinterOptsPartial {..} <- - optsFromFile debug $ reverse $ xdg : scanl1 () (splitPath root) - return $ - PrinterOpts - { poIndentStep = fromMaybe poIndentStep popIndentation - } - --- | Search the directories, in order, for a config file. -optsFromFile :: Bool -> [FilePath] -> IO PrinterOptsPartial -optsFromFile debug dirs = + let dirs = reverse $ xdg : scanl1 () (splitPath root) findFile dirs configFileName >>= \case - Nothing -> do - printDebug $ - "No " ++ show configFileName ++ " found in any of:\n" - ++ unlines (map (" " ++) dirs) - return def - Just file -> do - printDebug $ "Found " ++ show file ++ "" - decodeFileEither file >>= \case - Left e -> do - printDebug $ prettyPrintParseException e - return def - Right x -> return x - where - def = PrinterOptsPartial Nothing - printDebug = when debug . hPutStrLn stderr + Nothing -> return $ ConfigNotFound dirs + Just file -> + either (ConfigParseError file) (ConfigLoaded file) + . decode1 + <$> BS.readFile file +-- | The result of calling 'loadConfigFile'. +data ConfigFileLoadResult + = ConfigLoaded FilePath PrinterOptsPartial + | ConfigParseError FilePath (Pos, String) + | ConfigNotFound [FilePath] + deriving (Eq, Show) + +-- | Expected file name for YAML config. configFileName :: FilePath configFileName = "fourmolu.yaml" diff --git a/src/Ormolu/Diff.hs b/src/Ormolu/Diff.hs --- a/src/Ormolu/Diff.hs +++ b/src/Ormolu/Diff.hs @@ -14,7 +14,7 @@ import qualified Data.Text as T import qualified FastString as GHC import GHC -import Ormolu.Imports (sortImports) +import Ormolu.Imports (normalizeImports) import Ormolu.Parser.CommentStream import Ormolu.Parser.Result import Ormolu.Utils @@ -47,8 +47,8 @@ } = matchIgnoringSrcSpans cstream0 cstream1 <> matchIgnoringSrcSpans - hs0 {hsmodImports = sortImports (hsmodImports hs0)} - hs1 {hsmodImports = sortImports (hsmodImports hs1)} + hs0 {hsmodImports = concat . normalizeImports False $ hsmodImports hs0} + hs1 {hsmodImports = concat . normalizeImports False $ hsmodImports hs1} -- | Compare two values for equality disregarding differences in 'SrcSpan's -- and the ordering of import lists. diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -4,82 +4,205 @@ -- | Manipulations on import lists. module Ormolu.Imports - ( sortImports, + ( normalizeImports, ) where import Data.Bifunctor +import Data.Char (isAlphaNum) +import Data.Foldable (toList) import Data.Function (on) -import Data.Generics (gcompare) -import Data.List (sortBy) +import Data.List (foldl', nubBy, sortBy, sortOn) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import FastString (FastString) import GHC hiding (GhcPs, IE) import GHC.Hs.Extension import GHC.Hs.ImpExp (IE (..)) -import Ormolu.Utils (notImplemented) +import Ormolu.Utils (groupBy', notImplemented, separatedByBlank, showOutputable) --- | Sort imports by module name. This also sorts explicit import lists for --- each declaration. -sortImports :: [LImportDecl GhcPs] -> [LImportDecl GhcPs] -sortImports = sortBy compareIdecl . fmap (fmap sortImportLists) +-- | Sort, group and normalize imports. Assumes input list is sorted by source location. +normalizeImports :: Bool -> [LImportDecl GhcPs] -> [[LImportDecl GhcPs]] +normalizeImports preserveGroups = + map + ( fmap snd + . M.toAscList + . M.fromListWith combineImports + . fmap (\x -> (importId x, g x)) + ) + . if preserveGroups + then map toList . groupBy' (\x y -> not $ separatedByBlank getLoc x y) + else pure where - sortImportLists :: ImportDecl GhcPs -> ImportDecl GhcPs - sortImportLists = \case - ImportDecl {..} -> + g (L l ImportDecl {..}) = + L + l ImportDecl - { ideclHiding = second (fmap sortLies) <$> ideclHiding, + { ideclHiding = second (fmap normalizeLies) <$> ideclHiding, .. } - XImportDecl x -> noExtCon x + g _ = notImplemented "XImportDecl" --- | Compare two @'LImportDecl' 'GhcPs'@ things. -compareIdecl :: LImportDecl GhcPs -> LImportDecl GhcPs -> Ordering -compareIdecl (L _ m0) (L _ m1) = - case (isPrelude n0, isPrelude n1) of - (False, False) -> n0 `compare` n1 - (True, False) -> GT - (False, True) -> LT - (True, True) -> m0 `gcompare` m1 +-- | Combine two import declarations. It should be assumed that 'ImportId's +-- are equal. +combineImports :: + LImportDecl GhcPs -> + LImportDecl GhcPs -> + LImportDecl GhcPs +combineImports (L lx ImportDecl {..}) (L _ y) = + L + lx + ImportDecl + { ideclHiding = case (ideclHiding, GHC.ideclHiding y) of + (Just (hiding, L l' xs), Just (_, L _ ys)) -> + Just (hiding, (L l' (normalizeLies (xs ++ ys)))) + _ -> Nothing, + .. + } +combineImports _ _ = notImplemented "XImportDecl" + +-- | Import id, a collection of all things that justify having a separate +-- import entry. This is used for merging of imports. If two imports have +-- the same 'ImportId' they can be merged. +data ImportId = ImportId + { importIsPrelude :: Bool, + importIdName :: ModuleName, + importPkgQual :: Maybe FastString, + importSource :: Bool, + importSafe :: Bool, + importQualified :: Bool, + importImplicit :: Bool, + importAs :: Maybe ModuleName, + importHiding :: Maybe Bool + } + deriving (Eq, Ord) + +-- | Obtain an 'ImportId' for a given import. +importId :: LImportDecl GhcPs -> ImportId +importId (L _ ImportDecl {..}) = + ImportId + { importIsPrelude = isPrelude, + importIdName = moduleName, + importPkgQual = sl_fs <$> ideclPkgQual, + importSource = ideclSource, + importSafe = ideclSafe, + importQualified = case ideclQualified of + QualifiedPre -> True + QualifiedPost -> True + NotQualified -> False, + importImplicit = ideclImplicit, + importAs = unLoc <$> ideclAs, + importHiding = fst <$> ideclHiding + } where - n0 = unLoc (ideclName m0) - n1 = unLoc (ideclName m1) - isPrelude = (== "Prelude") . moduleNameString + isPrelude = moduleNameString moduleName == "Prelude" + moduleName = unLoc ideclName +importId _ = notImplemented "XImportDecl" --- | Sort located import or export. -sortLies :: [LIE GhcPs] -> [LIE GhcPs] -sortLies = sortBy (compareIE `on` unLoc) . fmap (fmap sortThings) +-- | Normalize a collection of import\/export items. +normalizeLies :: [LIE GhcPs] -> [LIE GhcPs] +normalizeLies = sortOn (getIewn . unLoc) . M.elems . foldl' combine M.empty + where + combine :: + Map IEWrappedNameOrd (LIE GhcPs) -> + LIE GhcPs -> + Map IEWrappedNameOrd (LIE GhcPs) + combine m (L new_l new) = + let wname = getIewn new + normalizeWNames = + nubBy (\x y -> compareLIewn x y == EQ) . sortBy compareLIewn + alter = \case + Nothing -> Just . L new_l $ + case new of + IEThingWith NoExtField n wildcard g flbl -> + IEThingWith NoExtField n wildcard (normalizeWNames g) flbl + other -> other + Just old -> + let f = \case + IEVar NoExtField n -> IEVar NoExtField n + IEThingAbs NoExtField _ -> new + IEThingAll NoExtField n -> IEThingAll NoExtField n + IEThingWith NoExtField n wildcard g flbl -> + case new of + IEVar NoExtField _ -> + error "Ormolu.Imports broken presupposition" + IEThingAbs NoExtField _ -> + IEThingWith NoExtField n wildcard g flbl + IEThingAll NoExtField n' -> + IEThingAll NoExtField n' + IEThingWith NoExtField n' wildcard' g' flbl' -> + let combinedWildcard = + case (wildcard, wildcard') of + (IEWildcard _, _) -> IEWildcard 0 + (_, IEWildcard _) -> IEWildcard 0 + _ -> NoIEWildcard + in IEThingWith + NoExtField + n' + combinedWildcard + (normalizeWNames (g <> g')) + flbl' + IEModuleContents NoExtField _ -> notImplemented "IEModuleContents" + IEGroup NoExtField _ _ -> notImplemented "IEGroup" + IEDoc NoExtField _ -> notImplemented "IEDoc" + IEDocNamed NoExtField _ -> notImplemented "IEDocNamed" + XIE x -> noExtCon x + IEModuleContents NoExtField _ -> notImplemented "IEModuleContents" + IEGroup NoExtField _ _ -> notImplemented "IEGroup" + IEDoc NoExtField _ -> notImplemented "IEDoc" + IEDocNamed NoExtField _ -> notImplemented "IEDocNamed" + XIE x -> noExtCon x + in Just (f <$> old) + in M.alter alter wname m --- | Sort imports\/exports inside of 'IEThingWith'. -sortThings :: IE GhcPs -> IE GhcPs -sortThings = \case - IEThingWith NoExtField x w xs fl -> - IEThingWith NoExtField x w (sortBy (compareIewn `on` unLoc) xs) fl - other -> other +-- | A wrapper for @'IEWrappedName' 'RdrName'@ that allows us to define an +-- 'Ord' instance for it. +newtype IEWrappedNameOrd = IEWrappedNameOrd (IEWrappedName RdrName) + deriving (Eq) --- | Compare two located imports or exports. -compareIE :: IE GhcPs -> IE GhcPs -> Ordering -compareIE = compareIewn `on` getIewn +instance Ord IEWrappedNameOrd where + compare (IEWrappedNameOrd x) (IEWrappedNameOrd y) = compareIewn x y -- | Project @'IEWrappedName' 'RdrName'@ from @'IE' 'GhcPs'@. -getIewn :: IE GhcPs -> IEWrappedName RdrName +getIewn :: IE GhcPs -> IEWrappedNameOrd getIewn = \case - IEVar NoExtField x -> unLoc x - IEThingAbs NoExtField x -> unLoc x - IEThingAll NoExtField x -> unLoc x - IEThingWith NoExtField x _ _ _ -> unLoc x + IEVar NoExtField x -> IEWrappedNameOrd (unLoc x) + IEThingAbs NoExtField x -> IEWrappedNameOrd (unLoc x) + IEThingAll NoExtField x -> IEWrappedNameOrd (unLoc x) + IEThingWith NoExtField x _ _ _ -> IEWrappedNameOrd (unLoc x) IEModuleContents NoExtField _ -> notImplemented "IEModuleContents" IEGroup NoExtField _ _ -> notImplemented "IEGroup" IEDoc NoExtField _ -> notImplemented "IEDoc" IEDocNamed NoExtField _ -> notImplemented "IEDocNamed" XIE x -> noExtCon x +-- | Like 'compareIewn' for located wrapped names. +compareLIewn :: LIEWrappedName RdrName -> LIEWrappedName RdrName -> Ordering +compareLIewn = compareIewn `on` unLoc + -- | Compare two @'IEWrapppedName' 'RdrName'@ things. compareIewn :: IEWrappedName RdrName -> IEWrappedName RdrName -> Ordering -compareIewn (IEName x) (IEName y) = unLoc x `compare` unLoc y +compareIewn (IEName x) (IEName y) = unLoc x `compareRdrName` unLoc y compareIewn (IEName _) (IEPattern _) = LT compareIewn (IEName _) (IEType _) = LT compareIewn (IEPattern _) (IEName _) = GT -compareIewn (IEPattern x) (IEPattern y) = unLoc x `compare` unLoc y +compareIewn (IEPattern x) (IEPattern y) = unLoc x `compareRdrName` unLoc y compareIewn (IEPattern _) (IEType _) = LT compareIewn (IEType _) (IEName _) = GT compareIewn (IEType _) (IEPattern _) = GT -compareIewn (IEType x) (IEType y) = unLoc x `compare` unLoc y +compareIewn (IEType x) (IEType y) = unLoc x `compareRdrName` unLoc y + +compareRdrName :: RdrName -> RdrName -> Ordering +compareRdrName x y = + case (getNameStr x, getNameStr y) of + ([], []) -> EQ + ((_ : _), []) -> GT + ([], (_ : _)) -> LT + ((x' : _), (y' : _)) -> + case (isAlphaNum x', isAlphaNum y') of + (False, False) -> x `compare` y + (True, False) -> LT + (False, True) -> GT + (True, True) -> x `compare` y + where + getNameStr = showOutputable . rdrNameOcc diff --git a/src/Ormolu/Parser.hs b/src/Ormolu/Parser.hs --- a/src/Ormolu/Parser.hs +++ b/src/Ormolu/Parser.hs @@ -32,7 +32,7 @@ import Ormolu.Parser.CommentStream import Ormolu.Parser.Result import Ormolu.Processing.Preprocess (preprocess) -import Ormolu.Utils (incSpanLine) +import Ormolu.Utils (incSpanLine, removeIndentation) import qualified Panic as GHC import qualified Parser as GHC import qualified StringBuffer as GHC @@ -51,8 +51,9 @@ Either (SrcSpan, String) ParseResult ) parseModule Config {..} path rawInput = liftIO $ do - let (literalPrefix, input, literalSuffix, extraComments) = + let (literalPrefix, indentedInput, literalSuffix, extraComments) = preprocess path rawInput cfgRegion + (input, indent) = removeIndentation indentedInput -- It's important that 'setDefaultExts' is done before -- 'parsePragmasIntoDynFlags', because otherwise we might enable an -- extension that was explicitly disabled in the file. @@ -110,7 +111,8 @@ prImportQualifiedPost = GHC.xopt ImportQualifiedPost dynFlags, prLiteralPrefix = T.pack literalPrefix, - prLiteralSuffix = T.pack literalSuffix + prLiteralSuffix = T.pack literalSuffix, + prIndent = indent } return (warnings, r) diff --git a/src/Ormolu/Parser/CommentStream.hs b/src/Ormolu/Parser/CommentStream.hs --- a/src/Ormolu/Parser/CommentStream.hs +++ b/src/Ormolu/Parser/CommentStream.hs @@ -27,7 +27,8 @@ import qualified Lexer as GHC import Ormolu.Parser.Pragma import Ormolu.Parser.Shebang -import Ormolu.Utils (showOutputable) +import Ormolu.Processing.Common +import Ormolu.Utils (onTheSameLine, showOutputable) import SrcLoc ---------------------------------------------------------------------------- @@ -85,7 +86,7 @@ -- | A wrapper for a single comment. The 'Bool' indicates whether there were -- atoms before beginning of the comment in the original input. The --- 'NonEmpty' list inside contains lines of multiline comment @{- … -}@ or +-- 'NonEmpty' list inside contains lines of multiline comment @{\- … -\}@ or -- just single item\/line otherwise. data Comment = Comment Bool (NonEmpty String) deriving (Eq, Show, Data) @@ -109,11 +110,15 @@ Nothing -> s :| [] Just (x :| xs) -> let getIndent y = - if all isSpace y + if all isSpace y || y == endDisabling then startIndent else length (takeWhile isSpace y) n = minimum (startIndent : fmap getIndent xs) - in x :| (drop n <$> xs) + removeIndent y = + if y == endDisabling + then y + else drop n y + in x :| (removeIndent <$> xs) else s :| [] (atomsBefore, ls') = case dropWhile ((< commentLine) . fst) ls of @@ -145,6 +150,7 @@ -- | Detect and extract stack header if it is present. extractStackHeader :: + -- | Comment stream to analyze [RealLocated String] -> ([RealLocated String], Maybe (RealLocated Comment)) extractStackHeader = \case @@ -160,7 +166,9 @@ -- | Extract pragmas and their associated comments. extractPragmas :: + -- | Input String -> + -- | Comment stream to analyze [RealLocated String] -> ([RealLocated Comment], [([RealLocated Comment], Pragma)]) extractPragmas input = go initialLs id id @@ -174,8 +182,17 @@ let (ls', x') = mkComment ls x in go ls' (csSoFar . (x' :)) pragmasSoFar xs Just pragma -> - let combined = (csSoFar [], pragma) - in go ls id (pragmasSoFar . (combined :)) xs + let combined ys = (csSoFar ys, pragma) + go' ls' ys rest = go ls' id (pragmasSoFar . (combined ys :)) rest + in case xs of + [] -> go' ls [] xs + (y : ys) -> + let (ls', y') = mkComment ls y + in if onTheSameLine + (RealSrcSpan (getRealSrcSpan x)) + (RealSrcSpan (getRealSrcSpan y)) + then go' ls' [y'] ys + else go' ls [] xs -- | Get a 'String' from 'GHC.AnnotationComment'. unAnnotationComment :: GHC.AnnotationComment -> Maybe String diff --git a/src/Ormolu/Parser/Result.hs b/src/Ormolu/Parser/Result.hs --- a/src/Ormolu/Parser/Result.hs +++ b/src/Ormolu/Parser/Result.hs @@ -35,7 +35,9 @@ -- | Literal prefix prLiteralPrefix :: Text, -- | Literal suffix - prLiteralSuffix :: Text + prLiteralSuffix :: Text, + -- | Indentation level, can be non-zero in case of region formatting + prIndent :: Int } -- | Pretty-print a 'ParseResult'. diff --git a/src/Ormolu/Printer.hs b/src/Ormolu/Printer.hs --- a/src/Ormolu/Printer.hs +++ b/src/Ormolu/Printer.hs @@ -19,14 +19,14 @@ printModule :: -- | Result of parsing ParseResult -> - PrinterOpts -> + PrinterOptsTotal -> -- | Resulting rendition Text printModule ParseResult {..} printerOpts = prLiteralPrefix <> region <> prLiteralSuffix where region = - postprocess $ + postprocess prIndent $ runR ( p_hsModule prStackHeader diff --git a/src/Ormolu/Printer/Combinators.hs b/src/Ormolu/Printer/Combinators.hs --- a/src/Ormolu/Printer/Combinators.hs +++ b/src/Ormolu/Printer/Combinators.hs @@ -21,6 +21,8 @@ space, newline, inci, + inciIf, + inciBy, located, located', switchLayout, @@ -29,6 +31,7 @@ getLayout, breakpoint, breakpoint', + getPrinterOpt, -- ** Formatting lists sep, @@ -51,6 +54,7 @@ -- ** Literals comma, + commaDel, equals, -- ** Stateful markers @@ -65,6 +69,7 @@ import Control.Monad import Data.List (intersperse) import Data.Text (Text) +import Ormolu.Config import Ormolu.Printer.Comments import Ormolu.Printer.Internal import SrcLoc @@ -72,6 +77,15 @@ ---------------------------------------------------------------------------- -- Basic +-- | Indent the inner expression if the first argument is 'True'. +inciIf :: + -- | Whether to indent + Bool -> + -- | The expression to indent + R () -> + R () +inciIf b m = if b then inci m else m + -- | Enter a 'Located' entity. This combinator handles outputting comments -- and sets layout (single-line vs multi-line) for the inner computation. -- Roughly, the rule for using 'located' is that every time there is a @@ -174,10 +188,12 @@ xs' -> if ub then do - txt "{ " - sep (txt "; ") (dontUseBraces . f) xs' - txt " }" - else sep (txt "; ") f xs' + txt "{" + space + sep (txt ";" >> space) (dontUseBraces . f) xs' + space + txt "}" + else sep (txt ";" >> space) f xs' multiLine = sep newline (dontUseBraces . f) xs @@ -190,6 +206,7 @@ N | -- | Shifted one level S + deriving (Eq, Show) -- | Surround given entity by backticks. backticks :: R () -> R () @@ -218,7 +235,7 @@ parensHash :: BracketStyle -> R () -> R () parensHash = brackets_ True "(#" "#)" --- | Braces as used for pragmas: @{-#@ and @#-}@. +-- | Braces as used for pragmas: @{\-#@ and @#-\}@. pragmaBraces :: R () -> R () pragmaBraces m = sitcc $ do txt "{-#" @@ -262,13 +279,18 @@ txt close multiLine = do txt open - if needBreaks - then newline >> inci m - else space >> sitcc m + commaStyle <- getPrinterOpt poCommaStyle + case commaStyle of + Leading -> + if needBreaks + then inci $ newline >> m + else inciIf (style == S) $ space >> m + Trailing -> + if needBreaks + then newline >> inci m + else space >> sitcc m newline - case style of - N -> txt close - S -> inci (txt close) + inciIf (style == S) (txt close) ---------------------------------------------------------------------------- -- Literals @@ -276,6 +298,13 @@ -- | Print @,@. comma :: R () comma = txt "," + +-- | Delimiting combination with 'comma'. To be used with 'sep'. +commaDel :: R () +commaDel = + getPrinterOpt poCommaStyle >>= \case + Leading -> breakpoint' >> comma >> space + Trailing -> comma >> breakpoint -- | Print @=@. Do not use @'txt' "="@. equals :: R () diff --git a/src/Ormolu/Printer/Comments.hs b/src/Ormolu/Printer/Comments.hs --- a/src/Ormolu/Printer/Comments.hs +++ b/src/Ormolu/Printer/Comments.hs @@ -154,6 +154,7 @@ -- | Last printed comment span Maybe SpanMark -> Bool +needsNewlineBefore _ (Just (HaddockSpan _ _)) = True needsNewlineBefore l mlastMark = case spanMarkSpan <$> mlastMark of Nothing -> False @@ -231,18 +232,17 @@ let startColumn = srcLocCol . realSrcSpanStart in startColumn espn > startColumn ref || ( abs (startColumn espn - startColumn l) - >= abs (startColumn ref - startColumn l) + >= abs (startColumn ref - startColumn l) ) continuation = -- A comment is a continuation when it doesn't have non-whitespace -- lexemes in front of it and goes right after the previous comment. not (hasAtomsBefore comment) && ( case mlastMark of - Just (HaddockSpan _ spn) -> - srcSpanEndLine spn + 1 == srcSpanStartLine l - Just (CommentSpan spn) -> - srcSpanEndLine spn + 1 == srcSpanStartLine l - _ -> False + Just (HaddockSpan _ _) -> False + Just (CommentSpan spn) -> + srcSpanEndLine spn + 1 == srcSpanStartLine l + _ -> False ) lastInEnclosing = case meSpn of diff --git a/src/Ormolu/Printer/Internal.hs b/src/Ormolu/Printer/Internal.hs --- a/src/Ormolu/Printer/Internal.hs +++ b/src/Ormolu/Printer/Internal.hs @@ -20,11 +20,13 @@ newline, useRecordDot, inci, + inciBy, sitcc, Layout (..), enterLayout, vlayout, getLayout, + getPrinterOpt, -- * Helpers for braces useBraces, @@ -57,6 +59,7 @@ import Control.Monad.State.Strict import Data.Bool (bool) import Data.Coerce +import Data.Functor.Identity (runIdentity) import Data.Maybe (listToMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -94,7 +97,7 @@ rcCanUseBraces :: Bool, -- | Whether the source could have used the record dot preprocessor rcUseRecDot :: Bool, - rcPrinterOpts :: PrinterOpts + rcPrinterOpts :: PrinterOptsTotal } -- | State context of 'R'. @@ -160,7 +163,7 @@ CommentStream -> -- | Annotations Anns -> - PrinterOpts -> + PrinterOptsTotal -> -- | Use Record Dot Syntax Bool -> -- | Resulting rendition @@ -224,7 +227,8 @@ R () txt = spit SimpleText --- | +-- | Similar to 'txt' but the text inserted this way is assumed to break the +-- “link” between the preceding atom and its pending comments. interferingTxt :: -- | 'Text' to output Text -> @@ -247,6 +251,7 @@ -- | 'Text' to output Text -> R () +spit _ "" = return () spit stype text = do requestedDel <- R (gets scRequestedDelimiter) pendingComments <- R (gets scPendingComments) @@ -377,13 +382,19 @@ -- to be valid Haskell. When layout is single-line there is no obvious -- effect, but with multi-line layout correct indentation levels matter. inci :: R () -> R () -inci (R m) = do - indentStep <- R (asks (poIndentStep . rcPrinterOpts)) +inci = inciBy 1 + +-- | Like 'inci', but indents by the given fraction of a full step. +inciBy :: Int -> R () -> R () +inciBy x (R m) = do + step <- (`quot` x) <$> R (asks (runIdentity . poIndentation . rcPrinterOpts)) let modRC rc = rc - { rcIndent = rcIndent rc + indentStep + { rcIndent = roundDownToNearest step (rcIndent rc) + step } R (local modRC m) + where + roundDownToNearest r n = (n `div` r) * r -- | Set indentation level for the inner computation equal to current -- column. This makes sure that the entire inner block is uniformly @@ -424,6 +435,10 @@ -- | Get current 'Layout'. getLayout :: R Layout getLayout = R (asks rcLayout) + +-- | Get a particular 'PrinterOpts' field from the environment. +getPrinterOpt :: (forall f. PrinterOpts f -> f a) -> R a +getPrinterOpt f = R $ asks $ runIdentity . f . rcPrinterOpts ---------------------------------------------------------------------------- -- Special helpers for comment placement diff --git a/src/Ormolu/Printer/Meat/Common.hs b/src/Ormolu/Printer/Meat/Common.hs --- a/src/Ormolu/Printer/Meat/Common.hs +++ b/src/Ormolu/Printer/Meat/Common.hs @@ -11,16 +11,17 @@ p_qualName, p_infixDefHelper, p_hsDocString, - p_hsDocName, ) where import Control.Monad -import Data.List (isPrefixOf) +import Data.Functor +import Data.List (intersperse, isPrefixOf) import qualified Data.Text as T import GHC hiding (GhcPs, IE) import Name (nameStableString) import OccName (OccName (..)) +import Ormolu.Config import Ormolu.Printer.Combinators import Ormolu.Utils @@ -114,35 +115,35 @@ p_infixDefHelper :: -- | Whether to format in infix style Bool -> - -- | Indentation-bumping wrapper - (R () -> R ()) -> + -- | Whether to bump indentation for arguments + Bool -> -- | How to print the operator\/name R () -> -- | How to print the arguments [R ()] -> R () -p_infixDefHelper isInfix inci' name args = +p_infixDefHelper isInfix indentArgs name args = case (isInfix, args) of (True, p0 : p1 : ps) -> do let parens' = if null ps then id - else parens N + else parens N . sitcc parens' $ do p0 breakpoint - inci $ sitcc $ do + inci . sitcc $ do name space p1 - unless (null ps) . inci' $ do + unless (null ps) . inciIf indentArgs $ do breakpoint sitcc (sep breakpoint sitcc ps) (_, ps) -> do name unless (null ps) $ do breakpoint - inci' $ sitcc (sep breakpoint sitcc args) + inciIf indentArgs $ sitcc (sep breakpoint sitcc args) -- | Print a Haddock. p_hsDocString :: @@ -161,16 +162,35 @@ goesAfterComment <- maybe False isCommentSpan <$> getSpanMark -- Make sure the Haddock is separated by a newline from other comments. when goesAfterComment newline - forM_ (zip (splitDocString str) (True : repeat False)) $ \(x, isFirst) -> do - if isFirst - then case hstyle of - Pipe -> txt "-- |" - Caret -> txt "-- ^" - Asterisk n -> txt ("-- " <> T.replicate n "*") - Named name -> p_hsDocName name - else newline >> txt "--" - space - unless (T.null x) (txt x) + let txt' x = unless (T.null x) (txt x) + docLines = splitDocString str + body s = do + txt $ case hstyle of + Pipe -> " |" + Caret -> " ^" + Asterisk n -> " " <> T.replicate n "*" + Named name -> " $" <> T.pack name + sequence_ $ intersperse (newline >> s) $ map txt' docLines + single <- + getPrinterOpt poHaddockStyle <&> \case + HaddockSingleLine -> True + -- Use multiple single-line comments when the whole comment is indented + HaddockMultiLine -> maybe False ((> 1) . srcSpanStartCol) $ unSrcSpan l + if single + then do + txt "--" + body $ txt "--" + else + if length docLines <= 1 + then do + txt "--" + body $ pure () + else do + txt "{-" + body $ pure () + newline + txt "-}" + when needsNewline newline case l of UnhelpfulSpan _ -> @@ -179,7 +199,3 @@ -- nearest enclosing span. getEnclosingSpan (const True) >>= mapM_ (setSpanMark . HaddockSpan hstyle) RealSrcSpan spn -> setSpanMark (HaddockSpan hstyle spn) - --- | Print anchor of named doc section. -p_hsDocName :: String -> R () -p_hsDocName name = txt ("-- $" <> T.pack name) diff --git a/src/Ormolu/Printer/Meat/Declaration.hs b/src/Ormolu/Printer/Meat/Declaration.hs --- a/src/Ormolu/Printer/Meat/Declaration.hs +++ b/src/Ormolu/Printer/Meat/Declaration.hs @@ -12,7 +12,7 @@ where import Data.List (sort) -import Data.List.NonEmpty ((<|), NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as NE import GHC hiding (InlinePragma) import OccName (occNameFS) @@ -54,12 +54,13 @@ p_hsDeclsRespectGrouping = p_hsDecls' Respect p_hsDecls' :: UserGrouping -> FamilyStyle -> [LHsDecl GhcPs] -> R () -p_hsDecls' grouping style decls = sepSemi id $ - -- Return a list of rendered declarations, adding a newline to separate - -- groups. - case groupDecls decls of - [] -> [] - (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs) +p_hsDecls' grouping style decls = + sepSemi id $ + -- Return a list of rendered declarations, adding a newline to separate + -- groups. + case groupDecls decls of + [] -> [] + (x : xs) -> renderGroup x ++ concat (zipWith renderGroupWithPrev (x : xs) xs) where renderGroup = NE.toList . fmap (located' $ dontUseBraces . p_hsDecl style) renderGroupWithPrev prev curr = @@ -84,9 +85,6 @@ isHaddock _ = False -- | Group relevant declarations together. --- --- Add a declaration to a group iff it is relevant to either the first or --- the preceding declaration in the group. groupDecls :: [LHsDecl GhcPs] -> [NonEmpty (LHsDecl GhcPs)] groupDecls [] = [] groupDecls (l@(L _ DocNext) : xs) = @@ -99,7 +97,8 @@ let (grp, rest) = flip span (zip (header : xs) xs) $ \(previous, current) -> let relevantToHdr = groupedDecls header current relevantToPrev = groupedDecls previous current - in relevantToHdr || relevantToPrev + isDeclSeries = declSeries previous current + in isDeclSeries || relevantToHdr || relevantToPrev in (header :| map snd grp) : groupDecls (map snd rest) p_hsDecl :: FamilyStyle -> HsDecl GhcPs -> R () @@ -196,6 +195,18 @@ (_, DocPrev) -> True _ -> False +-- | Detect declaration series that should not have blanks between them. +declSeries :: + LHsDecl GhcPs -> + LHsDecl GhcPs -> + Bool +declSeries (L _ x) (L _ y) = + case (x, y) of + ( SigD NoExtField (TypeSig NoExtField _ _), + SigD NoExtField (TypeSig NoExtField _ _) + ) -> True + _ -> False + intersects :: Ord a => [a] -> [a] -> Bool intersects a b = go (sort a) (sort b) where @@ -288,9 +299,10 @@ patSigRdrNames _ = Nothing warnSigRdrNames :: HsDecl GhcPs -> Maybe [RdrName] -warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $ flip concatMap ws $ \case - L _ (Warning NoExtField ns _) -> map unLoc ns - L _ (XWarnDecl x) -> noExtCon x +warnSigRdrNames (WarningD NoExtField (Warnings NoExtField _ ws)) = Just $ + flip concatMap ws $ \case + L _ (Warning NoExtField ns _) -> map unLoc ns + L _ (XWarnDecl x) -> noExtCon x warnSigRdrNames _ = Nothing patBindNames :: Pat GhcPs -> [RdrName] diff --git a/src/Ormolu/Printer/Meat/Declaration.hs-boot b/src/Ormolu/Printer/Meat/Declaration.hs-boot --- a/src/Ormolu/Printer/Meat/Declaration.hs-boot +++ b/src/Ormolu/Printer/Meat/Declaration.hs-boot @@ -9,5 +9,4 @@ import Ormolu.Printer.Meat.Common p_hsDecls :: FamilyStyle -> [LHsDecl GhcPs] -> R () - p_hsDeclsRespectGrouping :: FamilyStyle -> [LHsDecl GhcPs] -> R () diff --git a/src/Ormolu/Printer/Meat/Declaration/Class.hs b/src/Ormolu/Printer/Meat/Declaration/Class.hs --- a/src/Ormolu/Printer/Meat/Declaration/Class.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Class.hs @@ -14,6 +14,7 @@ import Data.Foldable import Data.List (sortOn) import GHC +import Ormolu.Config import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration @@ -58,7 +59,7 @@ switchLayout signatureSpans $ p_infixDefHelper (isInfix fixity) - inci + True (p_rdrName name) (located' p_hsTyVarBndr <$> hsq_explicit) inci (p_classFundeps fdeps) @@ -82,7 +83,12 @@ breakpoint txt "|" space - sitcc $ sep (comma >> breakpoint) (sitcc . located' p_funDep) fdeps + inci' $ sep commaDel (sitcc . located' p_funDep) fdeps + where + inci' x = + getPrinterOpt poCommaStyle >>= \case + Leading -> id x + Trailing -> inci x p_funDep :: FunDep (Located RdrName) -> R () p_funDep (before, after) = do diff --git a/src/Ormolu/Printer/Meat/Declaration/Data.hs b/src/Ormolu/Printer/Meat/Declaration/Data.hs --- a/src/Ormolu/Printer/Meat/Declaration/Data.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Data.hs @@ -10,7 +10,9 @@ import Control.Monad import Data.Maybe (isJust, maybeToList) +import qualified Data.Text as Text import GHC +import Ormolu.Config import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type @@ -41,7 +43,7 @@ inci $ p_infixDefHelper (isInfix fixity) - inci + True (p_rdrName name) (located' p_hsType <$> tpats) case dd_kindSig of @@ -60,28 +62,26 @@ txt "where" breakpoint sepSemi (located' (p_conDecl False)) dd_cons - else switchLayout (getLoc name : (getLoc <$> dd_cons)) - $ inci - $ do - let singleConstRec = isSingleConstRec dd_cons - if singleConstRec - then space - else - if hasHaddocks dd_cons - then newline - else breakpoint - equals - space - layout <- getLayout - let s = - if layout == MultiLine || hasHaddocks dd_cons - then newline >> txt "|" >> space - else space >> txt "|" >> space - sitcc' = - if singleConstRec - then id - else sitcc - sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons + else switchLayout (getLoc name : (getLoc <$> dd_cons)) . inci $ do + let singleConstRec = isSingleConstRec dd_cons + if singleConstRec + then space + else + if hasHaddocks dd_cons + then newline + else breakpoint + equals + space + layout <- getLayout + let s = + if layout == MultiLine || hasHaddocks dd_cons + then newline >> txt "|" >> space + else space >> txt "|" >> space + sitcc' = + if singleConstRec + then id + else sitcc + sep s (sitcc' . located' (p_conDecl singleConstRec)) dd_cons unless (null $ unLoc dd_derivs) breakpoint inci . located dd_derivs $ \xs -> sep newline (located' p_hsDerivingClause) xs @@ -106,11 +106,10 @@ (c : cs) -> do p_rdrName c unless (null cs) . inci $ do - comma - breakpoint - sitcc $ sep (comma >> breakpoint) p_rdrName cs - space + commaDel + sep commaDel p_rdrName cs inci $ do + space txt "::" let interArgBreak = if hasDocStrings (unLoc con_res_ty) @@ -149,6 +148,8 @@ when (unLoc con_forall) $ do p_forallBndrs ForallInvis p_hsTyVarBndr con_ex_tvs breakpoint + indent <- getPrinterOpt poIndentation + vlayout (pure ()) . txt $ Text.replicate (indent - 2) " " forM_ con_mb_cxt p_lhsContext switchLayout conDeclSpn $ case con_args of PrefixCon xs -> do @@ -158,11 +159,7 @@ RecCon l -> do p_rdrName con_name breakpoint - let inci' = - if singleConstRec - then id - else inci - inci' (located l p_conDeclFields) + inciIf (not singleConstRec) (located l p_conDeclFields) InfixCon x y -> do located x p_hsType breakpoint @@ -211,9 +208,9 @@ let derivingWhat = located deriv_clause_tys $ \case [] -> txt "()" xs -> - parens N . sitcc $ + parens N $ sep - (comma >> breakpoint) + commaDel (sitcc . located' p_hsType . hsib_body) xs space diff --git a/src/Ormolu/Printer/Meat/Declaration/Default.hs b/src/Ormolu/Printer/Meat/Declaration/Default.hs --- a/src/Ormolu/Printer/Meat/Declaration/Default.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Default.hs @@ -15,6 +15,6 @@ DefaultDecl NoExtField ts -> do txt "default" breakpoint - inci . parens N . sitcc $ - sep (comma >> breakpoint) (sitcc . located' p_hsType) ts + inci . parens N $ + sep commaDel (sitcc . located' p_hsType) ts XDefaultDecl x -> noExtCon x diff --git a/src/Ormolu/Printer/Meat/Declaration/Instance.hs b/src/Ormolu/Printer/Meat/Declaration/Instance.hs --- a/src/Ormolu/Printer/Meat/Declaration/Instance.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Instance.hs @@ -32,9 +32,7 @@ txt "instance" breakpoint match_overlap_mode deriv_overlap_mode breakpoint - if toIndent - then inci typesAfterInstance - else typesAfterInstance + inciIf toIndent typesAfterInstance txt "deriving" space case deriv_strategy of @@ -90,12 +88,10 @@ unless (null allDecls) $ do breakpoint txt "where" - unless (null allDecls) - $ inci - $ do - -- Ensure whitespace is added after where clause. - breakpoint - dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls + unless (null allDecls) . inci $ do + -- Ensure whitespace is added after where clause. + breakpoint + dontUseBraces $ p_hsDeclsRespectGrouping Associated allDecls XHsImplicitBndrs x -> noExtCon x XClsInstDecl x -> noExtCon x diff --git a/src/Ormolu/Printer/Meat/Declaration/Rule.hs b/src/Ormolu/Printer/Meat/Declaration/Rule.hs --- a/src/Ormolu/Printer/Meat/Declaration/Rule.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Rule.hs @@ -18,7 +18,7 @@ p_ruleDecls :: RuleDecls GhcPs -> R () p_ruleDecls = \case HsRules NoExtField _ xs -> - pragma "RULES" . sitcc $ + pragma "RULES" $ sep breakpoint (sitcc . located' p_ruleDecl) xs XRuleDecls x -> noExtCon x @@ -55,7 +55,7 @@ p_ruleBndr :: RuleBndr GhcPs -> R () p_ruleBndr = \case RuleBndr NoExtField x -> p_rdrName x - RuleBndrSig NoExtField x hswc -> parens N $ do + RuleBndrSig NoExtField x hswc -> parens N . sitcc $ do p_rdrName x p_typeAscription hswc XRuleBndr x -> noExtCon x diff --git a/src/Ormolu/Printer/Meat/Declaration/Signature.hs b/src/Ormolu/Printer/Meat/Declaration/Signature.hs --- a/src/Ormolu/Printer/Meat/Declaration/Signature.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Signature.hs @@ -14,7 +14,6 @@ import BasicTypes import BooleanFormula import Control.Monad -import Data.Bool (bool) import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common @@ -48,25 +47,22 @@ p_rdrName n if null ns then p_typeAscription hswc - else do - comma - breakpoint - bool id inci indentTail $ do - sep (comma >> breakpoint) p_rdrName ns - p_typeAscription hswc + else inciIf indentTail $ do + commaDel + sep commaDel p_rdrName ns + p_typeAscription hswc p_typeAscription :: LHsSigWcType GhcPs -> R () -p_typeAscription HsWC {..} = do +p_typeAscription HsWC {..} = inci $ do space - inci $ do - txt "::" - let t = hsib_body hswc_body - if hasDocStrings (unLoc t) - then newline - else breakpoint - located t p_hsType + txt "::" + let t = hsib_body hswc_body + if hasDocStrings (unLoc t) + then newline + else breakpoint + located t p_hsType p_typeAscription (XHsWildCardBndrs x) = noExtCon x p_patSynSig :: @@ -108,7 +104,7 @@ space atom n space - sitcc $ sep (comma >> breakpoint) p_rdrName names + sitcc $ sep commaDel p_rdrName names XFixitySig x -> noExtCon x p_inlineSig :: @@ -147,7 +143,7 @@ space txt "::" breakpoint - inci $ sep (comma >> breakpoint) (located' p_hsType . hsib_body) ts + inci $ sep commaDel (located' p_hsType . hsib_body) ts p_inlineSpec :: InlineSpec -> R () p_inlineSpec = \case @@ -191,13 +187,13 @@ And xs -> sitcc $ sep - (comma >> breakpoint) + commaDel (located' p_booleanFormula) xs Or xs -> sitcc $ sep - (breakpoint >> txt "| ") + (breakpoint >> txt "|" >> space) (located' p_booleanFormula) xs Parens l -> located l (parens N . p_booleanFormula) @@ -211,7 +207,7 @@ p_completeSig cs' mty = located cs' $ \cs -> pragma "COMPLETE" . inci $ do - sitcc $ sep (comma >> breakpoint) p_rdrName cs + sep commaDel p_rdrName cs forM_ mty $ \ty -> do space txt "::" @@ -228,12 +224,13 @@ p_standaloneKindSig :: StandaloneKindSig GhcPs -> R () p_standaloneKindSig (StandaloneKindSig NoExtField name bndrs) = do txt "type" - space - p_rdrName name - space - txt "::" - breakpoint - inci $ case bndrs of - HsIB NoExtField sig -> located sig p_hsType - XHsImplicitBndrs x -> noExtCon x + inci $ do + space + p_rdrName name + space + txt "::" + breakpoint + case bndrs of + HsIB NoExtField sig -> located sig p_hsType + XHsImplicitBndrs x -> noExtCon x p_standaloneKindSig (XStandaloneKindSig c) = noExtCon c diff --git a/src/Ormolu/Printer/Meat/Declaration/Type.hs b/src/Ormolu/Printer/Meat/Declaration/Type.hs --- a/src/Ormolu/Printer/Meat/Declaration/Type.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Type.hs @@ -28,7 +28,7 @@ switchLayout (getLoc name : map getLoc hsq_explicit) $ p_infixDefHelper (case fixity of Infix -> True; _ -> False) - inci + True (p_rdrName name) (map (located' p_hsTyVarBndr) hsq_explicit) space diff --git a/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs b/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs --- a/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs +++ b/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs @@ -31,7 +31,7 @@ switchLayout (getLoc fdLName : (getLoc <$> hsq_explicit)) $ p_infixDefHelper (isInfix fdFixity) - inci + True (p_rdrName fdLName) (located' p_hsTyVarBndr <$> hsq_explicit) let resultSig = p_familyResultSigL fdResultSig @@ -92,12 +92,12 @@ Just bndrs -> do p_forallBndrs ForallInvis p_hsTyVarBndr bndrs breakpoint - (if null feqn_bndrs then id else inci) $ do + inciIf (not $ null feqn_bndrs) $ do let famLhsSpn = getLoc feqn_tycon : fmap (getLoc . typeArgToType) feqn_pats switchLayout famLhsSpn $ p_infixDefHelper (isInfix feqn_fixity) - inci + True (p_rdrName feqn_tycon) (located' p_hsType . typeArgToType <$> feqn_pats) space diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs b/src/Ormolu/Printer/Meat/Declaration/Value.hs --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} @@ -22,12 +23,13 @@ import Data.Data hiding (Infix, Prefix) import Data.Functor ((<&>)) import Data.List (intersperse, sortOn) -import Data.List.NonEmpty ((<|), NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified Data.Text as Text import GHC -import OccName (mkVarOcc) +import OccName (occNameString) +import Ormolu.Config import Ormolu.Printer.Combinators import Ormolu.Printer.Internal import Ormolu.Printer.Meat.Common @@ -61,7 +63,7 @@ -- should use it and avoid bumping one level -- of indentation Hanging - deriving (Eq) + deriving (Eq, Show) p_valDecl :: HsBindLR GhcPs GhcPs -> R () p_valDecl = \case @@ -180,25 +182,24 @@ NoSrcStrict -> return () SrcStrict -> txt "!" SrcLazy -> txt "~" - inci' <- case NE.nonEmpty m_pats of - Nothing -> id <$ case style of - Function name -> p_rdrName name - _ -> return () + indentBody <- case NE.nonEmpty m_pats of + Nothing -> + False <$ case style of + Function name -> p_rdrName name + _ -> return () Just ne_pats -> do - let combinedSpans = - combineSrcSpans' $ - getLoc <$> ne_pats - inci' = - if isOneLineSpan combinedSpans - then id - else inci + let combinedSpans = case style of + Function name -> combineSrcSpans (getLoc name) patSpans + _ -> patSpans + patSpans = combineSrcSpans' (getLoc <$> ne_pats) + indentBody = not (isOneLineSpan combinedSpans) switchLayout [combinedSpans] $ do let stdCase = sep breakpoint (located' p_pat) m_pats case style of Function name -> p_infixDefHelper isInfix - inci' + indentBody (p_rdrName name) (located' p_pat <$> m_pats) PatternBind -> stdCase @@ -213,7 +214,7 @@ when needsSpace space sitcc stdCase LambdaCase -> stdCase - return inci' + return indentBody let -- Calculate position of end of patterns. This is useful when we decide -- about putting certain constructions in hanging positions. endOfPats = case NE.nonEmpty m_pats of @@ -225,7 +226,7 @@ Case -> True LambdaCase -> True _ -> False - let hasGuards = withGuards grhssGRHSs + hasGuards = withGuards grhssGRHSs grhssSpan = combineSrcSpans' $ getGRHSSpan . unLoc <$> NE.fromList grhssGRHSs @@ -251,10 +252,11 @@ let whereIsEmpty = GHC.isEmptyLocalBindsPR (unLoc grhssLocalBinds) unless (GHC.eqEmptyLocalBinds (unLoc grhssLocalBinds)) $ do breakpoint - txt "where" + indentWhere <- getPrinterOpt poIndentWheres + bool (inciBy $ -2) id indentWhere $ txt "where" unless whereIsEmpty breakpoint - inci $ located grhssLocalBinds p_hsLocalBinds - inci' $ do + inciIf indentWhere $ located grhssLocalBinds p_hsLocalBinds + inciIf indentBody $ do unless (length grhssGRHSs > 1) $ case style of Function _ | hasGuards -> return () @@ -285,7 +287,7 @@ xs -> do txt "|" space - sitcc (sep (comma >> breakpoint) (sitcc . located' p_stmt) xs) + sitcc (sep commaDel (sitcc . located' p_stmt) xs) space inci $ case style of EqualSign -> equals @@ -317,7 +319,7 @@ HsHigherOrderApp -> txt "-<<" placeHanging (exprPlacement (unLoc input)) $ located input p_hsExpr - HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ sitcc $ do + HsCmdArrForm NoExtField form Prefix _ cmds -> banana $ do located form p_hsExpr unless (null cmds) $ do breakpoint @@ -334,7 +336,7 @@ -- does. Open an issue and ping @yumiova if this ever occurs in output. notImplemented "HsCmdApp" HsCmdLam NoExtField mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup - HsCmdPar NoExtField c -> parens N (located c p_hsCmd) + HsCmdPar NoExtField c -> parens N $ sitcc $ located c p_hsCmd HsCmdCase NoExtField e mgroup -> p_case cmdPlacement p_hsCmd e mgroup HsCmdIf NoExtField _ if' then' else' -> @@ -354,7 +356,14 @@ HsCmdTop NoExtField cmd -> located cmd p_hsCmd XCmdTop x -> noExtCon x -withSpacing :: Data a => (a -> R ()) -> Located a -> R () +-- | Render an expression preserving blank lines between such consecutive +-- expressions found in the original source code. +withSpacing :: + -- | Rendering function + (a -> R ()) -> + -- | Entity to render + Located a -> + R () withSpacing f l = located l $ \x -> do case getLoc l of UnhelpfulSpan _ -> f x @@ -465,30 +474,24 @@ p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R () p_hsLocalBinds = \case HsValBinds NoExtField (ValBinds NoExtField bag lsigs) -> do - let ssStart = - either - (srcSpanStart . getLoc) - (srcSpanStart . getLoc) - items = - (Left <$> bagToList bag) ++ (Right <$> lsigs) - p_item (Left x) = located x p_valDecl - p_item (Right x) = located x p_sigDecl -- When in a single-line layout, there is a chance that the inner -- elements will also contain semicolons and they will confuse the -- parser. so we request braces around every element except the last. br <- layoutToBraces <$> getLayout - sitcc $ - sepSemi - ( \(p, i) -> - ( case p of - SinglePos -> id - FirstPos -> br - MiddlePos -> br - LastPos -> id - ) - (p_item i) - ) - (attachRelativePos $ sortOn ssStart items) + let items = + let injectLeft (L l x) = L l (Left x) + injectRight (L l x) = L l (Right x) + in (injectLeft <$> bagToList bag) ++ (injectRight <$> lsigs) + positionToBracing = \case + SinglePos -> id + FirstPos -> br + MiddlePos -> br + LastPos -> id + p_item' (p, item) = + positionToBracing p $ + withSpacing (either p_valDecl p_sigDecl) item + binds = sortOn (srcSpanStart . getLoc) items + sitcc $ sepSemi p_item' (attachRelativePos binds) HsValBinds NoExtField _ -> notImplemented "HsValBinds" HsIPBinds NoExtField (IPBinds NoExtField xs) -> -- Second argument of IPBind is always Left before type-checking. @@ -521,12 +524,6 @@ else Normal placeHanging placement (located hsRecFieldArg p_hsExpr) -p_hsTupArg :: HsTupArg GhcPs -> R () -p_hsTupArg = \case - Present NoExtField x -> located x p_hsExpr - Missing NoExtField -> pure () - XTupArg x -> noExtCon x - p_hsExpr :: HsExpr GhcPs -> R () p_hsExpr = p_hsExpr' N @@ -590,23 +587,21 @@ -- do-block or case expression it is not a good idea. It seems -- to be safe to always bump indentation when the function -- expression is parenthesised. - indent = + doIndent = case func of - L _ (HsPar NoExtField _) -> inci - L _ (HsAppType NoExtField _ _) -> inci - L _ (HsMultiIf NoExtField _) -> inci - L spn _ -> - if isOneLineSpan spn - then inci - else id - ub <- getLayout <&> \case - SingleLine -> useBraces - MultiLine -> id + L _ (HsPar NoExtField _) -> True + L _ (HsAppType NoExtField _ _) -> True + L _ (HsMultiIf NoExtField _) -> True + L spn _ -> isOneLineSpan spn + ub <- + getLayout <&> \case + SingleLine -> useBraces + MultiLine -> id ub $ do located func (p_hsExpr' s) breakpoint - indent $ sep breakpoint (located' p_hsExpr) initp - indent $ do + inciIf doIndent $ sep breakpoint (located' p_hsExpr) initp + inciIf doIndent $ do unless (null initp) breakpoint located lastp p_hsExpr Hanging -> do @@ -621,16 +616,21 @@ breakpoint inci $ do txt "@" + -- Insert a space when the type is represented as a TH splice to avoid + -- gluing @ and $ together. + case unLoc (hswc_body a) of + HsSpliceTy {} -> space + _ -> return () located (hswc_body a) p_hsType OpApp NoExtField x op y -> do let opTree = OpBranch (exprOpTree x) op (exprOpTree y) - p_exprOpTree True s (reassociateOpTree getOpName opTree) + p_exprOpTree s (reassociateOpTree getOpName opTree) NegApp NoExtField e _ -> do txt "-" space located e p_hsExpr - HsPar NoExtField e -> - parens s (located e (dontUseBraces . p_hsExpr)) + HsPar NoExtField e -> do + parens s $ sitcc $ located e $ dontUseBraces . p_hsExpr SectionL NoExtField x op -> do located x p_hsExpr breakpoint @@ -641,22 +641,27 @@ let isRecordDot' = isRecordDot (unLoc op) (getLoc x) unless (useRecordDot' && isRecordDot') breakpoint inci (located x p_hsExpr) - ExplicitTuple NoExtField args boxity -> do + ExplicitTuple NoExtField args boxity -> let isSection = any (isMissing . unLoc) args isMissing = \case Missing NoExtField -> True _ -> False - let parens' = + p_arg = \case + Present NoExtField x -> located x p_hsExprListItem + Missing NoExtField -> pure () + XTupArg x -> noExtCon x + p_larg = sitcc . located' p_arg + parens' = case boxity of Boxed -> parens Unboxed -> parensHash - if isSection - then - switchLayout [] . parens' s $ - sep comma (located' p_hsTupArg) args - else - switchLayout (getLoc <$> args) . parens' s . sitcc $ - sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args + in if isSection + then + switchLayout [] . parens' s $ + sep comma p_larg args + else + switchLayout (getLoc <$> args) . parens' s $ + sep commaDel p_larg args ExplicitSum NoExtField tag arity e -> p_unboxedSum N tag arity (located e p_hsExpr) HsCase NoExtField e mgroup -> @@ -666,7 +671,7 @@ HsMultiIf NoExtField guards -> do txt "if" breakpoint - inci . inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards + inci . inci $ sep newline (located' (p_grhs RightArrow)) guards HsLet NoExtField localBinds e -> p_let p_hsExpr localBinds e HsDo NoExtField ctx es -> do @@ -678,16 +683,20 @@ sepSemi (ub . withSpacing (p_stmt' exprPlacement (p_hsExpr' S))) (unLoc es) - compBody = brackets N $ located es $ \xs -> do + compBody = brackets N . located es $ \xs -> do let p_parBody = sep - (breakpoint >> txt "| ") + (breakpoint >> txt "|" >> space) p_seqBody p_seqBody = - sitcc + sitcc' . sep - (comma >> breakpoint) + commaDel (located' (sitcc . p_stmt)) + sitcc' x = + getPrinterOpt poCommaStyle >>= \case + Leading -> id x + Trailing -> sitcc x stmts = init xs yield = last xs lists = foldr (liftAppend . gatherStmt) [] stmts @@ -707,11 +716,11 @@ ParStmtCtxt _ -> notImplemented "ParStmtCtxt" TransStmtCtxt _ -> notImplemented "TransStmtCtxt" ExplicitList _ _ xs -> - brackets s . sitcc $ - sep (comma >> breakpoint) (sitcc . located' p_hsExpr) xs + brackets s $ + sep commaDel (sitcc . located' p_hsExprListItem) xs RecordCon {..} -> do located rcon_con_name atom - breakpoint + breakpointPreRecordBrace let HsRecFields {..} = rcon_flds updName f = (f :: HsRecField GhcPs (LHsExpr GhcPs)) @@ -724,8 +733,8 @@ case rec_dotdot of Just {} -> [txt ".."] Nothing -> [] - inci . braces N . sitcc $ - sep (comma >> breakpoint) sitcc (fields <> dotdot) + inci . braces N $ + sep commaDel sitcc (fields <> dotdot) RecordUpd {..} -> do located rupd_expr p_hsExpr useRecordDot' <- useRecordDot @@ -735,7 +744,7 @@ let isPluginForm = ((1 +) . srcSpanEndCol <$> mrs rupd_expr) == (srcSpanStartCol <$> mrs (head rupd_flds)) - unless (useRecordDot' && isPluginForm) breakpoint + unless (useRecordDot' && isPluginForm) breakpointPreRecordBrace let updName f = (f :: HsRecUpdField GhcPs) { hsRecFieldLbl = case unLoc $ hsRecFieldLbl f of @@ -743,9 +752,9 @@ Unambiguous _ n -> n XAmbiguousFieldOcc x -> noExtCon x } - inci . braces N . sitcc $ + inci . braces N $ sep - (comma >> breakpoint) + commaDel (sitcc . located' (p_hsRecField . updName)) rupd_flds ExprWithTySig NoExtField x HsWC {hswc_body = HsIB {..}} -> sitcc $ do @@ -758,22 +767,22 @@ ExprWithTySig NoExtField _ (XHsWildCardBndrs x) -> noExtCon x ArithSeq NoExtField _ x -> case x of - From from -> brackets s . sitcc $ do + From from -> brackets s $ do located from p_hsExpr breakpoint txt ".." - FromThen from next -> brackets s . sitcc $ do - sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next] + FromThen from next -> brackets s $ do + sep commaDel (located' p_hsExpr) [from, next] breakpoint txt ".." - FromTo from to -> brackets s . sitcc $ do + FromTo from to -> brackets s $ do located from p_hsExpr breakpoint txt ".." space located to p_hsExpr - FromThenTo from next to -> brackets s . sitcc $ do - sitcc $ sep (comma >> breakpoint) (located' p_hsExpr) [from, next] + FromThenTo from next to -> brackets s $ do + sep commaDel (located' p_hsExpr) [from, next] breakpoint txt ".." space @@ -830,9 +839,9 @@ txt "<-" breakpoint located psb_def p_pat - newline + breakpoint txt "where" - newline + breakpoint inci (p_matchGroup (Function psb_id) mgroup) txt "pattern" case psb_args of @@ -849,9 +858,9 @@ p_rdrName psb_id inci $ do switchLayout (getLoc . recordPatSynPatVar <$> xs) $ do - unless (null xs) breakpoint - braces N . sitcc $ - sep (comma >> breakpoint) (p_rdrName . recordPatSynPatVar) xs + unless (null xs) breakpointPreRecordBrace + braces N $ + sep commaDel (p_rdrName . recordPatSynPatVar) xs rhs InfixCon l r -> do switchLayout [getLoc l, getLoc r] $ do @@ -942,18 +951,18 @@ txt "@" located pat p_pat ParPat NoExtField pat -> - located pat (parens S . p_pat) + located pat (parens S . sitcc . p_pat) BangPat NoExtField pat -> do txt "!" located pat p_pat ListPat NoExtField pats -> - brackets S . sitcc $ sep (comma >> breakpoint) (located' p_pat) pats + brackets S $ sep commaDel (located' p_pat) pats TuplePat NoExtField pats boxing -> do - let f = + let parens' = case boxing of Boxed -> parens S Unboxed -> parensHash S - f . sitcc $ sep (comma >> breakpoint) (sitcc . located' p_pat) pats + parens' $ sep commaDel (sitcc . located' p_pat) pats SumPat NoExtField pat tag arity -> p_unboxedSum S tag arity (located pat p_pat) ConPatIn pat details -> @@ -965,11 +974,11 @@ inci . sitcc $ sep breakpoint (sitcc . located' p_pat) xs RecCon (HsRecFields fields dotdot) -> do p_rdrName pat - breakpoint + breakpointPreRecordBrace let f = \case Nothing -> txt ".." Just x -> located x p_pat_hsRecField - inci . braces N . sitcc . sep (comma >> breakpoint) f $ + inci . braces N . sep commaDel f $ case dotdot of Nothing -> Just <$> fields Just (L _ n) -> (Just <$> take n fields) ++ [Nothing] @@ -1019,17 +1028,15 @@ let before = tag - 1 after = arity - before - 1 args = replicate before Nothing <> [Just m] <> replicate after Nothing - f (x, i) = do - let isFirst = i == 0 - isLast = i == arity - 1 + f x = case x :: Maybe (R ()) of Nothing -> - unless (isFirst || isLast) space + space Just m' -> do - unless isFirst space + space m' - unless isLast space - parensHash s $ sep (txt "|") f (zip args [0 ..]) + space + parensHash s $ sep (txt "|") f args p_hsSplice :: HsSplice GhcPs -> R () p_hsSplice = \case @@ -1231,11 +1238,10 @@ HsCase NoExtField _ _ -> Hanging HsDo NoExtField DoExpr _ -> Hanging HsDo NoExtField MDoExpr _ -> Hanging - -- If the rightmost expression in an operator chain is hanging, make the - -- whole block hanging; so that we can use the common @f = foo $ do@ - -- style. - OpApp NoExtField _ _ y -> exprPlacement (unLoc y) - -- Same thing for function applications (usually with -XBlockArguments) + OpApp NoExtField _ op y -> + case (fmap getOpNameStr . getOpName . unLoc) op of + Just "$" -> exprPlacement (unLoc y) + _ -> Normal HsApp NoExtField _ y -> exprPlacement (unLoc y) HsProc NoExtField p _ -> -- Indentation breaks if pattern is longer than one line and left @@ -1261,15 +1267,16 @@ HsVar NoExtField (L _ a) -> Just a _ -> Nothing +getOpNameStr :: RdrName -> String +getOpNameStr = occNameString . rdrNameOcc + p_exprOpTree :: - -- | Can use special handling of dollar? - Bool -> -- | Bracket style to use BracketStyle -> OpTree (LHsExpr GhcPs) (LHsExpr GhcPs) -> R () -p_exprOpTree _ s (OpNode x) = located x (p_hsExpr' s) -p_exprOpTree isDollarSpecial s (OpBranch x op y) = do +p_exprOpTree s (OpNode x) = located x (p_hsExpr' s) +p_exprOpTree s (OpBranch x op y) = do -- If the beginning of the first argument and the second argument are on -- the same line, and the second argument has a hanging form, use hanging -- placement. @@ -1291,51 +1298,61 @@ MultiLine -> case placement of Hanging -> useBraces Normal -> dontUseBraces - gotDollar = case getOpName (unLoc op) of - Just rname -> mkVarOcc "$" == rdrNameOcc rname - _ -> False + opNameStr = (fmap getOpNameStr . getOpName . unLoc) op + gotDollar = opNameStr == Just "$" + gotColon = opNameStr == Just ":" + gotRecordDot = isRecordDot (unLoc op) (opTreeLoc y) lhs = switchLayout [opTreeLoc x] $ - p_exprOpTree (not gotDollar) s x - let p_op = located op (opWrapper . p_hsExpr) - p_y = switchLayout [opTreeLoc y] (p_exprOpTree True N y) + p_exprOpTree s x + p_op = located op (opWrapper . p_hsExpr) + p_y = switchLayout [opTreeLoc y] (p_exprOpTree N y) isSection = case (opTreeLoc x, getLoc op) of (RealSrcSpan treeSpan, RealSrcSpan opSpan) -> srcSpanEndCol treeSpan /= srcSpanStartCol opSpan _ -> False + isDoBlock = \case + OpNode (L _ HsDo {}) -> True + _ -> False useRecordDot' <- useRecordDot - let isRecordDot' = isRecordDot (unLoc op) (opTreeLoc y) - if useRecordDot' && isRecordDot' - then do - lhs - when isSection space - p_op - p_y - else - if isDollarSpecial - && gotDollar - && placement - == Normal - && isOneLineSpan (opTreeLoc x) - then do - useBraces lhs - space - p_op - breakpoint - inci p_y - else do - ub lhs - let opAndRhs = do - p_op - space - p_y - case x of - -- This case prevents an operator from being indented past the start of a `do` block - -- constituting its left operand, thus altering the AST. - -- This is only relevant when the `do` block is on one line, as otherwise we will - -- insert a newline after `do` anyway. - OpNode (unLoc -> HsDo _ _ _) | isOneLineSpan (opTreeLoc x) -> breakpoint >> opAndRhs - _ -> placeHanging placement opAndRhs + if + | gotColon -> do + lhs + space + p_op + case placement of + Hanging -> do + space + p_y + Normal -> do + breakpoint + inciIf (isDoBlock y) p_y + | gotDollar + && isOneLineSpan (opTreeLoc x) + && placement == Normal -> do + useBraces lhs + space + p_op + breakpoint + inci p_y + | useRecordDot' && gotRecordDot -> do + lhs + when isSection space + p_op + p_y + | otherwise -> do + ub lhs + let opAndRhs = do + p_op + space + p_y + case x of + -- This case prevents an operator from being indented past the start of a `do` block + -- constituting its left operand, thus altering the AST. + -- This is only relevant when the `do` block is on one line, as otherwise we will + -- insert a newline after `do` anyway. + OpNode (unLoc -> HsDo _ _ _) | isOneLineSpan (opTreeLoc x) -> breakpoint >> opAndRhs + _ -> placeHanging placement opAndRhs -- | Return 'True' if given expression is a record-dot operator expression. isRecordDot :: @@ -1346,14 +1363,10 @@ Bool isRecordDot op (RealSrcSpan ySpan) = case op of HsVar NoExtField (L (RealSrcSpan opSpan) opName) -> - isDot opName && (srcSpanEndCol opSpan == srcSpanStartCol ySpan) + (getOpNameStr opName == ".") && (srcSpanEndCol opSpan == srcSpanStartCol ySpan) _ -> False isRecordDot _ _ = False --- | Check whether a given 'RdrName' is the dot operator. -isDot :: RdrName -> Bool -isDot name = rdrNameOcc name == mkVarOcc "." - -- | Get annotations for the enclosing element. getEnclosingAnns :: R [AnnKeywordId] getEnclosingAnns = do @@ -1361,3 +1374,29 @@ case e of Nothing -> return [] Just e' -> getAnns (RealSrcSpan e') + +-- | For use before record braces. Collapse to empty if not 'poRecordBraceSpace'. +breakpointPreRecordBrace :: R () +breakpointPreRecordBrace = do + useSpace <- getPrinterOpt poRecordBraceSpace + if useSpace + then breakpoint + else breakpoint' + +-- | For nested lists/tuples, pad with whitespace so that we always indent correctly, +-- rather than sometimes indenting by 2 regardless of 'poIndentation'. +p_hsExprListItem :: HsExpr GhcPs -> R () +p_hsExprListItem e = do + indent <- getPrinterOpt poIndentation + when (listLike e) $ do + getPrinterOpt poCommaStyle >>= \case + Leading -> breakpoint' + Trailing -> pure () + vlayout (pure ()) (spaces $ indent - 2) + p_hsExpr e + where + spaces n = txt $ Text.replicate n " " + listLike = \case + ExplicitList {} -> True + ExplicitTuple {} -> True + _ -> False diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot b/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot @@ -11,11 +11,7 @@ import Ormolu.Printer.Combinators p_valDecl :: HsBindLR GhcPs GhcPs -> R () - p_pat :: Pat GhcPs -> R () - p_hsExpr :: HsExpr GhcPs -> R () - p_hsSplice :: HsSplice GhcPs -> R () - p_stringLit :: String -> R () diff --git a/src/Ormolu/Printer/Meat/Declaration/Warning.hs b/src/Ormolu/Printer/Meat/Declaration/Warning.hs --- a/src/Ormolu/Printer/Meat/Declaration/Warning.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Warning.hs @@ -32,10 +32,9 @@ p_topLevelWarning :: [Located RdrName] -> WarningTxt -> R () p_topLevelWarning fnames wtxt = do let (pragmaText, lits) = warningText wtxt - switchLayout (fmap getLoc fnames ++ fmap getLoc lits) - $ pragma pragmaText . inci - $ do - sitcc $ sep (comma >> breakpoint) p_rdrName fnames + switchLayout (fmap getLoc fnames ++ fmap getLoc lits) $ + pragma pragmaText . inci $ do + sep commaDel p_rdrName fnames breakpoint p_lits lits @@ -47,4 +46,4 @@ p_lits :: [Located StringLiteral] -> R () p_lits = \case [l] -> atom l - ls -> brackets N . sitcc $ sep (comma >> breakpoint) atom ls + ls -> brackets N $ sep commaDel atom ls diff --git a/src/Ormolu/Printer/Meat/ImportExport.hs b/src/Ormolu/Printer/Meat/ImportExport.hs --- a/src/Ormolu/Printer/Meat/ImportExport.hs +++ b/src/Ormolu/Printer/Meat/ImportExport.hs @@ -6,11 +6,14 @@ module Ormolu.Printer.Meat.ImportExport ( p_hsmodExports, p_hsmodImport, + breakIfNotDiffFriendly, ) where import Control.Monad +import qualified Data.Text as T import GHC +import Ormolu.Config (poDiffFriendlyImportExport) import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Utils (RelativePos (..), attachRelativePos) @@ -21,7 +24,7 @@ breakpoint' txt ")" p_hsmodExports xs = - parens N . sitcc $ do + parens' False $ do layout <- getLayout sep breakpoint @@ -64,8 +67,8 @@ case ideclHiding of Nothing -> return () Just (_, L _ xs) -> do - breakpoint - parens N . sitcc $ do + breakIfNotDiffFriendly + parens' True $ do layout <- getLayout sep breakpoint @@ -89,13 +92,12 @@ p_comma IEThingWith NoExtField l1 w xs _ -> sitcc $ do located l1 p_ieWrappedName - breakpoint + breakIfNotDiffFriendly inci $ do let names :: [R ()] names = located' p_ieWrappedName <$> xs - parens N . sitcc - $ sep (comma >> breakpoint) sitcc - $ case w of + parens' False . sep commaDel' sitcc $ + case w of NoIEWildcard -> names IEWildcard n -> let (before, after) = splitAt n names @@ -113,7 +115,7 @@ p_hsDocString (Asterisk n) False (noLoc str) IEDoc NoExtField str -> p_hsDocString Pipe False (noLoc str) - IEDocNamed NoExtField str -> p_hsDocName str + IEDocNamed NoExtField str -> txt $ "-- $" <> T.pack str XIE x -> noExtCon x where p_comma = @@ -125,3 +127,40 @@ MiddlePos -> comma LastPos -> return () MultiLine -> comma + +---------------------------------------------------------------------------- +-- Unlike the versions in 'Ormolu.Printer.Combinators', these do not depend on +-- whether 'leadingCommas' is set. This is useful here is we choose to keep +-- import and export lists independent of that setting. + +-- | Delimiting combination with 'comma'. To be used with 'sep'. +commaDel' :: R () +commaDel' = comma >> breakpoint + +-- | Surround given entity by parentheses @(@ and @)@. +parens' :: Bool -> R () -> R () +parens' topLevelImport m = + getPrinterOpt poDiffFriendlyImportExport >>= \case + True -> do + txt "(" + breakpoint' + sitcc body + vlayout (txt ")") (inciBy (-1) trailingParen) + False -> sitcc $ do + txt "(" + body + txt ")" + where + body = vlayout singleLine multiLine + singleLine = m + multiLine = do + space + sitcc m + newline + trailingParen = if topLevelImport then txt " )" else txt ")" + +breakIfNotDiffFriendly :: R () +breakIfNotDiffFriendly = + getPrinterOpt poDiffFriendlyImportExport >>= \case + True -> space + False -> breakpoint diff --git a/src/Ormolu/Printer/Meat/Module.hs b/src/Ormolu/Printer/Meat/Module.hs --- a/src/Ormolu/Printer/Meat/Module.hs +++ b/src/Ormolu/Printer/Meat/Module.hs @@ -11,7 +11,8 @@ import Control.Monad import qualified Data.Text as T import GHC -import Ormolu.Imports +import Ormolu.Config +import Ormolu.Imports (normalizeImports) import Ormolu.Parser.CommentStream import Ormolu.Parser.Pragma import Ormolu.Parser.Shebang @@ -56,22 +57,31 @@ located hsmodName' $ \name -> do forM_ hsmodHaddockModHeader (p_hsDocString Pipe True) p_hsmodName name - breakpoint forM_ hsmodDeprecMessage $ \w -> do - located' p_moduleWarning w breakpoint + located' p_moduleWarning w + breakIfNotDiffFriendly + + -- This works around an awkward idempotency bug with deprecation messages. + diffFriendly <- getPrinterOpt poDiffFriendlyImportExport + when (diffFriendly && not (null hsmodDeprecMessage)) newline + case hsmodExports of Nothing -> return () Just l -> do located l $ \exports -> do inci (p_hsmodExports exports) - breakpoint + breakIfNotDiffFriendly txt "where" newline newline - forM_ (sortImports hsmodImports) (located' (p_hsmodImport qualifiedPost)) + preserveGroups <- getPrinterOpt poRespectful + forM_ (normalizeImports preserveGroups hsmodImports) $ \importGroup -> do + forM_ importGroup (located' (p_hsmodImport qualifiedPost)) + newline newline switchLayout (getLoc <$> hsmodDecls) $ do - p_hsDecls Free hsmodDecls + preserveSpacing <- getPrinterOpt poRespectful + (if preserveSpacing then p_hsDeclsRespectGrouping else p_hsDecls) Free hsmodDecls newline spitRemainingComments diff --git a/src/Ormolu/Printer/Meat/Type.hs b/src/Ormolu/Printer/Meat/Type.hs --- a/src/Ormolu/Printer/Meat/Type.hs +++ b/src/Ormolu/Printer/Meat/Type.hs @@ -52,6 +52,7 @@ HsTyVar NoExtField p n -> do case p of IsPromoted -> do + space txt "'" case showOutputable (unLoc n) of _ : '\'' : _ -> space @@ -67,7 +68,7 @@ L _ (HsAppTy _ l r) -> gatherArgs l (r : knownArgs) _ -> (f', knownArgs) (func, args) = gatherArgs f [x] - switchLayout (getLoc f : fmap getLoc args) $ sitcc $ do + switchLayout (getLoc f : fmap getLoc args) . sitcc $ do located func p_hsType breakpoint inci $ @@ -98,17 +99,16 @@ HsBoxedTuple -> parens N HsConstraintTuple -> parens N HsBoxedOrConstraintTuple -> parens N - in parens' . sitcc $ - sep (comma >> breakpoint) (sitcc . located' p_hsType) xs + in parens' $ sep commaDel (sitcc . located' p_hsType) xs HsSumTy NoExtField xs -> - parensHash N . sitcc $ + parensHash N $ sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs HsOpTy NoExtField x op y -> sitcc $ let opTree = OpBranch (tyOpTree x) op (tyOpTree y) in p_tyOpTree (reassociateOpTree Just opTree) HsParTy NoExtField t -> - parens N (located t p_hsType) + parens N $ sitcc $ located t p_hsType HsIParamTy NoExtField n t -> sitcc $ do located n atom space @@ -118,9 +118,9 @@ HsStarTy NoExtField _ -> txt "*" HsKindSig NoExtField t k -> sitcc $ do located t p_hsType - space -- FIXME - txt "::" space + txt "::" + breakpoint inci (located k p_hsType) HsSpliceTy NoExtField splice -> p_hsSplice splice HsDocTy NoExtField t str -> @@ -154,14 +154,14 @@ case (p, xs) of (IsPromoted, L _ t : _) | isPromoted t -> space _ -> return () - sitcc $ sep (comma >> breakpoint) (sitcc . located' p_hsType) xs + sep commaDel (sitcc . located' p_hsType) xs HsExplicitTupleTy NoExtField xs -> do txt "'" parens N $ do case xs of L _ t : _ | isPromoted t -> space _ -> return () - sep (comma >> breakpoint) (located' p_hsType) xs + sep commaDel (located' p_hsType) xs HsTyLit NoExtField t -> case t of HsStrTy (SourceText s) _ -> p_stringLit s @@ -192,15 +192,13 @@ p_hsContext = \case [] -> txt "()" [x] -> located x p_hsType - xs -> - parens N . sitcc $ - sep (comma >> breakpoint) (sitcc . located' p_hsType) xs + xs -> parens N $ sep commaDel (sitcc . located' p_hsType) xs p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R () p_hsTyVarBndr = \case UserTyVar NoExtField x -> p_rdrName x - KindedTyVar NoExtField l k -> parens N $ do + KindedTyVar NoExtField l k -> parens N . sitcc $ do located l atom space txt "::" @@ -224,15 +222,14 @@ p_conDeclFields :: [LConDeclField GhcPs] -> R () p_conDeclFields xs = - braces N . sitcc $ - sep (comma >> breakpoint) (sitcc . located' p_conDeclField) xs + braces N $ sep commaDel (sitcc . located' p_conDeclField) xs p_conDeclField :: ConDeclField GhcPs -> R () p_conDeclField ConDeclField {..} = do mapM_ (p_hsDocString Pipe True) cd_fld_doc sitcc $ sep - (comma >> breakpoint) + commaDel (located' (p_rdrName . rdrNameFieldOcc)) cd_fld_names space @@ -274,6 +271,6 @@ -- . This is fine as -- long as 'tyVarToType' does not get applied to right-hand sides of -- declarations. - HsParTy NoExtField $ noLoc $ + HsParTy NoExtField . noLoc $ HsKindSig NoExtField (noLoc (HsTyVar NoExtField NotPromoted tvar)) kind XTyVarBndr x -> noExtCon x diff --git a/src/Ormolu/Printer/Operators.hs b/src/Ormolu/Printer/Operators.hs --- a/src/Ormolu/Printer/Operators.hs +++ b/src/Ormolu/Printer/Operators.hs @@ -16,7 +16,7 @@ import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, mapMaybe) import GHC -import OccName (mkVarOcc) +import OccName (occNameString) import Ormolu.Utils (unSrcSpan) -- | Intermediate representation of operator trees. It has two type @@ -57,7 +57,7 @@ reassociateOpTreeWith :: forall ty op. -- | Fixity map for operators - Map RdrName Fixity -> + Map String Fixity -> -- | How to get the name of an operator (op -> Maybe RdrName) -> -- | Original 'OpTree' @@ -68,8 +68,8 @@ where fixityOf :: op -> Fixity fixityOf op = fromMaybe defaultFixity $ do - opName <- getOpName op - M.lookup opName fixityMap + s <- occNameString . rdrNameOcc <$> getOpName op + M.lookup s fixityMap -- Here, left branch is already associated and the root alongside with -- the right branch is right-associated. This function picks up one item -- from the right and inserts it correctly to the left. @@ -112,26 +112,26 @@ -- | Operator tree OpTree (Located ty) (Located op) -> -- | Fixity map - Map RdrName Fixity + Map String Fixity buildFixityMap getOpName opTree = addOverrides . M.fromList . concatMap (\(i, ns) -> map (\(n, _) -> (n, fixity i InfixL)) ns) - . zip [1 ..] + . zip [2 ..] . L.groupBy ((==) `on` snd) . selectScores $ score opTree where - addOverrides :: Map RdrName Fixity -> Map RdrName Fixity + addOverrides :: Map String Fixity -> Map String Fixity addOverrides m = - let mk k v = (mkRdrUnqual (mkVarOcc k), fixity v InfixL) - in M.fromList - [ mk "$" 0, - mk "." 9 - ] - `M.union` m + M.fromList + [ ("$", fixity 0 InfixR), + (":", fixity 1 InfixR), + (".", fixity 100 InfixL) + ] + `M.union` m fixity = Fixity NoSourceText - score :: OpTree (Located ty) (Located op) -> [(RdrName, Score)] + score :: OpTree (Located ty) (Located op) -> [(String, Score)] score (OpNode _) = [] score (OpBranch l o r) = fromMaybe (score r) $ do -- If we fail to get any of these, 'defaultFixity' will be used by @@ -141,13 +141,13 @@ oe <- srcSpanEndLine <$> unSrcSpan (getLoc o) -- operator end rb <- srcSpanStartLine <$> unSrcSpan (opTreeLoc r) -- right begin oc <- srcSpanStartCol <$> unSrcSpan (getLoc o) -- operator column - opName <- getOpName (unLoc o) + opName <- occNameString . rdrNameOcc <$> getOpName (unLoc o) let s | le < ob = AtBeginning oc | oe < rb = AtEnd | otherwise = InBetween return $ (opName, s) : score r - selectScores :: [(RdrName, Score)] -> [(RdrName, Score)] + selectScores :: [(String, Score)] -> [(String, Score)] selectScores = L.sortOn snd . mapMaybe diff --git a/src/Ormolu/Processing/Common.hs b/src/Ormolu/Processing/Common.hs --- a/src/Ormolu/Processing/Common.hs +++ b/src/Ormolu/Processing/Common.hs @@ -20,7 +20,7 @@ -- | Marker for the beginning of the region where Ormolu should be disabled. startDisabling :: IsString s => s -startDisabling = "{- ORMOLU_DISABLING_START" +startDisabling = "{- ORMOLU_DISABLE_START" -- | Marker for the end of the region where Ormolu should be disabled. endDisabling :: IsString s => s diff --git a/src/Ormolu/Processing/Postprocess.hs b/src/Ormolu/Processing/Postprocess.hs --- a/src/Ormolu/Processing/Postprocess.hs +++ b/src/Ormolu/Processing/Postprocess.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + -- | Postprocessing for the results of printing. module Ormolu.Processing.Postprocess ( postprocess, @@ -10,12 +13,19 @@ import qualified Ormolu.Processing.Cpp as Cpp -- | Postprocess output of the formatter. -postprocess :: Text -> Text -postprocess = +postprocess :: + -- | Desired indentation level + Int -> + -- | Input to process + Text -> + Text +postprocess indent = T.unlines + . fmap indentLine . fmap Cpp.unmaskLine . filter (not . magicComment) . T.lines where - magicComment x = + magicComment (T.stripStart -> x) = x == startDisabling || x == endDisabling + indentLine x = T.replicate indent " " <> x diff --git a/src/Ormolu/Processing/Preprocess.hs b/src/Ormolu/Processing/Preprocess.hs --- a/src/Ormolu/Processing/Preprocess.hs +++ b/src/Ormolu/Processing/Preprocess.hs @@ -11,8 +11,7 @@ import Control.Monad import Data.Char (isSpace) import qualified Data.List as L -import Data.Maybe (isJust) -import Data.Maybe (maybeToList) +import Data.Maybe (isJust, maybeToList) import FastString import Ormolu.Config (RegionDeltas (..)) import Ormolu.Parser.Shebang (isShebang) @@ -128,11 +127,11 @@ -- | Return 'True' if the given string is an enabling marker. isOrmoluEnable :: String -> Bool -isOrmoluEnable = magicComment "ORMOLU_ENABLE" +isOrmoluEnable s = magicComment "ORMOLU_ENABLE" s || magicComment "FOURMOLU_ENABLE" s -- | Return 'True' if the given string is a disabling marker. isOrmoluDisable :: String -> Bool -isOrmoluDisable = magicComment "ORMOLU_DISABLE" +isOrmoluDisable s = magicComment "ORMOLU_DISABLE" s || magicComment "FOURMOLU_DISABLE" s -- | Construct a function for whitespace-insensitive matching of string. magicComment :: @@ -143,7 +142,8 @@ -- | Whether or not the two strings watch Bool magicComment expected s0 = isJust $ do - s1 <- dropWhile isSpace <$> L.stripPrefix "{-" s0 - s2 <- dropWhile isSpace <$> L.stripPrefix expected s1 + let trim = dropWhile isSpace + s1 <- trim <$> L.stripPrefix "{-" (trim s0) + s2 <- trim <$> L.stripPrefix expected s1 s3 <- L.stripPrefix "-}" s2 guard (all isSpace s3) diff --git a/src/Ormolu/Utils.hs b/src/Ormolu/Utils.hs --- a/src/Ormolu/Utils.hs +++ b/src/Ormolu/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} -- | Random utilities used by the code. module Ormolu.Utils @@ -15,12 +16,15 @@ separatedByBlank, separatedByBlankNE, onTheSameLine, + removeIndentation, + groupBy', ) where +import Data.Char (isSpace) import Data.List (dropWhileEnd) -import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -68,8 +72,7 @@ _ -> r where r = - fmap escapeLeadingDollar - . dropPaddingSpace + fmap (escapeLeadingDollar . escapeCommentBraces) . dropWhileEnd T.null . fmap (T.stripEnd . T.pack) . lines @@ -81,20 +84,7 @@ case T.uncons txt of Just ('$', _) -> T.cons '\\' txt _ -> txt - dropPaddingSpace xs = - case dropWhile T.null xs of - [] -> [] - (x : _) -> - let leadingSpace txt = case T.uncons txt of - Just (' ', _) -> True - _ -> False - dropSpace txt = - if leadingSpace txt - then T.drop 1 txt - else txt - in if leadingSpace x - then dropSpace <$> xs - else xs + escapeCommentBraces = T.replace "{-" "{\\-" . T.replace "-}" "-\\}" -- | Get 'LHsType' out of 'LHsTypeArg'. typeArgToType :: LHsTypeArg p -> LHsType p @@ -139,3 +129,24 @@ onTheSameLine :: SrcSpan -> SrcSpan -> Bool onTheSameLine a b = isOneLineSpan (mkSrcSpan (srcSpanEnd a) (srcSpanStart b)) + +-- | Remove indentation from a given 'String'. Return the input with +-- indentation removed and the detected indentation level. +removeIndentation :: String -> (String, Int) +removeIndentation (lines -> xs) = (unlines (drop n <$> xs), n) + where + n = minimum (getIndent <$> xs) + getIndent y = + if all isSpace y + then 0 + else length (takeWhile isSpace y) + +-- | A generalisation of 'groupBy' to functions which aren't equivalences - a group ends +-- when comparison fails with the previous element, rather than the first of the group. +groupBy' :: (a -> a -> Bool) -> [a] -> [NonEmpty a] +groupBy' eq = flip foldr [] $ \x -> \case + [] -> [pure x] + (y :| ys) : zs -> + if x `eq` y + then (x :| y : ys) : zs + else pure x : (y :| ys) : zs diff --git a/tests/Ormolu/PrinterSpec.hs b/tests/Ormolu/PrinterSpec.hs --- a/tests/Ormolu/PrinterSpec.hs +++ b/tests/Ormolu/PrinterSpec.hs @@ -10,6 +10,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Ormolu +import Ormolu.Config import Path import Path.IO import qualified System.FilePath as F @@ -18,14 +19,24 @@ spec :: Spec spec = do es <- runIO locateExamples - forM_ es checkExample + let ormoluOpts = + PrinterOpts + { poIndentation = pure 2, + poCommaStyle = pure Trailing, + poIndentWheres = pure True, + poRecordBraceSpace = pure True, + poDiffFriendlyImportExport = pure False, + poRespectful = pure False, + poHaddockStyle = pure HaddockSingleLine + } + sequence_ $ uncurry checkExample <$> [(ormoluOpts, ""), (defaultPrinterOpts, "-four")] <*> es -- | Check a single given example. -checkExample :: Path Rel File -> Spec -checkExample srcPath' = it (fromRelFile srcPath' ++ " works") . withNiceExceptions $ do +checkExample :: PrinterOptsTotal -> String -> Path Rel File -> Spec +checkExample po suffix srcPath' = it (fromRelFile srcPath' ++ " works") . withNiceExceptions $ do let srcPath = examplesDir srcPath' - cfg = defaultConfig {cfgPrinterOpts = PrinterOpts {poIndentStep = 2}} - expectedOutputPath <- deriveOutput srcPath + cfg = defaultConfig {cfgPrinterOpts = po} + expectedOutputPath <- deriveOutput suffix srcPath -- 1. Given input snippet of source code parse it and pretty print it. -- 2. Parse the result of pretty-printing again and make sure that AST -- is the same as AST of the original snippet. (This happens in @@ -55,10 +66,10 @@ in exts == ".hs" && not ("-out" `isSuffixOf` s') -- | For given path of input file return expected name of output. -deriveOutput :: Path Rel File -> IO (Path Rel File) -deriveOutput path = +deriveOutput :: String -> Path Rel File -> IO (Path Rel File) +deriveOutput suffix path = parseRelFile $ - F.addExtension (F.dropExtensions (fromRelFile path) ++ "-out") "hs" + F.addExtension (F.dropExtensions (fromRelFile path) ++ suffix ++ "-out") "hs" -- | A version of 'shouldBe' that is specialized to comparing 'Text' values. -- It also prints multi-line snippets in a more readable form.