packages feed

brittany (empty) → 0.8.0.2

raw patch · 43 files changed

+11248/−0 lines, 43 filesdep +aesondep +basedep +brittanysetup-changed

Dependencies added: aeson, base, brittany, butcher, bytestring, cmdargs, containers, czipwith, data-tree-print, deepseq, directory, either, extra, filepath, ghc, ghc-boot-th, ghc-exactprint, ghc-paths, hspec, monad-memo, mtl, multistate, neat-interpolation, parsec, pretty, safe, semigroups, strict, syb, text, transformers, uniplate, unsafe, yaml

Files

+ ChangeLog.md view
@@ -0,0 +1,78 @@+# Revision history for brittany++## 0.8.0.2  -- August 2017++* Add library interface, to be used by `haskell-ide-engine`.+* Publish to hackage.++## 0.8.0.1  -- May 2017++* Document the high-level design of the program+* Improve layouting for many different cases, too many to list here. Brittany+  still does only reformat top-level type signatures and bindings.+* Publish all dependencies on hackage; `ghc-exactprint ` adaptions got merged+  upstream as well.+* Reduce the aggressiveness of horizontal alignment; this is configurable+  via the `lconfig_alignmentLimit` and `lconfig_alignmentBreakOnMultiline`+  values (config file only for now).+* (!) Breaking change to the config file format: The keys previously contained+  underscore (e.g. `_econf_Werror`) but do not anymore (`econf_Werror`).+  Add config version; also+* Move config value `conf_errorHandling.econf_CPPMode` to+  `conf_preprocessor.ppconf_CPPMode`.+* Cope with unhandled syntactical constructs more gracefully by falling back+  on the ghc-exactprint output; Brittany simply won't touch certain+  subexpressions instead of aborting. This is further configurable via the+  `econf_omit_output_valid_check` config value.+* Due to improvements to the `butcher` library: Accept `--key=value` on+  commandline (only `--key value` was supported previously).+* Improve testsuite setup: The `tests.blt` file contains many different+  testcases that allow quick addition - feel free to report bugs directly+  by making PRs with additions to that file.+* Release under the terms of the AGPLv3++## 0.7.1.0  -- 2016-09-06++* Support stack+* Fix --ghc-options handling+* Add commandline param to allow shortcut `brittany Foo.hs`+  meaning `brittany -i Foo.hs`++## 0.7.0.0  -- 2016-09-04++* First official alpha release+* Fix commandline flag parsing+* Implement/Improve horizontal aligning+* Various minor fixes and layouting improvements++## 0.6.0.0  -- 2016-08-12++* Add check that output is syntactically valid+* (!) Change config format, breaking previous configs+* Various layouting additions/imporements+* Various minor fixes++## 0.5.0.0  -- 2016-08-08++* Support --ghc-options+* Support user and local config files: Local config file is not mandatory+  anymore.++## 0.4.0.0  -- 2016-08-06++* Make comment handling a bit more clever+* Various layouting additions/imporements++## 0.3.0.0  -- 2016-08-04++* Various layouting additions/imporements++## 0.2.0.0  -- 2016-07-30++* Basic and partial implementation for+  expression/decl/statement/pattern layouting+* Prevent exponential behaviour using manual stablenames++## 0.1.0.0  -- 2016-06-05++* First working code for type signature layouting
+ LICENSE view
@@ -0,0 +1,661 @@+                    GNU AFFERO GENERAL PUBLIC LICENSE+                       Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU Affero General Public License is a free, copyleft license for+software and other kinds of works, specifically designed to ensure+cooperation with the community in the case of network server software.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+our General Public Licenses are intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  Developers that use our General Public Licenses protect your rights+with two steps: (1) assert copyright on the software, and (2) offer+you this License which gives you legal permission to copy, distribute+and/or modify the software.++  A secondary benefit of defending all users' freedom is that+improvements made in alternate versions of the program, if they+receive widespread use, become available for other developers to+incorporate.  Many developers of free software are heartened and+encouraged by the resulting cooperation.  However, in the case of+software used on network servers, this result may fail to come about.+The GNU General Public License permits making a modified version and+letting the public access it on a server without ever releasing its+source code to the public.++  The GNU Affero General Public License is designed specifically to+ensure that, in such cases, the modified source code becomes available+to the community.  It requires the operator of a network server to+provide the source code of the modified version running there to the+users of that server.  Therefore, public use of a modified version, on+a publicly accessible server, gives the public access to the source+code of the modified version.++  An older license, called the Affero General Public License and+published by Affero, was designed to accomplish similar goals.  This is+a different license, not a version of the Affero GPL, but Affero has+released a new version of the Affero GPL which permits relicensing under+this license.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU Affero General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Remote Network Interaction; Use with the GNU General Public License.++  Notwithstanding any other provision of this License, if you modify the+Program, your modified version must prominently offer all users+interacting with it remotely through a computer network (if your version+supports such interaction) an opportunity to receive the Corresponding+Source of your version by providing access to the Corresponding Source+from a network server at no charge, through some standard or customary+means of facilitating copying of software.  This Corresponding Source+shall include the Corresponding Source for any work covered by version 3+of the GNU General Public License that is incorporated pursuant to the+following paragraph.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the work with which it is combined will remain governed by version+3 of the GNU General Public License.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU Affero General Public License from time to time.  Such new versions+will be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU Affero General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU Affero General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU Affero General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU Affero General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU Affero General Public License for more details.++    You should have received a copy of the GNU Affero General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If your software can interact with users remotely through a computer+network, you should also make sure that it provides a way for users to+get its source.  For example, if your program is a web application, its+interface could display a "Source" link that leads users to an archive+of the code.  There are many ways you could offer source, and different+solutions will be better for different programs; see section 13 for the+specific requirements.++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU AGPL, see+<http://www.gnu.org/licenses/>.
+ README.md view
@@ -0,0 +1,131 @@+# brittany+haskell source code formatter++![Output sample](https://github.com/lspitzner/brittany/raw/master/brittany-sample.gif)++(see [more examples and comparisons](/doc/showcases))++This project's goals roughly are to:++- Always retain the semantics of the source being transformed;+- Be idempotent (this also directly ensures that only valid haskell is+  produced);+- Support the full GHC-haskell syntax including syntactic extensions+  (but excluding `-XCPP` which is too hard);+- Retain newlines and comments unmodified;+- Be clever about using the available horizontal space while not overflowing+  it if it cannot be avoided;+- Be clever about aligning things horizontally (this can be turned off+  completely however);+- Have linear complexity in the size of the input.++In theory, the core algorithm inside brittany reaches these goals. It is rather+clever about making use of horizontal space while still being linear in the+size of the input (although the constant factor is not small). See+[these examples of clever layouting](/doc/showcases/Layout_Interactions.md).++But brittany is not finished yet, and there are some open issues that yet+require fixing:++- **only type-signatures and function/value bindings** are processed;+  other module elements (data-decls, classes, instances, imports/exports etc.)+  are not transformed in any way; this extends to e.g. **bindings inside class+  instance definitions** - they **won't be touched** (yet).+- By using `ghc-exactprint` as the parser, brittany supports full GHC +  including extensions, but **some of the less common syntactic elements+  (even of 2010 haskell) are not handled**.+- **There are some known issues regarding handling of in-source comments.**+  There are cases where comments are not copied to the output (this will+  be detected and the user will get an error); there are other cases where+  comments are moved slightly; there are also cases where comments result in+  wonky newline insertion (although this should be a purely aesthetic issue.)+- There is an **open performance issue on large inputs** (due to an+  accidentally quadratic sub-algorithm); noticable for inputs with >1k loc.++# Other usage notes++- Requires `GHC-8.0.*`; support for 8.2 is on the list, but I haven't even+  looked at how much the `GHC` API changes.+- config (file) documentation is lacking.+- some config values can not be configured via commandline yet.+- uses/creates user config file in `~/.brittany/config.yaml`;+  also reads `brittany.yaml` in current dir if present.++# Installation++- via `cabal` "old-build"++  ~~~~.sh+  # optionally:+  # mkdir brittany+  # cd brittany+  # cabal sandbox init+  cabal install brittany --bindir=$HOME/.cabal/bin # -w $PATH_TO_GHC_8_0+  ~~~~++- via `cabal new-build`++  ~~~~.sh+  cabal unpack brittany+  cd brittany-0.8.0.2+  # cabal new-configure -w $PATH_TO_GHC_8_0+  cabal new-build exe:brittany+  # and it should be safe to just copy the executable, e.g.+  cp `./find dist-newstyle/build/ -type f -name brittany` $HOME/.cabal/bin/+  ~~~~++- via `stack`++  ~~~~.sh+  git clone https://github.com/lspitzner/brittany.git+  cd brittany+  stack install+  ~~~~+++# Usage++- Currently one mode of operation: Transform a single module. By default read+  from `stdin` and written to `stdout`, but commandline arguments allow to+  read/write from/to files.+- For stdin/stdout usage it makes sense to enable certain syntactic extensions+  by default, i.e. to add something like this to your+  `~/.brittany/config.yaml` (execute `brittany` once to create default):++  ~~~~+  conf_forward:+    options_ghc:+    - -XLambdaCase+    - -XMultiWayIf+    - -XGADTs+    - -XPatternGuards+    - -XViewPatterns+    - -XRecursiveDo+    - -XTupleSections+    - -XExplicitForAll+    - -XImplicitParams+    - -XQuasiQuotes+    - -XTemplateHaskell+    - -XBangPatterns+  ~~~~++# Implementation/High-level Documentation++[See the documentation index](doc/implementation/index.md)++# License++Copyright (C) 2016-2017 Lennart Spitzner++This program is free software: you can redistribute it and/or modify+it under the terms of the+[GNU Affero General Public License, version 3](http://www.gnu.org/licenses/agpl-3.0.html),+as published by the Free Software Foundation.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+GNU Affero General Public License for more details.++You should have received a copy of the GNU Affero General Public License+along with this program.  If not, see <http://www.gnu.org/licenses/>.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ brittany.cabal view
@@ -0,0 +1,402 @@+name:                 brittany+version:              0.8.0.2+synopsis:             Haskell source code formatter+description: {+  See <https://github.com/lspitzner/brittany/blob/master/README.md the README>++  If you are interested in the implementation, have a look at <https://github.com/lspitzner/brittany/blob/master/doc/implementation/theory.md this document>;++  The implementation is documented in more detail <https://github.com/lspitzner/brittany/blob/master/doc/implementation/index.md here>.+}+license:              AGPL-3+license-file:         LICENSE+author:               Lennart Spitzner+maintainer:           Lennart Spitzner <hexagoxel@hexagoxel.de>+copyright:            Copyright (C) 2016-2017 Lennart Spitzner+category:             Language+build-type:           Simple+cabal-version:        >=1.18+homepage:             https://github.com/lspitzner/brittany/+bug-reports:          https://github.com/lspitzner/brittany/issues+extra-doc-files: {+  ChangeLog.md+  README.md+  doc/implementation/*.md+}++source-repository head {+  type: git+  location: https://github.com/lspitzner/brittany.git+}++flag brittany-dev+  description: dev options+  default: False+  manual: True++flag brittany-dev-lib+  description: set buildable false for anything but lib+  default: False+  manual: True++library {+  default-language:+    Haskell2010+  hs-source-dirs:+    src+  install-includes: {+    srcinc/prelude.inc+  }+  exposed-modules: {+    Language.Haskell.Brittany+    Language.Haskell.Brittany.Internal+    Language.Haskell.Brittany.Internal.Prelude+    Language.Haskell.Brittany.Internal.Types+    Language.Haskell.Brittany.Internal.Utils+    Language.Haskell.Brittany.Internal.Config+    Language.Haskell.Brittany.Internal.Config.Types+    Paths_brittany+  }+  other-modules: {+    Language.Haskell.Brittany.Internal.LayouterBasics+    Language.Haskell.Brittany.Internal.Backend+    Language.Haskell.Brittany.Internal.BackendUtils+    Language.Haskell.Brittany.Internal.ExactPrintUtils+    Language.Haskell.Brittany.Internal.Layouters.Type+    Language.Haskell.Brittany.Internal.Layouters.Decl+    Language.Haskell.Brittany.Internal.Layouters.Expr+    Language.Haskell.Brittany.Internal.Layouters.Stmt+    Language.Haskell.Brittany.Internal.Layouters.Pattern+    Language.Haskell.Brittany.Internal.Transformations.Alt+    Language.Haskell.Brittany.Internal.Transformations.Floating+    Language.Haskell.Brittany.Internal.Transformations.Par+    Language.Haskell.Brittany.Internal.Transformations.Columns+    Language.Haskell.Brittany.Internal.Transformations.Indent+  }+  ghc-options: {+    -Wall+    -j+    -fno-warn-unused-imports+    -fno-warn-orphans+    -fno-warn-redundant-constraints+  }+  if flag(brittany-dev) {+    ghc-options: -O0 -Werror -fobject-code+  }+  build-depends:+    { base >=4.9 && <4.10+    , ghc >=8.0.1 && <8.1+    , ghc-paths >=0.1.0.9 && <0.2+    , ghc-exactprint >=0.5.3.0 && <0.6+    , transformers >=0.5.2.0 && <0.6+    , containers >=0.5.7.1 && <0.6+    , mtl >=2.2.1 && <2.3+    , text >=1.2 && <1.3+    , multistate >=0.7.1.1 && <0.8+    , syb >=0.6 && <0.7+    , neat-interpolation >=0.3.2 && <0.4+    , data-tree-print+    , pretty >=1.1.3.3 && <1.2+    , bytestring >=0.10.8.1 && <0.11+    , directory >=1.2.6.2 && <1.4+    , butcher >=1.1.0.0 && <1.2+    , yaml >=0.8.18 && <0.9+    , aeson >=1.0.1.0 && <1.3+    , extra >=1.4.10 && <1.6+    , uniplate >=1.6.12 && <1.7+    , strict >=0.3.2 && <0.4+    , monad-memo >=0.4.1 && <0.5+    , unsafe >=0.0 && <0.1+    , safe >=0.3.9 && <0.4+    , deepseq >=1.4.2.0 && <1.5+    , either >=4.4.1.1 && <4.5+    , semigroups >=0.18.2 && <0.19+    , cmdargs >=0.10.14 && <0.11+    , czipwith >=1.0.0.0 && <1.1+    , ghc-boot-th >=8.0.1 && <8.1+    }+  default-extensions: {+    CPP++    NoImplicitPrelude++    GADTs++    FlexibleContexts+    FlexibleInstances+    ScopedTypeVariables+    MonadComprehensions+    LambdaCase+    MultiWayIf+    KindSignatures+  }+  include-dirs:+    srcinc+}++executable brittany+  if flag(brittany-dev-lib) {+    buildable: False+  } else {+    buildable: True+  }+  main-is:             Main.hs+  other-modules: {+    Paths_brittany+  }+  -- other-extensions:    +  build-depends:+    { brittany+    , base+    , ghc+    , ghc-paths+    , ghc-exactprint+    , transformers+    , containers+    , mtl+    , text+    , multistate+    , syb+    , neat-interpolation+    , data-tree-print+    , pretty+    , bytestring+    , directory+    , butcher+    , yaml+    , aeson+    , extra+    , uniplate+    , strict+    , monad-memo+    , unsafe+    , safe+    , deepseq+    , either+    , semigroups+    , cmdargs+    , czipwith+    , ghc-boot-th+    , hspec >=2.4.1 && <2.5+    , filepath >=1.4.1.0 && <1.5+    }+  hs-source-dirs:      src-brittany+  default-language:    Haskell2010+  default-extensions: {+    CPP++    NoImplicitPrelude++    GADTs++    FlexibleContexts+    FlexibleInstances+    ScopedTypeVariables+    MonadComprehensions+    LambdaCase+    MultiWayIf+    KindSignatures+  }+  ghc-options: {+    -Wall+    -j+    -fno-spec-constr+    -fno-warn-unused-imports+    -fno-warn-orphans+    -fno-warn-redundant-constraints+    -rtsopts+    -with-rtsopts "-M2G"+  }+  if flag(brittany-dev) {+    ghc-options:+      -O0+      -Werror+      -fobject-code+      -fprof-auto+      -fprof-cafs+  }++test-suite unittests+  if flag(brittany-dev-lib) {+    buildable: False+  } else {+    buildable: True+  }+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  build-depends:+    { brittany+    , base+    , ghc+    , ghc-paths+    , ghc-exactprint+    , transformers+    , containers+    , mtl+    , text+    , multistate+    , syb+    , neat-interpolation+    , data-tree-print+    , pretty+    , bytestring+    , directory+    , butcher+    , yaml+    , aeson+    , extra+    , uniplate+    , strict+    , monad-memo+    , unsafe+    , safe+    , deepseq+    , either+    , semigroups+    , cmdargs+    , czipwith+    , ghc-boot-th+    , hspec >=2.4.1 && <2.5+    }+  ghc-options:      -Wall+  main-is:          TestMain.hs+  other-modules:    TestUtils+                    AsymptoticPerfTests+  hs-source-dirs:   src-unittests+  default-extensions: {+    CPP++    NoImplicitPrelude++    GADTs++    FlexibleContexts+    FlexibleInstances+    ScopedTypeVariables+    MonadComprehensions+    LambdaCase+    MultiWayIf+    KindSignatures+  }+  ghc-options: {+    -Wall+    -j+    -fno-warn-unused-imports+    -fno-warn-orphans+    -rtsopts+    -with-rtsopts "-M2G"+  }+  if flag(brittany-dev) {+    ghc-options: -O0 -Werror -fobject-code+  }++test-suite littests+  if flag(brittany-dev-lib) {+    buildable: False+  } else {+    buildable: True+  }+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  build-depends:+    { brittany+    , base+    , ghc+    , ghc-paths+    , ghc-exactprint+    , transformers+    , containers+    , mtl+    , text+    , multistate+    , syb+    , neat-interpolation+    , data-tree-print+    , pretty+    , bytestring+    , directory+    , butcher+    , yaml+    , aeson+    , extra+    , uniplate+    , strict+    , monad-memo+    , unsafe+    , safe+    , deepseq+    , either+    , semigroups+    , cmdargs+    , czipwith+    , ghc-boot-th+    , hspec >=2.4.1 && <2.5+    , parsec >=3.1.11 && <3.2+    }+  ghc-options:      -Wall+  main-is:          Main.hs+  other-modules:    +  hs-source-dirs:   src-literatetests+  default-extensions: {+    CPP++    NoImplicitPrelude++    GADTs++    FlexibleContexts+    FlexibleInstances+    ScopedTypeVariables+    MonadComprehensions+    LambdaCase+    MultiWayIf+    KindSignatures+  }+  ghc-options: {+    -Wall+    -j+    -fno-warn-unused-imports+    -fno-warn-orphans+    -rtsopts+    -with-rtsopts "-M2G"+  }+  if flag(brittany-dev) {+    ghc-options: -O0 -Werror -fobject-code+  }++test-suite libinterfacetests+  if flag(brittany-dev-lib) {+    buildable: False+  } else {+    buildable: True+  }+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  build-depends:+    { brittany+    , base+    , text+    , transformers+    , hspec >=2.4.1 && <2.5+    }+  ghc-options:      -Wall+  main-is:          Main.hs+  other-modules:    +  hs-source-dirs:   src-libinterfacetests+  default-extensions: {+    FlexibleContexts+    FlexibleInstances+    ScopedTypeVariables+    MonadComprehensions+    LambdaCase+    MultiWayIf+    KindSignatures+  }+  ghc-options: {+    -Wall+    -j+    -fno-warn-unused-imports+    -fno-warn-orphans+    -rtsopts+    -with-rtsopts "-M2G"+  }
+ doc/implementation/bridoc-api.md view
@@ -0,0 +1,423 @@+# BriDoc nodes/Smart constructors and their semantics++At this point, you should have a rough idea of what the involved+types mean. This leaves us to explain the different `BriDoc`+(smart) constructors and their exact semantics.++### Special nodes++- docDebug/BDDebug++  Like the `trace` statement of the `BriDoc` type. It does not affect the+  normal output, but prints stuff to stderr when the transformation traverses+  this node.++- BDExternal is used for original-source reproduction.++### Basic nodes++- docEmpty/BDEmpty Text++  ""++  The empty document. Has empty output. Should never affect layouting.++- docLit/BDLit++  "a" "Maybe" "("++  The most basic building block - a simple string. Has nothing to do with+  literals in the parsing sense. Will always be produces as-is in the output.+  It must be free of newline characters and should normally be free of any+  spaces (because those would never be considered for line-breaking - but there+  are cases where this makes sense still).++- docSeq/BDSeq [BriDoc]+  +  "func foo = 13"++  A in-line/horizontal sequence of sub-docs. The sub-documents should not+  contain any newlines, but there is an exception: The last element of the+  sequence may be multi-line. In combination with `docSetBaseY` this allows+  for example:++  ~~~~.hs+  foo | bar = 1+      | baz = 2+  ~~~~++  which is represented roughly like++  ~~~~+  docSeq+    "foo"+    space+    docSetBaseY+      docLines+        stuff that results in "| bar = 1"+        stuff that results in "| baz = 2"+  ~~~~++  But in general it should be preferred to use `docPar` to handle multi-line+  sub-nodes, where possible.++- docAlt/BDAlt [BriDoc]++  Specify multiple alternative layouts. Take care to appropriately maintain+  sharing for the documents representing the children of the current node.++  See the "Controlling layouting" section below.++- docAltFilter++  simple utility wrapper around `docAlt`: Each alternative is accompanied by+  a boolean; if False the alternative is discarded.++- docPar `:: m BriDocNumbered -> m BriDocNumbered -> m BriDocMumbered`++  (does not completely match `BDPar`, which has an extra argument.)+  +  Describes a "paragraph" - a layout consisting of some headline (which may+  contain newlines, although it rarely does) and content+  (that may contain newlines). Simple example is a `do`-block:++  ~~~~.hs+  do -- headline+    stmt -- content+    stmt -- content+    stmt -- content+  ~~~~++  But let us first consider the simplest case:+  `docPar (docLit "foo") (docLit "bar")`+  placed at the start of the line; it will be layouted like this:++  ~~~~.hs+  foo+  bar+  ~~~~++  As you can see, the content is not indented by default. In this form,+  `docPar a b` behaves like `docLines [a,b]`, and `docPar a (docLines bs)` like+  `docLines (a:bs)`. What makes `docPar` special is that it allows differing+  indentation of headline and content, where the lines of `docLines` are+  supposed to have the same indentation.++  This allows two common uses of `docPar`:++  1. The pattern `docAddBaseY BrIndentRegular $ docPar _ _`. Here `docAddBaseY`+     does not affect+     the current line (i.e. the headline of `docPar`) but it _does_ indent the+     content.++  2. At the end of a sequence; the following is valid and common:+     `docSeq [elem1, elem2, docPar elem3 content]` which looks like+     ~~~~.hs+     elem1 elem2 elem3+     content+     ~~~~++     So the headline does not need occur at the start of the line.++   This interaction between `docSeq`, `docAddBaseY`, and `docPar` allows us to+   add indentation to the content of a childnode without even knowing if that+   childnode will actually make use of `docPar`. We can simply use+   `docAddBaseY BrIndentRegular $ docSeq [foo, bar, childNodeDoc]` and get+   sensible layout including indentation of the _potential_ content-part of the+   child node. Such a behaviour would not be possible without this interaction+   unless we resorted to analysing the doc created for the childnode - which+   would lead to complex special-casing.++    ~~~~.hs+    foo bar child-oneline+    -- or+    foo bar child-headline+      child-content+    ~~~~++   This pattern does however requires that we keep this interaction in mind+   when writing the layouting of such parent/childnode relationships. For+   example using `docLines` in the child node instead of `docPar` would+   probably lead to bad results if the parent used `docAddBaseY`.++- docLines/BDLines++  Where `docSeq` is horizontal sequence, `docLines` is the vertical sequence+  operator. `docLines` has one important requirement: All lines must have the+  same indentation. Violating this will lead to undefined layouting behaviour.++  As a consequence, there are two valid usage patterns:++  1. `docLines` is used at the start of a line, e.g. as the content of a+     `docPar`.++  2. The `docSetBaseY $ docLines _` or+     `docSetBaseAndIndent $ docNonBottomSpacing $ docLines _` patterns allow+     using `docLines` as a final element of a sequence; the `docSetBase~`+     constructs ensure that the rest-lines are indented as much as the+     headline. An example is:+  +      ~~~~.hs+      foo | bar = 1+          | baz = 2+      ~~~~++     where "| bar = 1" and "| bar = 2" are two lines of a docLines.++- docSeparator/BDSeparator++  Adds a space, unless it is the last element in a line. Also merges with+  other separators and has no effect if inserted right after inserting space+  (e.g. in the start of a line when indented) or if already indented due to+  horizontal alignment.++  Note also this helper:++  ~~~~.hs+  appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+  appSep x = docSeq [x, docSeparator]+  ~~~~+++### Creating horizontal alignment++- docCols/BDCols ColSig [BriDoc]+  +  This works like docSeq, but adds horizontal alignment if possible. The+  implementation involves a lot of special-case trickeries and I assume that+  it is impossible to specify the exact semantics. But the rough idea is:+  If++  1. horizontal alignment is not turned off via global config+  2. there are consecutive lines (created e.g. by docLines or docPar) and+  3. both lines consist of docCols (where "consist" can ignore certain shallow+     wrappers like `docAddBaseY`) and+  4. the two ColSigs are equal and+  5. the two docCols contain an equal number of children and+  6. there is enough horizontal space to insert the additional spaces++  then the contained docs will be aligned horizontally.++  And further, if there are multiple lines so that consecutive pairs fulfill+  these requirements, the whole block will be aligned to the same horizontal+  tabs.++  And further, if a docCols contains another docCols, and the docCols in the+  next line also does, and the child docCols also match in ColSigs and have+  the same number of arguments and so on, then the children's children are+  also aligned horizontally.++  And of course this nesting also works over blocks built of matching+  consecutive pairs.++  Wait, was this not supposed to be broadly simplifying? Well.. it is. uhm.+  Let us just.. example.. an example seems fine.++  Considering the following declaration/formatting:++  ~~~~.hs+  func (MyLongFoo abc def) = 1+  func (Bar       a   d  ) = 2+  func _                   = 3+  ~~~~++  Note how the "=" are aligned over all three lines, and the patterns in the+  first two lines are as well, but the pattern in the third line is just a+  structureless underscore?++  The representation behind that source is something in the direction of this+  (heavily simplified and not exact at all; e.g. spaces are not represented at+  all):++  ~~~~+  docLines+    docCols equationSigToken+      "func"+      docCols patternSigToken+        "("+        "MyLongFoo"+        "abc"+        "def"+        ")"+      docSeq+        "="+        "1"+    docCols equation+      "func"+      docCols patternSigToken+        "("+        "Bar"+        "a"+        "d"+        ")"+      docSeq+        "="+        "2"+    docCols equation+      "func"+      "_"+      docSeq+        "="+        "3"+  ~~~~++### Controlling indentation level++Firstly, we keep track of two slightly different notions of indentation,+indicated by the terms "Base" and "Indent".++The latter is used for indentation+levels that affect parsing (i.e. for those instances where haskell is+layout-sensitive). Consequently "Indent" is changed exactly in those cases+where the "off-side rule" applies (see the "Layout" chapter in the haskell+2010 report). This indentation level is important for comments, as comments+in ghc-exactprint have positions relative to the this "Indent".++"Base" on the other hand refers to all other indentation happening.++- docAddBaseY/BDAddBaseY++  Does not affect the current line, but anything after a newline (e.g. when+  the child is a docPar).++  Stacking more than one of these will combine the two indentation-amounts+  using maximum, not addition.++- docSetBaseY++  Sets the "Base" to the current "cursor position", i.e. with the+  `docSetBaseY (docLines ..)` pattern the lines will line up to the left.++- docSetIndentLevel++  Similar to docSetBaseY, but for "Indent".++- docSetBaseAndIndent++  Literally `docSetBaseY . docSetIndentLevel`.++- docEnsureIndent (this really should be named docAddEnsureBaseAndIndent unless+  I forgot some detail.)++  This _adds_ to both Base and Indent, and immediately applies this as well.+  This is in contrast to the other operations that only have an effect after+  the first newline occuring in the child node.+  If the cursor is currently left of the new indentation level, spaces will be+  inserted, and new lines will be indented (at least) as far, too.+++### Controlling layouting++The purpose of these nodes/modifiers is affecting the choices of alternatives+(see `docAlt`) made. For example in a bridoc tree like++~~~~+docAlt+  docForceSingleLine+    [stuff]+  [otherOption]+~~~~++if stuff only returns layouts that use multiple lines, then this alternative+will not be considered, and this will be effectively simplified to just+`[otherOption]`.++- docNonBottomSpacing++  Enforces that this node is _not_ discarded even when all considered layouts+  use more space than available. This counteracts the fact that we consider+  a limited amount of layouts in order to retain linear runtime. Bad usage+  of this modifier will lead to unnecessary overflow over the max-columns (80+  by default) even when other layoutings were available.++  [TODO: consideration of valid usecases]++- docSetParSpacing and docForceParSpacing++  We say a node has "ParSpacing" if it looks like a `docPar` result.. it has+  a headline and (indented) content in new lines. This property can propagate+  somewhat non-trivially upwards and is used by certain parents. It mainly+  provides nice layouting choices in cases such as:++  ~~~~.hs+  foo = abc $ def $ do+    stmt+    stmt+  ~~~~++  Consider what we know when translating the equation: We have two+  possibilites:++  ~~~~.hs+  foo = child-node-doc -- note that child may contain a docPar.+  -- or+  foo =+    child-node-doc+  ~~~~++  As usual, we do not to inspect child-node-doc; this makes deciding between+  the two choices hard. Looking at is-single/multi-line is not sufficient.++  Instead we define a new property (I'll call it "has_par_spacing" here) that+  propagates appropriately upwards:++  ~~~~.prolog+  has_par_spacing(setParSpacing(_)).+  has_par_spacing(docSeq[_, .., x]) :- has_par_spacing(x).+  has_par_spacing(docCols[_, .., x]) :- has_par_spacing(x).+  has_par_spacing(docNonBottomSpacing(x)) :- has_par_spacing(x).+  has_par_spacing(docAddBaseY(x)) :- has_par_spacing(x).+  ~~~~++  and so on for other simple unary wrappers. (i hope my sloppy prolog is not+  too confusing.)++- docForceSingleline++  Discards child layouts that contain newlines.++- docForceMultiline++  Discards child layouts lacking newlines.++### Inserting comments / Controlling comment placement++For many cases it is sufficient to use the following construct to insert+comments into the output:++- docWrapNode++  Inserts all comments associated above this node above the node, and all+  other comments below. Works on simple nodes, but also on lists and Seqs of+  nodes.++ghc-exactprint does not associate all comments to the exactly preceding node+and instead tries to associate to the "logically connected" node. This+behaviour is desirable when considering automatic refactoring, think of moving+a function and the comment above the function along with it. But not even this+is sufficient - there exist comments that need to be inserted in the middle of+a syntactical construct, for example consider the pattern+`Foo{{- we don't care about fields! -}}`. Here, the comment is placed between+keywords (or "keysymbols" or whatever) that do not have separate nodes in+the syntax tree. ghc-exactprint captures such comment in some way that allows+inserting them back properly.++The logic used here is determined by the ghc-exactprint design. The core type+is [the Annotation type](https://hackage.haskell.org/package/ghc-exactprint-0.5.3.0/docs/Language-Haskell-GHC-ExactPrint-Types.html#t:Annotation)++- docAnnotationPrior+- docAnnotationKW+- docAnnotationRest++To match this, there are special comment-insertion nodes in the BriDoc type+that allow for fine-grained control of where specific comments are inserted.+"Prior" refers to the same `annPriorComments` annotation field. "KW" refers to+the `annsDP` field. "Rest" refers to all remaining (i.e. not-yet-inserted;+brittany keeps track of which have already been processed) comments, including+the `annFollowingComments` field.++### Deprecated++- BDForwardLineMode is unused and apparently should be deprecated.+- BDProhibitMTEL is deprecated+
+ doc/implementation/bridoc-design.md view
@@ -0,0 +1,274 @@+# The BriDoc type and the to-BriDoc transformation++The `BriDoc` type is the brittany equivalent of the `Doc` type from+general-purpose formatting libraries such as the `pretty` package.+It is specialized for this usecase: Representing a formatted+haskell source code document. As a consequence, it is a good amount+more complex than the `Doc` type (which has 8, not directly exposed,+constructors): The `BriDoc` type has ~25 constructors.+(26, but one for debugging, two deprecated and so on.)+Examples are `BDEmpty`, `BDSeq [BriDoc]` (inline sequence),+and `BDAddBaseY BrIndent BriDoc` (add a certain type of indentation+to the inner doc).++The main bulk of code that makes brittany work is the translation+of different syntactical constructs into a raw `BriDoc` value.+(technically a `BriDocF` value, we'll explain soon.)++The input of this translation is the syntax tree produced by+GHC/ExactPrint. The GHC API exposes the syntax tree nodes, and+ExactPrint adds certain annotations (e.g. information about+in-source comments). The main thing that you will be looking+at here is the GHC API documentation, for example+https://downloads.haskell.org/~ghc/8.0.2/docs/html/libraries/ghc-8.0.2/HsDecls.html++Brittany has several flags for dumping intermediate values of the+transformation process; relevant for the "input" syntax tree are the flags+`--dump-ast-unknown` and `--dump-ast-full`, where the latter will print the+whole ast of the input to stderr, the former will only do so for nodes where+brittany falls back on the ghc-exactprint output (i.e. in those cases where+we don't transform, but do a mere copy).+See [this example ast output](output-example-01.md)+(yeah, raw ASTs are ~~annoying large~~ fun!)++## Two examples of the process producing raw BriDoc++1. For example, `Brittany.hs` contains the following code (shortened a bit):++    ~~~~.hs+    ppDecl d@(L loc decl) = case decl of+      SigD sig  -> [..] $ do+        briDoc <- briDocMToPPM $ layoutSig (L loc sig)+        layoutBriDoc d briDoc+      ValD bind -> [..] $ do+        briDoc <- [..] layoutBind (L loc bind)+        layoutBriDoc d briDoc+      _         -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d+    ~~~~++    which matches on the type of module top-level syntax node and+    dispatches to `layoutSig`/`layoutBind` to layout type signatures+    and equations. For all other constructs, it currently falls back to using+    ExactPrint to reproduce the exact original.++2. Lets look at a "lower" level fragment that actually produces BriDoc (from Type.hs):++    ~~~~.hs+      -- if our type is an application; think "HsAppTy Maybe Int"+      HsAppTy typ1 typ2 -> do+        typeDoc1 <- docSharedWrapper layoutType typ1 -- layout `Maybe`+        typeDoc2 <- docSharedWrapper layoutType typ2 -- layout `Int`+        docAlt                                       -- produce two possible layouts+          [ docSeq                                       -- a singular-line sequence, with a space in between+            [ docForceSingleline typeDoc1                -- "Maybe Int"+            , docLit $ Text.pack " "+            , docForceSingleline typeDoc2+            ]+          , docPar                                       -- a multi-line result, with the "child" indented.+              typeDoc1                                   -- "Maybe\+              (docEnsureIndent BrIndentRegular typeDoc2) --    Int"+          ]+    ~~~~++    here, all functions prefixed with "doc" produce new BriDoc(F) nodes.+    I think this example can be understood already, even when many details+    (what is `docSharedWrapper`?+    What are the exact semantics of the different `doc..` functions?+    Why do we need to wrap the `BriDoc` constructors behind those smart-constructor thingies?)+    are not explained yet.++  In [this example output](output-example-02.md) the BriDoc tree produced in+  this fashion is shown for the trivial input `x :: Maybe Int`. Can you spot+  the `BDAlt` node that matches the above `docAlt` invocation? (hint: the+  node is used twice, so we can see two identical `BDAlt` nodes.)+  This leads directly to:+  +## Size of BriDoc trees, Sharing and Complexity++In order to explain the `BriDocF` type and the reasoning behind smart+constructors, we need to consider the size of the `BriDoc` tree produced by+this whole process.+As seen above, we can have multiple alternative layouts (`docAlt`) for+the same node.+This means the number of nodes in the `BriDoc` value we produces in general is+exponential in the number for syntax nodes of the input.++But we are aiming for linear run-time, right? So what can save us here?+You might think: We have sharing! For `let x = 3+3; (x, x)` we only have one+`x` in memory ever. And indeed, we do the same above: `typeDoc1` and `2` are+used in exactly that manner: Both are referenced once in each of the two+alternatives.++Unfortunately this does not mean that we can forget this issue entirely.+The problem is that the BriDoc tree (or maybe: rooted DAG, given that we share+nodes) value will get transformed by multiple transformations.+And this "breaks" sharing: If we naively traverse every path in a DAG and+`fmap` some function `f` on it (think of some general-purpose tree/graph that+is Functor) then `f` will be evaluated an exponential number of times, because+our linear DAG still has an exponential amount of different paths.+And worse, the output will have lost any sharing, so becomes a tree with an+exponential number of nodes. Sharing is not automatic memoization.+And this holds for BriDoc, even when the transformations are not exactly+`fmap`s.++So.. we already mentioned "memoization" there, right?++1. The bad news:+   Any existing memoization utilities/approaches didn't work for one reason+   or another. (I suspect that there is a bug in the GHC StableName+   implementation, or I messed up..) After trying several memoization+   approaches and wasting tons of time, I went with a manual approach,+   and it worked more or less instantly. So that is where we are at.++   Manual memoization means that we manually tag every node of the `BriDoc`+   with a unique `Int`. This is rather annoying at places, but then again+   we can abstract over that pretty well.+   +2. The good news:+   With manual memoization, we really work on rooted DAGs+   (with linear amount of nodes and edges) instead of trees, because we share+   nodes. Not messing up this property (that we always share nodes where+   necessary) can take a bit of consideration - but otherwise we are set.+   Transformations on this DAG can be expressed in such a way that they only+   require a linear amount of work, and our first transformation will output+   a (linear-sized) tree, so there is relatively little code that needs to+   handle a DAG.++   This property is the defining one that motivates the BriDoc+   intermediate representation.++Lets have a look at this selection work! We saw at+[the above example](output-example-02.md) how `x :: Maybe Int` had a+non-trivial raw `BriDoc` representation, already with two nested `BDAlt`+nodes and resulting four alternatives. Removing those nodes is the first+step of the `BriDoc` transformation, and we can+[observe the output after removing those nodes](output-example-03.md).+Quite a bit shorter, the tree-printing-algorithm even thinks that it fits+in a single line now.++We will not go into detail about how this "alt-transformation" (the one doing+the "selection work" works and what other transformations follow here.+For this example not much happens; you can see so in the final `BriDoc` which+you probably already noticed in the last example.++But for the "alt-transformation" itself, lets at least consider what it does:+We traverse the input BriDoc and whenever a `BDAlt` is encountered, one of the+alternatives is chosen; the other alternatives and the `BDAlt` node itself are+discarded.+The choice is made in such a fashion that, well, the final output does not+contain lines with more than 80 columns but otherwise relatively few newlines.+Magic! (for now at least.)++## BriDocF++The `BriDocF f` type encapsulates the idea that each subnode is wrapped+in the `f` container. This notion gives us the following nice properties:++`BriDocF Identity ~ BriDoc` and `BriDocF ((,) Int)` is the+manual-memoization tree/DAG with labeled nodes. Abstractions, abstractions..++Lets have a glance at related code/types we have so far:++~~~~.hs+-- The pure BriDoc: What we really want, but cannot use everywhere due+-- to sharing issues.+-- Isomorphic to `BriDocF Identity`. We still use this type, because+-- then we have to unwrap the `Identities` only in once place after turning+-- the DAG into a tree (and getting rid of any exponentiality in the process).+data BriDoc+  = BDEmpty+  | BDLit !Text+  | BDSeq [BriDoc]+  | BDAddBaseY BrIndent BriDoc+  | BDAlt [BriDoc]+  .. [a good amount more]++data BriDocF f+  = BDFEmpty+  | BDFLit !Text+  | BDFSeq [f (BriDocF f)]+  | BDFAddBaseY BrIndent (f (BriDocF f))+  | BDFAlt [f (BriDocF f)]+  .. [a good amount more]++type BriDocFInt = BriDocF ((,) Int)+type BriDocNumbered = (Int, BriDocFInt)++-- drop the labels+unwrapBriDocNumbered :: BriDocNumbered -> BriDoc+unwrapBriDocNumbered = ..+~~~~++And, because we will need it below: The monadic context that the creation+of the BriDocF tree uses:++~~~~.hs+-- If you are not familiar with the `multistate`+-- package and RWS, this is somewhat similar to:+-- ReaderT Config (ReaderT Anns (WriterT [LayoutError] (WriterT (Seq String) (State NodeAllocIndex))))+-- i.e. it is basically an environment allowing:+--   a) read access to global program config `Config` and the exactprint+--      annotations `Anns` of given input;+--   b) write access of errors and "good" output;+--   c) a local/"State" "variable" `NodeAllocIndex`+--      (yep, for the manual memoization node labels).+type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[LayoutError], Seq String] '[NodeAllocIndex]+~~~~++We don't use this directly, but the code below uses this,+and if the type `ToBriDocM` scared you, see how mundane it+is used here (`m` will be `ToBriDocM` mostly):++~~~~.hs+allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int+allocNodeIndex = do+  NodeAllocIndex i <- mGet+  mSet $ NodeAllocIndex (i + 1)+  return i+~~~~+ +## The `doc..` smart constructors++In most cases the smart constructors are fairly dumb: Their main purpose+is to allocate the unique label for the current node, and return it+together with the node itself. Lets look at two examples to get a+feeling for the types involved:++~~~~.hs+docEmpty :: ToBriDocM BriDocNumbered+docEmpty = allocateNode BDFEmpty -- what a "smart" constructor, right?++docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered+docSeq l = allocateNode . BDFSeq =<< sequence l+-- this is a bit more elaborate: In order to allow proper+-- composition of these smart constructors, we accept a list of+-- actions instead of just `BriDocNumbered`s, and use `sequence`+-- to make it work. Nothing unusual otherwise.+~~~~++There is one rather special `doc..` function: `docSharedWrapper`.+Lets consider the code first:++~~~~.hs+docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y)+docSharedWrapper f x = return <$> f x+~~~~++How is this useful? Consider this: All the smart constructors+expect as input actions returning (freshly labeled) nodes.+But what if we want sharing? In those cases we do _not_ want+fresh labels on multiple uses. Here `docSharedWrapper` comes+into play: It executes the contained label-allocation once+and returns a pure action via `return`; this pure action+can then be passed e.g. to docSeq but does not do any new+allocation. This gives us sharing in the cases where we+want it.++But wait, one more thing: Not all `BriDoc` constructors have+an exactly matching smart constructor, and there are smart+constructors that involve multiple BriDoc constructors behind+the scenes. For this reason, we will focus on the smart+constructors in the following, because they define the+real interface to be used.++You now might have a glance at [bridoc-api.md](bridoc-api.md).
+ doc/implementation/dataflow.md view
@@ -0,0 +1,49 @@+# Dataflow++From the program design standpoint, Brittany performes a+`Config -> Text -> Text` transformation; it is not interactive in any way and+it processes the whole input at once (no streaming going on). This makes for+a very simple design with nice separation of IO and non-IO.++Brittany makes heavy usage of mtl-on-steroids-style transformers, mostly+limited to Reader, Writer and State. For this kind of task it makes a lot of+sense; we do a pure transformation involving multiple steps+that each requires certain local state during traversals of recursive data+structures. By using MultiRWS we can even entirely avoid using lens without+inducing too much boilerplate.++Firstly, the topmost layer, the IO bits:++<img src="https://cdn.rawgit.com/lspitzner/brittany/7775812cfdc7d2596883f87b5ba9207fbf61f2b3/doc-svg-gen/generated/periphery.svg">++The corresponding code is in these modules:++- `Main`+- `Language.Haskell.Brittany`++The latter [contains the code to run our Reader/Writer/State stack](https://github.com/lspitzner/brittany/blob/7775812cfdc7d2596883f87b5ba9207fbf61f2b3/src/Language/Haskell/Brittany.hs#L64-L75) (well, no state yet).++Note that `MultiRWS` here behaves like a nicer version of a stack like+`ReaderT x (ReaderT y (WriterT w1 (WriterT2 w2 (Writer w3)..)`.+The next graph zooms in on that transformation:++<img src="https://cdn.rawgit.com/lspitzner/brittany/7775812cfdc7d2596883f87b5ba9207fbf61f2b3/doc-svg-gen/generated/ppm.svg">++Two places (The `BriDoc` generation and the backend) have additional local+state (added to the monadic context).+The following is a very simplified description of the BriDoc generation:++<img src="https://cdn.rawgit.com/lspitzner/brittany/7775812cfdc7d2596883f87b5ba9207fbf61f2b3/doc-svg-gen/generated/bridocgen.svg">+++For the `BriDoc` generation, the relevant modules are+- `Language.Haskell.Brittany.Layouters.*`+- `Language.Haskell.Brittany.LayouterBasics`++For the `BriDoc` tree transformations, the relevant modules are+- `Language.Haskell.Brittany.Transformations.*`++Finally, for the backend, the relevant modules are+- `Language.Haskell.Brittany.Backend`+- `Language.Haskell.Brittany.BackendUtils`+
+ doc/implementation/index.md view
@@ -0,0 +1,41 @@+- [theory](theory.md)++  Explains the core idea of the formatter that makes it so cool.++- [dataflow](dataflow.md)++  Looking at how the data is tranformed should give the reader a good+  idea of the high-level design, given that Brittany essentially+  performs a `Text -> Text` transformation.++- [bridoc-design](bridoc-design.md)++  An explanation of the `BriDoc` datatype focussed on (potential) contributors+  that wish to add support for more syntactical constructs.++- [bridoc-api](bridoc-api.md)++  Specifying the semantics of the different (smart) constructors of the+  `BriDoc` type.++- Brittany uses the following (randomly deemed noteworthy) libraries:++  - [`ghc-exactprint`](https://hackage.haskell.org/package/ghc-exactprint)+    (and [`ghc`](https://hackage.haskell.org/package/ghc)) for parsing of haskell source;+  - [`uniplate`](https://hackage.haskell.org/package/uniplate)+    for efficient transformations on the recursive `BriDoc` datatype;+    this powers the main computational work done by Brittany;+  - [`monad-memo`](https://hackage.haskell.org/package/monad-memo)+    for explicit function memoization;+  - [`multistate`](https://hackage.haskell.org/package/multistate)+    as an alternative to an unwieldly transformer stack;+  - [`butcher`](https://github.com/lspitzner/butcher)+    for parsing commandline arguments (as an alternative to+    [`optparse-applicative`](https://hackage.haskell.org/package/optparse-applicative))+  - [`yaml`](https://hackage.haskell.org/package/yaml)+    to handle config file;+  - [`safe`](https://hackage.haskell.org/package/safe)+    and+    [`unsafe`](https://hackage.haskell.org/package/unsafe)+    (heh).+
+ doc/implementation/output-example-01.md view
@@ -0,0 +1,59 @@+invocation:++~~~~+> brittany --dump-ast-full+~~~~++input (via stdin, remember ctrl-d to end-of-file):++~~~~+id :: a -> a+~~~~++output (all but the last line is stderr):++~~~~+---- ast ----+A Just (Ann (DP (0,0)) [] [] [((G AnnEofPos),DP (1,0))] Nothing Nothing)+  HsModule+    Nothing+    Nothing+    []+    [ A Just (Ann (DP (0,0)) [] [] [((G AnnDcolon),DP (0,1))] Nothing Nothing)+        SigD+          TypeSig+            [ A Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing)+                Unqual {OccName: id}+            ]+            HsIB+              PlaceHolder+              HsWC+                PlaceHolder+                Nothing+                A Just (Ann (DP (0,1)) [] [] [((G AnnRarrow),DP (0,1))] Nothing Nothing)+                  HsFunTy+                    A Just (Ann (DP (0,0)) [] [] [] Nothing Nothing)+                      HsAppsTy+                        [ A Just (Ann (DP (0,0)) [] [] [] Nothing Nothing)+                            HsAppPrefix+                              A Just (Ann (DP (0,0)) [] [] [] Nothing Nothing)+                                HsTyVar+                                  A Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing)+                                    Unqual {OccName: a}+                        ]+                    A Just (Ann (DP (0,1)) [] [] [] Nothing Nothing)+                      HsAppsTy+                        [ A Just (Ann (DP (0,0)) [] [] [] Nothing Nothing)+                            HsAppPrefix+                              A Just (Ann (DP (0,0)) [] [] [] Nothing Nothing)+                                HsTyVar+                                  A Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing)+                                    Unqual {OccName: a}+                        ]+    ]+    Nothing+    Nothing+----+id :: a -> a+~~~~+
+ doc/implementation/output-example-02.md view
@@ -0,0 +1,46 @@+invocation:++~~~~+> brittany --dump-bridoc-raw+~~~~++input (via stdin, remember ctrl-d to end-of-file):++~~~~+x :: Maybe Int+~~~~++output (all but the last line is stderr):++~~~~+---- bridoc raw ----+BDAlt+  [ BDSeq+      [ BDSeq [BDLit (pack "x"),BDSeparator]+      , BDSeq [BDLit (pack "::"),BDSeparator]+      , BDForceSingleline+          BDAlt+            [ BDSeq [BDForceSingleline (BDLit (pack "Maybe")),BDLit (pack " "),BDForceSingleline (BDLit (pack "Int"))]+            , BDPar BrIndentNone (BDLit (pack "Maybe")) (BDLines [BDEnsureIndent BrIndentRegular (BDLit (pack "Int"))])+            ]+      ]+  , BDAddBaseY+      BrIndentRegular+      BDPar+        BrIndentNone+        BDLit (pack "x")+        BDCols+          ColTyOpPrefix+          [ BDLit (pack ":: ")+          , BDAddBaseY+              BrIndentSpecial 3+              BDAlt+                [ BDSeq [BDForceSingleline (BDLit (pack "Maybe")),BDLit (pack " "),BDForceSingleline (BDLit (pack "Int"))]+                , BDPar BrIndentNone (BDLit (pack "Maybe")) (BDLines [BDEnsureIndent BrIndentRegular (BDLit (pack "Int"))])+                ]+          ]+  ]+----+x :: Maybe Int+~~~~+
+ doc/implementation/output-example-03.md view
@@ -0,0 +1,23 @@+invocation:++~~~~+> brittany --dump-bridoc-alt --dump-bridoc-final+~~~~++input (via stdin, remember ctrl-d to end-of-file):++~~~~+x :: Maybe Int+~~~~++output (all but the last line is stderr):++~~~~+---- bridoc post-alt ----+BDSeq [BDSeq [BDLit (pack "x"),BDSeparator],BDSeq [BDLit (pack "::"),BDSeparator],BDSeq [BDLit (pack "Maybe"),BDLit (pack " "),BDLit (pack "Int")]]+---- bridoc final ----+BDSeq [BDLit (pack "x"),BDSeparator,BDLit (pack "::"),BDSeparator,BDLit (pack "Maybe"),BDLit (pack " "),BDLit (pack "Int")]+----+x :: Maybe Int+~~~~+
+ doc/implementation/theory.md view
@@ -0,0 +1,316 @@+# Introduction++[The readme](../../master/README.md) mentions a couple of goals for this+project, including the following two:++- Be clever about using the available horizontal space while not overflowing+  it if it cannot be avoided;+- Have linear complexity in the size of the input.++These two goals stand in conflict, and this project chooses a solution+to this that distinguishes it from (all) other existing formatters. This+approach was an important motivation for writing Brittany. The approach might+also be applicable to more general-purposes structured-document formatters+(although we will not expand on that here). Before explaining the idea, we+will first consider++## The problem++Every haskell module can be written in a single line - of course, in most+cases, an unwieldly long one. We humans prefer our lines limitted to some+laughingly small limit like 80 or 160 or whatever. Further, we generally+prefer the indentation of our expressions(, statements etc.) line up with+its syntactic structure. This preferences (and the layouting rule which+already enforces it partially) still leaves a good amount of choice for+where exactly to insert newlines. For example, these are all consistent+in their newline/indentation usage:++~~~~.hs+myRecord = MyRecord { abc = "abc", def = "def"}+myRecord = MyRecord+  { abc = "abc"+  , def = "def"+  }+myList = [ "abc", "def"]+myList =+  [ "abc"+  , "def"+  ]+~~~~++While consistency has the first priority, we also prefer short code: If it+fits, we prefer the version/layout with less lines of code. So we wish to trade+more lines for less columns, but only until things fit.++For simple cases we can give a trivial rule: If there is space+for the one-line layout, use it; otherwise use the indented-multiline+layout (this applies to `myRecord` example). The+straight-forward approach works well: Calculate the length of the+one-line layout for each node, then recurse top-down and make the choices+according to that rule. Linear runtime with good results.++Things get more interesting with nesting, and with structures with more than+two alternatives. Consider the following four alternative layouts of the+same expression:++~~~~.hs+--        10        20        30        40+-- 1)                                   -- lets assume the user wants+nestedCaseExpr = case e1 of             -- 40 columns max.+  Left x -> if func x then "good" else "bad" -- too long+-- 2)                                   -- +nestedCaseExpr = case e1 of             -- +  Left x -> if func x                   -- +    then "good"                         -- +    else "bad"                          -- +-- 3)                                   -- +nestedCaseExpr = case e1 of             -- +  Left x ->                             -- +    if func x then "good" else "bad"    -- +-- 4)                                   -- +nestedCaseExpr = case e1 of             -- +  Left x ->                             -- +    if func x                           -- +      then "good"                       -- +      else "bad"                        -- +~~~~++- We nest a case-expression and an if-expression; for both we consider two+  alternative layouts, meaning that+- There are a total of four, and in general an exponential amount of+  possible layouts;+- With a top-down approach, one would choose 2), as "if func x" has space in+  the current line. But..+- Layout 3) is the optimal solution considering lines-of-code and the 40-column+  limit.++So our question: Is there an algorithm which, given some input syntax tree,+returns the/an optimal (least lines-of-code while respecting max-column limit)+layout (out of a potentially exponential number of valid layouts). Further,+this algorithm's time/space usage should be linear in the size of the input+(we might weaken this to some polynomial upper bound - but that should be the+limit).++If we pessimistically assume that such algorithm does not exist, we may ask+alternatively: What linear algorithm returns solutions which,+on average, are closest to the optimal solution?++In the following we will describe _one_ such algorithm that seems to return+the optimal solution in several non-trivial cases, and near-optimal solutions+in many other. We won't try to prove that it is the best algorithm, but we will+consider the circumstances for which a non-optimal solution is returned.++## The Reasoning++A top-down approach is so bad because when there are exponentially many+layouts to consider, there information passed down from the parents does+not help at all in pruning the alternatives on a given layer. In the above+`nestedCaseExpr` example, we might obtain a better solution by looking not+at just the first, but the first n possible layouts, but against an exponential+search-space, this does not scale: Just consider the possibility that there+are exponentially many sub-solutions for layout 2) (replace "good" with some+slightly more complex expression). You basically always end up with either+"the current line is not yet full, try to fill it up" or+"more than n columns used, abort".++But a (pure) bottom-up approach does not work either: If we have no clue about+the "current" indentation while layouting some node of our syntax tree,+information about the (potential) size of (the layout of) child-nodes does+not allow us to make good decisions.++So we need information to flow bottom-to-top to allow for pruning whole trees+of possible layouts, and top-to-bottom for making the actual decisions.. well,+this can be arranged.++# The Algorithm++This algorithm works in two passes over the input syntax tree. The first pass+is bottom-up and adds a label to each node. This label contains (a set of)+"spacings" - certain information regarding the number of columns/lines needed+for the textual representation of potential layouts of that node.+For example we might return two possible spacings for the following (same)+expression:++~~~~.hs+if func x then "good" else "bad"+-- => 1 line, 32 columns used+if func x+  then "good"+  else "bad"+-- => 3 lines, 13 columns used+~~~~++This is heavily simplified; in Brittany spacing information is (as usual) a+bit more complex.++We restrict the size of these sets. Given the sets of spacings for the+child-nodes in the syntax-tree, we generate a limited number of possible+spacings in the current node. We then prune nodes that already violate desired+properties, e.g. any spacing that already uses more columns locally than+globally available.++The second pass is top-down and uses the spacing-information to decide on one+of the possible layouts for the current node. It passes the current+"cursor position" (indentation, etc.) downwards, allowing to check that the+layout fits (e.g. ensure "current indentation + columns used < max columns").++This algorithm is trivially linear - two traversals and only linear space+required per node of the input.++### Consequences++- when calculating spacings during bottom-up, several spacings are combined+  into a single one via min/max/some other associative operation. Perhaps+  consider how in a multi-line list layout the "columns used" will be derived+  from the element spacings. For additional information embedded into the+  spacings, we will need at least one such Semigroup instance.++- We require an order on the alternatives for each syntactical construct.+  The first alternative where we find some combination of spacings for the+  children which is acceptable will be used.++  In unlucky cases, all spacings might get pruned. In that case, we will+  default to the last alternative, which therefor should be the most+  "conservative" choice, i.e. the one that gives the child-nodes the most+  space.++  The first alternative should always be the "one-liner" layout, if it exists;+  this alternative is preferable in general and will be filtered first should+  it not fit.++  In between those two extremes can be other choices that gradually trade+  "columns used" for "lines used".++- Sometimes there exist several (near) optimal solutions. E.g. when there exist+  multiple nodes where we can trade lines for columns in such a way that the+  whole result fits.++  In such cases, Brittany makes the following choice: We prefer "trading"+  in the node higher up in the syntax tree. The reasoning is that we rather+  spend one line early on to gain additional horizontal space for _all_ the+  children than the other way around. (In those cases where there are+  alternatives to choose from, there are often several children.) We can apply+  this to the `nestedCaseExpr` example above: The options are to either+  put the right-hand-side of the case-alternative into a new line, or+  split up the if-then-else. The "case" is the outer one, so Brittany will+  prefer 3) over 2), which proves to be the right choice (at least in this+  case).++  As a consequence, we are most interested in the maximum spacings. Still we do+  not have a total order because we cannot generally prefer one of two spacings+  where the first uses more columns, the second more lines.++- The number of syntactical constructs in haskell is large. If we were to+  work directly on the syntax tree to do our traversals, we'd have to write two+  (or even three - one to generate spacings, one to make the choices, one to+  do the output and insert comments) different functions each respecting every+  syntactical construct in haskell. It would be an incredible amount of code+  (and work) times three.++  Instead we can use some recursive data-type describing a structured document,+  which abstracts of different syntactical constructs and only considers the+  things relevant for layouting. This data-type is called `BriDoc`.++- If we did not share values, we'd work on `BriDoc` trees of exponential size.+  By sharing child-nodes across different alternatives we instead obtain a+  rooted DAG of linear size, but still with an exponential number of different+  paths.+  In the `nestedCaseExpr` example above, note how there are four layouts, but+  essentially only two ways in which the "if" is layouted.+  Either as a single line or with then/else on new lines. We can handle+  spacings in such a way that we can share them for 1/3 and 2/4.+  This already hints at how "columns used" will need to be redesigned slightly+  so that 2/4 really have the same spacing label at the "if".++### Concessions/non-Optimality++- Prefering to trade in the higher node can give non-optimal results, e.g.+  when there is only one child.++- Spacings and the pruning of spacings happens in bottom-up fashion, meaning+  that we might not prune a "70 columns used" spacing even though we later+  notice that the current indentation already needs to be 20 and we only have+  60 columns left. If all spacings found in one label have this property,+  the top-down traversal might be forced to make the "conservative" choice,+  trading more lines for less indentation to prevent potential (but unknown)+  overflow during child-node layouting.++- We can increase the limits arbitrarily (i.e. increase the constant factor+  while remaining linear) to get better (optimal) results in more cases. We can+  choose constant factors in such a way that we get optimal results for all+  inputs up to a certain size. Of course calling them "constant factors" is+  delusional if they grow exponentially - but it is still nice that this+  heuristical algorithm can trivially be transformed into the perfect+  (but exponential) algorithm.++### Examples of non-Optimality and Border-Cases in General++TODO++# Practical details++## Comments++Comments don't affect semantics and thus are free-form; as the user we almost+never want them reformatted in any way. The tempting approach is to keep them+entirely separate: Don't layout comments, and don't let comments affect+layout. However, this not possible always:++~~~~.hs+val = f -- useful comment here+      x+-- reformatted to+val = f -- useful comment here x+~~~~++Does not work too well, even when the one-liner "f x" would certainly be the+layout of choice.++Brittany handles this in two ways:++1) Some alternatives are pruned based on the existence of comments;+2) Always insert newlines after end-of-line comments, and restore the+   current indetation to prevent violation of the layouting rule:++    ~~~~.hs+    val = do+      myAction -- useful comment here+               x+      g+    ~~~~++## CPP++Conditional text-based source-code insertion is horrible.+"#if"-guarded code in one line can easily affect in which way all other code+is parsed. This makes it more or less impossible to layout code involving+the preprocessor. One might be able to re-implement the preprocessor to then+determine when things are safe to layout, but that is no fun, and Brittany+does not bother.++Brittany allows one thing: Working on the already pre-processed code, treating+any disabled sections like comments. This is not safe in general, but is nice+when the user makes only responsible usage of CPP (e.g.: only put "#if"-guards+around module top-level constructs).++## Horizontal alignment++Sometimes horizontal alignment can make things more readable. However there+are good reasons against using such whitespace: It can cause larger diffs+on simple changes and it is rather subjective in which cases things are+"more readable" rather than "annoyingly spaced".++Nonetheless Brittany has a fully-featured implementation for horizontal+alignment:++~~~~.hs+func (MyLongFoo abc def) = 1+func (Bar       a   d  ) = 2+func _                   = 3+~~~~++Again we have to ask the question: Does alignment affect the layouting choices,+and does layouting affect alignment? The answer is clear in this case: No.+First we make layouting-choices, then, independently, we add alignment but only+in those cases where it does not cause overflows.+
+ src-brittany/Main.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE DataKinds #-}++module Main where++++#include "prelude.inc"++import qualified Language.Haskell.GHC.ExactPrint as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types+import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers+import qualified Data.Map as Map++import qualified Data.Text.Lazy.Builder as Text.Builder++import           Data.CZipWith++import qualified Debug.Trace as Trace++import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal+import           Language.Haskell.Brittany.Internal.Config+import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.Utils++import qualified Text.PrettyPrint as PP++import           DataTreePrint+import           UI.Butcher.Monadic++import qualified System.Exit+import qualified System.Directory as Directory+import qualified System.FilePath.Posix as FilePath++import qualified DynFlags as GHC+import qualified GHC.LanguageExtensions.Type as GHC++import Paths_brittany++++main :: IO ()+main = mainFromCmdParserWithHelpDesc mainCmdParser++helpDoc :: PP.Doc+helpDoc = PP.vcat $ List.intersperse+  (PP.text "")+  [ parDocW+    [ "Transforms one haskell module by reformatting"+    , "(parts of) the source code (while preserving the"+    , "parts not transformed)."+    , "Based on ghc-exactprint, thus (theoretically) supporting all"+    , "that ghc does."+    , "Currently, only type-signatures and function-bindings are transformed."+    ]+  , parDocW+    [ "This program is written carefully and contains safeguards to ensure"+    , "the transformation does not change semantics (or the syntax tree at all)"+    , "and that no comments are removed."+    , "Nonetheless, this is a young project, and there will always be bugs."+    , "Please do check the output and do not let brittany override your large"+    , "codebase without having backups."+    ]+  , parDoc $ "There is NO WARRANTY, to the extent permitted by law."+  , parDocW ["This program is free software released under the AGPLv3.", "For details use the --license flag."]+  , parDoc $ "See https://github.com/lspitzner/brittany"+  , parDoc $ "Please report bugs at" ++ " https://github.com/lspitzner/brittany/issues"+  ]++licenseDoc :: PP.Doc+licenseDoc = PP.vcat $ List.intersperse+  (PP.text "")+  [ parDoc $ "Copyright (C) 2016-2017 Lennart Spitzner"+  , parDocW+    [ "This program is free software: you can redistribute it and/or modify"+    , "it under the terms of the GNU Affero General Public License,"+    , "version 3, as published by the Free Software Foundation."+    ]+  , parDocW+    [ "This program is distributed in the hope that it will be useful,"+    , "but WITHOUT ANY WARRANTY; without even the implied warranty of"+    , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"+    , "GNU Affero General Public License for more details."+    ]+  , parDocW+    [ "You should have received a copy of the GNU Affero General Public"+    , "License along with this program.  If not, see"+    , "<http://www.gnu.org/licenses/>."+    ]+  ]++mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()+mainCmdParser helpDesc = do+  addCmdSynopsis "haskell source pretty printer"+  addCmdHelp $ helpDoc+  -- addCmd "debugArgs" $ do+  addHelpCommand helpDesc+  addCmd "license" $ addCmdImpl $ print $ licenseDoc+  -- addButcherDebugCommand+  reorderStart+  printHelp      <- addSimpleBoolFlag "" ["help"] mempty+  printVersion   <- addSimpleBoolFlag "" ["version"] mempty+  printLicense   <- addSimpleBoolFlag "" ["license"] mempty+  inputPaths     <- addFlagStringParams "i" ["input"] "PATH" (flagHelpStr "path to input haskell source file")+  outputPaths    <- addFlagStringParams "o" ["output"] "PATH" (flagHelpStr "output file path")+  configPaths    <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?+  cmdlineConfig  <- configParser+  suppressOutput <- addSimpleBoolFlag+    ""+    ["suppress-output"]+    (flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source")+  _verbosity <- addSimpleCountFlag "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]")+  reorderStop+  inputParam <- addStringParamOpt "PATH" (paramHelpStr "path to input haskell source file")+  desc       <- peekCmdDesc+  addCmdImpl $ void $ do+    when printLicense $ do+      liftIO $ print licenseDoc+      System.Exit.exitSuccess+    when printVersion $ do+      liftIO $ do+        putStrLn $ "brittany version " ++ showVersion version+        putStrLn $ "Copyright (C) 2016-2017 Lennart Spitzner"+        putStrLn $ "There is NO WARRANTY, to the extent permitted by law."+      System.Exit.exitSuccess+    when printHelp $ do+      liftIO $ print $ ppHelpShallow desc+      System.Exit.exitSuccess+    inputPathM <- case maybeToList inputParam ++ inputPaths of+      [] -> do+        return Nothing+      [x] -> return $ Just x+      _   -> do+        liftIO $ putStrErrLn $ "more than one input, aborting"+        System.Exit.exitWith (System.Exit.ExitFailure 50)+    outputPath <- case outputPaths of+      [] -> do+        return Nothing+      [x] -> return $ Just x+      _   -> do+        liftIO $ putStrErrLn $ "more than one output, aborting"+        System.Exit.exitWith (System.Exit.ExitFailure 50)+    config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case+      Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 50)+      Just x  -> return x+    when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do+      trace (showConfigYaml config) $ return ()+    let ghcOptions = config & _conf_forward & _options_ghc & runIdentity+    liftIO $ do+      -- there is a good of code duplication between the following code and the+      -- `pureModuleTransform` function. Unfortunately, there are also a good+      -- amount of slight differences: This module is a bit more verbose, and+      -- it tries to use the full-blown `parseModule` function which supports+      -- CPP (but requires the input to be a file..).+      let cppMode            = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack+      -- the flag will do the following: insert a marker string+      -- ("-- BRITTANY_INCLUDE_HACK ") right before any lines starting with+      -- "#include" before processing (parsing) input; and remove that marker+      -- string from the transformation output.+      let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack+      let exactprintOnly     = config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack+      let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags+            then case cppMode of+              CPPModeAbort -> do+                return $ Left "Encountered -XCPP. Aborting."+              CPPModeWarn -> do+                putStrErrLn+                  $  "Warning: Encountered -XCPP."+                  ++ " Be warned that -XCPP is not supported and that"+                  ++ " brittany cannot check that its output is syntactically"+                  ++ " valid in its presence."+                return $ Right True+              CPPModeNowarn -> return $ Right True+            else return $ Right False+      parseResult <- case inputPathM of+        Nothing -> do+          -- TODO: refactor this hack to not be mixed into parsing logic+          let hackF s = if "#include" `isPrefixOf` s then "-- BRITTANY_INCLUDE_HACK " ++ s else s+          let hackTransform =+                if hackAroundIncludes && not exactprintOnly then List.unlines . fmap hackF . List.lines else id+          inputString <- System.IO.hGetContents System.IO.stdin+          parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform inputString)+        Just p -> parseModule ghcOptions p cppCheckFunc+      case parseResult of+        Left left -> do+          putStrErrLn "parse error:"+          printErr left+          System.Exit.exitWith (System.Exit.ExitFailure 60)+        Right (anns, parsedSource, hasCPP) -> do+          when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do+            let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource+            trace ("---- ast ----\n" ++ show val) $ return ()+          (errsWarns, outLText) <- do+            if exactprintOnly+              then do+                pure ([], TextL.pack $ ExactPrint.exactPrint parsedSource anns)+              else do+                let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack+                (ews, outRaw) <- if hasCPP || omitCheck+                  then return $ pPrintModule config anns parsedSource+                  else pPrintModuleAndCheck config anns parsedSource+                let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s+                pure $ if hackAroundIncludes+                  then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw)+                  else (ews, outRaw)+          let customErrOrder ErrorInput{}         = 4+              customErrOrder LayoutWarning{}      = 0 :: Int+              customErrOrder ErrorOutputCheck{}   = 1+              customErrOrder ErrorUnusedComment{} = 2+              customErrOrder ErrorUnknownNode{}   = 3+          when (not $ null errsWarns) $ do+            let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder $ errsWarns+            groupedErrsWarns `forM_` \case+              (ErrorOutputCheck{}:_) -> do+                putStrErrLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result."+              (ErrorInput str:_) -> do+                putStrErrLn $ "ERROR: parse error: " ++ str+              uns@(ErrorUnknownNode{}:_) -> do+                putStrErrLn $ "ERROR: encountered unknown syntactical constructs:"+                uns `forM_` \case+                  ErrorUnknownNode str ast -> do+                    putStrErrLn str+                    when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack) $ do+                      putStrErrLn $ "  " ++ show (astToDoc ast)+                  _ -> error "cannot happen (TM)"+              warns@(LayoutWarning{}:_) -> do+                putStrErrLn $ "WARNINGS:"+                warns `forM_` \case+                  LayoutWarning str -> putStrErrLn str+                  _                 -> error "cannot happen (TM)"+              unused@(ErrorUnusedComment{}:_) -> do+                putStrErrLn+                  $  "Error: detected unprocessed comments."+                  ++ " The transformation output will most likely"+                  ++ " not contain certain of the comments"+                  ++ " present in the input haskell source file."+                putStrErrLn $ "Affected are the following comments:"+                unused `forM_` \case+                  ErrorUnusedComment str -> putStrErrLn str+                  _                      -> error "cannot happen (TM)"+              [] -> error "cannot happen"+          -- TODO: don't output anything when there are errors unless user+          -- adds some override?+          let hasErrors = case config & _conf_errorHandling & _econf_Werror & confUnpack of+                False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)+                True  -> not $ null errsWarns+              outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack+              shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs)++          when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPath of+            Nothing -> TextL.IO.putStr $ outLText+            Just p  -> TextL.IO.writeFile p $ outLText++          when hasErrors $ System.Exit.exitWith (System.Exit.ExitFailure 70)+ where+  addTraceSep conf =+    if or+         [ confUnpack $ _dconf_dump_annotations conf+         , confUnpack $ _dconf_dump_ast_unknown conf+         , confUnpack $ _dconf_dump_ast_full conf+         , confUnpack $ _dconf_dump_bridoc_raw conf+         , confUnpack $ _dconf_dump_bridoc_simpl_alt conf+         , confUnpack $ _dconf_dump_bridoc_simpl_floating conf+         , confUnpack $ _dconf_dump_bridoc_simpl_columns conf+         , confUnpack $ _dconf_dump_bridoc_simpl_indent conf+         , confUnpack $ _dconf_dump_bridoc_final conf+         ]+      then trace "----"+      else id++readConfigs :: CConfig Option -> [System.IO.FilePath] -> MaybeT IO Config+readConfigs cmdlineConfig configPaths = do+  let defLocalConfigPath = "brittany.yaml"+  userBritPath <- liftIO $ Directory.getAppUserDataDirectory "brittany"+  let defUserConfigPath = userBritPath FilePath.</> "config.yaml"+  merged <- case configPaths of+    [] -> do+      liftIO $ Directory.createDirectoryIfMissing False userBritPath+      return cmdlineConfig+        >>= readMergePersConfig defLocalConfigPath False+        >>= readMergePersConfig defUserConfigPath  True+    -- TODO: ensure that paths exist ?+    paths -> foldl (\prev p -> prev >>= readMergePersConfig p False) (return cmdlineConfig) paths+  return $ cZipWith fromOptionIdentity staticDefaultConfig merged
+ src-libinterfacetests/Main.hs view
@@ -0,0 +1,32 @@+module Main where++++import           Test.Hspec+import           Language.Haskell.Brittany+import qualified Data.Text as Text+import qualified System.Exit as Exit+import           Control.Monad.IO.Class++++main :: IO ()+main = hspec $ do+  describe "library interface basic functionality" $ do+    it "gives properly formatted result for valid input" $ do+      let+        input = Text.pack $ unlines+          ["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"]+      let expected = Text.pack $ unlines+            [ "func ="+            , "  [ 00000000000000000000000"+            , "  , 00000000000000000000000"+            , "  , 00000000000000000000000"+            , "  , 00000000000000000000000"+            , "  ]"+            ]+      output <- liftIO $ parsePrintModule staticDefaultConfig input+      input `shouldSatisfy` \_ -> case output of+        Right x | x == expected -> True+        _                       -> False+
+ src-literatetests/Main.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE QuasiQuotes #-}++module Main where++++#include "prelude.inc"++import Test.Hspec++import NeatInterpolation++import qualified Text.Parsec as Parsec+import Text.Parsec.Text ( Parser )++import Data.Char ( isSpace )+import Data.List ( groupBy )++import Language.Haskell.Brittany.Internal++import Language.Haskell.Brittany.Internal.Config.Types+import Language.Haskell.Brittany.Internal.Config++import Data.Coerce ( coerce )++import qualified Data.Text.IO as Text.IO++++data InputLine+  = GroupLine Text+  | HeaderLine Text+  | PendingLine+  | NormalLine Text+  | CommentLine+  deriving Show+++main :: IO ()+main = do+  input <- Text.IO.readFile "src-literatetests/tests.blt"+  let groups = createChunks input+  hspec $ groups `forM_` \(groupname, tests) -> do+    describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do+      (if pend then before_ pending else id)+        $ it (Text.unpack name)+        $ roundTripEqual inp+ where+  -- this function might be implemented in a weirdly complex fashion; the+  -- reason being that it was copied from a somewhat more complex variant.+  createChunks :: Text -> [(Text, [(Text, Bool, Text)])]+  createChunks input =+--    fmap (\case+--        HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines)+--        HeaderLine n:rest | Just rlines <- mapM extractNormal rest -> (n, False, Text.unlines rlines)+--        l -> error $ "first non-empty line must start with #test footest\n" ++ show l+--      )+--      $   fmap (groupBy grouperT)+    fmap+        ( \case+          GroupLine g:grouprest ->+            (,) g+              $ fmap+                  ( \case+                    HeaderLine n:PendingLine:rest | Just rlines <- mapM+                      extractNormal+                      rest ->+                      (n, True, Text.unlines rlines)+                    HeaderLine n:rest | Just rlines <- mapM extractNormal rest ->+                      (n, False, Text.unlines rlines)+                    l ->+                      error+                        $ "first non-empty line must start with #test footest\n"+                        ++ show l+                  )+              $ groupBy grouperT+              $ filter (not . lineIsSpace)+              $ grouprest+          l -> error $ "first non-empty line must be a #group\n" ++ show l+        )+      $   groupBy grouperG+      $   filter (not . lineIsSpace)+      $   lineMapper+      <$> Text.lines input+   where+    extractNormal (NormalLine l) = Just l+    extractNormal _              = Nothing+    specialLineParser :: Parser InputLine+    specialLineParser = Parsec.choice+      [ [ GroupLine $ Text.pack name+        | _    <- Parsec.try $ Parsec.string "#group"+        , _    <- Parsec.many1 $ Parsec.oneOf " \t"+        , name <- Parsec.many1 $ Parsec.noneOf "\r\n:"+        , _    <- Parsec.eof+        ]+      , [ HeaderLine $ Text.pack name+        | _    <- Parsec.try $ Parsec.string "#test"+        , _    <- Parsec.many1 $ Parsec.oneOf " \t"+        , name <- Parsec.many1 $ Parsec.noneOf "\r\n:"+        , _    <- Parsec.eof+        ]+      , [ PendingLine+        | _ <- Parsec.try $ Parsec.string "#pending"+        , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n")+        , _ <- Parsec.eof+        ]+      , [ CommentLine+        | _ <- Parsec.many $ Parsec.oneOf " \t"+        , _ <-+          Parsec.optional $ Parsec.string "##" <* many (Parsec.noneOf "\r\n")+        , _ <- Parsec.eof+        ]+      ]+    lineMapper :: Text -> InputLine+    lineMapper line = case Parsec.runParser specialLineParser () "" line of+      Left  _e -> NormalLine line+      Right l  -> l+    lineIsSpace :: InputLine -> Bool+    lineIsSpace CommentLine = True+    lineIsSpace _           = False+    grouperG :: InputLine -> InputLine -> Bool+    grouperG _ GroupLine{} = False+    grouperG _ _           = True+    grouperT :: InputLine -> InputLine -> Bool+    grouperT _ HeaderLine{} = False+    grouperT _ _            = True+++--------------------+-- past this line:  copy-pasta from other test (meh..)+--------------------+roundTripEqual :: Text -> Expectation+roundTripEqual t =+  fmap (fmap PPTextWrapper)+       (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)+    `shouldReturn` Right (PPTextWrapper t)++newtype PPTextWrapper = PPTextWrapper Text+  deriving Eq++instance Show PPTextWrapper where+  show (PPTextWrapper t) = "\n" ++ Text.unpack t+++defaultTestConfig :: Config+defaultTestConfig = Config+  { _conf_version = _conf_version staticDefaultConfig+  , _conf_debug   = _conf_debug staticDefaultConfig+  , _conf_layout  = LayoutConfig+    { _lconfig_cols                      = coerce (80 :: Int)+    , _lconfig_indentPolicy              = coerce IndentPolicyFree+    , _lconfig_indentAmount              = coerce (2 :: Int)+    , _lconfig_indentWhereSpecial        = coerce True+    , _lconfig_indentListSpecial         = coerce True+    , _lconfig_importColumn              = coerce (60 :: Int)+    , _lconfig_altChooser                = coerce $ AltChooserBoundedSearch 3+    , _lconfig_columnAlignMode           = coerce (ColumnAlignModeMajority 0.7)+    , _lconfig_alignmentLimit            = coerce (30 :: Int)+    , _lconfig_alignmentBreakOnMultiline = coerce True+    }+  , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig)+    { _econf_omit_output_valid_check = coerce True+    }+  , _conf_preprocessor = _conf_preprocessor staticDefaultConfig+  , _conf_forward      = ForwardOptions+    { _options_ghc = Identity []+    }+  }+
+ src-unittests/AsymptoticPerfTests.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE QuasiQuotes #-}++module AsymptoticPerfTests+  ( asymptoticPerfTest+  )+where++++#include "prelude.inc"++import Test.Hspec++import NeatInterpolation++import Language.Haskell.Brittany.Internal++import TestUtils++++asymptoticPerfTest :: Spec+asymptoticPerfTest = do+  it "1000 do statements"+    $  roundTripEqualWithTimeout 1000000+    $  (Text.pack "func = do\n")+    <> Text.replicate 1000 (Text.pack "  statement\n")+  it "1000 do nestings"+    $  roundTripEqualWithTimeout 4000000+    $  (Text.pack "func = ")+    <> mconcat+         (   [0 .. 999]+         <&> \(i :: Int) ->+               (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n")+         )+    <> Text.replicate 2000 (Text.pack " ")+    <> Text.pack "return\n"+    <> Text.replicate 2002 (Text.pack " ")+    <> Text.pack "()"+  it "1000 AppOps"+    $  roundTripEqualWithTimeout 1000000+    $  (Text.pack "func = expr")+    <> Text.replicate 200 (Text.pack "\n     . expr") --TODO
+ src-unittests/TestMain.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE QuasiQuotes #-}++module Main where++++#include "prelude.inc"++import Test.Hspec++import NeatInterpolation++import Language.Haskell.Brittany.Internal++import AsymptoticPerfTests++++main :: IO ()+main = hspec $ tests++tests :: Spec+tests = do+  describe "asymptotic perf roundtrips" $ asymptoticPerfTest
+ src-unittests/TestUtils.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE QuasiQuotes #-}++module TestUtils where++++#include "prelude.inc"++import Test.Hspec++import NeatInterpolation++import Language.Haskell.Brittany.Internal++import Language.Haskell.Brittany.Internal.Config.Types+import Language.Haskell.Brittany.Internal.Config++import System.Timeout ( timeout )++import Data.Coerce ( coerce )++++roundTripEqual :: Text -> Expectation+roundTripEqual t =+  fmap (fmap PPTextWrapper)+       (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)+    `shouldReturn` Right (PPTextWrapper t)++roundTripEqualWithTimeout :: Int -> Text -> Expectation+roundTripEqualWithTimeout time t =+  timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust)+ where+  action = fmap (fmap PPTextWrapper)+                (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)++newtype PPTextWrapper = PPTextWrapper Text+  deriving Eq++instance Show PPTextWrapper where+  show (PPTextWrapper t) = "\n" ++ Text.unpack t++defaultTestConfig :: Config+defaultTestConfig = Config+  { _conf_version = _conf_version staticDefaultConfig+  , _conf_debug   = _conf_debug staticDefaultConfig+  , _conf_layout  = LayoutConfig+    { _lconfig_cols                      = coerce (80 :: Int)+    , _lconfig_indentPolicy              = coerce IndentPolicyFree+    , _lconfig_indentAmount              = coerce (2 :: Int)+    , _lconfig_indentWhereSpecial        = coerce True+    , _lconfig_indentListSpecial         = coerce True+    , _lconfig_importColumn              = coerce (60 :: Int)+    , _lconfig_altChooser                = coerce $ AltChooserBoundedSearch 3+    , _lconfig_columnAlignMode           = coerce (ColumnAlignModeMajority 0.7)+    , _lconfig_alignmentLimit            = coerce (30 :: Int)+    , _lconfig_alignmentBreakOnMultiline = coerce True+    }+  , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig)+    { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever+    }+  , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig)+  , _conf_forward      = ForwardOptions+    { _options_ghc = Identity []+    }+  }
+ src/Language/Haskell/Brittany.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Brittany+  ( parsePrintModule+  , staticDefaultConfig+  , forwardOptionsSyntaxExtsEnabled+  , Config+  , CConfig(..)+  , CDebugConfig(..)+  , CLayoutConfig(..)+  , CErrorHandlingConfig(..)+  , CForwardOptions(..)+  , CPreProcessorConfig(..)+  , BrittanyError(..)+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal+import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.Config+
+ src/Language/Haskell/Brittany/Internal.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Brittany.Internal+  ( parsePrintModule+  , parsePrintModuleTests+  , pPrintModule+  , pPrintModuleAndCheck+   -- re-export from utils:+  , parseModule+  , parseModuleFromString+  )+where++++#include "prelude.inc"++import qualified Language.Haskell.GHC.ExactPrint as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types+import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers++import           Data.Data+import           Control.Monad.Trans.Either+import           Data.HList.HList+import           Data.CZipWith++import qualified Data.Text.Lazy.Builder as Text.Builder++import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.Config+import           Language.Haskell.Brittany.Internal.LayouterBasics++import           Language.Haskell.Brittany.Internal.Layouters.Type+import           Language.Haskell.Brittany.Internal.Layouters.Decl+import           Language.Haskell.Brittany.Internal.Utils+import           Language.Haskell.Brittany.Internal.Backend+import           Language.Haskell.Brittany.Internal.BackendUtils+import           Language.Haskell.Brittany.Internal.ExactPrintUtils++import           Language.Haskell.Brittany.Internal.Transformations.Alt+import           Language.Haskell.Brittany.Internal.Transformations.Floating+import           Language.Haskell.Brittany.Internal.Transformations.Par+import           Language.Haskell.Brittany.Internal.Transformations.Columns+import           Language.Haskell.Brittany.Internal.Transformations.Indent++import qualified GHC as GHC hiding (parseModule)+import           ApiAnnotation ( AnnKeywordId(..) )+import           RdrName ( RdrName(..) )+import           GHC ( runGhc, GenLocated(L), moduleNameString )+import           SrcLoc ( SrcSpan )+import           HsSyn+import qualified DynFlags as GHC+import qualified GHC.LanguageExtensions.Type as GHC++++-- | Exposes the transformation in an pseudo-pure fashion. The signature+-- contains `IO` due to the GHC API not exposing a pure parsing function, but+-- there should be no observable effects.+--+-- Note that this function ignores/resets all config values regarding+-- debugging, i.e. it will never use `trace`/write to stderr.+parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)+parsePrintModule configRaw inputText = runEitherT $ do+  let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig }+  let ghcOptions         = config & _conf_forward & _options_ghc & runIdentity+  let config_pp          = config & _conf_preprocessor+  let cppMode            = config_pp & _ppconf_CPPMode & confUnpack+  let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack+  (anns, parsedSource, hasCPP) <- do+    let hackF s = if "#include" `isPrefixOf` s+          then "-- BRITTANY_INCLUDE_HACK " ++ s+          else s+    let hackTransform = if hackAroundIncludes+          then List.unlines . fmap hackF . List.lines+          else id+    let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags+          then case cppMode of+            CPPModeAbort  -> return $ Left "Encountered -XCPP. Aborting."+            CPPModeWarn   -> return $ Right True+            CPPModeNowarn -> return $ Right True+          else return $ Right False+    parseResult <- lift $ parseModuleFromString+      ghcOptions+      "stdin"+      cppCheckFunc+      (hackTransform $ Text.unpack inputText)+    case parseResult of+      Left  err -> left $ [ErrorInput err]+      Right x   -> pure $ x+  (errsWarns, outputTextL) <- do+    let omitCheck =+          config+            & _conf_errorHandling+            & _econf_omit_output_valid_check+            & confUnpack+    (ews, outRaw) <- if hasCPP || omitCheck+      then return $ pPrintModule config anns parsedSource+      else lift $ pPrintModuleAndCheck config anns parsedSource+    let hackF s = fromMaybe s+          $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s+    pure $ if hackAroundIncludes+      then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw)+      else (ews, outRaw)+  let customErrOrder ErrorInput{}         = 4+      customErrOrder LayoutWarning{}      = 0 :: Int+      customErrOrder ErrorOutputCheck{}   = 1+      customErrOrder ErrorUnusedComment{} = 2+      customErrOrder ErrorUnknownNode{}   = 3+  let hasErrors =+        case config & _conf_errorHandling & _econf_Werror & confUnpack of+          False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)+          True  -> not $ null errsWarns+  if hasErrors then left $ errsWarns else pure $ TextL.toStrict outputTextL+++-- BrittanyErrors can be non-fatal warnings, thus both are returned instead+-- of an Either.+-- This should be cleaned up once it is clear what kinds of errors really+-- can occur.+pPrintModule+  :: Config+  -> ExactPrint.Types.Anns+  -> GHC.ParsedSource+  -> ([BrittanyError], TextL.Text)+pPrintModule conf anns parsedModule =+  let+    ((out, errs), debugStrings) =+      runIdentity+        $ MultiRWSS.runMultiRWSTNil+        $ MultiRWSS.withMultiWriterAW+        $ MultiRWSS.withMultiWriterAW+        $ MultiRWSS.withMultiWriterW+        $ MultiRWSS.withMultiReader anns+        $ MultiRWSS.withMultiReader conf+        $ do+            traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations+              $ annsDoc anns+            ppModule parsedModule+    tracer =+      if Seq.null debugStrings+      then+        id+      else+        trace ("---- DEBUGMESSAGES ---- ")+          . foldr (seq . join trace) id debugStrings+  in+    tracer $ (errs, Text.Builder.toLazyText out)+  -- unless () $ do+  --   +  --   debugStrings `forM_` \s ->+  --     trace s $ return ()++-- | Additionally checks that the output compiles again, appending an error+-- if it does not.+pPrintModuleAndCheck+  :: Config+  -> ExactPrint.Types.Anns+  -> GHC.ParsedSource+  -> IO ([BrittanyError], TextL.Text)+pPrintModuleAndCheck conf anns parsedModule = do+  let ghcOptions     = conf & _conf_forward & _options_ghc & runIdentity+  let (errs, output) = pPrintModule conf anns parsedModule+  parseResult <- parseModuleFromString ghcOptions+                                       "output"+                                       (\_ -> return $ Right ())+                                       (TextL.unpack output)+  let errs' = errs ++ case parseResult of+        Left{}  -> [ErrorOutputCheck]+        Right{} -> []+  return (errs', output)+++-- used for testing mostly, currently.+-- TODO: use parsePrintModule instead and remove this function.+parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text)+parsePrintModuleTests conf filename input = do+  let inputStr = Text.unpack input+  parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr+  case parseResult of+    Left  (_   , s           ) -> return $ Left $ "parsing error: " ++ s+    Right (anns, parsedModule) -> do+      let omitCheck =+            conf+              &  _conf_errorHandling+              .> _econf_omit_output_valid_check+              .> confUnpack+      (errs, ltext) <- if omitCheck+        then return $ pPrintModule conf anns parsedModule+        else pPrintModuleAndCheck conf anns parsedModule+      return $ if null errs+        then Right $ TextL.toStrict $ ltext+        else+          let errStrs = errs <&> \case+                ErrorInput         str -> str+                ErrorUnusedComment str -> str+                LayoutWarning      str -> str+                ErrorUnknownNode str _ -> str+                ErrorOutputCheck       -> "Output is not syntactically valid."+          in  Left $ "pretty printing error(s):\n" ++ List.unlines errStrs+++-- this approach would for with there was a pure GHC.parseDynamicFilePragma.+-- Unfortunately that does not exist yet, so we cannot provide a nominally+-- pure interface.++-- parsePrintModuleTests :: Text -> Either String Text+-- parsePrintModuleTests input = do+--   let dflags = GHC.unsafeGlobalDynFlags+--   let fakeFileName = "SomeTestFakeFileName.hs"+--   let pragmaInfo = GHC.getOptions+--         dflags+--         (GHC.stringToStringBuffer $ Text.unpack input)+--         fakeFileName+--   (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags pragmaInfo+--   let parseResult = ExactPrint.Parsers.parseWith+--         dflags1+--         fakeFileName+--         GHC.parseModule+--         inputStr+--   case parseResult of+--     Left (_, s) -> Left $ "parsing error: " ++ s+--     Right (anns, parsedModule) -> do+--       let (out, errs) = runIdentity+--                       $ runMultiRWSTNil+--                       $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterAW+--                       $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterW+--                       $ Control.Monad.Trans.MultiRWS.Lazy.withMultiReader anns+--                       $ ppModule parsedModule+--       if (not $ null errs)+--         then do+--           let errStrs = errs <&> \case+--                 ErrorUnusedComment str -> str+--           Left $ "pretty printing error(s):\n" ++ List.unlines errStrs+--         else return $ TextL.toStrict $ Text.Builder.toLazyText out++ppModule :: GenLocated SrcSpan (HsModule RdrName) -> PPM ()+ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do+  let emptyModule = L loc m { hsmodDecls = [] }+  (anns', post) <- do+    anns <- mAsk+    -- evil partiality. but rather unlikely.+    return $ case Map.lookup (ExactPrint.Types.mkAnnKey lmod) anns of+      Nothing -> (anns, [])+      Just mAnn ->+        let modAnnsDp = ExactPrint.Types.annsDP mAnn+            isWhere (ExactPrint.Types.G AnnWhere) = True+            isWhere _                             = False+            isEof (ExactPrint.Types.G AnnEofPos) = True+            isEof _                              = False+            whereInd    = List.findIndex (isWhere . fst) modAnnsDp+            eofInd      = List.findIndex (isEof . fst) modAnnsDp+            (pre, post) = case (whereInd, eofInd) of+              (Nothing, Nothing) -> ([], modAnnsDp)+              (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp+              (Nothing, Just _i) -> ([], modAnnsDp)+              (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp+            mAnn'       = mAnn { ExactPrint.Types.annsDP = pre }+            anns'       = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns+        in  (anns', post)+  MultiRWSS.withMultiReader anns' $ processDefault emptyModule+  decls `forM_` ppDecl+  let finalComments = filter+        ( fst .> \case+          ExactPrint.Types.AnnComment{} -> True+          _                             -> False+        )+        post+  post `forM_` \case+    (ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do+      ppmMoveToExactLoc l+      mTell $ Text.Builder.fromString cmStr+    (ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX, eofY))) ->+      let+        folder (acc, _) (kw, ExactPrint.Types.DP (x, y)) = case kw of+          ExactPrint.Types.AnnComment cm+            | GHC.RealSrcSpan span <- ExactPrint.Types.commentIdentifier cm+            -> ( acc + x + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span+               , y + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span+               )+          _ -> (acc + x, y)+        (cmX, cmY) = foldl' folder (0, 0) finalComments+      in+        ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY - cmY)+    _ -> return ()++withTransformedAnns :: Data ast => ast -> PPM () -> PPM ()+withTransformedAnns ast m = do+  -- TODO: implement `local` for MultiReader/MultiRWS+  readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR+  MultiRWSS.mPutRawR (conf :+: f anns :+: HNil)+  m+  MultiRWSS.mPutRawR readers+ where+  f anns =+    let ((), (annsBalanced, _), _) =+          ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)+    in  annsBalanced+++ppDecl :: LHsDecl RdrName -> PPM ()+ppDecl d@(L loc decl) = case decl of+  SigD sig  -> -- trace (_sigHead sig) $+               withTransformedAnns d $ do+    -- runLayouter $ Old.layoutSig (L loc sig)+    briDoc <- briDocMToPPM $ layoutSig (L loc sig)+    layoutBriDoc d briDoc+  ValD bind -> -- trace (_bindHead bind) $+               withTransformedAnns d $ do+    -- Old.layoutBind (L loc bind)+    briDoc <- briDocMToPPM $ do+      eitherNode <- layoutBind (L loc bind)+      case eitherNode of+        Left  ns -> docLines $ return <$> ns+        Right n -> return n+    layoutBriDoc d briDoc+  _         -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d++_sigHead :: Sig RdrName -> String+_sigHead = \case+  TypeSig names _ ->+    "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)+  _ -> "unknown sig"++_bindHead :: HsBind RdrName -> String+_bindHead = \case+  FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)+  PatBind _pat _ _ _ ([], []) -> "PatBind smth"+  _ -> "unknown bind"++++layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM ()+layoutBriDoc ast briDoc = do+  -- first step: transform the briDoc.+  briDoc'                       <- MultiRWSS.withMultiStateS BDEmpty $ do+    -- Note that briDoc is BriDocNumbered, but state type is BriDoc.+    -- That's why the alt-transform looks a bit special here.+    traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw+      $ briDocToDoc+      $ unwrapBriDocNumbered+      $ briDoc+    -- bridoc transformation: remove alts+    transformAlts briDoc >>= mSet+    mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-alt"+                                            _dconf_dump_bridoc_simpl_alt+    -- bridoc transformation: float stuff in+    mGet >>= transformSimplifyFloating .> mSet+    mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-floating"+                                            _dconf_dump_bridoc_simpl_floating+    -- bridoc transformation: par removal+    mGet >>= transformSimplifyPar .> mSet+    mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-par"+                                            _dconf_dump_bridoc_simpl_par+    -- bridoc transformation: float stuff in+    mGet >>= transformSimplifyColumns .> mSet+    mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-columns"+                                            _dconf_dump_bridoc_simpl_columns+    -- bridoc transformation: indent+    mGet >>= transformSimplifyIndent .> mSet+    mGet >>= briDocToDoc .> traceIfDumpConf "bridoc post-indent"+                                            _dconf_dump_bridoc_simpl_indent+    mGet >>= briDocToDoc .> traceIfDumpConf "bridoc final"+                                            _dconf_dump_bridoc_final+    -- -- convert to Simple type+    -- simpl <- mGet <&> transformToSimple+    -- return simpl++  anns :: ExactPrint.Types.Anns <- mAsk+  let filteredAnns = filterAnns ast anns++  traceIfDumpConf "bridoc annotations filtered/transformed"+                  _dconf_dump_annotations+    $ annsDoc filteredAnns++  let state = LayoutState+        { _lstate_baseYs           = [0]+        , _lstate_curYOrAddNewline = Right 0 -- important that we use left here+                                             -- because moveToAnn stuff of the+                                             -- first node needs to do its+                                             -- thing properly.+        , _lstate_indLevels        = [0]+        , _lstate_indLevelLinger   = 0+        , _lstate_comments         = filteredAnns+        , _lstate_commentCol       = Nothing+        , _lstate_addSepSpace      = Nothing+        , _lstate_inhibitMTEL      = False+        }++  state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'++  let remainingComments =+        extractAllComments =<< Map.elems (_lstate_comments state')+  remainingComments+    `forM_` (fst .> show .> ErrorUnusedComment .> (:[]) .> mTell)++  return $ ()
+ src/Language/Haskell/Brittany/Internal/Backend.hs view
@@ -0,0 +1,535 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ConstraintKinds #-}++module Language.Haskell.Brittany.Internal.Backend+  ( layoutBriDocM+  )+where++++#include "prelude.inc"++import qualified Language.Haskell.GHC.ExactPrint as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types+import           Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation )++import           Language.Haskell.Brittany.Internal.LayouterBasics+import           Language.Haskell.Brittany.Internal.BackendUtils+import           Language.Haskell.Brittany.Internal.Utils+import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.Types+++import qualified Data.Text.Lazy.Builder as Text.Builder+++import           Data.HList.ContainsType++import           Control.Monad.Extra ( whenM )++import qualified Control.Monad.Trans.Writer.Strict as WriterS++++type ColIndex  = Int++data ColumnSpacing+  = ColumnSpacingLeaf Int+  | ColumnSpacingRef Int Int++type ColumnBlock  a = [a]+type ColumnBlocks a = Seq [a]+type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing)+type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)+                                          -- (ratio of hasSpace, maximum, raw)++data ColInfo+  = ColInfoStart -- start value to begin the mapAccumL.+  | ColInfoNo BriDoc+  | ColInfo ColIndex ColSig [(Int, ColInfo)]++instance Show ColInfo where+  show ColInfoStart = "ColInfoStart"+  show ColInfoNo{} = "ColInfoNo{}"+  show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list++data ColBuildState = ColBuildState+  { _cbs_map :: ColMap1+  , _cbs_index :: ColIndex+  }++type LayoutConstraints m = ( MonadMultiReader Config m+                           , MonadMultiReader ExactPrint.Types.Anns m+                           , MonadMultiWriter Text.Builder.Builder m+                           , MonadMultiWriter (Seq String) m+                           , MonadMultiState LayoutState m+                           )++layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()+layoutBriDocM = \case+  BDEmpty -> do+    return () -- can it be that simple+  BDLit t -> do+    layoutIndentRestorePostComment+    layoutRemoveIndentLevelLinger+    layoutWriteAppend t+  BDSeq list -> do+    list `forM_` layoutBriDocM+  -- in this situation, there is nothing to do about cols.+  -- i think this one does not happen anymore with the current simplifications.+  -- BDCols cSig list | BDPar sameLine lines <- List.last list ->+  --   alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines+  BDCols _ list -> do+    list `forM_` layoutBriDocM+  BDSeparator -> do+    layoutAddSepSpace+  BDAddBaseY indent bd -> do+    let indentF = case indent of+          BrIndentNone      -> id+          BrIndentRegular   -> layoutWithAddBaseCol+          BrIndentSpecial i -> layoutWithAddBaseColN i+    indentF $ layoutBriDocM bd+  BDBaseYPushCur bd -> do+    layoutBaseYPushCur+    layoutBriDocM bd+  BDBaseYPop bd -> do+    layoutBriDocM bd+    layoutBaseYPop+  BDIndentLevelPushCur bd -> do+    layoutIndentLevelPushCur+    layoutBriDocM bd+  BDIndentLevelPop bd -> do+    layoutBriDocM bd+    layoutIndentLevelPop+  BDEnsureIndent indent bd -> do+    let indentF = case indent of+          BrIndentNone      -> id+          BrIndentRegular   -> layoutWithAddBaseCol+          BrIndentSpecial i -> layoutWithAddBaseColN i+    indentF $ do+      layoutWriteEnsureBlock+      layoutBriDocM bd+  BDPar indent sameLine indented -> do+    layoutBriDocM sameLine+    let indentF = case indent of+          BrIndentNone      -> id+          BrIndentRegular   -> layoutWithAddBaseCol+          BrIndentSpecial i -> layoutWithAddBaseColN i+    indentF $ do+      layoutWriteNewlineBlock+      layoutBriDocM indented+  BDLines           lines                      -> alignColsLines lines+  BDAlt             []                         -> error "empty BDAlt"+  BDAlt             (alt:_)                    -> layoutBriDocM alt+  BDForceMultiline  bd                         -> layoutBriDocM bd+  BDForceSingleline bd                         -> layoutBriDocM bd+  BDForwardLineMode bd                         -> layoutBriDocM bd+  BDExternal annKey subKeys shouldAddComment t -> do+    let tlines     = Text.lines $ t <> Text.pack "\n"+        tlineCount = length tlines+    anns :: ExactPrint.Anns <- mAsk+    when shouldAddComment $ do+      layoutWriteAppend+        $  Text.pack+        $  "{-"+        ++ show (annKey, Map.lookup annKey anns)+        ++ "-}"+    zip [1 ..] tlines `forM_` \(i, l) -> do+      layoutWriteAppend $ l+      unless (i == tlineCount) layoutWriteNewlineBlock+    do+      state <- mGet+      let filterF k _ = not $ k `Set.member` subKeys+      mSet $ state+        { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state+        }+  BDAnnotationPrior annKey bd -> do+    state <- mGet+    let m = _lstate_comments state+    let allowMTEL = not (_lstate_inhibitMTEL state)+          && Data.Either.isRight (_lstate_curYOrAddNewline state)+    mAnn <- do+      let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m+      mSet $ state+        { _lstate_comments = Map.adjust+          (\ann -> ann { ExactPrint.annPriorComments = [] })+          annKey+          m+        }+      return mAnn+    case mAnn of+      Nothing     -> when allowMTEL $ moveToExactAnn annKey+      Just []     -> when allowMTEL $ moveToExactAnn annKey+      Just priors -> do+        -- layoutResetSepSpace+        priors+          `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->+                    do+                      -- evil hack for CPP:+                      case comment of+                        ('#':_) -> layoutMoveToCommentPos y (-999)+                        _       -> layoutMoveToCommentPos y x+                      -- fixedX <- fixMoveToLineByIsNewline x+                      -- replicateM_ fixedX layoutWriteNewline+                      -- layoutMoveToIndentCol y+                      layoutWriteAppendMultiline $ Text.pack $ comment+          -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }+        when allowMTEL $ moveToExactAnn annKey+    layoutBriDocM bd+  BDAnnotationKW annKey keyword bd -> do+    layoutBriDocM bd+    mAnn <- do+      state <- mGet+      let m    = _lstate_comments state+      let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m+      let mToSpan = case mAnn of+            Just anns | keyword == Nothing -> Just anns+            Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just+              annR+            _ -> Nothing+      case mToSpan of+        Just anns -> do+          let (comments, rest) = flip spanMaybe anns $ \case+                (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)+                _ -> Nothing+          mSet $ state+            { _lstate_comments = Map.adjust+              (\ann -> ann { ExactPrint.annsDP = rest })+              annKey+              m+            }+          return $ [ comments | not $ null comments ]+        _ -> return Nothing+    forM_ mAnn+      $ mapM_+      $ \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->+          do+            -- evil hack for CPP:+            case comment of+              ('#':_) -> layoutMoveToCommentPos y (-999)+              _       -> layoutMoveToCommentPos y x+            -- fixedX <- fixMoveToLineByIsNewline x+            -- replicateM_ fixedX layoutWriteNewline+            -- layoutMoveToIndentCol y+            layoutWriteAppendMultiline $ Text.pack $ comment+      -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }+  BDAnnotationRest annKey bd -> do+    layoutBriDocM bd+    mAnn <- do+      state <- mGet+      let m    = _lstate_comments state+      let mAnn = extractAllComments <$> Map.lookup annKey m+      mSet $ state+        { _lstate_comments = Map.adjust+          ( \ann -> ann { ExactPrint.annFollowingComments = []+                        , ExactPrint.annPriorComments     = []+                        , ExactPrint.annsDP               = []+                        }+          )+          annKey+          m+        }+      return mAnn+    forM_ mAnn+      $ mapM_+      $ \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->+          do+      -- evil hack for CPP:+            case comment of+              ('#':_) -> layoutMoveToCommentPos y (-999)+              _       -> layoutMoveToCommentPos y x+            -- fixedX <- fixMoveToLineByIsNewline x+            -- replicateM_ fixedX layoutWriteNewline+            -- layoutMoveToIndentCol y+            layoutWriteAppendMultiline $ Text.pack $ comment+      -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }+  BDNonBottomSpacing bd -> layoutBriDocM bd+  BDSetParSpacing    bd -> layoutBriDocM bd+  BDForceParSpacing  bd -> layoutBriDocM bd+  BDProhibitMTEL     bd -> do+    -- set flag to True for this child, but disable afterwards.+    -- two hard aspects+    -- 1) nesting should be allowed. this means that resetting at the end must+    --    not indiscriminantely set to False, but take into account the+    --    previous value+    -- 2) nonetheless, newlines cancel inhibition. this means that if we ever+    --    find the flag set to False afterwards, we must not return it to+    --    the previous value, which might be True in the case of testing; it+    --    must remain False.+    state <- mGet+    mSet $ state { _lstate_inhibitMTEL = True }+    layoutBriDocM bd+    state' <- mGet+    when (_lstate_inhibitMTEL state') $ do+      mSet $ state' { _lstate_inhibitMTEL = _lstate_inhibitMTEL state }+  BDDebug s bd -> do+    mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"+    layoutBriDocM bd++briDocLineLength :: BriDoc -> Int+briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc+                          -- the state encodes whether a separator was already+                          -- appended at the current position.+ where+  rec = \case+    BDEmpty                 -> return $ 0+    BDLit t                 -> StateS.put False $> Text.length t+    BDSeq bds               -> sum <$> rec `mapM` bds+    BDCols _ bds            -> sum <$> rec `mapM` bds+    BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1+    BDAddBaseY _ bd         -> rec bd+    BDBaseYPushCur       bd -> rec bd+    BDBaseYPop           bd -> rec bd+    BDIndentLevelPushCur bd -> rec bd+    BDIndentLevelPop     bd -> rec bd+    BDPar _ line _          -> rec line+    BDAlt{}                 -> error "briDocLineLength BDAlt"+    BDForceMultiline  bd    -> rec bd+    BDForceSingleline bd    -> rec bd+    BDForwardLineMode bd    -> rec bd+    BDExternal _ _ _ t      -> return $ Text.length t+    BDAnnotationPrior _ bd  -> rec bd+    BDAnnotationKW _ _ bd   -> rec bd+    BDAnnotationRest _ bd   -> rec bd+    BDLines ls@(_:_)        -> do+      x <- StateS.get+      return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x+    BDLines []            -> error "briDocLineLength BDLines []"+    BDEnsureIndent _ bd   -> rec bd+    BDProhibitMTEL     bd -> rec bd+    BDSetParSpacing    bd -> rec bd+    BDForceParSpacing  bd -> rec bd+    BDNonBottomSpacing bd -> rec bd+    BDDebug _ bd          -> rec bd++briDocIsMultiLine :: BriDoc -> Bool+briDocIsMultiLine briDoc = rec briDoc+ where+  rec :: BriDoc -> Bool+  rec = \case+    BDEmpty                 -> False+    BDLit _                 -> False+    BDSeq bds               -> any rec bds+    BDCols _ bds            -> any rec bds+    BDSeparator             -> False+    BDAddBaseY _ bd         -> rec bd+    BDBaseYPushCur       bd -> rec bd+    BDBaseYPop           bd -> rec bd+    BDIndentLevelPushCur bd -> rec bd+    BDIndentLevelPop     bd -> rec bd+    BDPar _ _ _             -> True+    BDAlt{}                 -> error "briDocIsMultiLine BDAlt"+    BDForceMultiline  _     -> True+    BDForceSingleline bd    -> rec bd+    BDForwardLineMode bd    -> rec bd+    BDExternal _ _ _ _      -> True+    BDAnnotationPrior _ bd  -> rec bd+    BDAnnotationKW _ _ bd   -> rec bd+    BDAnnotationRest _ bd   -> rec bd+    BDLines (_:_:_)         -> True+    BDLines [_    ]         -> False+    BDLines []              -> error "briDocIsMultiLine BDLines []"+    BDEnsureIndent _ bd     -> rec bd+    BDProhibitMTEL     bd   -> rec bd+    BDSetParSpacing    bd   -> rec bd+    BDForceParSpacing  bd   -> rec bd+    BDNonBottomSpacing bd   -> rec bd+    BDDebug _ bd            -> rec bd++alignColsLines :: LayoutConstraints m => [BriDoc] -> m ()+alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do+  curX <- do+    state <- mGet+    return $ either id (const 0) (_lstate_curYOrAddNewline state) + fromMaybe+      0+      (_lstate_addSepSpace state)+  colMax     <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack+  alignMax   <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack+  alignBreak <-+    mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack+  case () of+    _ ->+      sequence_+        $   List.intersperse layoutWriteEnsureNewlineBlock+        $   colInfos+        <&> processInfo processedMap+     where+      (colInfos, finalState) =+        StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0)+      -- maxZipper :: [Int] -> [Int] -> [Int]+      -- maxZipper [] ys = ys+      -- maxZipper xs [] = xs+      -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr+      colAggregation :: [Int] -> Int+      colAggregation xs = maximum [ x | x <- xs, x < minimum xs + alignMax ]++      processedMap :: ColMap2+      processedMap =+        fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) ->+          let+            colss = colSpacingss <&> \spss -> case reverse spss of+              [] -> []+              (xN:xR) ->+                reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR+             where+              fLast (ColumnSpacingLeaf len ) = len+              fLast (ColumnSpacingRef len _) = len+              fInit (ColumnSpacingLeaf len) = len+              fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of+                Nothing           -> 0+                Just (_, maxs, _) -> sum maxs+            maxCols = {-Foldable.foldl1 maxZipper-}+              fmap colAggregation $ transpose $ Foldable.toList colss+            (_, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols+            counter count l = if List.last posXs + List.last l <= colMax+              then count + 1+              else count+            ratio = fromIntegral (foldl counter (0 :: Int) colss)+              / fromIntegral (length colss)+          in+            (ratio, maxCols, colss)++      mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]+      mergeBriDocs bds = mergeBriDocsW ColInfoStart bds++      mergeBriDocsW+        :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]+      mergeBriDocsW _        []       = return []+      mergeBriDocsW lastInfo (bd:bdr) = do+        info  <- mergeInfoBriDoc True lastInfo bd+        infor <- mergeBriDocsW+          (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info)+          bdr+        return $ info : infor++      mergeInfoBriDoc+        :: Bool+        -> ColInfo+        -> BriDoc+        -> StateS.StateT ColBuildState Identity ColInfo+      mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag+      mergeInfoBriDoc lastFlag ColInfoNo{}  = briDocToColInfo lastFlag+      mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) =+        \case+          brdc@(BDCols colSig subDocs)+            | infoSig == colSig && length subLengthsInfos == length subDocs+            -> do+              let+                isLastList = if lastFlag+                  then (==length subDocs) <$> [1 ..]+                  else repeat False+              infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs+                `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd+              let curLengths   = briDocLineLength <$> subDocs+              let trueSpacings = getTrueSpacings (zip curLengths infos)+              do -- update map+                s <- StateS.get+                let m                  = _cbs_map s+                let (Just (_, spaces)) = IntMapS.lookup infoInd m+                StateS.put s+                  { _cbs_map = IntMapS.insert+                    infoInd+                    (lastFlag, spaces Seq.|> trueSpacings)+                    m+                  }+              return $ ColInfo infoInd colSig (zip curLengths infos)+            | otherwise+            -> briDocToColInfo lastFlag brdc+          brdc -> return $ ColInfoNo brdc++briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo+briDocToColInfo lastFlag = \case+  BDCols sig list -> withAlloc lastFlag $ \ind -> do+    let isLastList =+          if lastFlag then (==length list) <$> [1 ..] else repeat False+    subInfos <- zip isLastList list `forM` uncurry briDocToColInfo+    let lengthInfos  = zip (briDocLineLength <$> list) subInfos+    let trueSpacings = getTrueSpacings lengthInfos+    return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)+  bd -> return $ ColInfoNo bd++getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]+getTrueSpacings lengthInfos = lengthInfos <&> \case+  (len, ColInfo i _ _) -> ColumnSpacingRef len i+  (len, _            ) -> ColumnSpacingLeaf len++withAlloc+  :: Bool+  -> (  ColIndex+     -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)+     )+  -> StateS.State ColBuildState ColInfo+withAlloc lastFlag f = do+  cbs <- StateS.get+  let ind = _cbs_index cbs+  StateS.put $ cbs { _cbs_index = ind + 1 }+  (space, info) <- f ind+  StateS.get >>= \c -> StateS.put+    $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c }+  return info++processInfo :: LayoutConstraints m => ColMap2 -> ColInfo -> m ()+processInfo m = \case+  ColInfoStart       -> error "should not happen (TM)"+  ColInfoNo doc      -> layoutBriDocM doc+  ColInfo ind _ list -> do+    colMax    <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack+    alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack+    curX      <- do+      state <- mGet+      return $ either id (const 0) (_lstate_curYOrAddNewline state) + fromMaybe+        0+        (_lstate_addSepSpace state)+    -- tellDebugMess $ show curX+    let Just (ratio, maxCols, _colss) = IntMapS.lookup ind m+    let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols+    -- handle the cases that the vertical alignment leads to more than max+    -- cols:+    -- this is not a full fix, and we must correct individually in addition.+    -- because: the (at least) line with the largest element in the last+    -- column will always still overflow, because we just updated the column+    -- sizes in such a way that it works _if_ we have sizes (*factor)+    -- in each column. but in that line, in the last column, we will be+    -- forced to occupy the full vertical space, not reduced by any factor.+    let fixedPosXs = case alignMode of+          ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX)+           where+            factor :: Float =+              -- 0.0001 as an offering to the floating point gods.+                              min+              1.0001+              (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX))+            offsets = (subtract curX) <$> posXs+            fixed   = offsets <&> fromIntegral .> (*factor) .> truncate+          _ -> posXs+    let alignAct = zip fixedPosXs list `forM_` \(destX, x) -> do+          layoutWriteEnsureAbsoluteN destX+          processInfo m (snd x)+        noAlignAct = list `forM_` (snd .> processInfoIgnore)+        animousAct =+          -- per-item check if there is overflowing.+                     if List.last fixedPosXs + fst (List.last list) > colMax+          then noAlignAct+          else alignAct+    case alignMode of+      ColumnAlignModeDisabled                        -> noAlignAct+      ColumnAlignModeUnanimously | maxX <= colMax    -> alignAct+      ColumnAlignModeUnanimously                     -> noAlignAct+      ColumnAlignModeMajority limit | ratio >= limit -> animousAct+      ColumnAlignModeMajority{}                      -> noAlignAct+      ColumnAlignModeAnimouslyScale{}                -> animousAct+      ColumnAlignModeAnimously                       -> animousAct+      ColumnAlignModeAlways                          -> alignAct++processInfoIgnore :: LayoutConstraints m => ColInfo -> m ()+processInfoIgnore = \case+  ColInfoStart     -> error "should not happen (TM)"+  ColInfoNo doc    -> layoutBriDocM doc+  ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)+
+ src/Language/Haskell/Brittany/Internal/BackendUtils.hs view
@@ -0,0 +1,605 @@+#define INSERTTRACES 0++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeApplications #-}+#if !INSERTTRACES+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif++module Language.Haskell.Brittany.Internal.BackendUtils+  ( layoutWriteAppend+  , layoutWriteAppendMultiline+  , layoutWriteNewlineBlock+  , layoutWriteNewline+  , layoutWriteEnsureNewlineBlock+  , layoutWriteEnsureBlock+  , layoutWithAddBaseCol+  , layoutWithAddBaseColBlock+  , layoutWithAddBaseColN+  , layoutWithAddBaseColNBlock+  , layoutBaseYPushCur+  , layoutBaseYPop+  , layoutIndentLevelPushCur+  , layoutIndentLevelPop+  , layoutWriteEnsureAbsoluteN+  , layoutAddSepSpace+  , layoutSetCommentCol+  , layoutMoveToCommentPos+  , layoutIndentRestorePostComment+  , moveToExactAnn+  , ppmMoveToExactLoc+  , layoutWritePriorComments+  , layoutWritePostComments+  , layoutRemoveIndentLevelLinger+  )+where+++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.GHC.ExactPrint.Types ( AnnKey+                                                       , Annotation+                                                       , KeywordId+                                                       )++import qualified Data.Text.Lazy.Builder as Text.Builder+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint+import           Language.Haskell.Brittany.Internal.Utils++import           GHC ( Located, GenLocated(L), moduleNameString )++++traceLocal+  :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m, Show a)+  => a+  -> m ()+#if INSERTTRACES+traceLocal x = do+  mGet >>= tellDebugMessShow @LayoutState+  tellDebugMessShow x+#else+traceLocal _ = return ()+#endif+++layoutWriteAppend+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiWriter (Seq String) m+     )+  => Text+  -> m ()+layoutWriteAppend t = do+  traceLocal ("layoutWriteAppend", t)+  state <- mGet+  case _lstate_curYOrAddNewline state of+    Right i -> do+#if INSERTTRACES+      tellDebugMessShow ("  inserted newlines: ", i)+#endif+      replicateM_ i $ mTell $ Text.Builder.fromString $ "\n"+    Left{} -> do+#if INSERTTRACES+      tellDebugMessShow ("  inserted no newlines")+#endif+      return ()+  let spaces = case _lstate_addSepSpace state of+        Just i -> i+        Nothing -> 0+#if INSERTTRACES+  tellDebugMessShow ("  inserted spaces: ", spaces)+#endif+  mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ')+  mTell $ Text.Builder.fromText $ t+  mModify $ \s -> s+    { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of+        Left c -> c + Text.length t + spaces+        Right{} -> Text.length t + spaces+    , _lstate_addSepSpace = Nothing+    }++layoutWriteAppendSpaces+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiWriter (Seq String) m+     )+  => Int+  -> m ()+layoutWriteAppendSpaces i = do+  traceLocal ("layoutWriteAppendSpaces", i)+  unless (i == 0) $ do+    state <- mGet+    mSet $ state+      { _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state+      }++layoutWriteAppendMultiline+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiWriter (Seq String) m+     )+  => Text+  -> m ()+layoutWriteAppendMultiline t = do+  traceLocal ("layoutWriteAppendMultiline", t)+  case Text.lines t of+    []     -> layoutWriteAppend t -- need to write empty, too.+    (l:lr) -> do+      layoutWriteAppend l+      lr `forM_` \x -> do+        layoutWriteNewline+        layoutWriteAppend x++-- adds a newline and adds spaces to reach the base column.+layoutWriteNewlineBlock+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiWriter (Seq String) m+     )+  => m ()+layoutWriteNewlineBlock = do+  traceLocal ("layoutWriteNewlineBlock")+  state <- mGet+  mSet $ state { _lstate_curYOrAddNewline = Right 1+               , _lstate_addSepSpace      = Just $ lstate_baseY state+               , _lstate_inhibitMTEL      = False+               }++-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m+--                     , MonadMultiWriter (Seq String) m) => Int -> m ()+-- layoutMoveToIndentCol i = do+-- #if INSERTTRACES+--   tellDebugMessShow ("layoutMoveToIndentCol", i)+-- #endif+--   state <- mGet+--   mSet $ state+--     { _lstate_addSepSpace = Just+--                           $ if isJust $ _lstate_addNewline state+--         then i +--         else _lstate_indLevelLinger state + i - _lstate_curY state+--     }++layoutSetCommentCol+  :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()+layoutSetCommentCol = do+  state <- mGet+  let col = case _lstate_curYOrAddNewline state of+        Left i  -> i + fromMaybe 0 (_lstate_addSepSpace state)+        Right{} -> lstate_baseY state+  traceLocal ("layoutSetCommentCol", col)+  unless (Data.Maybe.isJust $ _lstate_commentCol state)+    $ mSet state { _lstate_commentCol = Just col }++layoutMoveToCommentPos+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiWriter (Seq String) m+     )+  => Int+  -> Int+  -> m ()+layoutMoveToCommentPos y x = do+  traceLocal ("layoutMoveToCommentPos", y, x)+  state <- mGet+  if Data.Maybe.isJust (_lstate_commentCol state)+    then do+      mSet state+        { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of+          Left i  -> if y == 0 then Left i else Right y+          Right{} -> Right y+        , _lstate_addSepSpace = Just $ case _lstate_curYOrAddNewline state of+          Left{}  -> if y == 0 then x else _lstate_indLevelLinger state + x+          Right{} -> _lstate_indLevelLinger state + x+        }+    else do+      mSet state+        { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of+          Left i  -> if y == 0 then Left i else Right y+          Right{} -> Right y+        , _lstate_addSepSpace = Just+          $ if y == 0 then x else _lstate_indLevelLinger state + x+        , _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of+          Left i  -> i + fromMaybe 0 (_lstate_addSepSpace state)+          Right{} -> lstate_baseY state+        }++-- | does _not_ add spaces to again reach the current base column.+layoutWriteNewline+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiWriter (Seq String) m+     )+  => m ()+layoutWriteNewline = do+  traceLocal ("layoutWriteNewline")+  state <- mGet+  mSet $ state+    { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of+      Left{}  -> Right 1+      Right i -> Right (i + 1)+    , _lstate_addSepSpace      = Nothing+    , _lstate_inhibitMTEL      = False+    }++layoutWriteEnsureNewlineBlock+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiWriter (Seq String) m+     )+  => m ()+layoutWriteEnsureNewlineBlock = do+  traceLocal ("layoutWriteEnsureNewlineBlock")+  state <- mGet+  mSet $ state+    { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of+      Left{}  -> Right 1+      Right i -> Right $ max 1 i+    , _lstate_addSepSpace      = Just $ lstate_baseY state+    , _lstate_inhibitMTEL      = False+    , _lstate_commentCol       = Nothing+    }++layoutWriteEnsureAbsoluteN+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiWriter (Seq String) m+     )+  => Int+  -> m ()+layoutWriteEnsureAbsoluteN n = do+  state <- mGet+  let diff = case _lstate_curYOrAddNewline state of+        Left i  -> n - i+        Right{} -> n+  traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)+  when (diff > 0) $ do+    mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to+                                            -- at least (Just 1), so we won't+                                            -- overwrite any old value in any+                                            -- bad way.+                 }++layoutBaseYPushInternal+  :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m)+  => Int+  -> m ()+layoutBaseYPushInternal i = do+  traceLocal ("layoutBaseYPushInternal", i)+  mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s }++layoutBaseYPopInternal+  :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()+layoutBaseYPopInternal = do+  traceLocal ("layoutBaseYPopInternal")+  mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s }++layoutIndentLevelPushInternal+  :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m)+  => Int+  -> m ()+layoutIndentLevelPushInternal i = do+  traceLocal ("layoutIndentLevelPushInternal", i)+  mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s+                    , _lstate_indLevels      = i : _lstate_indLevels s+                    }++layoutIndentLevelPopInternal+  :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()+layoutIndentLevelPopInternal = do+  traceLocal ("layoutIndentLevelPopInternal")+  mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s+                    , _lstate_indLevels      = List.tail $ _lstate_indLevels s+                    }++layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m+             , MonadMultiWriter (Seq String) m+             ) => m ()+layoutRemoveIndentLevelLinger = do+#if INSERTTRACES+  tellDebugMessShow ("layoutRemoveIndentLevelLinger")+#endif+  mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s+                    }++layoutWithAddBaseCol+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiReader Config m+     , MonadMultiWriter (Seq String) m+     )+  => m ()+  -> m ()+layoutWithAddBaseCol m = do+#if INSERTTRACES+  tellDebugMessShow ("layoutWithAddBaseCol")+#endif+  amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack+  state <- mGet+  layoutBaseYPushInternal $ lstate_baseY state + amount+  m+  layoutBaseYPopInternal++layoutWithAddBaseColBlock+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiReader Config m+     , MonadMultiWriter (Seq String) m+     )+  => m ()+  -> m ()+layoutWithAddBaseColBlock m = do+#if INSERTTRACES+  tellDebugMessShow ("layoutWithAddBaseColBlock")+#endif+  amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack+  state <- mGet+  layoutBaseYPushInternal $ lstate_baseY state + amount+  layoutWriteEnsureBlock+  m+  layoutBaseYPopInternal++layoutWithAddBaseColNBlock+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiWriter (Seq String) m+     )+  => Int+  -> m ()+  -> m ()+layoutWithAddBaseColNBlock amount m = do+  traceLocal ("layoutWithAddBaseColNBlock", amount)+  state <- mGet+  layoutBaseYPushInternal $ lstate_baseY state + amount+  layoutWriteEnsureBlock+  m+  layoutBaseYPopInternal++layoutWriteEnsureBlock+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiWriter (Seq String) m+     )+  => m ()+layoutWriteEnsureBlock = do+  traceLocal ("layoutWriteEnsureBlock")+  state <- mGet+  let+    diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of+      (Nothing, Left i ) -> lstate_baseY state - i+      (Nothing, Right{}) -> lstate_baseY state+      (Just sp, Left i ) -> max sp (lstate_baseY state - i)+      (Just sp, Right{}) -> max sp (lstate_baseY state)+  -- when (diff>0) $ layoutWriteNewlineBlock+  when (diff > 0) $ do+    mSet $ state { _lstate_addSepSpace = Just $ diff }++layoutWithAddBaseColN+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiWriter (Seq String) m+     )+  => Int+  -> m ()+  -> m ()+layoutWithAddBaseColN amount m = do+#if INSERTTRACES+  tellDebugMessShow ("layoutWithAddBaseColN", amount)+#endif+  state <- mGet+  layoutBaseYPushInternal $ lstate_baseY state + amount+  m+  layoutBaseYPopInternal++layoutBaseYPushCur+  :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()+layoutBaseYPushCur = do+  traceLocal ("layoutBaseYPushCur")+  state <- mGet+  case _lstate_commentCol state of+    Nothing ->+      case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of+        (Left i , Just j ) -> layoutBaseYPushInternal (i + j)+        (Left i , Nothing) -> layoutBaseYPushInternal i+        (Right{}, _      ) -> layoutBaseYPushInternal $ lstate_baseY state+    Just cCol -> layoutBaseYPushInternal cCol++layoutBaseYPop+  :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()+layoutBaseYPop = do+  traceLocal ("layoutBaseYPop")+  layoutBaseYPopInternal++layoutIndentLevelPushCur+  :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()+layoutIndentLevelPushCur = do+  traceLocal ("layoutIndentLevelPushCur")+  state <- mGet+  let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of+        (Left i , Just j ) -> i + j+        (Left i , Nothing) -> i+        (Right{}, Just j ) -> j+        (Right{}, Nothing) -> 0+  layoutIndentLevelPushInternal y+  layoutBaseYPushInternal y++layoutIndentLevelPop+  :: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()+layoutIndentLevelPop = do+  traceLocal ("layoutIndentLevelPop")+  layoutBaseYPopInternal+  layoutIndentLevelPopInternal+  -- why are comment indentations relative to the previous indentation on+  -- the first node of an additional indentation, and relative to the outer+  -- indentation after the last node of some indented stuff? sure does not+  -- make sense.+  layoutRemoveIndentLevelLinger++layoutAddSepSpace :: (MonadMultiState LayoutState m+  , MonadMultiWriter (Seq String) m)+   => m ()+layoutAddSepSpace = do+#if INSERTTRACES+  tellDebugMessShow ("layoutAddSepSpace")+#endif+  state <- mGet+  mSet $ state+    { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state }++-- TODO: when refactoring is complete, the other version of this method+-- can probably be removed.+moveToExactAnn+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiReader (Map AnnKey Annotation) m+     , MonadMultiWriter (Seq String) m+     )+  => AnnKey+  -> m ()+moveToExactAnn annKey = do+  traceLocal ("moveToExactAnn", annKey)+  anns <- mAsk+  case Map.lookup annKey anns of+    Nothing  -> return ()+    Just ann -> do+      -- curY <- mGet <&> _lstate_curY+      let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann+      -- mModify $ \state -> state { _lstate_addNewline = Just x }+      mModify $ \state ->+        let upd = case _lstate_curYOrAddNewline state of+              Left  i -> if y == 0 then Left i else Right y+              Right i -> Right $ max y i+        in  state+              { _lstate_curYOrAddNewline = upd+              , _lstate_addSepSpace      = if Data.Either.isRight upd+                then+                  _lstate_commentCol state+                    <|> _lstate_addSepSpace state+                    <|> Just (lstate_baseY state)+                else Nothing+              , _lstate_commentCol       = Nothing+              }+-- fixMoveToLineByIsNewline :: MonadMultiState+--                                                   LayoutState m => Int -> m Int+-- fixMoveToLineByIsNewline x = do+--   newLineState <- mGet <&> _lstate_isNewline+--   return $ if newLineState == NewLineStateYes+--     then x-1+--     else x++ppmMoveToExactLoc+  :: MonadMultiWriter Text.Builder.Builder m+  => ExactPrint.DeltaPos+  -> m ()+ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do+  replicateM_ x $ mTell $ Text.Builder.fromString "\n"+  replicateM_ y $ mTell $ Text.Builder.fromString " "++layoutWritePriorComments+  :: ( Data.Data.Data ast+     , MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiWriter (Seq String) m+     )+  => Located ast+  -> m ()+layoutWritePriorComments ast = do+  mAnn <- do+    state <- mGet+    let key  = ExactPrint.mkAnnKey ast+    let anns = _lstate_comments state+    let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns+    mSet $ state+      { _lstate_comments =+          Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns+      }+    return mAnn+#if INSERTTRACES+  tellDebugMessShow ("layoutWritePriorComments", ExactPrint.mkAnnKey ast, mAnn)+#endif+  case mAnn of+    Nothing -> return ()+    Just priors -> do+      when (not $ null priors) $ layoutSetCommentCol+      priors `forM_` \( ExactPrint.Comment comment _ _+                      , ExactPrint.DP (x, y)+                      ) -> do+        replicateM_ x layoutWriteNewline+        layoutWriteAppendSpaces y+        layoutWriteAppendMultiline $ Text.pack $ comment++-- this currently only extracs from the `annsDP` field of Annotations.+-- per documentation, this seems sufficient, as the+-- "..`annFollowingComments` are only added by AST transformations ..".+layoutWritePostComments :: (Data.Data.Data ast,+                                               MonadMultiWriter Text.Builder.Builder m,+                                               MonadMultiState LayoutState m+                                               , MonadMultiWriter (Seq String) m)+                         => Located ast -> m ()+layoutWritePostComments ast = do+  mAnn <- do+    state <- mGet+    let key  = ExactPrint.mkAnnKey ast+    let anns = _lstate_comments state+    let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns+    mSet $ state+      { _lstate_comments =+          Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] })+                     key+                     anns+      }+    return mAnn+#if INSERTTRACES+  tellDebugMessShow ("layoutWritePostComments", ExactPrint.mkAnnKey ast, mAnn)+#endif+  case mAnn of+    Nothing -> return ()+    Just posts -> do+      when (not $ null posts) $ layoutSetCommentCol+      posts `forM_` \( ExactPrint.Comment comment _ _+                      , ExactPrint.DP (x, y)+                      ) -> do+        replicateM_ x layoutWriteNewline+        layoutWriteAppend $ Text.pack $ replicate y ' '+        layoutWriteAppendMultiline $ Text.pack $ comment++layoutIndentRestorePostComment+  :: ( MonadMultiState LayoutState m+     , MonadMultiWriter Text.Builder.Builder m+     , MonadMultiWriter (Seq String) m+     )+  => m ()+layoutIndentRestorePostComment = do+  state <- mGet+  let mCommentCol = _lstate_commentCol state+  let eCurYAddNL  = _lstate_curYOrAddNewline state+#if INSERTTRACES+  tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol)+#endif+  mModify $ \s -> s { _lstate_commentCol = Nothing }+  case (mCommentCol, eCurYAddNL) of+    (Just commentCol, Left{}) -> do+      layoutWriteEnsureNewlineBlock+      layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state)+    _                              -> return ()++-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,+--                                                MonadMultiWriter Text.Builder.Builder m,+--                                                MonadMultiState LayoutState m+--                                   , MonadMultiWriter (Seq String) m)+--                                 => Located ast -> m ()+-- layoutWritePriorCommentsRestore x = do+--   layoutWritePriorComments x+--   layoutIndentRestorePostComment+-- +-- layoutWritePostCommentsRestore :: (Data.Data.Data ast,+--                                                MonadMultiWriter Text.Builder.Builder m,+--                                                MonadMultiState LayoutState m+--                                                , MonadMultiWriter (Seq String) m)+--                                 => Located ast -> m ()+-- layoutWritePostCommentsRestore x = do+--   layoutWritePostComments x+--   layoutIndentRestorePostComment
+ src/Language/Haskell/Brittany/Internal/Config.hs view
@@ -0,0 +1,228 @@+module Language.Haskell.Brittany.Internal.Config+  ( CConfig(..)+  , CDebugConfig(..)+  , CLayoutConfig(..)+  , DebugConfig+  , LayoutConfig+  , Config+  , configParser+  , staticDefaultConfig+  , forwardOptionsSyntaxExtsEnabled+  , readMergePersConfig+  , showConfigYaml+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal.LayouterBasics++import qualified Data.Yaml++import           UI.Butcher.Monadic++import qualified System.Console.CmdArgs.Explicit as CmdArgs++import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.Utils++import           Data.Coerce ( Coercible, coerce )++++staticDefaultConfig :: Config+staticDefaultConfig = Config+  { _conf_version = coerce (1 :: Int)+  , _conf_debug   = DebugConfig+    { _dconf_dump_config                = coerce False+    , _dconf_dump_annotations           = coerce False+    , _dconf_dump_ast_unknown           = coerce False+    , _dconf_dump_ast_full              = coerce False+    , _dconf_dump_bridoc_raw            = coerce False+    , _dconf_dump_bridoc_simpl_alt      = coerce False+    , _dconf_dump_bridoc_simpl_floating = coerce False+    , _dconf_dump_bridoc_simpl_par      = coerce False+    , _dconf_dump_bridoc_simpl_columns  = coerce False+    , _dconf_dump_bridoc_simpl_indent   = coerce False+    , _dconf_dump_bridoc_final          = coerce False+    , _dconf_roundtrip_exactprint_only  = coerce False+    }+  , _conf_layout = LayoutConfig+    { _lconfig_cols                      = coerce (80 :: Int)+    , _lconfig_indentPolicy              = coerce IndentPolicyFree+    , _lconfig_indentAmount              = coerce (2 :: Int)+    , _lconfig_indentWhereSpecial        = coerce True+    , _lconfig_indentListSpecial         = coerce True+    , _lconfig_importColumn              = coerce (60 :: Int)+    , _lconfig_altChooser                = coerce (AltChooserBoundedSearch 3)+    , _lconfig_columnAlignMode           = coerce (ColumnAlignModeMajority 0.7)+    , _lconfig_alignmentLimit            = coerce (30 :: Int)+    , _lconfig_alignmentBreakOnMultiline = coerce True+    }+  , _conf_errorHandling = ErrorHandlingConfig+    { _econf_produceOutputOnErrors   = coerce False+    , _econf_Werror                  = coerce False+    , _econf_ExactPrintFallback      = coerce ExactPrintFallbackModeInline+    , _econf_omit_output_valid_check = coerce False+    }+  , _conf_preprocessor = PreProcessorConfig+    { _ppconf_CPPMode            = coerce CPPModeAbort+    , _ppconf_hackAroundIncludes = coerce False+    }+  , _conf_forward = ForwardOptions+    { _options_ghc = Identity []+    }+  }++forwardOptionsSyntaxExtsEnabled :: ForwardOptions+forwardOptionsSyntaxExtsEnabled = ForwardOptions+  { _options_ghc = Identity+    [ "-XLambdaCase"+    , "-XMultiWayIf"+    , "-XGADTs"+    , "-XPatternGuards"+    , "-XViewPatterns"+    , "-XTupleSections"+    , "-XExplicitForAll"+    , "-XImplicitParams"+    , "-XQuasiQuotes"+    , "-XTemplateHaskell"+    , "-XBangPatterns"+    , "-XTypeApplications"+    ]+  }++configParser :: CmdParser Identity out (CConfig Option)+configParser = do+  -- TODO: why does the default not trigger; ind never should be []!!+  ind                <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")+  cols               <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)")+  importCol          <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at")++  dumpConfig         <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)")+  dumpAnnotations    <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint")+  dumpUnknownAST     <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")+  dumpCompleteAST    <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")+  dumpBriDocRaw      <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc")+  dumpBriDocAlt      <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt")+  dumpBriDocPar      <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par")+  dumpBriDocFloating <- addSimpleBoolFlag ""+                                          ["dump-bridoc-floating"]+                                          (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")+  dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")+  dumpBriDocIndent  <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")+  dumpBriDocFinal   <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")++  outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible")+  wError            <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")+  omitValidCheck    <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid; for dev on brittany")++  roundtripOnly    <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)")++  optionsGhc        <- addFlagStringParams ""+                                           ["ghc-options"]+                                           "STRING"+                                           (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.")++  return $ Config+    { _conf_version = mempty+    , _conf_debug   = DebugConfig+      { _dconf_dump_config                = wrapLast $ falseToNothing dumpConfig+      , _dconf_dump_annotations           = wrapLast $ falseToNothing dumpAnnotations+      , _dconf_dump_ast_unknown           = wrapLast $ falseToNothing dumpUnknownAST+      , _dconf_dump_ast_full              = wrapLast $ falseToNothing dumpCompleteAST+      , _dconf_dump_bridoc_raw            = wrapLast $ falseToNothing dumpBriDocRaw+      , _dconf_dump_bridoc_simpl_alt      = wrapLast $ falseToNothing dumpBriDocAlt+      , _dconf_dump_bridoc_simpl_par      = wrapLast $ falseToNothing dumpBriDocPar+      , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating+      , _dconf_dump_bridoc_simpl_columns  = wrapLast $ falseToNothing dumpBriDocColumns+      , _dconf_dump_bridoc_simpl_indent   = wrapLast $ falseToNothing dumpBriDocIndent+      , _dconf_dump_bridoc_final          = wrapLast $ falseToNothing dumpBriDocFinal+      , _dconf_roundtrip_exactprint_only  = wrapLast $ falseToNothing roundtripOnly+      }+    , _conf_layout = LayoutConfig+      { _lconfig_cols                      = optionConcat cols+      , _lconfig_indentPolicy              = mempty+      , _lconfig_indentAmount              = optionConcat ind+      , _lconfig_indentWhereSpecial        = mempty -- falseToNothing _+      , _lconfig_indentListSpecial         = mempty -- falseToNothing _+      , _lconfig_importColumn              = optionConcat importCol+      , _lconfig_altChooser                = mempty+      , _lconfig_columnAlignMode           = mempty+      , _lconfig_alignmentLimit            = mempty+      , _lconfig_alignmentBreakOnMultiline = mempty+      }+    , _conf_errorHandling = ErrorHandlingConfig+      { _econf_produceOutputOnErrors   = wrapLast $ falseToNothing outputOnErrors+      , _econf_Werror                  = wrapLast $ falseToNothing wError+      , _econf_ExactPrintFallback      = mempty+      , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck+      }+    , _conf_preprocessor = PreProcessorConfig+      { _ppconf_CPPMode            = mempty+      , _ppconf_hackAroundIncludes = mempty+      }+    , _conf_forward = ForwardOptions+      { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ]+      }+    }+ where+  falseToNothing = Option . Bool.bool Nothing (Just True)+  wrapLast :: Option a -> Option (Semigroup.Last a)+  wrapLast = fmap Semigroup.Last+  optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a)+  optionConcat = mconcat . fmap (pure . pure)++-- configParser :: Parser Config+-- configParser = Config+--   <$> option (eitherReader $ maybe (Left "required <int>!") Right . readMaybe)+--         (long "indent" <> value 2 <> metavar "AMOUNT" <> help "spaces per indentation level")+--   <*> (Bar+--     <$> switch (long "bara" <> help "bara help")+--     <*> switch (long "barb")+--     <*> flag 3 5 (long "barc")+--   )+-- +-- configParserInfo :: ParserInfo Config+-- configParserInfo = ParserInfo+--   { infoParser      = configParser +--   , infoFullDesc    = True+--   , infoProgDesc    = return $ PP.text "a haskell code formatting utility based on ghc-exactprint"+--   , infoHeader      = return $ PP.text "brittany"+--   , infoFooter      = empty+--   , infoFailureCode = (-55)+--   , infoIntersperse = True+--   }++readMergePersConfig+  :: System.IO.FilePath -> Bool -> CConfig Option -> MaybeT IO (CConfig Option)+readMergePersConfig path shouldCreate conf = do+  exists <- liftIO $ System.Directory.doesFileExist path+  if+    | exists -> do+        contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm.+        fileConf <- case Data.Yaml.decodeEither contents of+          Left e -> do+            liftIO+              $ putStrErrLn+              $ "error reading in brittany config from " ++ path ++ ":"+            liftIO $ putStrErrLn e+            mzero+          Right x -> return x+        return $ fileConf Semigroup.<> conf+    | shouldCreate -> do+        liftIO $ ByteString.writeFile path+               $ Data.Yaml.encode+               $ cMap (Option . Just . runIdentity) staticDefaultConfig+        return $ conf+    | otherwise -> do+        return conf++showConfigYaml :: Config -> String+showConfigYaml = Data.ByteString.Char8.unpack+               . Data.Yaml.encode+               . cMap (\(Identity x) -> Just x)+
+ src/Language/Haskell/Brittany/Internal/Config/Types.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Language.Haskell.Brittany.Internal.Config.Types+where++++#include "prelude.inc"++import Data.Yaml+import qualified Data.Aeson.Types as Aeson+import GHC.Generics++import Data.Data ( Data )++import Data.Coerce ( Coercible, coerce )++import Data.Semigroup.Generic+import Data.Semigroup ( Last, Option )++import Data.CZipWith++++confUnpack :: Coercible a b => Identity a -> b+confUnpack (Identity x) = coerce x++data CDebugConfig f = DebugConfig+  { _dconf_dump_config                :: f (Semigroup.Last Bool)+  , _dconf_dump_annotations           :: f (Semigroup.Last Bool)+  , _dconf_dump_ast_unknown           :: f (Semigroup.Last Bool)+  , _dconf_dump_ast_full              :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_raw            :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_simpl_alt      :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_simpl_par      :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_simpl_columns  :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_simpl_indent   :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_final          :: f (Semigroup.Last Bool)+  , _dconf_roundtrip_exactprint_only  :: f (Semigroup.Last Bool)+  }+  deriving (Generic)++data CLayoutConfig f = LayoutConfig+  { _lconfig_cols         :: f (Last Int) -- the thing that has default 80.+  , _lconfig_indentPolicy :: f (Last IndentPolicy)+  , _lconfig_indentAmount :: f (Last Int)+  , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO).+  , _lconfig_indentListSpecial  :: f (Last Bool) -- use some special indentation for ","+                                                 -- when creating zero-indentation+                                                 -- multi-line list literals.+  , _lconfig_importColumn :: f (Last Int)+  , _lconfig_altChooser      :: f (Last AltChooser)+  , _lconfig_columnAlignMode :: f (Last ColumnAlignMode)+  , _lconfig_alignmentLimit  :: f (Last Int)+    -- roughly speaking, this sets an upper bound to the number of spaces+    -- inserted to create horizontal alignment.+    -- More specifically, if 'xs' are the widths of the columns in some+    -- alignment-block, then the block will be aligned with the width+    -- maximum [ x | x <- xs, x < minimum xs + alignmentLimit ].+  , _lconfig_alignmentBreakOnMultiline :: f (Last Bool)+    -- stops alignment between items that are not layouted as a single line.+    -- e.g. for single-line alignment, things remain unchanged:+    --   do+    --     short       <- stuff+    --     loooooooong <- stuff+    -- but not in cases such as:+    --   do+    --     short <- some more stuff+    --       that requires two lines+    --     loooooooong <- stuff+  }+  deriving (Generic)++data CForwardOptions f = ForwardOptions+  { _options_ghc :: f [String]+  }+  deriving (Generic)++data CErrorHandlingConfig f = ErrorHandlingConfig+  { _econf_produceOutputOnErrors   :: f (Semigroup.Last Bool)+  , _econf_Werror                  :: f (Semigroup.Last Bool)+  , _econf_ExactPrintFallback      :: f (Semigroup.Last ExactPrintFallbackMode)+    -- ^ Determines when to fall back on the exactprint'ed output when+    -- syntactical constructs are encountered which are not yet handled by+    -- brittany.+    -- Note that the "risky" setting is risky because even with the check of+    -- the syntactic validity of the brittany output, at least in theory there+    -- may be cases where the output is syntactically/semantically valid but+    -- has different semantics than the code pre-transformation.+  , _econf_omit_output_valid_check :: f (Semigroup.Last Bool)+  }+  deriving (Generic)++data CPreProcessorConfig f = PreProcessorConfig+  { _ppconf_CPPMode :: f (Semigroup.Last CPPMode)+  , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool)+  }+  deriving (Generic)++data CConfig f = Config+  { _conf_version       :: f (Semigroup.Last Int)+  , _conf_debug         :: CDebugConfig f+  , _conf_layout        :: CLayoutConfig f+  , _conf_errorHandling :: CErrorHandlingConfig f+  , _conf_forward       :: CForwardOptions f+  , _conf_preprocessor  :: CPreProcessorConfig f+  }+  deriving (Generic)++type DebugConfig = CDebugConfig Identity+type LayoutConfig = CLayoutConfig Identity+type ForwardOptions = CForwardOptions Identity+type ErrorHandlingConfig = CErrorHandlingConfig Identity+type Config = CConfig Identity++-- i wonder if any Show1 stuff could be leveraged.+deriving instance Show (CDebugConfig Identity)+deriving instance Show (CLayoutConfig Identity)+deriving instance Show (CErrorHandlingConfig Identity)+deriving instance Show (CForwardOptions Identity)+deriving instance Show (CPreProcessorConfig Identity)+deriving instance Show (CConfig Identity)++deriving instance Show (CDebugConfig Option)+deriving instance Show (CLayoutConfig Option)+deriving instance Show (CErrorHandlingConfig Option)+deriving instance Show (CForwardOptions Option)+deriving instance Show (CPreProcessorConfig Option)+deriving instance Show (CConfig Option)++deriving instance Data (CDebugConfig Identity)+deriving instance Data (CLayoutConfig Identity)+deriving instance Data (CErrorHandlingConfig Identity)+deriving instance Data (CForwardOptions Identity)+deriving instance Data (CPreProcessorConfig Identity)+deriving instance Data (CConfig Identity)++instance Semigroup.Semigroup (CDebugConfig Option) where+  (<>) = gmappend+instance Semigroup.Semigroup (CLayoutConfig Option) where+  (<>) = gmappend+instance Semigroup.Semigroup (CErrorHandlingConfig Option) where+  (<>) = gmappend+instance Semigroup.Semigroup (CForwardOptions Option) where+  (<>) = gmappend+instance Semigroup.Semigroup (CPreProcessorConfig Option) where+  (<>) = gmappend+instance Semigroup.Semigroup (CConfig Option) where+  (<>) = gmappend++instance Semigroup.Semigroup (CDebugConfig Identity) where+  (<>) = gmappend+instance Semigroup.Semigroup (CLayoutConfig Identity) where+  (<>) = gmappend+instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where+  (<>) = gmappend+instance Semigroup.Semigroup (CForwardOptions Identity) where+  (<>) = gmappend+instance Semigroup.Semigroup (CPreProcessorConfig Identity) where+  (<>) = gmappend+instance Semigroup.Semigroup (CConfig Identity) where+  (<>) = gmappend++instance Monoid (CDebugConfig Option) where+  mempty = gmempty+  mappend = gmappend+instance Monoid (CLayoutConfig Option) where+  mempty = gmempty+  mappend = gmappend+instance Monoid (CErrorHandlingConfig Option) where+  mempty = gmempty+  mappend = gmappend+instance Monoid (CForwardOptions Option) where+  mempty = gmempty+  mappend = gmappend+instance Monoid (CPreProcessorConfig Option) where+  mempty = gmempty+  mappend = gmappend+instance Monoid (CConfig Option) where+  mempty = gmempty+  mappend = gmappend++aesonDecodeOptionsBrittany :: Aeson.Options+aesonDecodeOptionsBrittany = Aeson.defaultOptions+  { Aeson.omitNothingFields = True+  , Aeson.fieldLabelModifier = dropWhile (=='_')+  }++#define makeFromJSON(type)\+  instance FromJSON (type) where\+    parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany+#define makeToJSON(type)\+  instance ToJSON (type) where\+    toJSON     = Aeson.genericToJSON aesonDecodeOptionsBrittany;\+    toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany++#define makeFromJSONMaybe(type)\+  instance FromJSON (type Maybe) where\+    parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany+#define makeFromJSONOption(type)\+  instance FromJSON (type Option) where\+    parseJSON = fmap (cMap Option) . parseJSON+#define makeToJSONMaybe(type)\+  instance ToJSON (type Maybe) where\+    toJSON     = Aeson.genericToJSON aesonDecodeOptionsBrittany;\+    toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany+#define makeToJSONOption(type)\+  instance ToJSON (type Option) where\+    toJSON     = toJSON     . cMap getOption;\+    toEncoding = toEncoding . cMap getOption+++makeFromJSONOption(CDebugConfig)+makeFromJSONMaybe(CDebugConfig)+makeToJSONOption(CDebugConfig)+makeToJSONMaybe(CDebugConfig)++makeFromJSON(IndentPolicy)+makeToJSON(IndentPolicy)+makeFromJSON(AltChooser)+makeToJSON(AltChooser)+makeFromJSON(ColumnAlignMode)+makeToJSON(ColumnAlignMode)+makeFromJSON(CPPMode)+makeToJSON(CPPMode)+makeFromJSON(ExactPrintFallbackMode)+makeToJSON(ExactPrintFallbackMode)++makeFromJSONOption(CLayoutConfig)+makeFromJSONMaybe(CLayoutConfig)+makeToJSONOption(CLayoutConfig)+makeToJSONMaybe(CLayoutConfig)++makeFromJSONOption(CErrorHandlingConfig)+makeFromJSONMaybe(CErrorHandlingConfig)+makeToJSONOption(CErrorHandlingConfig)+makeToJSONMaybe(CErrorHandlingConfig)++makeFromJSONOption(CForwardOptions)+makeFromJSONMaybe(CForwardOptions)+makeToJSONOption(CForwardOptions)+makeToJSONMaybe(CForwardOptions)++makeFromJSONOption(CPreProcessorConfig)+makeFromJSONMaybe(CPreProcessorConfig)+makeToJSONOption(CPreProcessorConfig)+makeToJSONMaybe(CPreProcessorConfig)++makeFromJSONOption(CConfig)+makeToJSONOption(CConfig)+makeToJSONMaybe(CConfig)++-- This custom instance ensures the "omitNothingFields" behaviour not only for+-- leafs, but for nodes of the config as well. This way e.g. "{}" is valid+-- config file content.+instance FromJSON (CConfig Maybe) where+  parseJSON (Object v) = Config+    <$> v .:?  Text.pack "conf_version"+    <*> v .:?= Text.pack "conf_debug"+    <*> v .:?= Text.pack "conf_layout"+    <*> v .:?= Text.pack "conf_errorHandling"+    <*> v .:?= Text.pack "conf_forward"+    <*> v .:?= Text.pack "conf_preprocessor"+  parseJSON invalid    = Aeson.typeMismatch "Config" invalid++-- Pretends that the value is {} when the key is not present.+(.:?=) :: FromJSON a => Object -> Text -> Parser a+o .:?= k = o .:? k >>= maybe (parseJSON (Aeson.object [])) pure++data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more+                                     -- than old indentation + amount+                  | IndentPolicyFree -- can create new indentations whereever+                  | IndentPolicyMultiple -- can create indentations only+                                         -- at any n * amount.+  deriving (Show, Generic, Data)++data AltChooser = AltChooserSimpleQuick -- always choose last alternative.+                                        -- leads to tons of sparsely filled+                                        -- lines.+                | AltChooserShallowBest -- choose the first matching alternative+                                        -- using the simplest spacing+                                        -- information for the children.+                | AltChooserBoundedSearch Int+                                        -- choose the first matching alternative+                                        -- using a bounded list of recursive+                                        -- options having sufficient space.+  deriving (Show, Generic, Data)++data ColumnAlignMode+  = ColumnAlignModeDisabled+    -- ^ Make no column alignments whatsoever+  | ColumnAlignModeUnanimously+    -- ^ Make column alignments only if it does not cause overflow for any of+    -- the affected lines.+  | ColumnAlignModeMajority Float+    -- ^ If at least (ratio::Float) of the aligned elements have sufficient+    -- space for the alignment, act like ColumnAlignModeAnimously; otherwise+    -- act like ColumnAlignModeDisabled.+  | ColumnAlignModeAnimouslyScale Int+    -- ^ Scale back columns to some degree if their sum leads to overflow.+    -- This is done in a linear fashion.+    -- The Int specifies additional columns to be added to column maximum for+    -- scaling calculation purposes.+  | ColumnAlignModeAnimously+    -- ^ Decide on a case-by-case basis if alignment would cause overflow.+    -- If it does, cancel all alignments for this (nested) column description.+  -- ColumnAlignModeAnimouslySome -- potentially to implement+  | ColumnAlignModeAlways+    -- ^ Always respect column alignments, even if it makes stuff overflow.+  deriving (Show, Generic, Data)++data CPPMode = CPPModeAbort  -- abort program on seeing -XCPP+             | CPPModeWarn   -- warn about CPP and non-roundtripping in its+                             -- presence.+             | CPPModeNowarn -- silently allow CPP, if possible (i.e. input is+                             -- file.)+  deriving (Show, Generic, Data)++data ExactPrintFallbackMode+  = ExactPrintFallbackModeNever  -- never fall back on exactprinting+  | ExactPrintFallbackModeInline -- fall back only if there are no newlines in+                                 -- the exactprint'ed output.+  | ExactPrintFallbackModeRisky  -- fall back even in the presence of newlines.+                                 -- THIS MAY THEORETICALLY CHANGE SEMANTICS OF+                                 -- A PROGRAM BY TRANSFORMING IT.+  deriving (Show, Generic, Data)++cMap :: CZipWith k => (forall a . f a -> g a) -> k f -> k g+cMap f c = cZipWith (\_ -> f) c c++deriveCZipWith ''CDebugConfig+deriveCZipWith ''CLayoutConfig+deriveCZipWith ''CErrorHandlingConfig+deriveCZipWith ''CForwardOptions+deriveCZipWith ''CPreProcessorConfig+deriveCZipWith ''CConfig+
+ src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Brittany.Internal.ExactPrintUtils+  ( parseModule+  , parseModuleFromString+  , commentAnnFixTransform+  , commentAnnFixTransformGlob+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.LayouterBasics+import           Language.Haskell.Brittany.Internal.Utils++import           DynFlags ( getDynFlags )+import           GHC ( runGhc, GenLocated(L), moduleNameString )+import qualified DynFlags      as GHC+import qualified GHC           as GHC hiding (parseModule)+import qualified Parser        as GHC+import qualified SrcLoc        as GHC+import           RdrName ( RdrName(..) )+import           HsSyn+import           SrcLoc ( SrcSpan, Located )+import           RdrName ( RdrName(..) )++import qualified Language.Haskell.GHC.ExactPrint            as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Annotate   as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Types      as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Parsers    as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Delta      as ExactPrint++import qualified Data.Generics as SYB++++parseModule+  :: [String]+  -> System.IO.FilePath+  -> (GHC.DynFlags -> IO (Either String a))+  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))+parseModule =+  parseModuleWithCpp ExactPrint.defaultCppOptions ExactPrint.normalLayout++-- | Parse a module with specific instructions for the C pre-processor.+parseModuleWithCpp+  :: ExactPrint.CppOptions+  -> ExactPrint.DeltaOptions+  -> [String]+  -> System.IO.FilePath+  -> (GHC.DynFlags -> IO (Either String a))+  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))+parseModuleWithCpp cpp opts args fp dynCheck =+  ExactPrint.ghcWrapper $ EitherT.runEitherT $ do+    dflags0                       <- lift $ GHC.getSessionDynFlags+    (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine+      dflags0+      (GHC.noLoc <$> args)+    void $ lift $ GHC.setSessionDynFlags dflags1+    dflags2                       <- lift $ ExactPrint.initDynFlags fp+    when (not $ null leftover)+      $  EitherT.left+      $  "when parsing ghc flags: leftover flags: "+      ++ show (leftover <&> \(L _ s) -> s)+    when (not $ null warnings)+      $  EitherT.left+      $  "when parsing ghc flags: encountered warnings: "+      ++ show (warnings <&> \(L _ s) -> s)+    x <- EitherT.EitherT $ liftIO $ dynCheck dflags2+    res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp+    EitherT.hoistEither+      $ either (\(span, err) -> Left $ show span ++ ": " ++ err)+               (\(a, m) -> Right (a, m, x))+      $ ExactPrint.postParseTransform res opts++parseModuleFromString+  :: [String]+  -> System.IO.FilePath+  -> (GHC.DynFlags -> IO (Either String a))+  -> String+  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))+parseModuleFromString args fp dynCheck str =+  ExactPrint.ghcWrapper $ EitherT.runEitherT $ do+    dflags0                       <- lift $ ExactPrint.initDynFlagsPure fp str+    (dflags1, leftover, warnings) <-+      lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args)+    when (not $ null leftover)+      $  EitherT.left+      $  "when parsing ghc flags: leftover flags: "+      ++ show (leftover <&> \(L _ s) -> s)+    when (not $ null warnings)+      $  EitherT.left+      $  "when parsing ghc flags: encountered warnings: "+      ++ show (warnings <&> \(L _ s) -> s)+    x <- EitherT.EitherT $ liftIO $ dynCheck dflags1+    EitherT.hoistEither+      $ either (\(span, err) -> Left $ show span ++ ": " ++ err)+               (\(a, m) -> Right (a, m, x))+      $ ExactPrint.parseWith dflags1 fp GHC.parseModule str++-----------++commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()+commentAnnFixTransformGlob ast = do+  let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)+      extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $+                const Seq.empty `SYB.ext2Q` (\(L a b) -> f1 a b)+       where+        f1 b c = (const Seq.empty `SYB.extQ` f2 c) b+        f2 c l = Seq.singleton (l, ExactPrint.mkAnnKey (L l c))+        -- i wonder if there is a way to avoid re-constructing the L above..+  let nodes = SYB.everything (<>) extract ast+  let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey+      annsMap = Map.fromListWith+        (flip const)+        [ (GHC.realSrcSpanEnd span, annKey)+        | (GHC.RealSrcSpan span, annKey) <- Foldable.toList nodes+        ]+  nodes `forM_` (snd .> processComs annsMap)+ where+  processComs annsMap annKey1 = do+    mAnn <- State.Class.gets fst <&> Map.lookup annKey1+    mAnn `forM_` \ann1 -> do+      let priors  = ExactPrint.annPriorComments ann1+          follows = ExactPrint.annFollowingComments ann1+          assocs  = ExactPrint.annsDP ann1+      let+        processCom+          :: (ExactPrint.Comment, ExactPrint.DeltaPos)+          -> ExactPrint.TransformT Identity Bool+        processCom comPair@(com, _) =+          case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of+            GHC.UnhelpfulLoc{}    -> return True -- retain comment at current node.+            GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of+              Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of+                (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->+                  move $> False+                (x, y) | x == y -> move $> False+                _               -> return True+               where+                ExactPrint.AnnKey annKeyLoc1 con1 = annKey1+                ExactPrint.AnnKey annKeyLoc2 con2 = annKey2+                loc1                              = GHC.srcSpanStart annKeyLoc1+                loc2                              = GHC.srcSpanStart annKeyLoc2+                move = ExactPrint.modifyAnnsT $ \anns ->+                  let+                    ann2  = Data.Maybe.fromJust $ Map.lookup annKey2 anns+                    ann2' = ann2+                      { ExactPrint.annFollowingComments =+                          ExactPrint.annFollowingComments ann2 ++ [comPair]+                      }+                  in+                    Map.insert annKey2 ann2' anns+              _ -> return True -- retain comment at current node.+      priors'  <- flip filterM priors processCom+      follows' <- flip filterM follows $ processCom+      assocs'  <- flip filterM assocs $ \case+        (ExactPrint.AnnComment com, dp) -> processCom (com, dp)+        _                               -> return True+      let ann1' = ann1 { ExactPrint.annPriorComments     = priors'+                       , ExactPrint.annFollowingComments = follows'+                       , ExactPrint.annsDP               = assocs'+                       }+      ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns+  +++commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()+commentAnnFixTransform modul = SYB.everything (>>) genF modul+ where+  genF :: Data.Data.Data a => a -> ExactPrint.Transform ()+  genF = (\_ -> return ()) `SYB.extQ` exprF+  exprF :: Located (HsExpr RdrName) -> ExactPrint.Transform ()+  exprF lexpr@(L _ expr) = case expr of+    RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) ->+      moveTrailingComments lexpr (List.last fs)+    RecordUpd _lname fs@(_:_) _ _ _ _ ->+      moveTrailingComments lexpr (List.last fs)+    _ -> return ()++moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)+                     => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()+moveTrailingComments astFrom astTo = do+  let+    k1 = ExactPrint.mkAnnKey astFrom+    k2 = ExactPrint.mkAnnKey astTo+    moveComments ans = ans'+      where+        an1 = Data.Maybe.fromJust $ Map.lookup k1 ans+        an2 = Data.Maybe.fromJust $ Map.lookup k2 ans+        cs1f = ExactPrint.annFollowingComments an1+        cs2f = ExactPrint.annFollowingComments an2+        (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1)+             $ \case+               (ExactPrint.AnnComment com, dp) -> Left (com, dp)+               x -> Right x+        an1' = an1+          { ExactPrint.annsDP               = nonComments+          , ExactPrint.annFollowingComments = []+          }+        an2' = an2+          { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments+          }+        ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans++  ExactPrint.modifyAnnsT moveComments
+ src/Language/Haskell/Brittany/Internal/LayouterBasics.hs view
@@ -0,0 +1,633 @@+module Language.Haskell.Brittany.Internal.LayouterBasics+  ( processDefault+  , rdrNameToText+  , lrdrNameToText+  , lrdrNameToTextAnn+  , lrdrNameToTextAnnTypeEqualityIsSpecial+  , askIndent+  , extractAllComments+  , filterAnns+  , docEmpty+  , docLit+  , docAlt+  , docAltFilter+  , docLines+  , docCols+  , docSeq+  , docPar+  , docNodeAnnKW+  , docWrapNode+  , docWrapNodePrior+  , docWrapNodeRest+  , docForceSingleline+  , docForceMultiline+  , docEnsureIndent+  , docAddBaseY+  , docSetBaseY+  , docSetIndentLevel+  , docSeparator+  , docAnnotationPrior+  , docAnnotationKW+  , docAnnotationRest+  , docNonBottomSpacing+  , docSetParSpacing+  , docForceParSpacing+  , docDebug+  , docSetBaseAndIndent+  , briDocByExact+  , briDocByExactNoComment+  , briDocByExactInlineOnly+  , foldedAnnKeys+  , unknownNodeError+  , appSep+  , docCommaSep+  , docParenLSep+  , spacifyDocs+  , briDocMToPPM+  , allocateNode+  , docSharedWrapper+  , hasAnyCommentsBelow+  )+where++++#include "prelude.inc"++import qualified Language.Haskell.GHC.ExactPrint as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils++import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation, KeywordId )++import qualified Data.Text.Lazy.Builder as Text.Builder++import Language.Haskell.Brittany.Internal.Config.Types+import Language.Haskell.Brittany.Internal.Types+import Language.Haskell.Brittany.Internal.Utils++import           RdrName ( RdrName(..) )+import           GHC ( Located, runGhc, GenLocated(L), moduleNameString )+import qualified SrcLoc        as GHC+import           OccName ( occNameString )+import           Name ( getOccString )+import           Module ( moduleName )+import           ApiAnnotation ( AnnKeywordId(..) )++import           Data.Data+import           Data.Generics.Schemes++import           DataTreePrint++++processDefault+  :: ( ExactPrint.Annotate.Annotate ast+     , MonadMultiWriter Text.Builder.Builder m+     , MonadMultiReader ExactPrint.Types.Anns m+     )+  => Located ast+  -> m ()+processDefault x = do+  anns <- mAsk+  let str = ExactPrint.exactPrint x anns+  -- this hack is here so our print-empty-module trick does not add+  -- a newline at the start if there actually is no module header / imports+  -- / anything.+  -- TODO: instead the appropriate annotation could be removed when "cleaning"+  --       the module (header). This would remove the need for this hack!+  case str of+    "\n" -> return ()+    _    -> mTell $ Text.Builder.fromString $ str++-- | Use ExactPrint's output for this node; add a newly generated inline comment+-- at insertion position (meant to point out to the user that this node is+-- not handled by brittany yet). Useful when starting implementing new+-- syntactic constructs when children are not handled yet.+briDocByExact+  :: (ExactPrint.Annotate.Annotate ast)+  => Located ast+  -> ToBriDocM BriDocNumbered+briDocByExact ast = do+  anns <- mAsk+  traceIfDumpConf "ast"+                  _dconf_dump_ast_unknown+                  (printTreeWithCustom 100 (customLayouterF anns) ast)+  docExt ast anns True++-- | Use ExactPrint's output for this node.+-- Consider that for multi-line input, the indentation of the code produced+-- by ExactPrint might be different, and even incompatible with the indentation+-- of its surroundings as layouted by brittany. But there are safe uses of+-- this, e.g. for any top-level declarations.+briDocByExactNoComment+  :: (ExactPrint.Annotate.Annotate ast)+  => Located ast+  -> ToBriDocM BriDocNumbered+briDocByExactNoComment ast = do+  anns <- mAsk+  traceIfDumpConf "ast"+                  _dconf_dump_ast_unknown+                  (printTreeWithCustom 100 (customLayouterF anns) ast)+  docExt ast anns False++-- | Use ExactPrint's output for this node, presuming that this output does+-- not contain any newlines. If this property is not met, the semantics+-- depend on the @econf_AllowRiskyExactPrintUse@ config flag.+briDocByExactInlineOnly+  :: (ExactPrint.Annotate.Annotate ast, Data ast)+  => String+  -> Located ast+  -> ToBriDocM BriDocNumbered+briDocByExactInlineOnly infoStr ast = do+  anns <- mAsk+  traceIfDumpConf "ast"+                  _dconf_dump_ast_unknown+                  (printTreeWithCustom 100 (customLayouterF anns) ast)+  let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns+  fallbackMode <-+    mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack+  let exactPrintNode = allocateNode $ BDFExternal+        (ExactPrint.Types.mkAnnKey ast)+        (foldedAnnKeys ast)+        False+        exactPrinted+  let+    errorAction = do+      mTell $ [ErrorUnknownNode infoStr ast]+      docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"+  case (fallbackMode, Text.lines exactPrinted) of+    (ExactPrintFallbackModeNever, _  ) -> errorAction+    (_                          , [_]) -> exactPrintNode+    (ExactPrintFallbackModeRisky, _  ) -> exactPrintNode+    _                                  -> errorAction++rdrNameToText :: RdrName -> Text+-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr+rdrNameToText (Unqual occname) = Text.pack $ occNameString occname+rdrNameToText (Qual mname occname) =+  Text.pack $ moduleNameString mname ++ "." ++ occNameString occname+rdrNameToText (Orig modul occname) =+  Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname+rdrNameToText (Exact name) = Text.pack $ getOccString name++lrdrNameToText :: GenLocated l RdrName -> Text+lrdrNameToText (L _ n) = rdrNameToText n++lrdrNameToTextAnn+  :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)+  => Located RdrName+  -> m Text+lrdrNameToTextAnn ast@(L _ n) = do+  anns <- mAsk+  let t = rdrNameToText n+  let hasUni x (ExactPrint.Types.G y, _) = x == y+      hasUni _ _                         = False+  -- TODO: in general: we should _always_ process all annotaiton stuff here.+  --       whatever we don't probably should have had some effect on the+  --       output. in such cases, resorting to byExact is probably the safe+  --       choice.+  return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of+    Nothing                                   -> t+    Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of+      Exact{} | t == Text.pack "()"      -> t+      _ | any (hasUni AnnBackquote) aks  -> Text.pack "`" <> t <> Text.pack "`"+      _ | any (hasUni AnnCommaTuple) aks -> t+      _ | any (hasUni AnnOpenP) aks      -> Text.pack "(" <> t <> Text.pack ")"+      _ | otherwise                      -> t++lrdrNameToTextAnnTypeEqualityIsSpecial+  :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)+  => Located RdrName+  -> m Text+lrdrNameToTextAnnTypeEqualityIsSpecial ast = do+  x <- lrdrNameToTextAnn ast+  return $ if x == Text.pack "Data.Type.Equality~"+    then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh+    else x++askIndent :: (MonadMultiReader Config m) => m Int+askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk+++extractAllComments+  :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]+extractAllComments ann =+  ExactPrint.annPriorComments ann+    ++ ExactPrint.annFollowingComments ann+    ++ ( ExactPrint.annsDP ann >>= \case+         (ExactPrint.AnnComment com, dp) -> [(com, dp)]+         _                               -> []+       )++foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey+foldedAnnKeys ast = everything+  Set.union+  ( \x -> maybe Set.empty+                Set.singleton+                [ gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x+                | locTyCon == typeRepTyCon (typeOf x)+                , l <- gmapQi 0 cast x+                ]+  )+  ast+ where+  locTyCon = typeRepTyCon (typeOf (L () ()))++filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns+filterAnns ast anns =+  Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns++hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool+hasAnyCommentsBelow ast@(L l _) = do+  anns <- filterAnns ast <$> mAsk+  return+    $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)+    $ (=<<) extractAllComments+    $ Map.elems+    $ anns++-- new BriDoc stuff++allocateNode+  :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered+allocateNode bd = do+  i <- allocNodeIndex+  return (i, bd)++allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int+allocNodeIndex = do+  NodeAllocIndex i <- mGet+  mSet $ NodeAllocIndex (i + 1)+  return i++-- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered+-- docEmpty = allocateNode BDFEmpty+-- +-- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered+-- docLit t = allocateNode $ BDFLit t+-- +-- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m)+--        => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered+-- docExt x anns shouldAddComment = allocateNode $ BDFExternal+--                   (ExactPrint.Types.mkAnnKey x)+--                   (foldedAnnKeys x)+--                   shouldAddComment+--                   (Text.pack $ ExactPrint.exactPrint x anns)+-- +-- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered+-- docAlt l = allocateNode . BDFAlt =<< sequence l+-- +-- +-- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered+-- docSeq l = allocateNode . BDFSeq =<< sequence l+-- +-- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered+-- docLines l = allocateNode . BDFLines =<< sequence l+-- +-- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered+-- docCols sig l = allocateNode . BDFCols sig =<< sequence l+-- +-- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered+-- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm+-- +-- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered+-- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm+-- +-- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered+-- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm+-- +-- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered+-- docSeparator = allocateNode BDFSeparator+-- +-- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered+-- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm+-- +-- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered+-- docAnnotationPost  annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm+-- +-- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered+-- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm+-- +-- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered+-- appSep x = docSeq [x, docSeparator]+-- +-- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered+-- docCommaSep = appSep $ docLit $ Text.pack ","+-- +-- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered+-- docParenLSep = appSep $ docLit $ Text.pack "("+-- +-- +-- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m)+--                => Located ast+--                -> m BriDocNumbered+--                -> m BriDocNumbered+-- docPostComment ast bdm = do+--   bd <- bdm+--   allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd+-- +-- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m)+--             => Located ast+--             -> m BriDocNumbered+--             -> m BriDocNumbered+-- docWrapNode ast bdm = do+--   bd <- bdm+--   i1 <- allocNodeIndex+--   i2 <- allocNodeIndex+--   return+--     $ (,) i1+--     $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)+--     $ (,) i2+--     $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast)+--     $ bd+-- +-- docPar :: MonadMultiState NodeAllocIndex m+--        => m BriDocNumbered+--        -> m BriDocNumbered+--        -> m BriDocNumbered+-- docPar lineM indentedM = do+--   line <- lineM+--   indented <- indentedM+--   allocateNode $ BDFPar BrIndentNone line indented+-- +-- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered+-- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm+-- +-- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered+-- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm+-- +-- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered+-- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd++docEmpty :: ToBriDocM BriDocNumbered+docEmpty = allocateNode BDFEmpty++docLit :: Text -> ToBriDocM BriDocNumbered+docLit t = allocateNode $ BDFLit t++docExt+  :: (ExactPrint.Annotate.Annotate ast)+  => Located ast+  -> ExactPrint.Types.Anns+  -> Bool+  -> ToBriDocM BriDocNumbered+docExt x anns shouldAddComment = allocateNode $ BDFExternal+  (ExactPrint.Types.mkAnnKey x)+  (foldedAnnKeys x)+  shouldAddComment+  (Text.pack $ ExactPrint.exactPrint x anns)++docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered+docAlt l = allocateNode . BDFAlt =<< sequence l++docAltFilter :: [(Bool, ToBriDocM BriDocNumbered)] -> ToBriDocM BriDocNumbered+docAltFilter = docAlt . map snd . filter fst+++docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered+docSeq [] = docEmpty+docSeq l = allocateNode . BDFSeq =<< sequence l++docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered+docLines l = allocateNode . BDFLines =<< sequence l++docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered+docCols sig l = allocateNode . BDFCols sig =<< sequence l++docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm++docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docSetBaseY bdm = do+  bd <- bdm+  -- the order here is important so that these two nodes can be treated+  -- properly over at `transformAlts`.+  n1 <- allocateNode $ BDFBaseYPushCur bd+  n2 <- allocateNode $ BDFBaseYPop n1+  return n2++docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docSetIndentLevel bdm = do+  bd <- bdm+  n1 <- allocateNode $ BDFIndentLevelPushCur bd+  n2 <- allocateNode $ BDFIndentLevelPop n1+  return n2++docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docSetBaseAndIndent = docSetBaseY . docSetIndentLevel++docSeparator :: ToBriDocM BriDocNumbered+docSeparator = allocateNode BDFSeparator++docAnnotationPrior+  :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm++docAnnotationKW+  :: AnnKey+  -> Maybe AnnKeywordId+  -> ToBriDocM BriDocNumbered+  -> ToBriDocM BriDocNumbered+docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm++docAnnotationRest+  :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm++docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm++docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm++docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm++docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docDebug s bdm = allocateNode . BDFDebug s =<< bdm++appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+appSep x = docSeq [x, docSeparator]++docCommaSep :: ToBriDocM BriDocNumbered+docCommaSep = appSep $ docLit $ Text.pack ","++docParenLSep :: ToBriDocM BriDocNumbered+docParenLSep = appSep $ docLit $ Text.pack "("++docNodeAnnKW+  :: Data.Data.Data ast+  => Located ast+  -> Maybe AnnKeywordId+  -> ToBriDocM BriDocNumbered+  -> ToBriDocM BriDocNumbered+docNodeAnnKW ast kw bdm =+  docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm++class DocWrapable a where+  docWrapNode :: ( Data.Data.Data ast)+              => Located ast+              -> ToBriDocM a+              -> ToBriDocM a+  docWrapNodePrior :: ( Data.Data.Data ast)+                   => Located ast+                   -> ToBriDocM a+                   -> ToBriDocM a+  docWrapNodeRest  :: ( Data.Data.Data ast)+                   => Located ast+                   -> ToBriDocM a+                   -> ToBriDocM a++instance DocWrapable BriDocNumbered where+  docWrapNode ast bdm = do+    bd <- bdm+    i1 <- allocNodeIndex+    i2 <- allocNodeIndex+    return+      $ (,) i1+      $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)+      $ (,) i2+      $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)+      $ bd+  docWrapNodePrior ast bdm = do+    bd <- bdm+    i1 <- allocNodeIndex+    return+      $ (,) i1+      $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)+      $ bd+  docWrapNodeRest ast bdm = do+    bd <- bdm+    i2 <- allocNodeIndex+    return+      $ (,) i2+      $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)+      $ bd++instance DocWrapable a => DocWrapable [a] where+  docWrapNode ast bdsm = do+    bds <- bdsm+    case bds of+      [] -> return $ [] -- TODO: this might be bad. maybe. then again, not really. well.+      [bd] -> do+        bd' <- docWrapNode ast (return bd)+        return [bd']+      (bd1:bdR) | (bdN:bdM) <- reverse bdR -> do+        bd1' <- docWrapNodePrior ast (return bd1)+        bdN' <- docWrapNodeRest  ast (return bdN)+        return $ [bd1'] ++ reverse bdM ++ [bdN']+      _ -> error "cannot happen (TM)"+  docWrapNodePrior ast bdsm = do+    bds <- bdsm+    case bds of+      [] -> return $ []+      (bd1:bdR) -> do+        bd1' <- docWrapNodePrior ast (return bd1)+        return $ (bd1':bdR)+  docWrapNodeRest ast bdsm = do+    bds <- bdsm+    case reverse bds of+      [] -> return $ []+      (bdN:bdR) -> do+        bdN' <- docWrapNodeRest ast (return bdN)+        return $ reverse $ (bdN':bdR)++instance DocWrapable a => DocWrapable (Seq a) where+  docWrapNode ast bdsm = do+    bds <- bdsm+    case Seq.viewl bds of+      Seq.EmptyL -> return $ Seq.empty -- TODO: this might be bad. maybe. then again, not really. well.+      bd1 Seq.:< rest -> case Seq.viewr rest of+        Seq.EmptyR -> do+          bd1' <- docWrapNode ast (return bd1)+          return $ Seq.singleton bd1'+        bdM Seq.:> bdN -> do+          bd1' <- docWrapNodePrior ast (return bd1)+          bdN' <- docWrapNodeRest  ast (return bdN)+          return $ (bd1' Seq.<| bdM) Seq.|> bdN'+  docWrapNodePrior ast bdsm = do+    bds <- bdsm+    case Seq.viewl bds of+      Seq.EmptyL -> return $ Seq.empty+      bd1 Seq.:< bdR -> do+        bd1' <- docWrapNodePrior ast (return bd1)+        return $ bd1' Seq.<| bdR+  docWrapNodeRest ast bdsm = do+    bds <- bdsm+    case Seq.viewr bds of+      Seq.EmptyR -> return $ Seq.empty+      bdR Seq.:> bdN -> do+        bdN' <- docWrapNodeRest ast (return bdN)+        return $ bdR Seq.|> bdN'++instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where+  docWrapNode ast stuffM = do+    (bds, bd, x) <- stuffM+    if null bds+      then do+        bd' <- docWrapNode ast (return bd)+        return $ (bds, bd', x)+      else do+        bds' <- docWrapNodePrior ast (return bds)+        bd' <- docWrapNodeRest ast (return bd)+        return $ (bds', bd', x)+  docWrapNodePrior ast stuffM = do+    (bds, bd, x) <- stuffM+    bds' <- docWrapNodePrior ast (return bds)+    return $ (bds', bd, x)+  docWrapNodeRest ast stuffM = do+    (bds, bd, x) <- stuffM+    bd' <- docWrapNodeRest ast (return bd)+    return $ (bds, bd', x)++++docPar+  :: ToBriDocM BriDocNumbered+  -> ToBriDocM BriDocNumbered+  -> ToBriDocM BriDocNumbered+docPar lineM indentedM = do+  line     <- lineM+  indented <- indentedM+  allocateNode $ BDFPar BrIndentNone line indented++docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm++docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm++docEnsureIndent+  :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd++unknownNodeError+  :: Data.Data.Data ast => String -> ast -> ToBriDocM BriDocNumbered+unknownNodeError infoStr ast = do+  mTell $ [ErrorUnknownNode infoStr ast]+  docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"++spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered]+spacifyDocs [] = []+spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]++briDocMToPPM :: ToBriDocM a -> PPM a+briDocMToPPM m = do+  readers <- MultiRWSS.mGetRawR+  let ((x, errs), debugs) =+        runIdentity+          $ MultiRWSS.runMultiRWSTNil+          $ MultiRWSS.withMultiStateA (NodeAllocIndex 1)+          $ MultiRWSS.withMultiReaders readers+          $ MultiRWSS.withMultiWriterAW+          $ MultiRWSS.withMultiWriterAW+          $ m+  mTell debugs+  mTell errs+  return x++docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y)+docSharedWrapper f x = return <$> f x
+ src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs view
@@ -0,0 +1,487 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Language.Haskell.Brittany.Internal.Layouters.Decl+  ( layoutSig+  , layoutBind+  , layoutLocalBinds+  , layoutGuardLStmt+  , layoutPatternBind+  , layoutGrhs+  , layoutPatternBindFinal+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal.LayouterBasics+import           Language.Haskell.Brittany.Internal.Config.Types++import           RdrName ( RdrName(..) )+import           GHC ( runGhc, GenLocated(L), moduleNameString )+import           SrcLoc ( SrcSpan )+import           HsSyn+import           Name+import           BasicTypes ( InlinePragma(..)+                            , Activation(..)+                            , InlineSpec(..)+                            , RuleMatchInfo(..)+                            )+import           Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )++import           Language.Haskell.Brittany.Internal.Layouters.Type+import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr+import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt+import           Language.Haskell.Brittany.Internal.Layouters.Pattern++import           Bag ( mapBagM )++++layoutSig :: ToBriDoc Sig+layoutSig lsig@(L _loc sig) = case sig of+  TypeSig names (HsIB _ (HsWC _ _ typ)) -> docWrapNode lsig $ do+    nameStrs <- names `forM` lrdrNameToTextAnn+    let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs+    typeDoc     <- docSharedWrapper layoutType typ+    hasComments <- hasAnyCommentsBelow lsig+    docAlt+      $  [ docSeq+           [ appSep $ docWrapNodeRest lsig $ docLit nameStr+           , appSep $ docLit $ Text.pack "::"+           , docForceSingleline typeDoc+           ]+         | not hasComments+         ]+      ++ [ docAddBaseY BrIndentRegular $ docPar+           (docWrapNodeRest lsig $ docLit nameStr)+           ( docCols+             ColTyOpPrefix+             [ docLit $ Text.pack ":: "+             , docAddBaseY (BrIndentSpecial 3) $ typeDoc+             ]+           )+         ]+  InlineSig name (InlinePragma _ spec _arity phaseAct conlike) ->+    docWrapNode lsig $ do+      nameStr <- lrdrNameToTextAnn name+      let specStr = case spec of+            Inline          -> "INLINE "+            Inlinable       -> "INLINABLE "+            NoInline        -> "NOINLINE "+            EmptyInlineSpec -> "" -- i have no idea if this is correct.+      let phaseStr = case phaseAct of+            NeverActive      -> "[] "+            AlwaysActive     -> ""+            ActiveBefore _ i -> "[~" ++ show i ++ "] "+            ActiveAfter  _ i -> "[" ++ show i ++ "] "+      let conlikeStr = case conlike of+            FunLike -> ""+            ConLike -> "CONLIKE "+      docLit+        $  Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)+        <> nameStr+        <> Text.pack " #-}"+  _ -> briDocByExactNoComment lsig -- TODO++layoutGuardLStmt :: ToBriDoc' (Stmt RdrName (LHsExpr RdrName))+layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of+  BodyStmt body _ _ _      -> layoutExpr body+  BindStmt lPat expr _ _ _ -> do+    patDoc <- docSharedWrapper layoutPat lPat+    expDoc <- docSharedWrapper layoutExpr expr+    docCols ColBindStmt+            [ appSep $ colsWrapPat =<< patDoc+            , docSeq [appSep $ docLit $ Text.pack "<-", expDoc]+            ]+  _                        -> unknownNodeError "" lgstmt -- TODO++layoutBind+  :: ToBriDocC+       (HsBindLR RdrName RdrName)+       (Either [BriDocNumbered] BriDocNumbered)+layoutBind lbind@(L _ bind) = case bind of+  FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do+    idStr       <- lrdrNameToTextAnn fId+    binderDoc   <- docLit $ Text.pack "="+    funcPatDocs <-+      docWrapNode lbind+        $      docWrapNode lmatches+        $      layoutPatternBind (Just idStr) binderDoc+        `mapM` matches+    return $ Left $ funcPatDocs+  PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do+    patDocs    <- colsWrapPat =<< layoutPat pat+    clauseDocs <- layoutGrhs `mapM` grhss+    mWhereDocs <- layoutLocalBinds whereBinds+    binderDoc  <- docLit $ Text.pack "="+    hasComments <- hasAnyCommentsBelow lbind+    fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing+                                                            binderDoc+                                                            (Just patDocs)+                                                            clauseDocs+                                                            mWhereDocs+                                                            hasComments+  _ -> Right <$> unknownNodeError "" lbind++data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName)+                  | BagSig (LSig RdrName)++bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan+bindOrSigtoSrcSpan (BagBind (L l _)) = l+bindOrSigtoSrcSpan (BagSig  (L l _)) = l++layoutLocalBinds+  :: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered])+layoutLocalBinds lbinds@(L _ binds) = case binds of+  -- HsValBinds (ValBindsIn lhsBindsLR []) ->+  --   Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering+  -- x@(HsValBinds (ValBindsIn{})) ->+  --   Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x+  HsValBinds (ValBindsIn bindlrs sigs) -> do+    let+      unordered+        =  [ BagBind b | b <- Data.Foldable.toList bindlrs ]+        ++ [ BagSig s | s <- sigs ]+      ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered+    docs <- docWrapNode lbinds $ join <$> ordered `forM` \case+      BagBind b -> either id return <$> layoutBind b+      BagSig  s -> return <$> layoutSig s+    return $ Just $ docs+  x@(HsValBinds (ValBindsOut _binds _lsigs)) ->+    -- i _think_ this case never occurs in non-processed ast+    Just . (:[]) <$> unknownNodeError "HsValBinds ValBindsOut{}" x+  x@(HsIPBinds _ipBinds) -> Just . (:[]) <$> unknownNodeError "HsIPBinds" x+  EmptyLocalBinds        -> return $ Nothing++-- TODO: we don't need the `LHsExpr RdrName` anymore, now that there is+-- parSpacing stuff.B+layoutGrhs+  :: LGRHS RdrName (LHsExpr RdrName)+  -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)+layoutGrhs lgrhs@(L _ (GRHS guards body)) = do+  guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards+  bodyDoc   <- layoutExpr body+  return (guardDocs, bodyDoc, body)++layoutPatternBind+  :: Maybe Text+  -> BriDocNumbered+  -> LMatch RdrName (LHsExpr RdrName)+  -> ToBriDocM BriDocNumbered+layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do+  patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p+  let isInfix = isInfixMatch match+  patDoc     <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of+    (Just idStr, p1:pr) | isInfix -> docCols+      ColPatternsFuncInfix+      (  [appSep $ docForceSingleline p1, appSep $ docLit idStr]+      ++ (spacifyDocs $ docForceSingleline <$> pr)+      )+    (Just idStr, []   )           -> docLit idStr+    (Just idStr, ps) ->+      docCols ColPatternsFuncPrefix+        $ appSep (docLit $ idStr)+        : (spacifyDocs $ docForceSingleline <$> ps)+    (Nothing, ps) ->+      docCols ColPatterns+        $ (List.intersperse docSeparator $ docForceSingleline <$> ps)+  clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss+  mWhereDocs <- layoutLocalBinds whereBinds+  let alignmentToken = if null pats then Nothing else mIdStr+  hasComments <- hasAnyCommentsBelow lmatch+  layoutPatternBindFinal alignmentToken+                         binderDoc+                         (Just patDoc)+                         clauseDocs+                         mWhereDocs+                         hasComments++layoutPatternBindFinal+  :: Maybe Text+  -> BriDocNumbered+  -> Maybe BriDocNumbered+  -> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)]+  -> Maybe [BriDocNumbered]+  -> Bool+  -> ToBriDocM BriDocNumbered+layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do+  let patPartInline  = case mPatDoc of+        Nothing     -> []+        Just patDoc -> [appSep $ docForceSingleline $ return patDoc]+      patPartParWrap = case mPatDoc of+        Nothing     -> id+        Just patDoc -> docPar (return patDoc)+  whereIndent                                      <-+    mAsk+      <&> _conf_layout+      .>  _lconfig_indentWhereSpecial+      .>  confUnpack+      .>  Bool.bool BrIndentRegular (BrIndentSpecial 1)+  -- TODO: apart from this, there probably are more nodes below which could+  --       be shared between alternatives.+  wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of+    Nothing  -> return $ []+    Just [w] -> fmap (pure . pure) $ docAlt+      [ docEnsureIndent BrIndentRegular+        $ docSeq+            [ docLit $ Text.pack "where"+            , docSeparator+            , docForceSingleline $ return w+            ]+      , docEnsureIndent whereIndent $ docLines+        [ docLit $ Text.pack "where"+        , docEnsureIndent whereIndent+          $ docSetIndentLevel+          $ docNonBottomSpacing+          $ return w+        ]+      ]+    Just ws  -> fmap (pure . pure) $ docEnsureIndent whereIndent $ docLines+      [ docLit $ Text.pack "where"+      , docEnsureIndent whereIndent+        $   docSetIndentLevel+        $   docNonBottomSpacing+        $   docLines+        $   return+        <$> ws+      ]+  let singleLineGuardsDoc guards = appSep $ case guards of+        []  -> docEmpty+        [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g]+        gs  -> docSeq+            $  [appSep $ docLit $ Text.pack "|"]+            ++ List.intersperse docCommaSep (return <$> gs)+  docAlt+    $  -- one-line solution+       [ docCols+         (ColBindingLine alignmentToken)+         [ docSeq (patPartInline ++ [guardPart])+         , docSeq+           [ appSep $ return binderDoc+           , docForceSingleline $ return body+           , wherePart+           ]+         ]+       | not hasComments+       , [(guards, body, _bodyRaw)] <- [clauseDocs]+       , let guardPart = singleLineGuardsDoc guards+       , wherePart <- case mWhereDocs of+         Nothing  -> return @[] $ docEmpty+         Just [w] -> return @[] $ docSeq+           [ docSeparator+           , appSep $ docLit $ Text.pack "where"+           , docSetIndentLevel $ docForceSingleline $ return w+           ]+         _        -> []+       ]+    ++ -- one-line solution + where in next line(s)+       [ docLines+         $  [ docCols+              (ColBindingLine alignmentToken)+              [ docSeq (patPartInline ++ [guardPart])+              , docSeq+                [appSep $ return binderDoc, docForceParSpacing $ return body]+              ]+            ]+         ++ wherePartMultiLine+       | [(guards, body, _bodyRaw)] <- [clauseDocs]+       , let guardPart = singleLineGuardsDoc guards+       , Data.Maybe.isJust mWhereDocs+       ]+    ++ -- two-line solution + where in next line(s)+       [ docLines+         $  [ docForceSingleline+            $ docSeq (patPartInline ++ [guardPart, return binderDoc])+            , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body+            ]+         ++ wherePartMultiLine+       | [(guards, body, _bodyRaw)] <- [clauseDocs]+       , let guardPart = singleLineGuardsDoc guards+       ]+    ++ -- pattern and exactly one clause in single line, body as par;+       -- where in following lines+       [                            docLines+         $  [ docCols+              (ColBindingLine alignmentToken)+              [ docSeq (patPartInline ++ [guardPart])+              , docSeq+                [ appSep $ return binderDoc+                , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body+                ]+              ]+            ]+          -- , lineMod $ docAlt+          --   [ docSetBaseY $ return body+          --   , docAddBaseY BrIndentRegular $ return body+          --   ]+         ++ wherePartMultiLine+       | [(guards, body, _bodyRaw)] <- [clauseDocs]+       , let guardPart = singleLineGuardsDoc guards+       ]+    ++ -- pattern and exactly one clause in single line, body in new line.+       [ docLines+         $  [ docSeq (patPartInline ++ [guardPart, return binderDoc])+            , docEnsureIndent BrIndentRegular+            $ docNonBottomSpacing+            $ (docAddBaseY BrIndentRegular $ return body)+            ]+         ++ wherePartMultiLine+       | [(guards, body, _)] <- [clauseDocs]+       , let guardPart = singleLineGuardsDoc guards+       ]+    ++ -- multiple clauses added in-paragraph, each in a single line+       -- example: foo | bar = baz+       --              | lll = asd+       [ docLines+         $  [ docSeq+              [ appSep $ docForceSingleline $ return patDoc+              , docSetBaseY+              $   docLines+              $   clauseDocs+              <&> \(guardDocs, bodyDoc, _) -> do+                    let guardPart = singleLineGuardsDoc guardDocs+                    -- the docForceSingleline might seems superflous, but it+                    -- helps the alternative resolving impl.+                    docForceSingleline $ docCols+                      ColGuardedBody+                      [ guardPart+                      , docSeq+                        [ appSep $ return binderDoc+                        , docForceSingleline $ return bodyDoc+                        -- i am not sure if there is a benefit to using+                        -- docForceParSpacing additionally here:+                        -- , docAddBaseY BrIndentRegular $ return bodyDoc+                        ]+                      ]+              ]+            ]+         ++ wherePartMultiLine+       | Just patDoc <- [mPatDoc]+       ]+    ++ -- multiple clauses, each in a separate, single line+       [ docLines+         $  [ docAddBaseY BrIndentRegular+              $   patPartParWrap+              $   docLines+              $   map docSetBaseY+              $   clauseDocs+              <&> \(guardDocs, bodyDoc, _) -> do+                    let guardPart = singleLineGuardsDoc guardDocs+                    -- the docForceSingleline might seems superflous, but it+                    -- helps the alternative resolving impl.+                    docForceSingleline $ docCols+                      ColGuardedBody+                      [ guardPart+                      , docSeq+                        [ appSep $ return binderDoc+                        , docForceSingleline $ return bodyDoc+                        -- i am not sure if there is a benefit to using+                        -- docForceParSpacing additionally here:+                        -- , docAddBaseY BrIndentRegular $ return bodyDoc+                        ]+                      ]+            ]+         ++ wherePartMultiLine+       ]+    ++ -- multiple clauses, each with the guard(s) in a single line, body+       -- as a paragraph+       [ docLines+         $  [ docAddBaseY BrIndentRegular+              $   patPartParWrap+              $   docLines+              $   map docSetBaseY+              $   clauseDocs+              <&> \(guardDocs, bodyDoc, _) ->+                    docSeq+                    $ ( case guardDocs of+                        [] -> []+                        [g] ->+                          [ docForceSingleline+                          $ docSeq [appSep $ docLit $ Text.pack "|", return g]+                          ]+                        gs ->+                          [  docForceSingleline+                          $  docSeq+                          $  [appSep $ docLit $ Text.pack "|"]+                          ++ List.intersperse docCommaSep (return <$> gs)+                          ]+                      )+                      ++ [ docSeparator+                         , docCols+                           ColOpPrefix+                           [ appSep $ return binderDoc+                           , docAddBaseY BrIndentRegular+                           $ docForceParSpacing+                           $ return bodyDoc+                           ]+                         ]+            ]+         ++ wherePartMultiLine+       ]+    ++ -- multiple clauses, each with the guard(s) in a single line, body+       -- in a new line as a paragraph+       [ docLines+         $  [ docAddBaseY BrIndentRegular+              $   patPartParWrap+              $   docLines+              $   map docSetBaseY+              $   clauseDocs+              >>= \(guardDocs, bodyDoc, _) ->+                    ( case guardDocs of+                      [] -> []+                      [g] ->+                        [ docForceSingleline+                        $ docSeq [appSep $ docLit $ Text.pack "|", return g]+                        ]+                      gs ->+                        [  docForceSingleline+                        $  docSeq+                        $  [appSep $ docLit $ Text.pack "|"]+                        ++ List.intersperse docCommaSep (return <$> gs)+                        ]+                    )+                    ++ [ docCols+                         ColOpPrefix+                         [ appSep $ return binderDoc+                         , docAddBaseY BrIndentRegular+                         $ docForceParSpacing+                         $ return bodyDoc+                         ]+                       ]+            ]+         ++ wherePartMultiLine+       ]+    ++ -- conservative approach: everything starts on the left.+       [ docLines+         $  [ docAddBaseY BrIndentRegular+              $   patPartParWrap+              $   docLines+              $   map docSetBaseY+              $   clauseDocs+              >>= \(guardDocs, bodyDoc, _) ->+                    ( case guardDocs of+                        [] -> []+                        [g] ->+                          [docSeq [appSep $ docLit $ Text.pack "|", return g]]+                        (g1:gr) ->+                          ( docSeq [appSep $ docLit $ Text.pack "|", return g1]+                          : (   gr+                            <&> \g ->+                                  docSeq+                                    [appSep $ docLit $ Text.pack ",", return g]+                            )+                          )+                      )+                      ++ [ docCols+                           ColOpPrefix+                           [ appSep $ return binderDoc+                           , docAddBaseY BrIndentRegular $ return bodyDoc+                           ]+                         ]+            ]+         ++ wherePartMultiLine+       ]
+ src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs view
@@ -0,0 +1,926 @@+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Brittany.Internal.Layouters.Expr+  ( layoutExpr+  , litBriDoc+  , overLitValBriDoc+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal.LayouterBasics++import           RdrName ( RdrName(..) )+import           GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) )+import           HsSyn+import           Name+import qualified FastString+import           BasicTypes++import           Language.Haskell.Brittany.Internal.Utils+import           Language.Haskell.Brittany.Internal.Layouters.Pattern+import           Language.Haskell.Brittany.Internal.Layouters.Decl+import           Language.Haskell.Brittany.Internal.Layouters.Stmt+import           Language.Haskell.Brittany.Internal.Layouters.Type++++layoutExpr :: ToBriDoc HsExpr+layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of+  HsVar vname -> do+    docLit =<< lrdrNameToTextAnn vname+  HsUnboundVar var -> case var of+    OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname+    TrueExprHole oname -> docLit $ Text.pack $ occNameString oname+  HsRecFld{} -> do+    -- TODO+    briDocByExactInlineOnly "HsRecFld" lexpr+  HsOverLabel{} -> do+    -- TODO+    briDocByExactInlineOnly "HsOverLabel{}" lexpr+  HsIPVar{} -> do+    -- TODO+    briDocByExactInlineOnly "HsOverLabel{}" lexpr+  HsOverLit (OverLit olit _ _ _) -> do+    allocateNode $ overLitValBriDoc olit+  HsLit lit -> do+    allocateNode $ litBriDoc lit+  HsLam (MG (L _ [lmatch@(L _ (Match _ pats _ (GRHSs [lgrhs@(L _ (GRHS [] body))] (L _ EmptyLocalBinds))))]) _ _ _) -> do+    patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p+    bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body+    let funcPatternPartLine =+          docCols ColCasePattern+            $ (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator]))+    docAlt+      [ -- single line+        docSeq+        [ docLit $ Text.pack "\\"+        , docWrapNode lmatch $ docForceSingleline funcPatternPartLine+        , appSep $ docLit $ Text.pack "->"+        , docWrapNode lgrhs $ docForceSingleline bodyDoc+        ]+        -- double line+      , docSetParSpacing+      $ docAddBaseY BrIndentRegular+      $ docPar+        (docSeq+          [ docLit $ Text.pack "\\"+          , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine+          , docLit $ Text.pack "->"+          ])+        (docWrapNode lgrhs $ docForceSingleline bodyDoc)+        -- wrapped par spacing+      , docSetParSpacing+      $ docSeq+        [ docLit $ Text.pack "\\"+        , docWrapNode lmatch $ docForceSingleline funcPatternPartLine+        , appSep $ docLit $ Text.pack "->"+        , docWrapNode lgrhs $ docForceParSpacing bodyDoc+        ]+        -- conservative+      , docSetParSpacing+      $ docAddBaseY BrIndentRegular+      $ docPar+        (docSeq+          [ docLit $ Text.pack "\\"+          , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine+          , docLit $ Text.pack "->"+          ])+        (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc)+      ]+  HsLam{} ->+    unknownNodeError "HsLam too complex" lexpr+  HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do+    binderDoc <- docLit $ Text.pack "->"+    funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches+    docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+      (docLit $ Text.pack "\\case")+      (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)+  HsApp exp1@(L _ HsApp{}) exp2 -> do+    let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName])+        gather list = \case+          (L _ (HsApp l r)) -> gather (r:list) l+          x -> (x, list)+    let (headE, paramEs) = gather [exp2] exp1+    headDoc <- docSharedWrapper layoutExpr headE+    paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs+    docAlt+      [ -- foo x y+        docCols ColApp+      $ appSep (docForceSingleline headDoc)+      : spacifyDocs (docForceSingleline <$> paramDocs)+      , -- foo x+        --     y+        docSeq+        [ appSep (docForceSingleline headDoc)+        , docSetBaseY+        $ docAddBaseY BrIndentRegular+        $ docLines+        $ (docForceSingleline <$> paramDocs)+        ]+      , -- foo+        --   x+        --   y+        docSetParSpacing+      $ docAddBaseY BrIndentRegular+      $ docPar+        (docForceSingleline headDoc)+        ( docNonBottomSpacing+        $ docLines paramDocs+        )+      , -- ( multi+        --   line+        --   function+        -- )+        --   x+        --   y+        docAddBaseY BrIndentRegular+      $ docPar+        headDoc+        ( docNonBottomSpacing+        $ docLines paramDocs+        )+      ]+  HsApp exp1 exp2 -> do+    -- TODO: if expDoc1 is some literal, we may want to create a docCols here.+    expDoc1 <- docSharedWrapper layoutExpr exp1+    expDoc2 <- docSharedWrapper layoutExpr exp2+    docAlt+      [ docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2]+      , docSetParSpacing+      $ docAddBaseY BrIndentRegular+      $ docSeq+        [ appSep $ docForceSingleline expDoc1+        , docForceParSpacing expDoc2+        ]+      , docSetParSpacing+      $ docAddBaseY BrIndentRegular+      $ docPar+        (docForceSingleline expDoc1)+        expDoc2+      , docAddBaseY BrIndentRegular+      $ docPar+        expDoc1+        expDoc2+      ]+  HsAppType exp1 (HsWC _ _ ty1) -> do+    t <- docSharedWrapper layoutType ty1+    e <- docSharedWrapper layoutExpr exp1+    docAlt+      [ docSeq+          [ docForceSingleline e+          , docSeparator+          , docLit $ Text.pack "@"+          , docForceSingleline t+          ]+      , docPar+          e+          (docSeq [docLit $ Text.pack "@", t ])+      ]+  HsAppTypeOut{} -> do+    -- TODO+    briDocByExactInlineOnly "HsAppTypeOut{}" lexpr+  OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do+    let gather :: [(LHsExpr RdrName, LHsExpr RdrName)] -> LHsExpr RdrName -> (LHsExpr RdrName, [(LHsExpr RdrName, LHsExpr RdrName)])+        gather opExprList = \case+          (L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1+          final -> (final, opExprList)+        (leftOperand, appList) = gather [] expLeft+    leftOperandDoc <- docSharedWrapper layoutExpr leftOperand+    appListDocs <- appList `forM` \(x,y) -> [ (xD, yD)+                                            | xD <- docSharedWrapper layoutExpr x+                                            , yD <- docSharedWrapper layoutExpr y+                                            ]+    opLastDoc <- docSharedWrapper layoutExpr expOp+    expLastDoc <- docSharedWrapper layoutExpr expRight+    let allowPar = case (expOp, expRight) of+          (L _ (HsVar (L _ (Unqual occname))), _)+            | occNameString occname == "$" -> True+          (_, L _ (HsApp _ (L _ HsVar{}))) -> False+          _ -> True+    docAlt+      [ docSeq+        [ appSep $ docForceSingleline leftOperandDoc+        , docSeq+        $ (appListDocs <&> \(od, ed) -> docSeq+            [ appSep $ docForceSingleline od+            , appSep $ docForceSingleline ed+            ]+          )+        , appSep $ docForceSingleline opLastDoc+        , (if allowPar then docForceParSpacing else docForceSingleline)+            expLastDoc+        ]+      -- this case rather leads to some unfortunate layouting than to anything+      -- useful; disabling for now. (it interfers with cols stuff.)+      -- , docSetBaseY+      -- - $ docPar+      --     leftOperandDoc+      --     ( docLines+      -- -    $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])+      --       ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]+      --     )+      , docPar+          leftOperandDoc+          ( docLines+          $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])+            ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]+          )+      ]+  OpApp expLeft expOp _ expRight -> do+    expDocLeft  <- docSharedWrapper layoutExpr expLeft+    expDocOp    <- docSharedWrapper layoutExpr expOp+    expDocRight <- docSharedWrapper layoutExpr expRight+    let allowPar = case (expOp, expRight) of+          (L _ (HsVar (L _ (Unqual occname))), _)+            | occNameString occname == "$" -> True+          (_, L _ (HsApp _ (L _ HsVar{}))) -> False+          _ -> True+    docAltFilter+      $   [ -- one-line+            (,) True+          $ docSeq+            [ appSep $ docForceSingleline expDocLeft+            , appSep $ docForceSingleline expDocOp+            , docForceSingleline expDocRight+            ]+          -- , -- line + freely indented block for right expression+          --   docSeq+          --   [ appSep $ docForceSingleline expDocLeft+          --   , appSep $ docForceSingleline expDocOp+          --   , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight+          --   ]+          , -- two-line+            (,) True+          $ docAddBaseY BrIndentRegular+          $ docPar+              expDocLeft+              ( docForceSingleline+              $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]+              )+          , -- one-line + par+            (,) allowPar+          $ docSeq+            [ appSep $ docForceSingleline expDocLeft+            , appSep $ docForceSingleline expDocOp+            , docForceParSpacing expDocRight+            ]+          , -- more lines+            (,) True+          $ docAddBaseY BrIndentRegular+          $ docPar+              expDocLeft+              (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight])+          ]+  NegApp op _ -> do+    opDoc <- docSharedWrapper layoutExpr op+    docSeq $ [ docLit $ Text.pack "-"+             , opDoc+             ]+  HsPar innerExp -> do+    innerExpDoc <- docSharedWrapper layoutExpr innerExp+    docAlt+      [ docSeq+        [ docLit $ Text.pack "("+        , docForceSingleline innerExpDoc+        , docLit $ Text.pack ")"+        ]+      , docSetBaseY $ docLines+        [ docCols ColOpPrefix+          [ docParenLSep+          , docAddBaseY (BrIndentSpecial 2) innerExpDoc+          ]+        , docLit $ Text.pack ")"+        ]+      ]+  SectionL left op -> do -- TODO: add to testsuite+    leftDoc <- docSharedWrapper layoutExpr left+    opDoc   <- docSharedWrapper layoutExpr op+    docSeq [leftDoc, opDoc]+  SectionR op right -> do -- TODO: add to testsuite+    opDoc    <- docSharedWrapper layoutExpr op+    rightDoc <- docSharedWrapper layoutExpr right+    docSeq [opDoc, rightDoc]+  ExplicitTuple args boxity+    | Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do+    argDocs <- docSharedWrapper layoutExpr `mapM` argExprs+    hasComments <- hasAnyCommentsBelow lexpr+    let (openLit, closeLit) = case boxity of+          Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")")+          Unboxed -> (docLit $ Text.pack "(#", docLit $ Text.pack "#)")+    case splitFirstLast argDocs of+      FirstLastEmpty -> docSeq+        [ openLit+        , docNodeAnnKW lexpr (Just AnnOpenP) $ closeLit+        ]+      FirstLastSingleton e -> docAlt+        [ docCols ColTuple+          [ openLit+          , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e+          , closeLit+          ]+        , docSetBaseY $ docLines+          [ docSeq+            [ openLit+            , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e+            ]+          , closeLit+          ]+        ]+      FirstLast e1 ems eN ->+        docAltFilter+          [ (,) (not hasComments)+          $ docCols ColTuple+            (  [docSeq [openLit, docForceSingleline e1]]+            ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e])+            ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]]+            )+          , (,) True+          $ let+              start = docCols ColTuples+                        [appSep $ openLit, e1]+              linesM = ems <&> \d ->+                      docCols ColTuples [docCommaSep, d]+              lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN]+              end   = closeLit+            in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]+          ]+  ExplicitTuple{} ->+    unknownNodeError "ExplicitTuple|.." lexpr +  HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do+    cExpDoc <- docSharedWrapper layoutExpr cExp+    binderDoc <- docLit $ Text.pack "->"+    funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches+    docAlt+      [ docSetParSpacing+      $ docAddBaseY BrIndentRegular+      $ docPar+        ( docSeq+          [ appSep $ docLit $ Text.pack "case"+          , appSep $ docForceSingleline cExpDoc+          , docLit $ Text.pack "of"+          ])+        (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)+      , docPar+          ( docAddBaseY BrIndentRegular+          $ docPar (docLit $ Text.pack "case") cExpDoc+          )+          ( docAddBaseY BrIndentRegular+          $ docPar (docLit $ Text.pack "of")+            (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)+          )+      ]+  HsIf _ ifExpr thenExpr elseExpr -> do+    ifExprDoc   <- docSharedWrapper layoutExpr ifExpr+    thenExprDoc <- docSharedWrapper layoutExpr thenExpr+    elseExprDoc <- docSharedWrapper layoutExpr elseExpr+    hasComments <- hasAnyCommentsBelow lexpr+    docAltFilter+      [ -- if _ then _ else _+        (,) (not hasComments)+      $ docSeq+        [ appSep $ docLit $ Text.pack "if"+        , appSep $ docForceSingleline ifExprDoc+        , appSep $ docLit $ Text.pack "then"+        , appSep $ docForceSingleline thenExprDoc+        , appSep $ docLit $ Text.pack "else"+        , docForceSingleline elseExprDoc+        ]+      , -- either+        --   if expr+        --   then foo+        --     bar+        --   else foo+        --     bar+        -- or+        --   if expr+        --   then+        --     stuff+        --   else+        --     stuff+        -- note that this has par-spacing+        (,) True+      $ docSetParSpacing+      $ docAddBaseY BrIndentRegular+      $ docPar+          ( docAddBaseY (BrIndentSpecial 3)+          $ docSeq+            [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"+            , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc+            ])+          (docLines+            [ docAddBaseY BrIndentRegular+            $ docNodeAnnKW lexpr (Just AnnThen)+            $ docAlt+              [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc]+              , docAddBaseY BrIndentRegular+              $ docPar (docLit $ Text.pack "then") thenExprDoc+              ]+            , docAddBaseY BrIndentRegular+            $ docAlt+              [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]+              , docAddBaseY BrIndentRegular+              $ docPar (docLit $ Text.pack "else") elseExprDoc+              ]+            ])+      , -- either+        --   if multi+        --      line+        --      condition+        --   then foo+        --     bar+        --   else foo+        --     bar+        -- or+        --   if multi+        --      line+        --      condition+        --   then+        --     stuff+        --   else+        --     stuff+        -- note that this does _not_ have par-spacing+        (,) True+      $ docAddBaseY BrIndentRegular+      $ docPar+          ( docAddBaseY (BrIndentSpecial 3)+          $ docSeq+            [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"+            , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc+            ])+          (docLines+            [ docAddBaseY BrIndentRegular+            $ docNodeAnnKW lexpr (Just AnnThen)+            $ docAlt+              [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc]+              , docAddBaseY BrIndentRegular+              $ docPar (docLit $ Text.pack "then") thenExprDoc+              ]+            , docAddBaseY BrIndentRegular+            $ docAlt+              [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]+              , docAddBaseY BrIndentRegular+              $ docPar (docLit $ Text.pack "else") elseExprDoc+              ]+            ])+      , (,) True+      $ docSetBaseY+      $ docLines+        [ docAddBaseY (BrIndentSpecial 3)+        $ docSeq+          [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"+          , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc+          ]+        , docNodeAnnKW lexpr (Just AnnThen)+        $ docAddBaseY BrIndentRegular+        $ docPar (docLit $ Text.pack "then") thenExprDoc+        , docAddBaseY BrIndentRegular+        $ docPar (docLit $ Text.pack "else") elseExprDoc+        ]+      ]+  HsMultiIf _ cases -> do+    clauseDocs <- cases `forM` layoutGrhs+    binderDoc <- docLit $ Text.pack "->"+    hasComments <- hasAnyCommentsBelow lexpr+    docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+      (docLit $ Text.pack "if")+      (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments)+  HsLet binds exp1 -> do+    expDoc1 <- docSharedWrapper layoutExpr exp1+    mBindDocs <- layoutLocalBinds binds+    -- this `docSetIndentLevel` might seem out of place, but is here due to+    -- ghc-exactprint's DP handling of "let" in particular.+    -- Just pushing another indentation level is a straightforward approach+    -- to making brittany idempotent, even though the result is non-optimal+    -- if "let" is moved horizontally as part of the transformation, as the+    -- comments before the first let item are moved horizontally with it.+    docSetIndentLevel $ case mBindDocs of+      Just [bindDoc] -> docAlt+        [ docSeq+          [ appSep $ docLit $ Text.pack "let"+          , appSep $ docForceSingleline $ return bindDoc+          , appSep $ docLit $ Text.pack "in"+          , docForceSingleline $ expDoc1+          ]+        , docLines+          [ docSeq+            [ appSep $ docLit $ Text.pack "let"+            , docSetBaseAndIndent $ return bindDoc+            ]+          , docSeq+            [ appSep $ docLit $ Text.pack "in "+            , docSetBaseY $ expDoc1+            ]+          ]+        , docLines+          [ docAddBaseY BrIndentRegular+          $ docPar+            (appSep $ docLit $ Text.pack "let")+            (docSetBaseAndIndent $ return bindDoc)+          , docAddBaseY BrIndentRegular+          $ docPar+            (appSep $ docLit $ Text.pack "in")+            (docSetBaseY $ expDoc1)+          ]+        ]+      Just bindDocs@(_:_) -> docAlt+        [ docLines+          [ docSeq+            [ appSep $ docLit $ Text.pack "let"+            , docSetBaseAndIndent $ docLines $ return <$> bindDocs+            ]+          , docSeq+            [ appSep $ docLit $ Text.pack "in "+            , docSetBaseY $ expDoc1+            ]+          ]+        , docLines+          [ docAddBaseY BrIndentRegular+          $ docPar+            (docLit $ Text.pack "let")+            (docSetBaseAndIndent $ docLines $ return <$> bindDocs)+          , docAddBaseY BrIndentRegular+          $ docPar+            (docLit $ Text.pack "in")+            (docSetBaseY $ expDoc1)+          ]+        ]+      _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1]+    -- docSeq [appSep $ docLit "let in", expDoc1]+  HsDo DoExpr (L _ stmts) _ -> do+    stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts+    docSetParSpacing+      $ docAddBaseY BrIndentRegular+      $ docPar+          (docLit $ Text.pack "do")+          (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)+  HsDo MDoExpr (L _ stmts) _ -> do+    stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts+    docSetParSpacing+      $ docAddBaseY BrIndentRegular+      $ docPar+          (docLit $ Text.pack "mdo")+          (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)+  HsDo x  (L _ stmts) _ | case x of { ListComp -> True+                                    ; MonadComp -> True+                                    ; _ -> False } -> do+    stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts+    hasComments <- hasAnyCommentsBelow lexpr+    docAltFilter+      [ (,) (not hasComments)+      $ docSeq+        [ docNodeAnnKW lexpr Nothing+        $ appSep+        $ docLit+        $ Text.pack "["+        , docNodeAnnKW lexpr (Just AnnOpenS)+        $ appSep+        $ docForceSingleline+        $ List.last stmtDocs+        , appSep $ docLit $ Text.pack "|"+        , docSeq $ List.intersperse docCommaSep+                $ fmap docForceSingleline $ List.init stmtDocs+        , docLit $ Text.pack " ]"+        ]+      , (,) True+      $ let+          start = docCols ColListComp+                    [ docNodeAnnKW lexpr Nothing+                    $ appSep $ docLit $ Text.pack "["+                    , docSetBaseY+                    $ docNodeAnnKW lexpr (Just AnnOpenS)+                    $ List.last stmtDocs+                    ]+          (s1:sM) = List.init stmtDocs+          line1 = docCols ColListComp+                    [appSep $ docLit $ Text.pack "|", s1]+          lineM = sM <&> \d ->+                  docCols ColListComp [docCommaSep, d]+          end   = docLit $ Text.pack "]"+        in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end]+      ]+  HsDo{} -> do+    -- TODO+    unknownNodeError "HsDo{} no comp" lexpr+  ExplicitList _ _ elems@(_:_) -> do+    elemDocs <- elems `forM` docSharedWrapper layoutExpr+    hasComments <- hasAnyCommentsBelow lexpr+    case splitFirstLast elemDocs of+      FirstLastEmpty -> docSeq+        [ docLit $ Text.pack "["+        , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]"+        ]+      FirstLastSingleton e -> docAlt+        [ docSeq+          [ docLit $ Text.pack "["+          , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e+          , docLit $ Text.pack "]"+          ]+        , docSetBaseY $ docLines+          [ docSeq+            [ docLit $ Text.pack "["+            , docSeparator+            , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) $ e+            ]+          , docLit $ Text.pack "]"+          ]+        ]+      FirstLast e1 ems eN ->+        docAltFilter+          [  (,) (not hasComments)+          $  docSeq+          $  [docLit $ Text.pack "["]+          ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]))+          ++ [docLit $ Text.pack "]"]+          , (,) True+          $ let+              start = docCols ColList+                        [appSep $ docLit $ Text.pack "[", e1]+              linesM = ems <&> \d ->+                      docCols ColList [docCommaSep, d]+              lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN]+              end   = docLit $ Text.pack "]"+            in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]+          ]+  ExplicitList _ _ [] ->+    docLit $ Text.pack "[]"+  ExplicitPArr{} -> do+    -- TODO+    briDocByExactInlineOnly "ExplicitPArr{}" lexpr+  RecordCon lname _ _ (HsRecFields [] Nothing) -> do+    let t = lrdrNameToText lname+    docWrapNode lname $ docSeq+      [ docNodeAnnKW lexpr (Just AnnOpenC) $ docLit $ t <> Text.pack "{"+      , docLit $ Text.pack "}"+      ]+  RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do+    let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname+    ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do+      fExpDoc <- if pun+        then return Nothing+        else Just <$> docSharedWrapper layoutExpr fExpr+      return $ (fieldl, lrdrNameToText lnameF, fExpDoc)+    docAlt+      [ docSetParSpacing+      $ docAddBaseY BrIndentRegular+      $ docPar+          (docNodeAnnKW lexpr Nothing $ nameDoc)+          (docNonBottomSpacing $ docLines $ let+            line1 = docCols ColRecUpdate+              [ appSep $ docLit $ Text.pack "{"+              , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n+              , case fd1e of+                  Just x -> docSeq+                    [ appSep $ docLit $ Text.pack "="+                    , docWrapNodeRest fd1l $ docAddBaseY BrIndentRegular $ x+                    ]+                  Nothing -> docEmpty+              ]+            lineR = fdr <&> \(lfield, fText, fDoc) -> docCols ColRecUpdate+              [ appSep $ docLit $ Text.pack ","+              , appSep $ docLit $ fText+              , case fDoc of+                  Just x -> docWrapNode lfield $ docSeq+                    [ appSep $ docLit $ Text.pack "="+                    , docAddBaseY BrIndentRegular x+                    ]+                  Nothing -> docEmpty+              ]+            lineN = docSeq+              [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty+              , docLit $ Text.pack "}"+              ]+            in [line1] ++ lineR ++ [lineN])+      -- TODO oneliner (?)+      ]+  RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do+    let t = lrdrNameToText lname+    docWrapNode lname $ docLit $ t <> Text.pack " {..}"+  RecordCon{} ->+    unknownNodeError "RecordCon with puns" lexpr+  RecordUpd rExpr [] _ _ _ _ -> do+    rExprDoc <- docSharedWrapper layoutExpr rExpr+    docSeq [rExprDoc, docLit $ Text.pack "{}"]+  RecordUpd rExpr fields@(_:_) _ _ _ _ -> do+    rExprDoc <- docSharedWrapper layoutExpr rExpr+    rFs@((rF1f, rF1n, rF1e):rFr) <- fields+      `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do+        rFExpDoc <- if pun+          then return Nothing+          else Just <$> docSharedWrapper layoutExpr rFExpr+        return $ case ambName of+          Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)+          Ambiguous   n _ -> (lfield, lrdrNameToText n, rFExpDoc)+    docAlt+      -- singleline+      [ docSeq+        [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc+        , appSep $ docLit $ Text.pack "{"+        , appSep $ docSeq $ List.intersperse docCommaSep+                $ rFs <&> \case+                  (lfield, fieldStr, Just fieldDoc) ->+                    docWrapNode lfield $ docSeq+                          [ appSep $ docLit fieldStr+                          , appSep $ docLit $ Text.pack "="+                          , docForceSingleline fieldDoc+                          ]+                  (lfield, fieldStr, Nothing) ->+                    docWrapNode lfield $ docLit fieldStr+        , docLit $ Text.pack "}"+        ]+      -- wild-indentation block+      , docSeq+        [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc+        , docSetBaseY $ docLines $ let+            line1 = docCols ColRecUpdate+              [ appSep $ docLit $ Text.pack "{"+              , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n+              , case rF1e of+                  Just x -> docWrapNodeRest rF1f $ docSeq+                                   [ appSep $ docLit $ Text.pack "="+                                   , docForceSingleline $ x+                                   ]+                  Nothing -> docEmpty+              ]+            lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate+              [ appSep $ docLit $ Text.pack ","+              , appSep $ docLit $ fText+              , case fDoc of+                  Just x ->  docSeq [ appSep $ docLit $ Text.pack "="+                                    , docForceSingleline x+                                    ]+                  Nothing -> docEmpty+              ]+            lineN = docSeq+              [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty+              , docLit $ Text.pack "}"+              ]+            in [line1] ++ lineR ++ [lineN]+        ]+      -- strict indentation block+      , docSetParSpacing+      $ docAddBaseY BrIndentRegular+      $ docPar+          (docNodeAnnKW lexpr Nothing $ rExprDoc)+          (docNonBottomSpacing $ docLines $ let+            line1 = docCols ColRecUpdate+              [ appSep $ docLit $ Text.pack "{"+              , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n+              , docWrapNodeRest rF1f $ case rF1e of+                  Just x -> docSeq [ appSep $ docLit $ Text.pack "="+                                   , docAddBaseY BrIndentRegular $ x+                                   ]+                  Nothing -> docEmpty+              ]+            lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate+              [ appSep $ docLit $ Text.pack ","+              , appSep $ docLit $ fText+              , case fDoc of+                  Just x ->  docSeq [ appSep $ docLit $ Text.pack "="+                                    , docAddBaseY BrIndentRegular x+                                    ]+                  Nothing -> docEmpty+              ]+            lineN = docSeq+              [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty+              , docLit $ Text.pack "}"+              ]+            in [line1] ++ lineR ++ [lineN])+      ]+  ExprWithTySig exp1 (HsIB _ (HsWC _ _ typ1)) -> do+    expDoc <- docSharedWrapper layoutExpr exp1+    typDoc <- docSharedWrapper layoutType typ1+    docSeq+      [ appSep expDoc+      , appSep $ docLit $ Text.pack "::"+      , typDoc+      ]+  ExprWithTySigOut{} -> do+    -- TODO+    briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr+  ArithSeq _ Nothing info ->+    case info of+      From e1 -> do+        e1Doc <- docSharedWrapper layoutExpr e1+        docSeq+          [ docLit $ Text.pack "["+          , appSep $ docForceSingleline e1Doc+          , docLit $ Text.pack "..]"+          ]+      FromThen e1 e2 -> do+        e1Doc <- docSharedWrapper layoutExpr e1+        e2Doc <- docSharedWrapper layoutExpr e2+        docSeq+          [ docLit $ Text.pack "["+          , docForceSingleline e1Doc+          , appSep $ docLit $ Text.pack ","+          , appSep $ docForceSingleline e2Doc+          , docLit $ Text.pack "..]"+          ]+      FromTo e1 eN -> do+        e1Doc <- docSharedWrapper layoutExpr e1+        eNDoc <- docSharedWrapper layoutExpr eN+        docSeq+          [ docLit $ Text.pack "["+          , appSep $ docForceSingleline e1Doc+          , appSep $ docLit $ Text.pack ".."+          , docForceSingleline eNDoc+          , docLit $ Text.pack "]"+          ]+      FromThenTo e1 e2 eN -> do+        e1Doc <- docSharedWrapper layoutExpr e1+        e2Doc <- docSharedWrapper layoutExpr e2+        eNDoc <- docSharedWrapper layoutExpr eN+        docSeq+          [ docLit $ Text.pack "["+          , docForceSingleline e1Doc+          , appSep $ docLit $ Text.pack ","+          , appSep $ docForceSingleline e2Doc+          , appSep $ docLit $ Text.pack ".."+          , docForceSingleline eNDoc+          , docLit $ Text.pack "]"+          ]+  ArithSeq{} ->+    briDocByExactInlineOnly "ArithSeq" lexpr+  PArrSeq{} -> do+    -- TODO+    briDocByExactInlineOnly "PArrSeq{}" lexpr+  HsSCC{} -> do+    -- TODO+    briDocByExactInlineOnly "HsSCC{}" lexpr+  HsCoreAnn{} -> do+    -- TODO+    briDocByExactInlineOnly "HsCoreAnn{}" lexpr+  HsBracket{} -> do+    -- TODO+    briDocByExactInlineOnly "HsBracket{}" lexpr+  HsRnBracketOut{} -> do+    -- TODO+    briDocByExactInlineOnly "HsRnBracketOut{}" lexpr+  HsTcBracketOut{} -> do+    -- TODO+    briDocByExactInlineOnly "HsTcBracketOut{}" lexpr+  HsSpliceE{} -> do+    -- TODO+    briDocByExactInlineOnly "HsSpliceE{}" lexpr+  HsProc{} -> do+    -- TODO+    briDocByExactInlineOnly "HsProc{}" lexpr+  HsStatic{} -> do+    -- TODO+    briDocByExactInlineOnly "HsStatic{}" lexpr+  HsArrApp{} -> do+    -- TODO+    briDocByExactInlineOnly "HsArrApp{}" lexpr+  HsArrForm{} -> do+    -- TODO+    briDocByExactInlineOnly "HsArrForm{}" lexpr+  HsTick{} -> do+    -- TODO+    briDocByExactInlineOnly "HsTick{}" lexpr+  HsBinTick{} -> do+    -- TODO+    briDocByExactInlineOnly "HsBinTick{}" lexpr+  HsTickPragma{} -> do+    -- TODO+    briDocByExactInlineOnly "HsTickPragma{}" lexpr+  EWildPat{} -> do+    docLit $ Text.pack "_"+  EAsPat{} -> do+    -- TODO+    briDocByExactInlineOnly "EAsPat{}" lexpr+  EViewPat{} -> do+    -- TODO+    briDocByExactInlineOnly "EViewPat{}" lexpr+  ELazyPat{} -> do+    -- TODO+    briDocByExactInlineOnly "ELazyPat{}" lexpr+  HsWrap{} -> do+    -- TODO+    briDocByExactInlineOnly "HsWrap{}" lexpr++litBriDoc :: HsLit -> BriDocFInt+litBriDoc = \case+  HsChar       t _c          -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']+  HsCharPrim   t _c          -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']+  HsString     t _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString+  HsStringPrim t _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString+  HsInt        t _i          -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i+  HsIntPrim    t _i          -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i+  HsWordPrim   t _i          -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i+  HsInt64Prim  t _i          -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i+  HsWord64Prim t _i          -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i+  HsInteger t _i _type       -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i+  HsRat (FL t _) _type       -> BDFLit $ Text.pack t+  HsFloatPrim  (FL t _)      -> BDFLit $ Text.pack t+  HsDoublePrim (FL t _)      -> BDFLit $ Text.pack t++overLitValBriDoc :: OverLitVal -> BriDocFInt+overLitValBriDoc = \case+  HsIntegral t _        -> BDFLit $ Text.pack t+  HsFractional (FL t _) -> BDFLit $ Text.pack t+  HsIsString t _        -> BDFLit $ Text.pack t
+ src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot view
@@ -0,0 +1,30 @@+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Brittany.Internal.Layouters.Expr+  ( layoutExpr+  , litBriDoc+  , overLitValBriDoc+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal.LayouterBasics++import           RdrName ( RdrName(..) )+import           GHC ( runGhc, GenLocated(L), moduleNameString )+import           HsSyn+import           Name++++layoutExpr :: ToBriDoc HsExpr++-- layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))++litBriDoc :: HsLit -> BriDocFInt++overLitValBriDoc :: OverLitVal -> BriDocFInt
+ src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Brittany.Internal.Layouters.Pattern+  ( layoutPat+  , colsWrapPat+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal.LayouterBasics++import           RdrName ( RdrName(..) )+import           GHC ( Located, runGhc, GenLocated(L), moduleNameString )+import           HsSyn+import           Name+import           BasicTypes++import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr+import           Language.Haskell.Brittany.Internal.Layouters.Type++++layoutPat :: ToBriDocC (Pat RdrName) (Seq BriDocNumbered)+layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of+  WildPat _  -> fmap Seq.singleton $ docLit $ Text.pack "_"+  VarPat n   -> fmap Seq.singleton $ docLit $ lrdrNameToText n+  LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit+  ParPat inner -> do+    left  <- docLit $ Text.pack "("+    right <- docLit $ Text.pack ")"+    innerDocs <- colsWrapPat =<< layoutPat inner+    return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right+    -- return $ (left Seq.<| innerDocs) Seq.|> right+    -- case Seq.viewl innerDocs of+    --   Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur..+    --   x1 Seq.:< rest -> case Seq.viewr rest of+    --     Seq.EmptyR ->+    --       fmap return $ docSeq+    --       [ docLit $ Text.pack "("+    --       , return x1+    --       , docLit $ Text.pack ")"+    --       ]+    --     middle Seq.:> xN -> do+    --       x1' <- docSeq [docLit $ Text.pack "(", return x1]+    --       xN' <- docSeq [return xN, docLit $ Text.pack ")"]+    --       return $ (x1' Seq.<| middle) Seq.|> xN'+  ConPatIn lname (PrefixCon args) -> do+    let nameDoc = lrdrNameToText lname+    argDocs <- layoutPat `mapM` args+    if null argDocs+      then return <$> docLit nameDoc+      else do+        x1 <- appSep (docLit nameDoc)+        xR <- fmap Seq.fromList+          $ sequence+          $ spacifyDocs+          $ fmap colsWrapPat argDocs+        return $ x1 Seq.<| xR+  ConPatIn lname (InfixCon left right) -> do+    let nameDoc = lrdrNameToText lname+    leftDoc  <- colsWrapPat =<< layoutPat left+    rightDoc <- colsWrapPat =<< layoutPat right+    middle <- docLit nameDoc+    return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc+  ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do+    let t = lrdrNameToText lname+    fmap Seq.singleton $ docLit $ t <> Text.pack "{}"+  ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do+    let t = lrdrNameToText lname+    fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do+      fExpDoc <- if pun+        then return Nothing+        else Just <$> docSharedWrapper layoutPat fPat+      return $ (lrdrNameToText lnameF, fExpDoc)+    fmap Seq.singleton $ docSeq+      [ appSep $ docLit t+      , appSep $ docLit $ Text.pack "{"+      , docSeq $ List.intersperse docCommaSep+               $ fds <&> \case+          (fieldName, Just fieldDoc) -> docSeq+            [ appSep $ docLit $ fieldName+            , appSep $ docLit $ Text.pack "="+            , fieldDoc >>= colsWrapPat+            ]+          (fieldName, Nothing) -> docLit fieldName+      , docSeparator+      , docLit $ Text.pack "}"+      ]+  ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do+    let t = lrdrNameToText lname+    fmap Seq.singleton $ docSeq+      [ appSep $ docLit t+      , docLit $ Text.pack "{..}"+      ]+  TuplePat args boxity _ -> do+    case boxity of+      Boxed   -> wrapPatListy args "(" ")"+      Unboxed -> wrapPatListy args "(#" "#)"+  AsPat asName asPat -> do+    wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")+  SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do+    patDocs <- layoutPat pat1+    tyDoc <- docSharedWrapper layoutType ty1+    case Seq.viewr patDocs of+      Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd"+      xR Seq.:> xN -> do+        xN' <- -- at the moment, we don't support splitting patterns into+               -- multiple lines. but we cannot enforce pasting everything+               -- into one line either, because the type signature will ignore+               -- this if we overflow sufficiently.+               -- In order to prevent syntactically invalid results in such+               -- cases, we need the AddBaseY here.+               -- This can all change when patterns get multiline support.+               docAddBaseY BrIndentRegular $ docSeq+          [ appSep $ return xN+          , appSep $ docLit $ Text.pack "::"+          , docForceSingleline $ tyDoc+          ]+        return $ xR Seq.|> xN'+  ListPat elems _ _ ->+    wrapPatListy elems "[" "]"+  BangPat pat1 -> do+    wrapPatPrepend pat1 (docLit $ Text.pack "!")+  LazyPat pat1 -> do+    wrapPatPrepend pat1 (docLit $ Text.pack "~")+  NPat llit@(L _ (OverLit olit _ _ _)) _ _ _ -> do+    fmap Seq.singleton $ docWrapNode llit $ allocateNode $ overLitValBriDoc olit++-- if MIN_VERSION_ghc(8,0,0)+--   VarPat n -> return $ stringLayouter lpat $ lrdrNameToText n+-- else+--   VarPat n -> return $ stringLayouter lpat $ rdrNameToText n+-- endif+  _ -> fmap return $ briDocByExactInlineOnly "some unknown pattern" lpat++colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered+colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList++wrapPatPrepend+  :: Located (Pat RdrName)+  -> ToBriDocM BriDocNumbered+  -> ToBriDocM (Seq BriDocNumbered)+wrapPatPrepend pat prepElem = do+  patDocs <- layoutPat pat+  case Seq.viewl patDocs of+    Seq.EmptyL -> return $ Seq.empty+    x1 Seq.:< xR -> do+      x1' <- docSeq [prepElem, return x1]+      return $ x1' Seq.<| xR++wrapPatListy+  :: [Located (Pat RdrName)]+  -> String+  -> String+  -> ToBriDocM (Seq BriDocNumbered)+wrapPatListy elems start end = do+  elemDocs <- Seq.fromList elems `forM` \e -> layoutPat e >>= colsWrapPat+  sDoc <- docLit $ Text.pack start+  eDoc <- docLit $ Text.pack end+  case Seq.viewl elemDocs of+    Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack $ start ++ end+    x1 Seq.:< rest -> do+        rest' <- rest `forM` \bd -> docSeq+          [ docLit $ Text.pack ","+          , docSeparator+          , return bd+          ]+        return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc
+ src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Brittany.Internal.Layouters.Stmt+  ( layoutStmt+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal.LayouterBasics++import           RdrName ( RdrName(..) )+import           GHC ( runGhc, GenLocated(L), moduleNameString )+import           HsSyn+import           Name+import qualified FastString+import           BasicTypes++import           Language.Haskell.Brittany.Internal.Layouters.Pattern+import           Language.Haskell.Brittany.Internal.Layouters.Decl+import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr++++layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))+layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of+  LastStmt body False _    -> do+    layoutExpr body+  BindStmt lPat expr _ _ _ -> do+    patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat+    expDoc <- docSharedWrapper layoutExpr expr+    docAlt+      [ docCols+        ColBindStmt+        [ appSep patDoc+        , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc]+        ]+      , docCols+        ColBindStmt+        [ appSep patDoc+        , docAddBaseY BrIndentRegular+          $ docPar (docLit $ Text.pack "<-") (expDoc)+        ]+      ]+  LetStmt binds            -> layoutLocalBinds binds >>= \case+    Nothing        -> docLit $ Text.pack "let" -- i just tested+                               -- it, and it is+                               -- indeed allowed.+                               -- heh.+    Just []        -> docLit $ Text.pack "let" -- this probably never happens+    Just [bindDoc] -> docAlt+      [ docCols+        ColDoLet+        [ appSep $ docLit $ Text.pack "let"+        , docSetBaseAndIndent $ return bindDoc+        ]+      , docAddBaseY BrIndentRegular+        $ docPar (docLit $ Text.pack "let")+                 (docSetBaseAndIndent $ return bindDoc)+      ]+    Just bindDocs  -> docAlt+      [ docSeq+        [ appSep $ docLit $ Text.pack "let"+        , docSetBaseAndIndent $ docLines $ return <$> bindDocs+        ]+      , docAddBaseY BrIndentRegular $ docPar+        (docLit $ Text.pack "let")+        (docSetBaseAndIndent $ docLines $ return <$> bindDocs)+      ]+  BodyStmt expr _ _ _      -> do+    expDoc <- docSharedWrapper layoutExpr expr+    docAddBaseY BrIndentRegular $ expDoc+  _                        -> briDocByExactInlineOnly "some unknown statement" lstmt
+ src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot view
@@ -0,0 +1,24 @@+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Brittany.Internal.Layouters.Stmt+  ( layoutStmt+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal.LayouterBasics++import           RdrName ( RdrName(..) )+import           GHC ( runGhc, GenLocated(L), moduleNameString )+import           HsSyn+import           Name+import qualified FastString+import           BasicTypes++++layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))
+ src/Language/Haskell/Brittany/Internal/Layouters/Type.hs view
@@ -0,0 +1,595 @@+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Brittany.Internal.Layouters.Type+  ( layoutType+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.Types+import           Language.Haskell.Brittany.Internal.LayouterBasics++import           RdrName ( RdrName(..) )+import           GHC ( runGhc, GenLocated(L), moduleNameString )+import           Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )+import           HsSyn+import           Name+import           Outputable ( ftext, showSDocUnsafe )++import           DataTreePrint++++layoutType :: ToBriDoc HsType+layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of+  -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"+  HsTyVar name -> do+    t <- lrdrNameToTextAnn name+    docWrapNode name $ docLit t+  HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts@(_:_)) typ2)) -> do+    typeDoc <- docSharedWrapper layoutType typ2+    tyVarDocs <- bndrs `forM` \case+      (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing)+      (L _ (KindedTyVar lrdrName kind)) -> do+        d <- docSharedWrapper layoutType kind+        return $ (lrdrNameToText lrdrName, Just $ d)+    cntxtDocs <- cntxts `forM` docSharedWrapper layoutType+    let maybeForceML = case typ2 of+          (L _ HsFunTy{}) -> docForceMultiline+          _               -> id+    let+      tyVarDocLineList = tyVarDocs >>= \case+        (tname, Nothing) -> [docLit $ Text.pack " " <> tname]+        (tname, Just doc) -> [ docLit $ Text.pack " ("+                                    <> tname+                                    <> Text.pack " :: "+                             , docForceSingleline $ doc+                             , docLit $ Text.pack ")"+                             ]+      forallDoc = docAlt+        [ let+            open = docLit $ Text.pack "forall"+            in docSeq ([open]++tyVarDocLineList)+        , docPar+            (docLit (Text.pack "forall"))+            (docLines+            $ tyVarDocs <&> \case+                (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname+                (tname, Just doc) -> docEnsureIndent BrIndentRegular+                  $ docLines+                    [ docCols ColTyOpPrefix+                      [ docParenLSep+                      , docLit tname+                      ]+                    , docCols ColTyOpPrefix+                      [ docLit $ Text.pack ":: "+                      , doc+                      ]+                    , docLit $ Text.pack ")"+                    ])+        ]+      contextDoc = case cntxtDocs of+        [x] -> x+        _ -> docAlt+          [ let+              open  = docLit $ Text.pack "("+              close = docLit $ Text.pack ")"+              list  = List.intersperse docCommaSep+                    $ docForceSingleline <$> cntxtDocs+              in docSeq ([open]++list++[close])+          , let+              open = docCols ColTyOpPrefix+                      [ docParenLSep+                      , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs+                      ]+              close = docLit $ Text.pack ")"+              list = List.tail cntxtDocs <&> \cntxtDoc ->+                     docCols ColTyOpPrefix+                      [ docCommaSep+                      , docAddBaseY (BrIndentSpecial 2) cntxtDoc+                      ]+            in docPar open $ docLines $ list ++ [close]+          ]+    docAlt+      -- :: forall a b c . (Foo a b c) => a b -> c+      [ docSeq+        [ if null bndrs+            then docEmpty+            else let+              open = docLit $ Text.pack "forall"+              close = docLit $ Text.pack " . "+              in docSeq ([open]++tyVarDocLineList++[close])+        , docForceSingleline contextDoc+        , docLit $ Text.pack " => "+        , docForceSingleline typeDoc+        ]+      -- :: forall a b c+      --  . (Foo a b c)+      -- => a b+      -- -> c+      , docPar+          forallDoc+          ( docLines+            [ docCols ColTyOpPrefix+              [ docWrapNodeRest ltype $ docLit $ Text.pack " . "+              , docAddBaseY (BrIndentSpecial 3)+              $ contextDoc+              ]+            , docCols ColTyOpPrefix+              [ docLit $ Text.pack "=> "+              , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc+              ]+            ]+          )+      ]+  HsForAllTy bndrs typ2 -> do+    typeDoc <- layoutType typ2+    tyVarDocs <- bndrs `forM` \case+      (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing)+      (L _ (KindedTyVar lrdrName kind)) -> do+        d <- layoutType kind+        return $ (lrdrNameToText lrdrName, Just $ return d)+    let maybeForceML = case typ2 of+          (L _ HsFunTy{}) -> docForceMultiline+          _               -> id+    let+      tyVarDocLineList = tyVarDocs >>= \case+        (tname, Nothing) -> [docLit $ Text.pack " " <> tname]+        (tname, Just doc) -> [ docLit $ Text.pack " ("+                                    <> tname+                                    <> Text.pack " :: "+                             , docForceSingleline doc+                             , docLit $ Text.pack ")"+                             ]+    docAlt+      -- forall x . x+      [ docSeq+        [ if null bndrs+            then docEmpty+            else let+              open = docLit $ Text.pack "forall"+              close = docLit $ Text.pack " . "+              in docSeq ([open]++tyVarDocLineList++[close])+        , docForceSingleline $ return $ typeDoc+        ]+      -- :: forall x+      -- .  x+      , docPar+          (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)+          ( docCols ColTyOpPrefix+            [ docWrapNodeRest ltype $ docLit $ Text.pack ". "+            , maybeForceML $ return typeDoc+            ]+          )+      -- :: forall+      --      (x :: *)+      -- .  x+      , docPar+          (docLit (Text.pack "forall"))+          (docLines+          $ (tyVarDocs <&> \case+              (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname+              (tname, Just doc) -> docEnsureIndent BrIndentRegular+                $ docLines+                  [ docCols ColTyOpPrefix+                    [ docParenLSep+                    , docLit tname+                    ]+                  , docCols ColTyOpPrefix+                    [ docLit $ Text.pack ":: "+                    , doc+                    ]+                  , docLit $ Text.pack ")"+                  ]+            )+          ++[ docCols ColTyOpPrefix+              [ docWrapNodeRest ltype $ docLit $ Text.pack ". "+              , maybeForceML $ return typeDoc+              ]+            ]+          )+      ]+  (HsQualTy (L _ []) _) ->+    briDocByExactInlineOnly "HsQualTy [] _" ltype+  HsQualTy lcntxts@(L _ cntxts@(_:_)) typ1 -> do+    typeDoc <- docSharedWrapper layoutType typ1+    cntxtDocs <- cntxts `forM` docSharedWrapper layoutType+    let+      contextDoc = docWrapNode lcntxts $ case cntxtDocs of+        [x] -> x+        _ -> docAlt+          [ let+              open  = docLit $ Text.pack "("+              close = docLit $ Text.pack ")"+              list  = List.intersperse docCommaSep+                    $ docForceSingleline <$> cntxtDocs+              in docSeq ([open]++list++[close])+          , let+              open = docCols ColTyOpPrefix+                      [ docParenLSep+                      , docAddBaseY (BrIndentSpecial 2)+                      $ head cntxtDocs+                      ]+              close = docLit $ Text.pack ")"+              list = List.tail cntxtDocs <&> \cntxtDoc ->+                     docCols ColTyOpPrefix+                      [ docCommaSep+                      , docAddBaseY (BrIndentSpecial 2) +                      $ cntxtDoc+                      ]+            in docPar open $ docLines $ list ++ [close]+          ]+    let maybeForceML = case typ1 of+          (L _ HsFunTy{}) -> docForceMultiline+          _               -> id+    docAlt+      -- (Foo a b c) => a b -> c+      [ docSeq+        [ docForceSingleline contextDoc+        , docLit $ Text.pack " => "+        , docForceSingleline typeDoc+        ]+      --    (Foo a b c)+      -- => a b+      -- -> c+      , docPar+          (docForceSingleline contextDoc)+          ( docCols ColTyOpPrefix+            [ docLit $ Text.pack "=> "+            , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc+            ]+          )+      ]+  HsFunTy typ1 typ2 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    typeDoc2 <- docSharedWrapper layoutType typ2+    let maybeForceML = case typ2 of+          (L _ HsFunTy{}) -> docForceMultiline+          _               -> id+    hasComments <- hasAnyCommentsBelow ltype+    docAlt $+      [ docSeq+        [ appSep $ docForceSingleline typeDoc1+        , appSep $ docLit $ Text.pack "->"+        , docForceSingleline typeDoc2+        ]+      | not hasComments+      ] +++      [ docPar+        (docNodeAnnKW ltype Nothing typeDoc1)+        ( docCols ColTyOpPrefix+          [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"+          , docAddBaseY (BrIndentSpecial 3)+          $ maybeForceML typeDoc2+          ]+        )+      ]+  HsParTy typ1 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    docAlt+      [ docSeq+        [ docWrapNodeRest ltype $ docLit $ Text.pack "("+        , docForceSingleline typeDoc1+        , docLit $ Text.pack ")"+        ]+      , docPar+          ( docCols ColTyOpPrefix+            [ docWrapNodeRest ltype $ docParenLSep+            , docAddBaseY (BrIndentSpecial 2) $ typeDoc1+            ])+          (docLit $ Text.pack ")")+      ]+  HsAppTy typ1 typ2 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    typeDoc2 <- docSharedWrapper layoutType typ2+    docAlt+      [ docSeq+        [ docForceSingleline typeDoc1+        , docLit $ Text.pack " "+        , docForceSingleline typeDoc2+        ]+      , docPar+          typeDoc1+          (docEnsureIndent BrIndentRegular typeDoc2)+      ]+  HsAppsTy [] -> error "HsAppsTy []"+  HsAppsTy [L _ (HsAppPrefix typ1)] -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    typeDoc1+  HsAppsTy [_lname@(L _ (HsAppInfix name))] -> do+    -- this redirection is somewhat hacky, but whatever.+    -- TODO: a general problem when doing deep inspections on+    --       the type (and this is not the only instance)+    --       is that we potentially omit annotations on some of+    --       the middle constructors. i have no idea under which+    --       circumstances exactly important annotations (comments)+    --       would be assigned to such constructors.+    typeDoc1 <- -- docSharedWrapper layoutType $ (L l $ HsTyVar name)+      lrdrNameToTextAnnTypeEqualityIsSpecial name+    docLit typeDoc1+  HsAppsTy (L _ (HsAppPrefix typHead):typRestA)+    | Just typRest <- mapM (\case L _ (HsAppPrefix t) -> Just t+                                  _ -> Nothing) typRestA -> do+    docHead <- docSharedWrapper layoutType typHead+    docRest <- docSharedWrapper layoutType `mapM` typRest+    docAlt+      [ docSeq+      $ docForceSingleline docHead : (docRest >>= \d ->+        [ docLit $ Text.pack " ", docForceSingleline d ])+      , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)+      ]+  HsAppsTy (typHead:typRest) -> do+    docHead <- docSharedWrapper layoutAppType typHead+    docRest <- docSharedWrapper layoutAppType `mapM` typRest+    docAlt+      [ docSeq+      $ docForceSingleline docHead : (docRest >>= \d ->+        [ docLit $ Text.pack " ", docForceSingleline d ])+      , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)+      ]+    where+      layoutAppType (L _ (HsAppPrefix t)) = layoutType t+      layoutAppType (L _ (HsAppInfix t))  = docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecial t+  HsListTy typ1 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    docAlt+      [ docSeq+        [ docWrapNodeRest ltype $ docLit $ Text.pack "["+        , docForceSingleline typeDoc1+        , docLit $ Text.pack "]"+        ]+      , docPar+          ( docCols ColTyOpPrefix+            [ docWrapNodeRest ltype $ docLit $ Text.pack "[ "+            , docAddBaseY (BrIndentSpecial 2) $ typeDoc1+            ])+          (docLit $ Text.pack "]")+      ]+  HsPArrTy typ1 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    docAlt+      [ docSeq+        [ docWrapNodeRest ltype $ docLit $ Text.pack "[:"+        , docForceSingleline typeDoc1+        , docLit $ Text.pack ":]"+        ]+      , docPar+          ( docCols ColTyOpPrefix+            [ docWrapNodeRest ltype $ docLit $ Text.pack "[:"+            , docAddBaseY (BrIndentSpecial 2) $ typeDoc1+            ])+          (docLit $ Text.pack ":]")+      ]+  HsTupleTy tupleSort typs -> case tupleSort of+    HsUnboxedTuple           -> unboxed+    HsBoxedTuple             -> simple+    HsConstraintTuple        -> simple+    HsBoxedOrConstraintTuple -> simple+   where+    unboxed = if null typs then error "unboxed unit?" else unboxedL+    simple = if null typs then unitL else simpleL+    unitL = docLit $ Text.pack "()"+    simpleL = do+      docs <- docSharedWrapper layoutType `mapM` typs+      docAlt+        [ docSeq $ [docLit $ Text.pack "("]+               ++ List.intersperse docCommaSep (docForceSingleline <$> docs)+               ++ [docLit $ Text.pack ")"]+        , let+            start = docCols ColTyOpPrefix [docParenLSep, head docs]+            lines = List.tail docs <&> \d ->+                    docCols ColTyOpPrefix [docCommaSep, d]+            end   = docLit $ Text.pack ")"+          in docPar+            (docAddBaseY (BrIndentSpecial 2) $ start)+            (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end])+        ]+    unboxedL = do+      docs <- docSharedWrapper layoutType `mapM` typs+      docAlt+        [ docSeq $ [docLit $ Text.pack "(#"]+               ++ List.intersperse docCommaSep docs+               ++ [docLit $ Text.pack "#)"]+        , let+            start = docCols ColTyOpPrefix [docLit $ Text.pack "(#", head docs]+            lines = List.tail docs <&> \d ->+                    docCols ColTyOpPrefix [docCommaSep, d]+            end   = docLit $ Text.pack "#)"+          in docPar+            (docAddBaseY (BrIndentSpecial 2) start)+            (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end])+        ]+  HsOpTy{} -> -- TODO+    briDocByExactInlineOnly "HsOpTy{}" ltype+  -- HsOpTy typ1 opName typ2 -> do+  --   -- TODO: these need some proper fixing. precedences don't add up.+  --   --       maybe the parser just returns some trivial right recursion+  --   --       parse result for any type level operators.+  --   --       need to check how things are handled on the expression level.+  --   let opStr = lrdrNameToText opName+  --   let opLen = Text.length opStr+  --   layouter1@(Layouter desc1 _ _) <- layoutType typ1+  --   layouter2@(Layouter desc2 _ _) <- layoutType typ2+  --   let line = do -- Maybe+  --         l1 <- _ldesc_line desc1+  --         l2 <- _ldesc_line desc2+  --         let len1 = _lColumns_min l1+  --         let len2 = _lColumns_min l2+  --         let len = 2 + opLen + len1 + len2+  --         return $ LayoutColumns+  --           { _lColumns_key = ColumnKeyUnique+  --           , _lColumns_lengths = [len]+  --           , _lColumns_min = len+  --           }+  --   let block = do -- Maybe+  --         rol1 <- descToBlockStart desc1+  --         (min2, max2) <- descToMinMax (1+opLen) desc2+  --         let (minR, maxR) = case descToBlockMinMax desc1 of+  --               Nothing -> (min2, max2)+  --               Just (min1, max1) -> (max min1 min2, max max1 max2)+  --         return $ BlockDesc+  --           { _bdesc_blockStart = rol1+  --           , _bdesc_min = minR+  --           , _bdesc_max = maxR+  --           , _bdesc_opIndentFloatUp = Just (1+opLen)+  --           }+  --   return $ Layouter+  --     { _layouter_desc = LayoutDesc+  --       { _ldesc_line = line+  --       , _ldesc_block = block+  --       }+  --     , _layouter_func = \params -> do+  --         remaining <- getCurRemaining+  --         let allowSameLine = _params_sepLines params /= SepLineTypeOp+  --         case line of+  --           Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do+  --             applyLayouterRestore layouter1 defaultParams+  --             layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " "+  --             applyLayouterRestore layouter2 defaultParams+  --           _ -> do+  --             let upIndent   = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params+  --             let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2+  --             layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams+  --             layoutWriteNewline+  --             layoutWriteAppend $ opStr <> Text.pack " "+  --             layoutWriteEnsureBlockPlusN downIndent+  --             applyLayouterRestore layouter2 defaultParams+  --               { _params_sepLines = SepLineTypeOp+  --               , _params_opIndent = Just downIndent+  --               }+  --     , _layouter_ast = ltype+  --     }+  HsIParamTy (HsIPName ipName) typ1 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    docAlt+      [ docSeq+        [ docWrapNodeRest ltype+        $ docLit+        $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")+        , docForceSingleline typeDoc1+        ]+      , docPar+          ( docLit+          $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))+          )+          (docCols ColTyOpPrefix+            [ docWrapNodeRest ltype+            $ docLit $ Text.pack "::"+            , docAddBaseY (BrIndentSpecial 2) typeDoc1+            ])+      ]+  HsEqTy typ1 typ2 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    typeDoc2 <- docSharedWrapper layoutType typ2+    docAlt+      [ docSeq+        [ docForceSingleline typeDoc1+        , docWrapNodeRest ltype+        $ docLit $ Text.pack " ~ "+        , docForceSingleline typeDoc2+        ]+      , docPar+          typeDoc1+          ( docCols ColTyOpPrefix+              [ docWrapNodeRest ltype+              $ docLit $ Text.pack "~ "+              , docAddBaseY (BrIndentSpecial 2) typeDoc2+              ])+      ]+  -- TODO: test KindSig+  HsKindSig typ1 kind1 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    kindDoc1 <- docSharedWrapper layoutType kind1+    docAlt+      [ docSeq+        [ docForceSingleline typeDoc1+        , docLit $ Text.pack " :: "+        , docForceSingleline kindDoc1+        ]+      , docPar+          typeDoc1+          ( docCols ColTyOpPrefix+              [ docWrapNodeRest ltype+              $ docLit $ Text.pack ":: "+              , docAddBaseY (BrIndentSpecial 3) kindDoc1+              ])+      ]+  HsBangTy{} -> -- TODO+    briDocByExactInlineOnly "HsBangTy{}" ltype+  -- HsBangTy bang typ1 -> do+  --   let bangStr = case bang of+  --         HsSrcBang _ unpackness strictness ->+  --           (++)+  --             (case unpackness of+  --               SrcUnpack   -> "{-# UNPACK -#} "+  --               SrcNoUnpack -> "{-# NOUNPACK -#} "+  --               NoSrcUnpack -> ""+  --             )+  --             (case strictness of+  --               SrcLazy     -> "~"+  --               SrcStrict   -> "!"+  --               NoSrcStrict -> ""+  --             )+  --   let bangLen = length bangStr+  --   layouter@(Layouter desc _ _) <- layoutType typ1+  --   let line = do -- Maybe+  --         l <- _ldesc_line desc+  --         let len = bangLen + _lColumns_min l+  --         return $ LayoutColumns+  --           { _lColumns_key = ColumnKeyUnique+  --           , _lColumns_lengths = [len]+  --           , _lColumns_min = len+  --           }+  --   let block = do -- Maybe+  --         rol <- descToBlockStart desc+  --         (minR,maxR) <- descToBlockMinMax desc+  --         return $ BlockDesc+  --           { _bdesc_blockStart = rol+  --           , _bdesc_min = minR+  --           , _bdesc_max = maxR+  --           , _bdesc_opIndentFloatUp = Nothing+  --           }+  --   return $ Layouter+  --     { _layouter_desc = LayoutDesc+  --       { _ldesc_line = line+  --       , _ldesc_block = block+  --       }+  --     , _layouter_func = \_params -> do+  --         remaining <- getCurRemaining+  --         case line of+  --           Just (LayoutColumns _ _ m) | m <= remaining -> do+  --             layoutWriteAppend $ Text.pack $ bangStr+  --             applyLayouterRestore layouter defaultParams+  --           _ -> do+  --             layoutWriteAppend $ Text.pack $ bangStr+  --             layoutWritePostCommentsRestore ltype+  --             applyLayouterRestore layouter defaultParams+  --     , _layouter_ast = ltype+  --     }+  HsSpliceTy{} -> -- TODO+    briDocByExactInlineOnly "" ltype+  HsDocTy{} -> -- TODO+    briDocByExactInlineOnly "" ltype+  HsRecTy{} -> -- TODO+    briDocByExactInlineOnly "" ltype+  HsExplicitListTy _ typs -> do+    typDocs <- docSharedWrapper layoutType `mapM` typs+    docAlt+      [ docSeq+      $  [docLit $ Text.pack "'["]+      ++ List.intersperse docCommaSep typDocs+      ++ [docLit $ Text.pack "]"]+      -- TODO+      ]+  HsExplicitTupleTy{} -> -- TODO+    briDocByExactInlineOnly "" ltype+  HsTyLit{} -> -- TODO+    briDocByExactInlineOnly "" ltype+  HsCoreTy{} -> -- TODO+    briDocByExactInlineOnly "" ltype+  HsWildCardTy _ ->+    docLit $ Text.pack "_"
+ src/Language/Haskell/Brittany/Internal/Prelude.hs view
@@ -0,0 +1,68 @@+module Language.Haskell.Brittany.Internal.Prelude+where++++import Prelude+import qualified Data.Strict.Maybe as Strict+import Debug.Trace+import Control.Monad+import System.IO++import Control.DeepSeq ( NFData, force )+import Control.Exception.Base ( evaluate )++import Control.Applicative++++instance Applicative Strict.Maybe where+  pure = Strict.Just+  Strict.Just f <*> Strict.Just x = Strict.Just (f x)+  _ <*> _ = Strict.Nothing++instance Monad Strict.Maybe where+  return = Strict.Just+  Strict.Nothing >>= _ = Strict.Nothing+  Strict.Just x >>= f = f x++instance Alternative Strict.Maybe where+  empty = Strict.Nothing+  x <|> Strict.Nothing = x+  _ <|> x = x++traceFunctionWith+  :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)+traceFunctionWith name s1 s2 f x =+  trace traceStr y+  where+    y = f x+    traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y++(<&!>) :: Monad m => m a -> (a -> b) -> m b+(<&!>) = flip (<$!>)++putStrErrLn :: String -> IO ()+putStrErrLn s = hPutStrLn stderr s++printErr :: Show a => a -> IO ()+printErr = putStrErrLn . show++errorIf :: Bool -> a -> a+errorIf False = id+errorIf True  = error "errorIf"++errorIfNote :: Maybe String -> a -> a+errorIfNote Nothing  = id+errorIfNote (Just x) = error x++(<&>) :: Functor f => f a -> (a -> b) -> f b+(<&>) = flip fmap+infixl 4 <&>++(.>) :: (a -> b) -> (b -> c) -> (a -> c)+f .> g = g . f+infixl 9 .>++evaluateDeep :: NFData a => a -> IO a+evaluateDeep = evaluate . force
+ src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs view
@@ -0,0 +1,826 @@+#define INSERTTRACESALT 0+#define INSERTTRACESALTVISIT 0+#define INSERTTRACESGETSPACING 0++{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}++module Language.Haskell.Brittany.Internal.Transformations.Alt+  ( transformAlts+  )+where++++#include "prelude.inc"++import           Data.HList.ContainsType++import           Language.Haskell.Brittany.Internal.Utils+import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.Types++import qualified Control.Monad.Memo as Memo++++data AltCurPos = AltCurPos+  { _acp_line :: Int -- chars in the current line+  , _acp_indent :: Int -- current indentation level+  , _acp_indentPrep :: Int -- indentChange affecting the next Par+  , _acp_forceMLFlag :: AltLineModeState+  }+  deriving (Show)++data AltLineModeState+  = AltLineModeStateNone+  | AltLineModeStateForceML Bool -- true ~ decays on next wrap+  | AltLineModeStateForceSL+  | AltLineModeStateContradiction+  -- i.e. ForceX False -> ForceX True -> None+  deriving (Show)++altLineModeRefresh :: AltLineModeState -> AltLineModeState+altLineModeRefresh AltLineModeStateNone          = AltLineModeStateNone+altLineModeRefresh AltLineModeStateForceML{}     = AltLineModeStateForceML False+altLineModeRefresh AltLineModeStateForceSL       = AltLineModeStateForceSL+altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction++altLineModeDecay :: AltLineModeState -> AltLineModeState+altLineModeDecay AltLineModeStateNone            = AltLineModeStateNone+altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True+altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone+altLineModeDecay AltLineModeStateForceSL         = AltLineModeStateForceSL+altLineModeDecay AltLineModeStateContradiction   = AltLineModeStateContradiction++mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos+mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of+  (AltLineModeStateContradiction, _) -> acp+  (AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x }+  (AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp+  (AltLineModeStateForceML{}, AltLineModeStateForceML{}) ->+    acp { _acp_forceMLFlag = s }+  _ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction }+++-- removes any BDAlt's from the BriDoc+transformAlts+  :: forall r w s+   . ( Data.HList.ContainsType.ContainsType Config r+     , Data.HList.ContainsType.ContainsType (Seq String) w+     )+  => BriDocNumbered+  -> MultiRWSS.MultiRWS r w s BriDoc+transformAlts briDoc =+  MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone)+    $ Memo.startEvalMemoT+    $ fmap unwrapBriDocNumbered+    $ rec+    $ briDoc+  where+    -- this funtion is exponential by nature and cannot be improved in any+    -- way i can think of, and if tried. (stupid StableNames.)+    -- transWrap :: BriDoc -> BriDocNumbered+    -- transWrap brDc = flip StateS.evalState (1::Int)+    --                $ Memo.startEvalMemoT+    --                $ go brDc+    --   where+    --     incGet = StateS.get >>= \i -> StateS.put (i+1) $> i+    --     go :: BriDoc -> Memo.MemoT BriDoc BriDocNumbered (StateS.State Int) BriDocNumbered+    --     go = Memo.memo $ \bdX -> do+    --       i <- lift $ incGet+    --       fmap (\bd' -> (i,bd')) $ case bdX of+    --         BDEmpty           -> return $ BDFEmpty+    --         BDLit t           -> return $ BDFLit t+    --         BDSeq list        -> BDFSeq <$> go `mapM` list+    --         BDCols sig list   -> BDFCols sig <$> go `mapM` list+    --         BDSeparator       -> return $ BDFSeparator+    --         BDAddBaseY ind bd -> BDFAddBaseY ind <$> go bd+    --         BDSetBaseY bd     -> BDFSetBaseY <$> go bd+    --         BDSetIndentLevel bd     -> BDFSetIndentLevel <$> go bd+    --         BDPar ind line indented -> [ BDFPar ind line' indented'+    --                                    | line' <- go line+    --                                    , indented' <- go indented+    --                                    ]+    --         BDAlt alts              -> BDFAlt <$> go `mapM` alts -- not that this will happen+    --         BDForceMultiline  bd    -> BDFForceMultiline <$> go bd+    --         BDForceSingleline bd    -> BDFForceSingleline <$> go bd+    --         BDForwardLineMode bd    -> BDFForwardLineMode <$> go bd+    --         BDExternal k ks c t         -> return $ BDFExternal k ks c t+    --         BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd+    --         BDAnnotationPost  annKey bd -> BDFAnnotationRest  annKey <$> go bd+    --         BDLines lines         -> BDFLines <$> go `mapM` lines+    --         BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd+    --         BDProhibitMTEL bd     -> BDFProhibitMTEL <$> go bd++++    rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered+    rec bdX@(brDcId, brDc) = do+#if INSERTTRACESALTVISIT+      do+        acp :: AltCurPos <- mGet+        tellDebugMess $ "transformAlts: visiting: " ++ case brDc of+          BDFAnnotationPrior annKey _ -> show (toConstr brDc, annKey, acp)+          BDFAnnotationRest annKey _ -> show (toConstr brDc, annKey, acp)+          _ -> show (toConstr brDc, acp)+#endif+      let reWrap = (,) brDcId+      -- debugAcp :: AltCurPos <- mGet+      case brDc of+        -- BDWrapAnnKey annKey bd -> do+        --   acp <- mGet+        --   mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }+        --   BDWrapAnnKey annKey <$> rec bd+        BDFEmpty{}    -> processSpacingSimple bdX $> bdX+        BDFLit{}      -> processSpacingSimple bdX $> bdX+        BDFSeq list      ->+          reWrap . BDFSeq <$> list `forM` rec+        BDFCols sig list ->+          reWrap . BDFCols sig <$> list `forM` rec+        BDFSeparator  -> processSpacingSimple bdX $> bdX+        BDFAddBaseY indent bd -> do+          acp <- mGet+          indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack+          let indAdd = case indent of+                BrIndentNone -> 0+                BrIndentRegular -> indAmount+                BrIndentSpecial i -> i+          mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd }+          r <- rec bd+          acp' <- mGet+          mSet $ acp' { _acp_indent = _acp_indent acp }+          return $ case indent of+            BrIndentNone -> r+            BrIndentRegular ->   reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r+            BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r+        BDFBaseYPushCur bd -> do+          acp <- mGet+          mSet $ acp { _acp_indent = _acp_line acp }+          r <- rec bd+          return $ reWrap $ BDFBaseYPushCur r+        BDFBaseYPop bd -> do+          acp <- mGet+          r <- rec bd+          acp' <- mGet+          mSet $ acp' { _acp_indent = _acp_indentPrep acp }+          return $ reWrap $ BDFBaseYPop r+        BDFIndentLevelPushCur bd -> do+          reWrap . BDFIndentLevelPushCur <$> rec bd+        BDFIndentLevelPop bd -> do+          reWrap . BDFIndentLevelPop <$> rec bd+        BDFPar indent sameLine indented -> do+          indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack+          let indAdd = case indent of+                BrIndentNone -> 0+                BrIndentRegular -> indAmount+                BrIndentSpecial i -> i+          acp <- mGet+          let ind = _acp_indent acp + _acp_indentPrep acp + indAdd+          mSet $ acp+            { _acp_indent = ind+            , _acp_indentPrep = 0+            }+          sameLine' <- rec sameLine+          mModify $ \acp' -> acp'+            { _acp_line   = ind+            , _acp_indent = ind+            }+          indented' <- rec indented+          return $ reWrap $ BDFPar indent sameLine' indented'+        BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a+                                        -- possibility, but i will prefer a+                                        -- fail-early approach; BDEmpty does not+                                        -- make sense semantically for Alt[].+        BDFAlt alts -> do+          altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack+          case altChooser of+            AltChooserSimpleQuick -> do+              rec $ head alts+            AltChooserShallowBest -> do+              spacings <- alts `forM` getSpacing+              acp <- mGet+              let lineCheck LineModeInvalid = False+                  lineCheck (LineModeValid (VerticalSpacing _ p _)) =+                    case _acp_forceMLFlag acp of+                      AltLineModeStateNone      -> True+                      AltLineModeStateForceSL{} -> p == VerticalSpacingParNone+                      AltLineModeStateForceML{} -> p /= VerticalSpacingParNone+                      AltLineModeStateContradiction -> False+                  lineCheck _ = error "ghc exhaustive check is insufficient"+              lconf <- _conf_layout <$> mAsk+#if INSERTTRACESALT+              tellDebugMess $ "considering options with " ++ show (length alts, acp)+#endif+              let options = -- trace ("considering options:" ++ show (length alts, acp)) $+                            (zip spacings alts+                             <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))+                               ( hasSpace1 lconf acp vs && lineCheck vs, bd))+#if INSERTTRACESALT+              zip spacings options `forM_` \(vs, (_, bd)) ->+                tellDebugMess $ "  " ++ "spacing=" ++ show vs+                             ++ ",hasSpace1=" ++ show (hasSpace1 lconf acp vs)+                             ++ ",lineCheck=" ++ show (lineCheck vs)+                             ++ " " ++ show (toConstr bd)+#endif+              id -- - $ (fmap $ \x -> traceShow (briDocToDoc x) x)+                 $ rec+                 $ fromMaybe (-- trace ("choosing last") $+                              List.last alts)+                 $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) ->+                     [ -- traceShow ("choosing option " ++ show i) $+                       x+                     | b+                     ])+                 $ zip [1..] options+            AltChooserBoundedSearch limit -> do+              spacings <- alts `forM` getSpacings limit+              acp <- mGet+              let lineCheck (VerticalSpacing _ p _) =+                    case _acp_forceMLFlag acp of+                      AltLineModeStateNone      -> True+                      AltLineModeStateForceSL{} -> p == VerticalSpacingParNone+                      AltLineModeStateForceML{} -> p /= VerticalSpacingParNone+                      AltLineModeStateContradiction -> False+              lconf <- _conf_layout <$> mAsk+#if INSERTTRACESALT+              tellDebugMess $ "considering options with " ++ show (length alts, acp)+#endif+              let options = -- trace ("considering options:" ++ show (length alts, acp)) $+                            (zip spacings alts+                             <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))+                               (  any (hasSpace2 lconf acp) vs+                               && any lineCheck vs, bd))+              let checkedOptions :: [Maybe (Int, BriDocNumbered)] =+                    zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ])+#if INSERTTRACESALT+              zip spacings options `forM_` \(vs, (_, bd)) ->+                tellDebugMess $ "  " ++ "spacing=" ++ show vs+                             ++ ",hasSpace2=" ++ show (hasSpace2 lconf acp <$> vs)+                             ++ ",lineCheck=" ++ show (lineCheck <$> vs)+                             ++ " " ++ show (toConstr bd)+              tellDebugMess $ "  " ++ show (Data.Maybe.mapMaybe (fmap fst) checkedOptions)+#endif+              id -- - $ (fmap $ \x -> traceShow (briDocToDoc x) x)+                 $ rec+                 $ fromMaybe (-- trace ("choosing last") $+                              List.last alts)+                 $ Data.List.Extra.firstJust (fmap snd) checkedOptions+        BDFForceMultiline bd -> do+          acp <- mGet+          x <- do+            mSet $ mergeLineMode acp (AltLineModeStateForceML False)+            rec bd+          acp' <- mGet+          mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }+          return $ x+        BDFForceSingleline bd -> do+          acp <- mGet+          x <- do+            mSet $ mergeLineMode acp AltLineModeStateForceSL+            rec bd+          acp' <- mGet+          mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }+          return $ x+        BDFForwardLineMode bd -> do+          acp <- mGet+          x <- do+            mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp }+            rec bd+          acp' <- mGet+          mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }+          return $ x+        BDFExternal{} -> processSpacingSimple bdX $> bdX+        BDFAnnotationPrior annKey bd -> do+          acp <- mGet+          mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }+          bd' <- rec bd+          return $ reWrap $ BDFAnnotationPrior annKey bd'+        BDFAnnotationRest annKey bd ->+          reWrap . BDFAnnotationRest annKey <$> rec bd+        BDFAnnotationKW annKey kw bd ->+          reWrap . BDFAnnotationKW annKey kw <$> rec bd+        BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless.+        BDFLines (l:lr) -> do+          ind <- _acp_indent <$> mGet+          l' <- rec l+          lr' <- lr `forM` \x -> do+            mModify $ \acp -> acp+              { _acp_line   = ind+              , _acp_indent = ind+              }+            rec x+          return $ reWrap $ BDFLines (l':lr')+        BDFEnsureIndent indent bd -> do+          acp <- mGet+          indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack+          let indAdd = case indent of+                BrIndentNone -> 0+                BrIndentRegular -> indAmount+                BrIndentSpecial i -> i+          mSet $ acp { _acp_indentPrep = 0 -- TODO: i am not sure this is valid,+                                           -- in general.+                     , _acp_indent = _acp_indent acp + indAdd+                     , _acp_line = _acp_line acp + indAdd+                     }+          r <- rec bd+          acp' <- mGet+          mSet $ acp' { _acp_indent = _acp_indent acp }+          return $ case indent of+            BrIndentNone -> r+            BrIndentRegular ->   reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r+            BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r+        BDFNonBottomSpacing bd -> rec bd+        BDFSetParSpacing bd -> rec bd+        BDFForceParSpacing bd -> rec bd+        BDFProhibitMTEL bd ->+          reWrap . BDFProhibitMTEL <$> rec bd+        BDFDebug s bd -> do+          acp :: AltCurPos <- mGet+          tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp+          reWrap . BDFDebug s <$> rec bd+    processSpacingSimple :: (MonadMultiReader+                                                     Config m,+                                                   MonadMultiState AltCurPos m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m ()+    processSpacingSimple bd = getSpacing bd >>= \case+      LineModeInvalid                           -> error "processSpacingSimple inv"+      LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do+        acp <- mGet+        mSet $ acp { _acp_line = _acp_line acp + i }+      LineModeValid (VerticalSpacing _ _ _)  -> error "processSpacingSimple par"+      _ -> error "ghc exhaustive check is insufficient"+    hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool+    hasSpace1 _ _ LineModeInvalid = False+    hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs+    hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient"+    hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool+    hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _)+      = line + sameLine <= confUnpack (_lconfig_cols lconf)+    hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _)+      = line + sameLine <= confUnpack (_lconfig_cols lconf)+        && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf)+    hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _)+      = line + sameLine <= confUnpack (_lconfig_cols lconf)++getSpacing+  :: forall m+   . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)+  => BriDocNumbered+  -> m (LineModeValidity VerticalSpacing)+getSpacing !bridoc = rec bridoc+ where+  rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing)+  rec (brDcId, brDc) = do+    config <- mAsk+    let colMax = config & _conf_layout & _lconfig_cols & confUnpack+    result <- case brDc of+      -- BDWrapAnnKey _annKey bd -> rec bd+      BDFEmpty ->+        return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False+      BDFLit t ->+        return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False+      BDFSeq list ->+        sumVs <$> rec `mapM` list+      BDFCols _sig list -> sumVs <$> rec `mapM` list+      BDFSeparator ->+        return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False+      BDFAddBaseY indent bd -> do+        mVs <- rec bd+        return $ mVs <&> \vs -> vs+          { _vs_paragraph = case _vs_paragraph vs of+              VerticalSpacingParNone -> VerticalSpacingParNone+              VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of+                BrIndentNone      -> i+                BrIndentRegular   -> i + ( confUnpack+                                         $ _lconfig_indentAmount+                                         $ _conf_layout+                                         $ config+                                         )+                BrIndentSpecial j -> i + j+              VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of+                BrIndentNone      -> i+                BrIndentRegular   -> i + ( confUnpack+                                         $ _lconfig_indentAmount+                                         $ _conf_layout+                                         $ config+                                         )+                BrIndentSpecial j -> i + j+          }+      BDFBaseYPushCur bd -> do+        mVs <- rec bd+        return $ mVs <&> \vs -> vs+          -- We leave par as-is, even though it technically is not+          -- accurate (in general).+          -- the reason is that we really want to _keep_ it Just if it is+          -- just so we properly communicate the is-multiline fact.+          -- An alternative would be setting to (Just 0).+          { _vs_sameLine = max (_vs_sameLine vs)+                               (case _vs_paragraph vs of+                                  VerticalSpacingParNone -> 0+                                  VerticalSpacingParSome i -> i+                                  VerticalSpacingParAlways i -> min colMax i)+          , _vs_paragraph = VerticalSpacingParSome 0+          }+      BDFBaseYPop bd -> rec bd+      BDFIndentLevelPushCur bd -> rec bd+      BDFIndentLevelPop bd -> rec bd+      BDFPar BrIndentNone sameLine indented -> do+        mVs <- rec sameLine+        mIndSp <- rec indented+        return+          $ [ VerticalSpacing lsp pspResult parFlagResult+            | VerticalSpacing lsp mPsp _ <- mVs+            , indSp <- mIndSp+            , lineMax <- getMaxVS $ mIndSp+            , let pspResult = case mPsp of+                    VerticalSpacingParSome psp   -> VerticalSpacingParSome $ max psp lineMax+                    VerticalSpacingParNone       -> VerticalSpacingParSome $ lineMax+                    VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax+            , let parFlagResult =  mPsp == VerticalSpacingParNone+                                && _vs_paragraph indSp ==  VerticalSpacingParNone+                                && _vs_parFlag indSp+            ]+      BDFPar{} -> error "BDPar with indent in getSpacing"+      BDFAlt [] -> error "empty BDAlt"+      BDFAlt (alt:_) -> rec alt+      BDFForceMultiline  bd -> rec bd+      BDFForceSingleline bd -> do+        mVs <- rec bd+        return $ mVs >>= _vs_paragraph .> \case+          VerticalSpacingParNone -> mVs+          _  -> LineModeInvalid+      BDFForwardLineMode bd -> rec bd+      BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of+        [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False+        _   -> VerticalSpacing 999 VerticalSpacingParNone False+      BDFAnnotationPrior _annKey bd -> rec bd+      BDFAnnotationKW _annKey _kw bd -> rec bd+      BDFAnnotationRest  _annKey bd -> rec bd+      BDFLines [] -> return+        $ LineModeValid+        $ VerticalSpacing 0 VerticalSpacingParNone False+      BDFLines ls@(_:_) -> do+        lSps@(mVs:_) <- rec `mapM` ls+        return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False+                 | VerticalSpacing lsp _ _ <- mVs+                 , lineMax <- getMaxVS $ maxVs $ lSps+                 ]+      BDFEnsureIndent indent bd -> do+        mVs <- rec bd+        let addInd = case indent of+              BrIndentNone      -> 0+              BrIndentRegular   -> confUnpack+                                 $ _lconfig_indentAmount+                                 $ _conf_layout+                                 $ config+              BrIndentSpecial i -> i+        return $ mVs <&> \(VerticalSpacing lsp psp pf) ->+          VerticalSpacing (lsp + addInd) psp pf+      BDFNonBottomSpacing bd -> do+        mVs <- rec bd+        return+          $   mVs+          <|> LineModeValid (VerticalSpacing 0+                                             (VerticalSpacingParAlways colMax)+                                             False)+      BDFSetParSpacing bd -> do+        mVs <- rec bd+        return $ mVs <&> \vs -> vs { _vs_parFlag = True }+      BDFForceParSpacing bd -> do+        mVs <- rec bd+        return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ]+      BDFProhibitMTEL bd -> rec bd+      BDFDebug s bd -> do+        r <- rec bd+        tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r+        return r+#if INSERTTRACESGETSPACING+    tellDebugMess $ "getSpacing: visiting: " ++ show (toConstr $ brDc) ++ " -> " ++ show result+#endif+    return result+  maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing+  maxVs = foldl'+    (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->+        VerticalSpacing (max x1 y1) (case (x2, y2) of+          (x, VerticalSpacingParNone) -> x+          (VerticalSpacingParNone, x) -> x+          (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->+            VerticalSpacingParAlways $ max i j+          (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->+            VerticalSpacingParAlways $ max i j+          (VerticalSpacingParSome j, VerticalSpacingParAlways i) ->+            VerticalSpacingParAlways $ max i j+          (VerticalSpacingParSome x, VerticalSpacingParSome y) ->+            VerticalSpacingParSome $ max x y) False))+    (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False)+  sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing+  sumVs sps = foldl' (liftM2 go) initial sps+   where+    go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing+      (x1 + y1)+      (case (x2, y2) of+        (x, VerticalSpacingParNone) -> x+        (VerticalSpacingParNone, x) -> x+        (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->+          VerticalSpacingParAlways $ i+j+        (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->+          VerticalSpacingParAlways $ i+j+        (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->+          VerticalSpacingParAlways $ i+j+        (VerticalSpacingParSome x, VerticalSpacingParSome y) ->+          VerticalSpacingParSome $ x + y)+      x3+    singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone+    singleline _                 = False+    isPar (LineModeValid x) = _vs_parFlag x+    isPar _                 = False+    parFlag = case sps of+      [] -> True+      _ -> all singleline (List.init sps) && isPar (List.last sps)+    initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag+  getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int+  getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of+    VerticalSpacingParSome i -> i+    VerticalSpacingParNone -> 0+    VerticalSpacingParAlways i -> i++getSpacings+  :: forall m+   . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)+  => Int+  -> BriDocNumbered+  -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]+getSpacings limit bridoc = preFilterLimit <$> rec bridoc+  where+    -- when we do `take K . filter someCondition` on a list of spacings, we+    -- need to first (also) limit the size of the input list, otherwise a+    -- _large_ input with a similarly _large_ prefix not passing our filtering+    -- process could lead to exponential runtime behaviour.+    -- TODO: 3 is arbitrary.+    preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing]+    preFilterLimit = take (3*limit)+    memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v+    memoWithKey k v = Memo.memo (const v) k+    rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]+    rec (brDcId, brdc) = memoWithKey brDcId $ do+      config <- mAsk+      let colMax = config & _conf_layout & _lconfig_cols & confUnpack+      let hasOkColCount (VerticalSpacing lsp psp _) =+            lsp <= colMax && case psp of+              VerticalSpacingParNone -> True+              VerticalSpacingParSome i -> i <= colMax+              VerticalSpacingParAlways{} -> True+      let -- the standard function used to enforce a constant upper bound+          -- on the number of elements returned for each node. Should be+          -- applied whenever in a parent the combination of spacings from+          -- its children might cause excess of the upper bound.+          filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing]+          filterAndLimit = take limit+                           -- prune so we always consider a constant+                           -- amount of spacings per node of the BriDoc.+                         . filter hasOkColCount+                           -- throw out any spacings (i.e. children) that+                           -- already use more columns than available in+                           -- total.+                         . List.nub+                           -- In the end we want to know if there is at least+                           -- one valid spacing for any alternative.+                           -- If there are duplicates in the list, then these+                           -- will either all be valid (so having more than the+                           -- first is pointless) or all invalid (in which+                           -- case having any of them is pointless).+                           -- Nonetheless I think the order of spacings should+                           -- be preserved as it provides a deterministic+                           -- choice for which spacings to prune (which is+                           -- an argument against simly using a Set).+                           -- I have also considered `fmap head . group` which+                           -- seems to work similarly well for common cases+                           -- and which might behave even better when it comes+                           -- to determinism of the algorithm. But determinism+                           -- should not be overrated here either - in the end+                           -- this is about deterministic behaviour of the+                           -- pruning we do that potentially results in+                           -- non-optimal layouts, and we'd rather take optimal+                           -- layouts when we can than take non-optimal layouts+                           -- just to be consistent with other cases where+                           -- we'd choose non-optimal layouts.+                         . preFilterLimit+      result <- case brdc of+        -- BDWrapAnnKey _annKey bd -> rec bd+        BDFEmpty ->+          return $ [VerticalSpacing 0 VerticalSpacingParNone False]+        BDFLit t ->+          return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]+        BDFSeq list ->+          fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list+        BDFCols _sig list ->+          fmap sumVs . sequence . fmap filterAndLimit <$> rec `mapM` list+        BDFSeparator ->+          return $ [VerticalSpacing 1 VerticalSpacingParNone False]+        BDFAddBaseY indent bd -> do+          mVs <- rec bd+          return $ mVs <&> \vs -> vs+            { _vs_paragraph = case _vs_paragraph vs of+                VerticalSpacingParNone -> VerticalSpacingParNone+                VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of+                  BrIndentNone      -> i+                  BrIndentRegular   -> i + ( confUnpack+                                           $ _lconfig_indentAmount+                                           $ _conf_layout+                                           $ config+                                           )+                  BrIndentSpecial j -> i + j+                VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of+                  BrIndentNone      -> i+                  BrIndentRegular   -> i + ( confUnpack+                                           $ _lconfig_indentAmount+                                           $ _conf_layout+                                           $ config+                                           )+                  BrIndentSpecial j -> i + j+            }+        BDFBaseYPushCur bd -> do+          mVs <- rec bd+          return $ mVs <&> \vs -> vs+            -- We leave par as-is, even though it technically is not+            -- accurate (in general).+            -- the reason is that we really want to _keep_ it Just if it is+            -- just so we properly communicate the is-multiline fact.+            -- An alternative would be setting to (Just 0).+            { _vs_sameLine = max (_vs_sameLine vs)+                                 (case _vs_paragraph vs of+                                  VerticalSpacingParNone -> 0+                                  VerticalSpacingParSome i -> i+                                  VerticalSpacingParAlways i -> min colMax i)+            , _vs_paragraph = case _vs_paragraph vs of+                VerticalSpacingParNone -> VerticalSpacingParNone+                VerticalSpacingParSome i -> VerticalSpacingParSome i+                VerticalSpacingParAlways i -> VerticalSpacingParAlways i+            }+        BDFBaseYPop bd -> rec bd+        BDFIndentLevelPushCur bd -> rec bd+        BDFIndentLevelPop bd -> rec bd+        BDFPar BrIndentNone sameLine indented -> do+          mVss   <- filterAndLimit <$> rec sameLine+          indSps <- filterAndLimit <$> rec indented+          let mVsIndSp = take limit+                       $ [ (x,y)+                         | x<-mVss+                         , y<-indSps+                         ]+          return $ mVsIndSp <&>+            \(VerticalSpacing lsp mPsp _, indSp) ->+              VerticalSpacing+                lsp+                (case mPsp of+                  VerticalSpacingParSome psp ->+                    VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO+                  VerticalSpacingParNone -> spMakePar indSp+                  VerticalSpacingParAlways psp ->+                    VerticalSpacingParAlways $ max psp $ getMaxVS indSp)+                (  mPsp == VerticalSpacingParNone+                && _vs_paragraph indSp == VerticalSpacingParNone+                && _vs_parFlag indSp+                )++        BDFPar{} -> error "BDPar with indent in getSpacing"+        BDFAlt [] -> error "empty BDAlt"+        -- BDAlt (alt:_) -> rec alt+        BDFAlt alts -> do+          r <- rec `mapM` alts+          return $ filterAndLimit =<< r+        BDFForceMultiline  bd -> rec bd+        BDFForceSingleline bd -> do+          mVs <- filterAndLimit <$> rec bd+          return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs+        BDFForwardLineMode bd -> rec bd+        BDFExternal _ _ _ txt | [t] <- Text.lines txt ->+          return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]+        BDFExternal{} ->+          return $ [] -- yes, we just assume that we cannot properly layout+                      -- this.+        BDFAnnotationPrior _annKey bd -> rec bd+        BDFAnnotationKW _annKey _kw bd -> rec bd+        BDFAnnotationRest  _annKey bd -> rec bd+        BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]+        BDFLines ls@(_:_) -> do+          -- we simply assume that lines is only used "properly", i.e. in+          -- such a way that the first line can be treated "as a part of the+          -- paragraph". That most importantly means that Lines should never+          -- be inserted anywhere but at the start of the line. A+          -- counterexample would be anything like Seq[Lit "foo", Lines].+          lSpss <- fmap filterAndLimit <$> rec `mapM` ls+          let worbled = fmap reverse+                      $ sequence+                      $ reverse+                      $ lSpss+              summed = worbled <&> \lSps@(lSp1:_) ->+                VerticalSpacing (_vs_sameLine lSp1) +                                (spMakePar $ maxVs lSps)+                                False+          return $ summed+          -- lSpss@(mVs:_) <- rec `mapM` ls+          -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only+          --                      -- consider the first alternative for the+          --                      -- line's spacings.+          --                      -- also i am not sure if always including+          --                      -- the first line length in the paragraph+          --                      -- length gives the desired results.+          --                      -- it is the safe path though, for now.+          --   []       -> []+          --   (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) ->+          --     VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps+        BDFEnsureIndent indent bd -> do+          mVs <- rec bd+          let addInd = case indent of+                BrIndentNone      -> 0+                BrIndentRegular   -> confUnpack+                                   $ _lconfig_indentAmount+                                   $ _conf_layout+                                   $ config+                BrIndentSpecial i -> i+          return $ mVs <&> \(VerticalSpacing lsp psp parFlag) ->+            VerticalSpacing (lsp + addInd) psp parFlag+        BDFNonBottomSpacing bd -> do+          mVs <- rec bd+          return $ if null mVs+            then [VerticalSpacing 0 (VerticalSpacingParAlways colMax) False]+            else mVs <&> \vs -> vs+              { _vs_paragraph = case _vs_paragraph vs of+                  VerticalSpacingParNone -> VerticalSpacingParNone+                  VerticalSpacingParAlways i -> VerticalSpacingParAlways i+                  VerticalSpacingParSome i -> VerticalSpacingParAlways i+              }+        BDFSetParSpacing bd -> do+          mVs <- rec bd+          return $ mVs <&> \vs -> vs { _vs_parFlag = True }+        BDFForceParSpacing bd -> do+          mVs <- preFilterLimit <$> rec bd+          return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ]+        BDFProhibitMTEL bd -> rec bd+        BDFDebug s bd -> do+          r <- rec bd+          tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r)+          return r+#if INSERTTRACESGETSPACING+      case brdc of+        BDFAnnotationPrior{} -> return ()+        BDFAnnotationRest{} -> return ()+        _ -> mTell $ Seq.fromList ["getSpacings: visiting: "+                            ++ show (toConstr $ brdc) -- (briDocToDoc $ unwrapBriDocNumbered (0, brdc))+                           , " -> "+                            ++ show (take 9 result)+                           ]+#endif+      return result+    maxVs :: [VerticalSpacing] -> VerticalSpacing+    maxVs = foldl'+      (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->+          VerticalSpacing+            (max x1 y1)+            (case (x2, y2) of+              (x, VerticalSpacingParNone) -> x+              (VerticalSpacingParNone, x) -> x+              (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->+                VerticalSpacingParAlways $ max i j+              (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->+                VerticalSpacingParAlways $ max i j+              (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->+                VerticalSpacingParAlways $ max i j+              (VerticalSpacingParSome x, VerticalSpacingParSome y) ->+                VerticalSpacingParSome $ max x y)+            False)+      (VerticalSpacing 0 VerticalSpacingParNone False)+    sumVs :: [VerticalSpacing] -> VerticalSpacing+    sumVs sps = foldl' go initial sps+     where+      go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing+        (x1 + y1)+        (case (x2, y2) of+          (x, VerticalSpacingParNone) -> x+          (VerticalSpacingParNone, x) -> x+          (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->+            VerticalSpacingParAlways $ i+j+          (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->+            VerticalSpacingParAlways $ i+j+          (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->+            VerticalSpacingParAlways $ i+j+          (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y)+        x3+      singleline x = _vs_paragraph x == VerticalSpacingParNone+      isPar      x = _vs_parFlag x+      parFlag = case sps of+        [] -> True+        _ -> all singleline (List.init sps) && isPar (List.last sps)+      initial = VerticalSpacing 0 VerticalSpacingParNone parFlag+    getMaxVS :: VerticalSpacing -> Int+    getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of+      VerticalSpacingParSome i -> i+      VerticalSpacingParNone -> 0+      VerticalSpacingParAlways i -> i+    spMakePar :: VerticalSpacing -> VerticalSpacingPar+    spMakePar (VerticalSpacing x1 x2 _) = case x2 of+      VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i+      VerticalSpacingParNone -> VerticalSpacingParSome $ x1+      VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i
+ src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs view
@@ -0,0 +1,136 @@+module Language.Haskell.Brittany.Internal.Transformations.Columns+  ( transformSimplifyColumns+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Utils+import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.Types++import qualified Data.Generics.Uniplate.Direct as Uniplate++++transformSimplifyColumns :: BriDoc -> BriDoc+transformSimplifyColumns = Uniplate.rewrite $ \case+  -- BDWrapAnnKey annKey bd ->+  --   BDWrapAnnKey annKey $ transformSimplify bd+  BDEmpty -> Nothing+  BDLit{} -> Nothing+  BDSeq list | any (\case BDSeq{} -> True+                          BDEmpty{} -> True+                          _ -> False) list -> Just $ BDSeq $+    filter isNotEmpty list >>= \case+      BDSeq l -> l+      x -> [x]+  BDSeq (BDCols sig1 cols1@(_:_):rest) ->+    Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)])+  BDLines lines | any (\case BDLines{} -> True+                             BDEmpty{} -> True+                             _ -> False) lines ->+    Just $ BDLines $ filter isNotEmpty $ lines >>= \case+      BDLines l -> l+      x -> [x]+  -- prior floating in+  BDAnnotationPrior annKey1 (BDSeq (l:lr)) ->+    Just $ BDSeq (BDAnnotationPrior annKey1 l:lr)+  BDAnnotationPrior annKey1 (BDLines (l:lr)) ->+    Just $ BDLines (BDAnnotationPrior annKey1 l:lr)+  BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->+    Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr)+  -- post floating in+  BDAnnotationRest annKey1 (BDSeq list) ->+    Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]+  BDAnnotationRest annKey1 (BDLines list) ->+    Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]+  BDAnnotationRest annKey1 (BDCols sig cols) ->+    Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]+  BDAnnotationKW annKey1 kw (BDSeq list) ->+    Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]+  BDAnnotationKW annKey1 kw (BDLines list) ->+    Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]+  BDAnnotationKW annKey1 kw (BDCols sig cols) ->+    Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols]+  -- ensureIndent float-in+  -- not sure if the following rule is necessary; tests currently are+  -- unaffected.+  -- BDEnsureIndent indent (BDLines lines) ->+  --   Just $ BDLines $ BDEnsureIndent indent <$> lines+  -- matching col special transformation+  BDCols sig1 cols1@(_:_)+    | BDLines lines@(_:_:_) <- List.last cols1+    , BDCols sig2 cols2 <- List.last lines+    , sig1==sig2 ->+        Just $ BDLines+          [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]+          , BDCols sig2 cols2+          ]+  BDCols sig1 cols1@(_:_)+    | BDLines lines@(_:_:_) <- List.last cols1+    , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines+    , sig1==sig2 ->+        Just $ BDLines+          [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]+          , BDCols sig2 cols2+          ]+  BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 ->+    Just $ BDAddBaseY ind (BDLines [col1, col2])+  BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest))+    | sig1==sig2 ->+    Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)+  BDPar ind (BDLines lines1) col2@(BDCols sig2 _)+    | BDCols sig1 _ <- List.last lines1+    , sig1==sig2 ->+    Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2])+  BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest))+    | BDCols sig1 _ <- List.last lines1+    , sig1==sig2 ->+    Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest)+  -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2))+  --   | sig1==sig2 ->+  --       Just $ BDPar+  --         ind1+  --         (BDLines [BDCols sig1 cols1, BDCols sig])+  BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols+                   , sig1==sig2 ->+    Just $ BDLines+      [ BDCols sig1 (List.init cols ++ [line])+      , BDCols sig2 cols2+      ]+  BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols+                   , BDCols sig2 cols2 <- List.last lines+                   , sig1==sig2 ->+    Just $ BDLines+      [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)]+      , BDCols sig2 cols2+      ]+  BDLines [x]         -> Just $ x+  BDLines []          -> Just $ BDEmpty+  BDSeq{}             -> Nothing+  BDCols{}            -> Nothing+  BDSeparator         -> Nothing+  BDAddBaseY{}        -> Nothing+  BDBaseYPushCur{}    -> Nothing+  BDBaseYPop{}        -> Nothing+  BDIndentLevelPushCur{} -> Nothing+  BDIndentLevelPop{}  -> Nothing+  BDPar{}             -> Nothing+  BDAlt{}             -> Nothing+  BDForceMultiline{}  -> Nothing+  BDForceSingleline{} -> Nothing+  BDForwardLineMode{} -> Nothing+  BDExternal{}        -> Nothing+  BDLines{}           -> Nothing+  BDAnnotationPrior{} -> Nothing+  BDAnnotationKW{}    -> Nothing+  BDAnnotationRest{}  -> Nothing+  BDEnsureIndent{}    -> Nothing+  BDProhibitMTEL{}    -> Nothing+  BDSetParSpacing{}   -> Nothing+  BDForceParSpacing{} -> Nothing+  BDDebug{}           -> Nothing+  BDNonBottomSpacing x -> Just x
+ src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs view
@@ -0,0 +1,192 @@+module Language.Haskell.Brittany.Internal.Transformations.Floating+  ( transformSimplifyFloating+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Utils+import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.Types++import qualified Data.Generics.Uniplate.Direct as Uniplate++++-- note that this is not total, and cannot be with that exact signature.+mergeIndents :: BrIndent -> BrIndent -> BrIndent+mergeIndents BrIndentNone        x                   = x+mergeIndents x                   BrIndentNone        = x+mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j)+mergeIndents _                   _                   = error "mergeIndents"+++transformSimplifyFloating :: BriDoc -> BriDoc+transformSimplifyFloating = stepBO .> stepFull+  -- note that semantically, stepFull is completely sufficient.+  -- but the bottom-up switch-to-top-down-on-match transformation has much+  -- better complexity.+  -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence+  --         the push/pop cases would need to be copied over+  where+    descendPrior = transformDownMay $ \case+      -- prior floating in+      BDAnnotationPrior annKey1 (BDPar ind line indented) ->+         Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented+      BDAnnotationPrior annKey1 (BDSeq (l:lr)) ->+         Just $ BDSeq (BDAnnotationPrior annKey1 l:lr)+      BDAnnotationPrior annKey1 (BDLines (l:lr)) ->+         Just $ BDLines (BDAnnotationPrior annKey1 l:lr)+      BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->+         Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr)+      BDAnnotationPrior annKey1 (BDAddBaseY indent x) ->+         Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x+      BDAnnotationPrior annKey1 (BDDebug s x) ->+         Just $ BDDebug s $ BDAnnotationPrior annKey1 x+      _ -> Nothing+    descendRest = transformDownMay $ \case+      -- post floating in+      BDAnnotationRest annKey1 (BDPar ind line indented) ->+        Just $ BDPar ind line $ BDAnnotationRest annKey1 indented+      BDAnnotationRest annKey1 (BDSeq list) ->+        Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]+      BDAnnotationRest annKey1 (BDLines list) ->+        Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]+      BDAnnotationRest annKey1 (BDCols sig cols) ->+        Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]+      BDAnnotationRest annKey1 (BDAddBaseY indent x) ->+        Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x+      BDAnnotationRest annKey1 (BDDebug s x) ->+        Just $ BDDebug s $ BDAnnotationRest annKey1 x+      _ -> Nothing+    descendKW = transformDownMay $ \case+      -- post floating in+      BDAnnotationKW annKey1 kw (BDPar ind line indented) ->+        Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented+      BDAnnotationKW annKey1 kw (BDSeq list) ->+        Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]+      BDAnnotationKW annKey1 kw (BDLines list) ->+        Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]+      BDAnnotationKW annKey1 kw (BDCols sig cols) ->+        Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols]+      BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->+        Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x+      BDAnnotationKW annKey1 kw (BDDebug s x) ->+        Just $ BDDebug s $ BDAnnotationKW annKey1 kw x+      _ -> Nothing+    descendBYPush = transformDownMay $ \case+      BDBaseYPushCur (BDCols sig cols@(_:_)) ->+        Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)+      BDBaseYPushCur (BDDebug s x) ->+        Just $ BDDebug s (BDBaseYPushCur x)+      _ -> Nothing+    descendBYPop = transformDownMay $ \case+      BDBaseYPop (BDCols sig cols@(_:_)) ->+        Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)])+      BDBaseYPop (BDDebug s x) ->+        Just $ BDDebug s (BDBaseYPop x)+      _ -> Nothing+    descendILPush = transformDownMay $ \case+      BDIndentLevelPushCur (BDCols sig cols@(_:_)) ->+        Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)+      BDIndentLevelPushCur (BDDebug s x) ->+        Just $ BDDebug s (BDIndentLevelPushCur x)+      _ -> Nothing+    descendILPop = transformDownMay $ \case+      BDIndentLevelPop (BDCols sig cols@(_:_)) ->+        Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)])+      BDIndentLevelPop (BDDebug s x) ->+        Just $ BDDebug s (BDIndentLevelPop x)+      _ -> Nothing+    descendAddB = transformDownMay $ \case+      -- AddIndent floats into Lines.+      BDAddBaseY BrIndentNone x ->+        Just x+      BDAddBaseY indent (BDLines lines) ->+        Just $ BDLines $ BDAddBaseY indent <$> lines+      -- AddIndent floats into last column+      BDAddBaseY indent (BDCols sig cols) ->+        Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]+      -- merge AddIndent and Par+      BDAddBaseY ind1 (BDPar ind2 line indented) ->+        Just $ BDPar (mergeIndents ind1 ind2) line indented+      BDAddBaseY ind (BDAnnotationPrior annKey1 x) ->+        Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x)+      BDAddBaseY ind (BDAnnotationRest annKey1 x) ->+        Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x)+      BDAddBaseY ind (BDAnnotationKW annKey1 kw x) ->+        Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)+      BDAddBaseY ind (BDSeq list) ->+        Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]+      BDAddBaseY _ lit@BDLit{} ->+        Just $ lit+      BDAddBaseY ind (BDBaseYPushCur x) ->+        Just $ BDBaseYPushCur (BDAddBaseY ind x)+      BDAddBaseY ind (BDBaseYPop x) ->+        Just $ BDBaseYPop (BDAddBaseY ind x)+      BDAddBaseY ind (BDDebug s x) ->+        Just $ BDDebug s (BDAddBaseY ind x)+      _ -> Nothing+    stepBO :: BriDoc -> BriDoc+    stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $+             transformUp f+      where+        f = \case+          x@BDAnnotationPrior{}    -> descendPrior x+          x@BDAnnotationKW{}       -> descendKW x+          x@BDAnnotationRest{}     -> descendRest  x+          x@BDAddBaseY{}           -> descendAddB  x+          x@BDBaseYPushCur{}       -> descendBYPush x+          x@BDBaseYPop{}           -> descendBYPop x+          x@BDIndentLevelPushCur{} -> descendILPush x+          x@BDIndentLevelPop{}     -> descendILPop x+          x -> x+    stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $+               Uniplate.rewrite $ \case+      -- AddIndent floats into Lines.+      BDAddBaseY BrIndentNone x ->+        Just $ x+      BDAddBaseY indent (BDLines lines) ->+        Just $ BDLines $ BDAddBaseY indent <$> lines+      -- AddIndent floats into last column+      BDAddBaseY indent (BDCols sig cols) ->+        Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]+      BDAddBaseY ind (BDSeq list) ->+        Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]+      -- merge AddIndent and Par+      BDAddBaseY ind1 (BDPar ind2 line indented) ->+        Just $ BDPar (mergeIndents ind1 ind2) line indented+      BDAddBaseY _ lit@BDLit{} ->+        Just $ lit+      BDAddBaseY ind (BDBaseYPushCur x) ->+        Just $ BDBaseYPushCur (BDAddBaseY ind x)+      BDAddBaseY ind (BDBaseYPop x) ->+        Just $ BDBaseYPop (BDAddBaseY ind x)+      -- prior floating in+      BDAnnotationPrior annKey1 (BDPar ind line indented) ->+        Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented+      BDAnnotationPrior annKey1 (BDSeq (l:lr)) ->+        Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr)+      BDAnnotationPrior annKey1 (BDLines (l:lr)) ->+        Just $ BDLines ((BDAnnotationPrior annKey1 l):lr)+      BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->+        Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr)+      -- EnsureIndent float-in+      -- BDEnsureIndent indent (BDCols sig (col:colr)) ->+      --   Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))+      -- not sure if the following rule is necessary; tests currently are+      -- unaffected.+      -- BDEnsureIndent indent (BDLines lines) ->+      --   Just $ BDLines $ BDEnsureIndent indent <$> lines+      -- post floating in+      BDAnnotationRest annKey1 (BDPar ind line indented) ->+        Just $ BDPar ind line $ BDAnnotationRest annKey1 indented+      BDAnnotationRest annKey1 (BDSeq list) ->+        Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]+      BDAnnotationRest annKey1 (BDLines list) ->+        Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]+      BDAnnotationRest annKey1 (BDCols sig cols) ->+        Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]+      _ -> Nothing
+ src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs view
@@ -0,0 +1,57 @@+module Language.Haskell.Brittany.Internal.Transformations.Indent+  ( transformSimplifyIndent+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Utils+import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.Types++import qualified Data.Generics.Uniplate.Direct as Uniplate++++-- prepare layouting by translating BDPar's, replacing them with Indents and+-- floating those in. This gives a more clear picture of what exactly is+-- affected by what amount of indentation.+transformSimplifyIndent :: BriDoc -> BriDoc+transformSimplifyIndent = Uniplate.rewrite $ \case+  BDPar ind (BDLines lines) indented ->+    Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented]+  BDPar ind (BDCols sig cols) indented ->+    Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented])+  BDPar BrIndentNone _ _ -> Nothing+  BDPar ind x indented ->+    Just $ BDPar BrIndentNone (BDAddBaseY ind x) (BDEnsureIndent ind indented)+  -- BDPar ind x indented ->+  --   Just $ BDLines+  --     [ BDAddBaseY ind x+  --     , BDEnsureIndent ind indented+  --     ]+  BDLines lines | any ( \case+                        BDLines{} -> True+                        BDEmpty{} -> True+                        _         -> False+                      )+                      lines ->+    Just $ BDLines $ filter isNotEmpty $ lines >>= \case+      BDLines l -> l+      x         -> [x]+  BDLines [l] -> Just l+  BDAddBaseY i (BDAnnotationPrior k x) ->+    Just $ BDAnnotationPrior k (BDAddBaseY i x)+  BDAddBaseY i (BDAnnotationKW k kw x) ->+    Just $ BDAnnotationKW k kw (BDAddBaseY i x)+  BDAddBaseY i (BDAnnotationRest k x) ->+    Just $ BDAnnotationRest k (BDAddBaseY i x)+  BDAddBaseY i (BDSeq l) ->+    Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]+  BDAddBaseY i (BDCols sig l) ->+    Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]+  BDAddBaseY _ lit@BDLit{} -> Just lit++  _                        -> Nothing
+ src/Language/Haskell/Brittany/Internal/Transformations/Par.hs view
@@ -0,0 +1,51 @@+module Language.Haskell.Brittany.Internal.Transformations.Par+  ( transformSimplifyPar+  )+where++++#include "prelude.inc"++import           Language.Haskell.Brittany.Internal.Utils+import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.Types++import qualified Data.Generics.Uniplate.Direct as Uniplate++++transformSimplifyPar :: BriDoc -> BriDoc+transformSimplifyPar = transformUp $ \case+  -- BDPar BrIndentNone line1 line2 -> Just $ BDLines [line1, line2]+  -- BDPar line indented ->+  --   Just $ BDLines [line, indented]+  -- BDPar ind1 (BDPar ind2 line p1) p2 | ind1==ind2 ->+  --   Just $ BDPar ind1 line (BDLines [p1, p2])+  x@(BDPar _ (BDPar _ BDPar{} _) _) -> x+  BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) ->+    BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))+  BDPar ind1 (BDPar ind2 line p1) p2 ->+    BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2])+  BDLines lines | any ( \case+                        BDLines{} -> True+                        BDEmpty{} -> True+                        _         -> False+                      )+                      lines  -> case go lines of+    []  -> BDEmpty+    [x] -> x+    xs  -> BDLines xs+   where+    go = (=<<) $ \case+      BDLines l -> go l+      BDEmpty   -> []+      x         -> [x]+  BDLines []                    -> BDEmpty+  BDLines [x]                   -> x+  -- BDCols sig cols | BDPar ind line indented <- List.last cols ->+  --   Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented+  -- BDPar BrIndentNone line indented ->+  --   Just $ BDLines [line, indented]+  BDEnsureIndent BrIndentNone x -> x+  x                             -> x
+ src/Language/Haskell/Brittany/Internal/Types.hs view
@@ -0,0 +1,432 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE BangPatterns #-}++module Language.Haskell.Brittany.Internal.Types+where++++#include "prelude.inc"++import qualified Language.Haskell.GHC.ExactPrint as ExactPrint++import qualified Data.Text.Lazy.Builder as Text.Builder++import           RdrName ( RdrName(..) )+import           GHC ( Located, runGhc, GenLocated(L), moduleNameString, AnnKeywordId )++import           Language.Haskell.GHC.ExactPrint ( AnnKey, Comment )+import           Language.Haskell.GHC.ExactPrint.Types ( KeywordId, Anns, DeltaPos, mkAnnKey )++import           Language.Haskell.Brittany.Internal.Config.Types++import           Data.Generics.Uniplate.Direct as Uniplate++++type PPM a = MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] '[Text.Builder.Builder, [BrittanyError], Seq String] '[] a++data LayoutState = LayoutState+  { _lstate_baseYs         :: [Int]+     -- ^ stack of number of current indentation columns+     -- (not number of indentations).+  , _lstate_curYOrAddNewline :: Either Int Int+             -- ^ Either:+             -- 1) number of chars in the current line.+             -- 2) number of newlines to be inserted before inserting any+             --    non-space elements.+  , _lstate_indLevels      :: [Int]+    -- ^ stack of current indentation levels. set for+    -- any layout-affected elements such as+    -- let/do/case/where elements.+    -- The main purpose of this member is to+    -- properly align comments, as their+    -- annotation positions are relative to the+    -- current layout indentation level.+  , _lstate_indLevelLinger :: Int -- like a "last" of indLevel. Used for+                                  -- properly treating cases where comments+                                  -- on the first indented element have an+                                  -- annotation offset relative to the last+                                  -- non-indented element, which is confusing.+  , _lstate_comments      :: Anns+  , _lstate_commentCol    :: Maybe Int -- this communicates two things:+                                       -- firstly, that cursor is currently+                                       -- at the end of a comment (so needs+                                       -- newline before any actual content).+                                       -- secondly, the column at which+                                       -- insertion of comments started.+  , _lstate_addSepSpace   :: Maybe Int -- number of spaces to insert if anyone+                                       -- writes (any non-spaces) in the+                                       -- current line.+  , _lstate_inhibitMTEL   :: Bool+      -- ^ inhibit move-to-exact-location.+      -- normally, processing a node's annotation involves moving to the exact+      -- (vertical) location of the node. this ensures that newlines in the+      -- input are retained in the output.+      -- While this flag is on, this behaviour will be disabled.+      -- The flag is automatically turned off when inserting any kind of+      -- newline.+  -- , _lstate_isNewline     :: NewLineState+  --     -- captures if the layouter currently is in a new line, i.e. if the+  --     -- current line only contains (indentation) spaces.+  }++lstate_baseY :: LayoutState -> Int+lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs++lstate_indLevel :: LayoutState -> Int+lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels++-- evil, incomplete Show instance; only for debugging.+instance Show LayoutState where+  show state =+    "LayoutState"+    ++ "{baseYs=" ++ show (_lstate_baseYs state)+    ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)+    ++ ",indLevels=" ++ show (_lstate_indLevels state)+    ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state)+    ++ ",commentCol=" ++ show (_lstate_commentCol state)+    ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state)+    ++ ",inhibitMTEL=" ++ show (_lstate_inhibitMTEL state)+    ++ "}"++-- data NewLineState = NewLineStateInit -- initial state. we do not know if in a+--                                      -- newline, really. by special-casing+--                                      -- this we can appropriately handle it+--                                      -- differently at use-site.+--                   | NewLineStateYes+--                   | NewLineStateNo+--   deriving Eq++-- data LayoutSettings = LayoutSettings+--   { _lsettings_cols :: Int -- the thing that has default 80.+--   , _lsettings_indentPolicy :: IndentPolicy+--   , _lsettings_indentAmount :: Int+--   , _lsettings_indentWhereSpecial :: Bool -- indent where only 1 sometimes (TODO).+--   , _lsettings_indentListSpecial  :: Bool -- use some special indentation for ","+--                                           -- when creating zero-indentation+--                                           -- multi-line list literals.+--   , _lsettings_importColumn :: Int+--   , _lsettings_initialAnns :: ExactPrint.Anns+--   }++data BrittanyError+  = ErrorInput String+    -- ^ parsing failed+  | ErrorUnusedComment String+    -- ^ internal error: some comment went missing+  | LayoutWarning String+    -- ^ some warning+  | forall ast . Data.Data.Data ast => ErrorUnknownNode String ast+    -- ^ internal error: pretty-printing is not implemented for type of node+    --   in the syntax-tree+  | ErrorOutputCheck+    -- ^ checking the output for syntactic validity failed++data BriSpacing = BriSpacing+  { _bs_spacePastLineIndent :: Int -- space in the current,+                                   -- potentially somewhat filled+                                   -- line.+  , _bs_spacePastIndent :: Int     -- space required in properly+                                   -- indented blocks below the+                                   -- current line.+  }++data ColSig+  = ColTyOpPrefix+    -- any prefixed operator/paren/"::"/..+    -- expected to have exactly two colums.+    -- e.g. ":: foo"+    --       111222+    --      "-> bar asd asd"+    --       11122222222222+  | ColPatternsFuncPrefix+    -- pattern-part of the lhs, e.g. "func (foo a b) c _".+    -- Has variable number of columns depending on the number of patterns.+  | ColPatternsFuncInfix+    -- pattern-part of the lhs, e.g. "Foo a <> Foo b".+    -- Has variable number of columns depending on the number of patterns.+  | ColPatterns+  | ColCasePattern+  | ColBindingLine (Maybe Text)+    -- e.g. "func pat pat = expr"+    --       1111111111111222222+    -- or   "pat | stmt -> expr"+    --       111111111112222222+    -- expected to have exactly two columns.+  | ColGuard+    -- e.g. "func pat pat | cond = ..."+    --       11111111111112222222+    -- or   "pat | cond1, cond2 -> ..."+    --       1111222222222222222+    -- expected to have exactly two columns+  | ColGuardedBody+    -- e.g. | foofoo = 1+    --      | bar    = 2+    --      111111111222+    -- expected to have exactly two columns+  | ColBindStmt+  | ColDoLet -- the non-indented variant+  | ColRecUpdate+  | ColListComp+  | ColList+  | ColApp+  | ColTuple+  | ColTuples+  | ColOpPrefix -- merge with ColList ? other stuff?++  -- TODO+  deriving (Eq, Ord, Data.Data.Data, Show)++data BrIndent = BrIndentNone+              | BrIndentRegular+              | BrIndentSpecial Int+  deriving (Eq, Ord, Typeable, Data.Data.Data, Show)++type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[BrittanyError], Seq String] '[NodeAllocIndex]++type ToBriDoc (sym :: * -> *) = Located (sym RdrName) -> ToBriDocM BriDocNumbered+type ToBriDoc' sym            = Located sym           -> ToBriDocM BriDocNumbered+type ToBriDocC sym c          = Located sym           -> ToBriDocM c++data DocMultiLine+  = MultiLineNo+  | MultiLinePossible+  deriving (Eq, Typeable)++-- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot+-- of transformations on `BriDocF Identity`s and it is really annoying to+-- `Identity`/`runIdentity` everywhere.+data BriDoc+  = -- BDWrapAnnKey AnnKey BriDoc+    BDEmpty+  | BDLit !Text+  | BDSeq [BriDoc] -- elements other than the last should+                   -- not contains BDPars.+  | BDCols ColSig [BriDoc] -- elements other than the last+                         -- should not contains BDPars+  | BDSeparator -- semantically, space-unless-at-end-of-line.+  | BDAddBaseY BrIndent BriDoc+  | BDBaseYPushCur BriDoc+  | BDBaseYPop BriDoc+  | BDIndentLevelPushCur BriDoc+  | BDIndentLevelPop BriDoc+  | BDPar+    { _bdpar_indent :: BrIndent+    , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars+    , _bdpar_indented :: BriDoc+    }+  -- | BDAddIndent BrIndent (BriDocF f)+  -- | BDNewline+  | BDAlt [BriDoc]+  | BDForwardLineMode BriDoc+  | BDExternal AnnKey+               (Set AnnKey) -- set of annkeys contained within the node+                            -- to be printed via exactprint+               Bool -- should print extra comment ?+               Text+  | BDAnnotationPrior AnnKey BriDoc+  | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc+  | BDAnnotationRest  AnnKey BriDoc+  | BDLines [BriDoc]+  | BDEnsureIndent BrIndent BriDoc+  -- the following constructors are only relevant for the alt transformation+  -- and are removed afterwards. They should never occur in any BriDoc+  -- after the alt transformation.+  | BDForceMultiline BriDoc+  | BDForceSingleline BriDoc+  | BDNonBottomSpacing BriDoc+  | BDSetParSpacing BriDoc+  | BDForceParSpacing BriDoc+  -- pseudo-deprecated+  | BDProhibitMTEL BriDoc -- move to exact location+                          -- TODO: this constructor is deprecated. should+                          --       still work, but i should probably completely+                          --       remove it, as i have no proper usecase for+                          --       it anymore.+  | BDDebug String BriDoc+  deriving (Data.Data.Data, Eq, Ord)++data BriDocF f+  = -- BDWrapAnnKey AnnKey BriDoc+    BDFEmpty+  | BDFLit !Text+  | BDFSeq [f (BriDocF f)] -- elements other than the last should+                   -- not contains BDPars.+  | BDFCols ColSig [f (BriDocF f)] -- elements other than the last+                         -- should not contains BDPars+  | BDFSeparator -- semantically, space-unless-at-end-of-line.+  | BDFAddBaseY BrIndent (f (BriDocF f))+  | BDFBaseYPushCur (f (BriDocF f))+  | BDFBaseYPop (f (BriDocF f))+  | BDFIndentLevelPushCur (f (BriDocF f))+  | BDFIndentLevelPop (f (BriDocF f))+  | BDFPar+    { _bdfpar_indent :: BrIndent+    , _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars+    , _bdfpar_indented :: f (BriDocF f)+    }+  -- | BDAddIndent BrIndent (BriDocF f)+  -- | BDNewline+  | BDFAlt [f (BriDocF f)]+  | BDFForwardLineMode (f (BriDocF f))+  | BDFExternal AnnKey+               (Set AnnKey) -- set of annkeys contained within the node+                            -- to be printed via exactprint+               Bool -- should print extra comment ?+               Text+  | BDFAnnotationPrior AnnKey (f (BriDocF f))+  | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f))+  | BDFAnnotationRest  AnnKey (f (BriDocF f))+  | BDFLines [(f (BriDocF f))]+  | BDFEnsureIndent BrIndent (f (BriDocF f))+  | BDFForceMultiline (f (BriDocF f))+  | BDFForceSingleline (f (BriDocF f))+  | BDFNonBottomSpacing (f (BriDocF f))+  | BDFSetParSpacing (f (BriDocF f))+  | BDFForceParSpacing (f (BriDocF f))+  | BDFProhibitMTEL (f (BriDocF f)) -- move to exact location+                          -- TODO: this constructor is deprecated. should+                          --       still work, but i should probably completely+                          --       remove it, as i have no proper usecase for+                          --       it anymore.+  | BDFDebug String (f (BriDocF f))++-- deriving instance Data.Data.Data (BriDocF Identity)+deriving instance Data.Data.Data (BriDocF ((,) Int))++type BriDocFInt = BriDocF ((,) Int)+type BriDocNumbered = (Int, BriDocFInt)++instance Uniplate.Uniplate BriDoc where+  uniplate x@BDEmpty{}                   = plate x+  uniplate x@BDLit{}                     = plate x+  uniplate (BDSeq list)                  = plate BDSeq ||* list+  uniplate (BDCols sig list)             = plate BDCols |- sig ||* list+  uniplate x@BDSeparator                 = plate x+  uniplate (BDAddBaseY ind bd)           = plate BDAddBaseY |- ind |* bd+  uniplate (BDBaseYPushCur       bd)     = plate BDBaseYPushCur |* bd+  uniplate (BDBaseYPop           bd)     = plate BDBaseYPop |* bd+  uniplate (BDIndentLevelPushCur bd)     = plate BDIndentLevelPushCur |* bd+  uniplate (BDIndentLevelPop     bd)     = plate BDIndentLevelPop |* bd+  uniplate (BDPar ind line indented)     = plate BDPar |- ind |* line |* indented+  uniplate (BDAlt             alts)      = plate BDAlt ||* alts+  uniplate (BDForwardLineMode bd  )      = plate BDForwardLineMode |* bd+  uniplate x@BDExternal{}                = plate x+  uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd+  uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd+  uniplate (BDAnnotationRest annKey bd)  = plate BDAnnotationRest |- annKey |* bd+  uniplate (BDLines lines)               = plate BDLines ||* lines+  uniplate (BDEnsureIndent ind bd)       = plate BDEnsureIndent |- ind |* bd+  uniplate (BDForceMultiline   bd)       = plate BDForceMultiline |* bd+  uniplate (BDForceSingleline  bd)       = plate BDForceSingleline |* bd+  uniplate (BDNonBottomSpacing bd)       = plate BDNonBottomSpacing |* bd+  uniplate (BDSetParSpacing    bd)       = plate BDSetParSpacing |* bd+  uniplate (BDForceParSpacing  bd)       = plate BDForceParSpacing |* bd+  uniplate (BDProhibitMTEL     bd)       = plate BDProhibitMTEL |* bd+  uniplate (BDDebug s bd)                = plate BDDebug |- s |* bd++newtype NodeAllocIndex = NodeAllocIndex Int++-- TODO: rename to "dropLabels" ?+unwrapBriDocNumbered :: BriDocNumbered -> BriDoc+unwrapBriDocNumbered tpl = case snd tpl of+  BDFEmpty                     -> BDEmpty+  BDFLit t                     -> BDLit t+  BDFSeq list                  -> BDSeq $ rec <$> list+  BDFCols sig list             -> BDCols sig $ rec <$> list+  BDFSeparator                 -> BDSeparator+  BDFAddBaseY ind bd           -> BDAddBaseY ind $ rec bd+  BDFBaseYPushCur       bd     -> BDBaseYPushCur $ rec bd+  BDFBaseYPop           bd     -> BDBaseYPop $ rec bd+  BDFIndentLevelPushCur bd     -> BDIndentLevelPushCur $ rec bd+  BDFIndentLevelPop     bd     -> BDIndentLevelPop $ rec bd+  BDFPar ind line indented     -> BDPar ind (rec line) (rec indented)+  BDFAlt             alts      -> BDAlt $ rec <$> alts -- not that this will happen+  BDFForwardLineMode bd        -> BDForwardLineMode $ rec bd+  BDFExternal k ks c t         -> BDExternal k ks c t+  BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd+  BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd+  BDFAnnotationRest annKey bd  -> BDAnnotationRest annKey $ rec bd+  BDFLines lines               -> BDLines $ rec <$> lines+  BDFEnsureIndent ind bd       -> BDEnsureIndent ind $ rec bd+  BDFForceMultiline   bd       -> BDForceMultiline $ rec bd+  BDFForceSingleline  bd       -> BDForceSingleline $ rec bd+  BDFNonBottomSpacing bd       -> BDNonBottomSpacing $ rec bd+  BDFSetParSpacing    bd       -> BDSetParSpacing $ rec bd+  BDFForceParSpacing  bd       -> BDForceParSpacing $ rec bd+  BDFProhibitMTEL     bd       -> BDProhibitMTEL $ rec bd+  BDFDebug s bd                -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd+ where+  rec = unwrapBriDocNumbered++isNotEmpty :: BriDoc -> Bool+isNotEmpty BDEmpty = False+isNotEmpty _       = True++-- this might not work. is not used anywhere either.+briDocSeqSpine :: BriDoc -> ()+briDocSeqSpine = \case+  BDEmpty                       -> ()+  BDLit _t                      -> ()+  BDSeq list                    -> foldl' ((briDocSeqSpine.) . seq) () list+  BDCols _sig list              -> foldl' ((briDocSeqSpine.) . seq) () list+  BDSeparator                   -> ()+  BDAddBaseY _ind bd            -> briDocSeqSpine bd+  BDBaseYPushCur       bd       -> briDocSeqSpine bd+  BDBaseYPop           bd       -> briDocSeqSpine bd+  BDIndentLevelPushCur bd       -> briDocSeqSpine bd+  BDIndentLevelPop     bd       -> briDocSeqSpine bd+  BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented+  BDAlt             alts        -> foldl' (\(!()) -> briDocSeqSpine) () alts+  BDForwardLineMode bd          -> briDocSeqSpine bd+  BDExternal{}                  -> ()+  BDAnnotationPrior _annKey bd  -> briDocSeqSpine bd+  BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd+  BDAnnotationRest _annKey bd   -> briDocSeqSpine bd+  BDLines lines                 -> foldl' (\(!()) -> briDocSeqSpine) () lines+  BDEnsureIndent _ind bd        -> briDocSeqSpine bd+  BDForceMultiline   bd         -> briDocSeqSpine bd+  BDForceSingleline  bd         -> briDocSeqSpine bd+  BDNonBottomSpacing bd         -> briDocSeqSpine bd+  BDSetParSpacing    bd         -> briDocSeqSpine bd+  BDForceParSpacing  bd         -> briDocSeqSpine bd+  BDProhibitMTEL     bd         -> briDocSeqSpine bd+  BDDebug _s bd                 -> briDocSeqSpine bd++briDocForceSpine :: BriDoc -> BriDoc+briDocForceSpine bd = briDocSeqSpine bd `seq` bd+++data VerticalSpacingPar+  = VerticalSpacingParNone -- no indented lines+  | VerticalSpacingParSome   Int -- indented lines, requiring this much +                                 -- vertical space at most+  | VerticalSpacingParAlways Int -- indented lines, requiring this much+                                 -- vertical space at most, but should+                                 -- be considered as having space for+                                 -- any spacing validity check.+    -- TODO: it might be wrong not to extend "always" to the none case, i.e.+    -- we might get better properties of spacing operators by having a+    -- product like (Normal|Always, None|Some Int).+  deriving (Eq, Show)++data VerticalSpacing+  = VerticalSpacing+    { _vs_sameLine  :: !Int+    , _vs_paragraph :: !VerticalSpacingPar+    , _vs_parFlag   :: !Bool+    }+  deriving (Eq, Show)++newtype LineModeValidity a = LineModeValidity (Strict.Maybe a)+  deriving (Functor, Applicative, Monad, Show, Alternative)++pattern LineModeValid :: forall t. t -> LineModeValidity t+pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t+pattern LineModeInvalid :: forall t. LineModeValidity t+pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t
+ src/Language/Haskell/Brittany/Internal/Utils.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Language.Haskell.Brittany.Internal.Utils+  ( parDoc+  , parDocW+  , fromMaybeIdentity+  , fromOptionIdentity+  , traceIfDumpConf+  , mModify+  , customLayouterF+  , astToDoc+  , briDocToDoc+  -- , displayBriDocSimpleTree+  , annsDoc+  , Max (..)+  , tellDebugMess+  , tellDebugMessShow+  , briDocToDocWithAnns+  , breakEither+  , spanMaybe+  , transformUp+  , transformDownMay+  , FirstLastView(..)+  , splitFirstLast+  )+where++++#include "prelude.inc"++import qualified Language.Haskell.GHC.ExactPrint as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types+import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils++import           Data.Data+import           Data.Generics.Schemes+import           Data.Generics.Aliases++import qualified Text.PrettyPrint as PP+import           Text.PrettyPrint ( ($+$), (<+>) )++import qualified Outputable    as GHC+import qualified DynFlags      as GHC+import qualified FastString    as GHC+import qualified SrcLoc        as GHC+import           OccName ( occNameString )+import qualified Data.ByteString as B++import           DataTreePrint++import           Language.Haskell.Brittany.Internal.Config.Types+import           Language.Haskell.Brittany.Internal.Types++import qualified Data.Generics.Uniplate.Direct as Uniplate++++parDoc :: String -> PP.Doc+parDoc = PP.fsep . fmap PP.text . List.words++parDocW :: [String] -> PP.Doc+parDocW = PP.fsep . fmap PP.text . List.words . List.unwords+++showSDoc_ :: GHC.SDoc -> String+showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags++showGhc :: (GHC.Outputable a) => a -> String+showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags++fromMaybeIdentity :: Identity a -> Maybe a -> Identity a+fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y++fromOptionIdentity :: Identity a -> Option a -> Identity a+fromOptionIdentity x y =+  Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) $ getOption y++-- maximum monoid over N+0+-- or more than N, because Num is allowed.+newtype Max a = Max { getMax :: a }+  deriving (Eq, Ord, Show, Bounded, Num)++instance (Num a, Ord a) => Monoid (Max a) where+  mempty  = Max 0+  mappend = Data.Coerce.coerce (max :: a -> a -> a)++newtype ShowIsId = ShowIsId String deriving Data++instance Show ShowIsId where show (ShowIsId x) = x++data A x = A ShowIsId x deriving Data++customLayouterF :: ExactPrint.Types.Anns -> LayouterF+customLayouterF anns layoutF =+  DataToLayouter+    $       f+    `extQ`  showIsId+    `extQ`  fastString+    `extQ`  bytestring+    `extQ`  occName+    `extQ`  srcSpan+    `ext2Q` located+ where+  DataToLayouter f = defaultLayouterF layoutF+  simpleLayouter :: String -> NodeLayouter+  simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)+  showIsId :: ShowIsId -> NodeLayouter+  showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case+    Left  True -> PP.parens $ PP.text s+    Left  False -> PP.text s+    Right _    -> PP.text s+  fastString =+    simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString+      -> NodeLayouter+  bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter+  occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString+  srcSpan :: GHC.SrcSpan -> NodeLayouter+  srcSpan ss = simpleLayouter+             -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"+                              $ "{" ++ showGhc ss ++ "}"+  located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter+  located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a+   where+    annStr = case cast ss of+      Just (s :: GHC.SrcSpan) ->+        ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)+      Nothing -> ShowIsId "nnnnnnnn"++customLayouterNoAnnsF :: LayouterF+customLayouterNoAnnsF layoutF =+  DataToLayouter+    $       f+    `extQ`  showIsId+    `extQ`  fastString+    `extQ`  bytestring+    `extQ`  occName+    `extQ`  srcSpan+    `ext2Q` located+ where+  DataToLayouter f = defaultLayouterF layoutF+  simpleLayouter :: String -> NodeLayouter+  simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)+  showIsId :: ShowIsId -> NodeLayouter+  showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case+    Left  True -> PP.parens $ PP.text s+    Left  False -> PP.text s+    Right _    -> PP.text s+  fastString =+    simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString+      -> NodeLayouter+  bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter+  occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString+  srcSpan :: GHC.SrcSpan -> NodeLayouter+  srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"+  located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter+  located (GHC.L _ss a) = runDataToLayouter layoutF a++-- displayBriDocTree :: BriDoc -> PP.Doc+-- displayBriDocTree = \case+--   BDWrapAnnKey annKey doc -> def "BDWrapAnnKey"+--                            $ PP.text (show annKey)+--                          $+$ displayBriDocTree doc+--   BDEmpty         -> PP.text "BDEmpty"+--   BDLit t         -> def "BDLit" $ PP.text (show t)+--   BDSeq list      -> def "BDSeq" $ displayList list+--   BDCols sig list -> def "BDCols" $ PP.text (show sig)+--                                 $+$ displayList list+--   BDSeparator     -> PP.text "BDSeparator"+--   BDPar rol indent lines -> def "BDPar" $ displayBriDocTree rol+--                                       $+$ PP.text (show indent)+--                                       $+$ displayList lines+--   BDAlt alts      -> def "BDAlt" $ displayList alts+--   BDExternal ast _t -> def "BDExternal" (astToDoc ast)+--   BDSpecialPostCommentLoc _ -> PP.text "BDSpecialPostCommentLoc"+--  where+--   def x r = PP.text x $+$ PP.nest 2 r+--   displayList :: [BriDoc] -> PP.Doc+--   displayList [] = PP.text "[]"+--   displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocTree x+--                               : [PP.text "," <+> displayBriDocTree t | t<-xr]+--                              ++ [PP.text "]"]++-- displayBriDocSimpleTree :: BriDocSimple -> PP.Doc+-- displayBriDocSimpleTree = \case+--   BDSWrapAnnKey annKey doc -> def "BDSWrapAnnKey"+--                            $ PP.text (show annKey)+--                          $+$ displayBriDocSimpleTree doc+--   BDSLit t         -> def "BDSLit" $ PP.text (show t)+--   BDSSeq list      -> def "BDSSeq" $ displayList list+--   BDSCols sig list -> def "BDSCols" $ PP.text (show sig)+--                                 $+$ displayList list+--   BDSSeparator     -> PP.text "BDSSeparator"+--   BDSPar rol indent lines -> def "BDSPar" $ displayBriDocSimpleTree rol+--                                       $+$ PP.text (show indent)+--                                       $+$ displayList lines+--   BDSExternal annKey _subKeys _t -> def "BDSExternal" (PP.text $ show annKey)+--   BDSSpecialPostCommentLoc _ -> PP.text "BDSSpecialPostCommentLoc"+--  where+--   def x r = PP.text x $+$ PP.nest 2 r+--   displayList :: [BriDocSimple] -> PP.Doc+--   displayList [] = PP.text "[]"+--   displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocSimpleTree x+--                               : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr]+--                              ++ [PP.text "]"]++traceIfDumpConf+  :: (MonadMultiReader Config m, Show a)+  => String+  -> (DebugConfig -> Identity (Semigroup.Last Bool))+  -> a+  -> m ()+traceIfDumpConf s accessor val = do+  whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do+    trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()++tellDebugMess :: MonadMultiWriter+  (Seq String) m => String -> m ()+tellDebugMess s = mTell $ Seq.singleton s++tellDebugMessShow :: forall a m . (MonadMultiWriter+  (Seq String) m, Show a) => a -> m () +tellDebugMessShow = tellDebugMess . show++-- i should really put that into multistate..+mModify :: MonadMultiState s m => (s -> s) -> m ()+mModify f = mGet >>= mSet . f++astToDoc :: Data ast => ast -> PP.Doc+astToDoc ast = printTreeWithCustom 160 customLayouterNoAnnsF ast++briDocToDoc :: BriDoc -> PP.Doc+briDocToDoc = astToDoc . removeAnnotations+ where+  removeAnnotations = Uniplate.transform $ \case+    BDAnnotationPrior _ x -> x+    BDAnnotationKW _ _ x  -> x+    BDAnnotationRest _ x  -> x+    x                     -> x++briDocToDocWithAnns :: BriDoc -> PP.Doc+briDocToDocWithAnns = astToDoc++annsDoc :: ExactPrint.Types.Anns -> PP.Doc+annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)++breakEither :: (a -> Either b c) -> [a] -> ([b], [c])+breakEither _  []      = ([], [])+breakEither fn (a1:aR) = case fn a1 of+  Left  b -> (b : bs, cs)+  Right c -> (bs, c : cs)+ where+  (bs, cs) = breakEither fn aR++spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])+spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs)+ where+  (ys, xs) = spanMaybe f xR+spanMaybe _ xs                       = ([], xs)++data FirstLastView a+  = FirstLastEmpty+  | FirstLastSingleton a+  | FirstLast a [a] a++splitFirstLast :: [a] -> FirstLastView a+splitFirstLast [] = FirstLastEmpty+splitFirstLast [x] = FirstLastSingleton x+splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr)++-- TODO: move to uniplate upstream?+-- aka `transform`+transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on)+transformUp f = g where g = f . Uniplate.descend g+_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on)+_transformDown f = g where g = Uniplate.descend g . f+transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)+transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x+_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)+_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x
+ srcinc/prelude.inc view
@@ -0,0 +1,792 @@+import qualified Data.ByteString+import qualified Data.ByteString.Builder+import qualified Data.ByteString.Builder.Extra+import qualified Data.ByteString.Builder.Prim +import qualified Data.ByteString.Char8+import qualified Data.ByteString.Lazy.Builder+import qualified Data.ByteString.Lazy.Builder.ASCII+import qualified Data.ByteString.Lazy.Builder.Extras+import qualified Data.ByteString.Lazy.Char8+import qualified Data.ByteString.Lazy+import qualified Data.ByteString.Short+import qualified Data.ByteString.Unsafe++import qualified Data.Graph+import qualified Data.IntMap+import qualified Data.IntMap.Lazy+import qualified Data.IntMap.Strict+import qualified Data.IntSet+import qualified Data.Map+import qualified Data.Map.Lazy+import qualified Data.Map.Strict+import qualified Data.Sequence+import qualified Data.Set+import qualified Data.Tree++import qualified System.Directory++import qualified Control.Concurrent.Extra+import qualified Control.Exception.Extra+import qualified Control.Monad.Extra+import qualified Data.Either.Extra+import qualified Data.IORef.Extra+import qualified Data.List.Extra+import qualified Data.Tuple.Extra+import qualified Data.Version.Extra+import qualified Numeric.Extra+import qualified System.Directory.Extra+import qualified System.Environment.Extra+import qualified System.IO.Extra+import qualified System.Info.Extra+import qualified System.Process.Extra+import qualified System.Time.Extra++-- import qualified Control.Exception.Lens+-- import qualified Control.Lens+-- import qualified Control.Lens.At+-- import qualified Control.Lens.Combinators+-- import qualified Control.Lens.Cons+-- import qualified Control.Lens.Each+-- import qualified Control.Lens.Empty+-- import qualified Control.Lens.Equality+-- import qualified Control.Lens.Extras+-- import qualified Control.Lens.Fold+-- import qualified Control.Lens.Getter+-- import qualified Control.Lens.Indexed+-- import qualified Control.Lens.Internal+-- import qualified Control.Lens.Internal.Bazaar+-- import qualified Control.Lens.Internal.ByteString+-- import qualified Control.Lens.Internal.Coerce+-- import qualified Control.Lens.Internal.Context+-- import qualified Control.Lens.Internal.Deque+-- import qualified Control.Lens.Internal.Exception+-- import qualified Control.Lens.Internal.FieldTH+-- import qualified Control.Lens.Internal.Fold+-- import qualified Control.Lens.Internal.Getter+-- import qualified Control.Lens.Internal.Indexed+-- import qualified Control.Lens.Internal.Instances+-- import qualified Control.Lens.Internal.Iso+-- import qualified Control.Lens.Internal.Level+-- import qualified Control.Lens.Internal.List+-- import qualified Control.Lens.Internal.Magma+-- import qualified Control.Lens.Internal.Prism+-- import qualified Control.Lens.Internal.PrismTH+-- import qualified Control.Lens.Internal.Review+-- import qualified Control.Lens.Internal.Setter+-- import qualified Control.Lens.Internal.TH+-- import qualified Control.Lens.Internal.Zoom+-- import qualified Control.Lens.Iso+-- import qualified Control.Lens.Lens+-- import qualified Control.Lens.Level+-- import qualified Control.Lens.Operators+-- import qualified Control.Lens.Plated+-- import qualified Control.Lens.Prism+-- import qualified Control.Lens.Reified+-- import qualified Control.Lens.Review+-- import qualified Control.Lens.Setter+-- import qualified Control.Lens.TH+-- import qualified Control.Lens.Traversal+-- import qualified Control.Lens.Tuple+-- import qualified Control.Lens.Type+-- import qualified Control.Lens.Wrapped+-- import qualified Control.Lens.Zoom+-- import qualified Control.Monad.Error.Lens+-- import qualified Control.Parallel.Strategies.Lens+-- import qualified Control.Seq.Lens+-- import qualified Data.Array.Lens+-- import qualified Data.Bits.Lens+-- import qualified Data.ByteString.Lazy.Lens+-- import qualified Data.ByteString.Lens+-- import qualified Data.ByteString.Strict.Lens+-- import qualified Data.Complex.Lens+-- import qualified Data.Data.Lens+-- import qualified Data.Dynamic.Lens+-- import qualified Data.HashSet.Lens+-- import qualified Data.IntSet.Lens+-- import qualified Data.List.Lens+-- import qualified Data.Map.Lens+-- import qualified Data.Sequence.Lens+-- import qualified Data.Set.Lens+-- import qualified Data.Text.Lazy.Lens+-- import qualified Data.Text.Lens+-- import qualified Data.Text.Strict.Lens+-- import qualified Data.Tree.Lens+-- import qualified Data.Typeable.Lens+-- import qualified Data.Vector.Generic.Lens+-- import qualified Data.Vector.Lens+-- import qualified GHC.Generics.Lens+-- import qualified Generics.Deriving.Lens+-- import qualified Language.Haskell.TH.Lens+-- import qualified Numeric.Lens+-- import qualified System.Exit.Lens+-- import qualified System.FilePath.Lens+-- import qualified System.IO.Error.Lens++-- import qualified Control.Monad.Cont+-- import qualified Control.Monad.Cont.Class+-- import qualified Control.Monad.Error.Class+-- import qualified Control.Monad.Except+-- import qualified Control.Monad.Identity+-- import qualified Control.Monad.List+-- import qualified Control.Monad.RWS+-- import qualified Control.Monad.RWS.Class+-- import qualified Control.Monad.RWS.Lazy+-- import qualified Control.Monad.RWS.Strict+-- import qualified Control.Monad.Reader+-- import qualified Control.Monad.Reader.Class+-- import qualified Control.Monad.State+-- import qualified Control.Monad.State.Class+-- import qualified Control.Monad.State.Lazy+-- import qualified Control.Monad.State.Strict+-- import qualified Control.Monad.Trans+-- import qualified Control.Monad.Writer+-- import qualified Control.Monad.Writer.Class+-- import qualified Control.Monad.Writer.Lazy+-- import qualified Control.Monad.Writer.Strict++-- import qualified Control.Monad.Trans.MultiRWS+import qualified Control.Monad.Trans.MultiRWS.Lazy+import qualified Control.Monad.Trans.MultiRWS.Strict+import qualified Control.Monad.Trans.MultiReader+import qualified Control.Monad.Trans.MultiReader.Class+import qualified Control.Monad.Trans.MultiReader.Lazy+import qualified Control.Monad.Trans.MultiReader.Strict+import qualified Control.Monad.Trans.MultiState+import qualified Control.Monad.Trans.MultiState.Class+import qualified Control.Monad.Trans.MultiState.Lazy+import qualified Control.Monad.Trans.MultiState.Strict+import qualified Control.Monad.Trans.MultiWriter+import qualified Control.Monad.Trans.MultiWriter.Class+import qualified Control.Monad.Trans.MultiWriter.Lazy+import qualified Control.Monad.Trans.MultiWriter.Strict++import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS+import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL++import qualified Text.PrettyPrint++import qualified Text.PrettyPrint.Annotated+import qualified Text.PrettyPrint.Annotated.HughesPJ+import qualified Text.PrettyPrint.Annotated.HughesPJClass++import qualified Text.PrettyPrint.HughesPJ+import qualified Text.PrettyPrint.HughesPJClass++-- import qualified Data.Generics+-- import qualified Data.Generics.Aliases+-- import qualified Data.Generics.Basics+-- import qualified Data.Generics.Builders+-- import qualified Data.Generics.Instances+-- import qualified Data.Generics.Schemes+-- import qualified Data.Generics.Text+-- import qualified Data.Generics.Twins+-- import qualified Generics.SYB+-- import qualified Generics.SYB.Aliases+-- import qualified Generics.SYB.Basics+-- import qualified Generics.SYB.Builders+-- import qualified Generics.SYB.Instances+-- import qualified Generics.SYB.Schemes+-- import qualified Generics.SYB.Text+-- import qualified Generics.SYB.Twins++import qualified Data.Text+import qualified Data.Text.Array+import qualified Data.Text.Encoding+import qualified Data.Text.Encoding.Error+import qualified Data.Text.Foreign+import qualified Data.Text.IO+-- import qualified Data.Text.Internal+-- import qualified Data.Text.Internal.Builder+-- import qualified Data.Text.Internal.Builder.Functions+-- import qualified Data.Text.Internal.Builder.Int.Digits+-- import qualified Data.Text.Internal.Builder.RealFloat.Functions+-- import qualified Data.Text.Internal.Encoding.Fusion+-- import qualified Data.Text.Internal.Encoding.Fusion.Common+-- import qualified Data.Text.Internal.Encoding.Utf16+-- import qualified Data.Text.Internal.Encoding.Utf32+-- import qualified Data.Text.Internal.Encoding.Utf8+-- import qualified Data.Text.Internal.Functions+-- import qualified Data.Text.Internal.Fusion+-- import qualified Data.Text.Internal.Fusion.CaseMapping+-- import qualified Data.Text.Internal.Fusion.Common+-- import qualified Data.Text.Internal.Fusion.Size+-- import qualified Data.Text.Internal.Fusion.Types+-- import qualified Data.Text.Internal.IO+-- import qualified Data.Text.Internal.Lazy+-- import qualified Data.Text.Internal.Lazy.Encoding.Fusion+-- import qualified Data.Text.Internal.Lazy.Fusion+-- import qualified Data.Text.Internal.Lazy.Search+-- import qualified Data.Text.Internal.Private+-- import qualified Data.Text.Internal.Read+-- import qualified Data.Text.Internal.Search+-- import qualified Data.Text.Internal.Unsafe+-- import qualified Data.Text.Internal.Unsafe.Char+-- import qualified Data.Text.Internal.Unsafe.Shift+import qualified Data.Text.Lazy+import qualified Data.Text.Lazy.Builder+-- import qualified Data.Text.Lazy.Builder.Int+-- import qualified Data.Text.Lazy.Builder.RealFloat+-- import qualified Data.Text.Lazy.Encoding+-- import qualified Data.Text.Lazy.IO+-- import qualified Data.Text.Lazy.Read+-- import qualified Data.Text.Read+-- import qualified Data.Text.Unsafe++-- import qualified Control.Applicative.Backwards+-- import qualified Control.Applicative.Lift+-- import qualified Control.Monad.IO.Class+-- import qualified Control.Monad.Signatures+-- import qualified Control.Monad.Trans.Class+-- import qualified Control.Monad.Trans.Cont+-- import qualified Control.Monad.Trans.Except+-- import qualified Control.Monad.Trans.Identity+-- import qualified Control.Monad.Trans.List+-- import qualified Control.Monad.Trans.Maybe+-- import qualified Control.Monad.Trans.RWS+-- import qualified Control.Monad.Trans.RWS.Lazy+-- import qualified Control.Monad.Trans.RWS.Strict+-- import qualified Control.Monad.Trans.Reader+-- import qualified Control.Monad.Trans.State+-- import qualified Control.Monad.Trans.State.Lazy+-- import qualified Control.Monad.Trans.State.Strict+-- import qualified Control.Monad.Trans.Writer+-- import qualified Control.Monad.Trans.Writer.Lazy+-- import qualified Control.Monad.Trans.Writer.Strict+-- import qualified Data.Functor.Classes+-- import qualified Data.Functor.Compose+-- import qualified Data.Functor.Constant+-- import qualified Data.Functor.Product+-- import qualified Data.Functor.Reverse+-- import qualified Data.Functor.Sum++-- import qualified Prelude+-- import qualified Control.Applicative+-- import qualified Control.Arrow+-- import qualified Control.Category+-- import qualified Control.Concurrent+-- import qualified Control.Concurrent.Chan+-- import qualified Control.Concurrent.MVar+-- import qualified Control.Concurrent.QSem+-- import qualified Control.Concurrent.QSemN+-- import qualified Control.Exception+-- import qualified Control.Exception.Base+-- import qualified Control.Monad+-- import qualified Control.Monad.Fix+-- import qualified Control.Monad.ST+-- import qualified Control.Monad.ST.Lazy+-- import qualified Control.Monad.ST.Lazy.Unsafe+-- import qualified Control.Monad.ST.Strict+-- import qualified Control.Monad.ST.Unsafe+-- import qualified Control.Monad.Zip+import qualified Data.Bifunctor+import qualified Data.Bits+import qualified Data.Bool+import qualified Data.Char+import qualified Data.Coerce+import qualified Data.Complex+import qualified Data.Data+import qualified Data.Dynamic+import qualified Data.Either+import qualified Data.Eq+import qualified Data.Fixed+import qualified Data.Foldable+import qualified Data.Function+import qualified Data.Functor+import qualified Data.Functor.Identity+import qualified Data.IORef+import qualified Data.Int+import qualified Data.Ix+import qualified Data.List+import qualified Data.Maybe+import qualified Data.Monoid+import qualified Data.Ord+import qualified Data.Proxy+-- import qualified Data.Ratio+-- import qualified Data.STRef+-- import qualified Data.STRef.Lazy+-- import qualified Data.STRef.Strict+-- import qualified Data.String+-- import qualified Data.Traversable+-- import qualified Data.Tuple+-- import qualified Data.Type.Bool+-- import qualified Data.Type.Coercion+-- import qualified Data.Type.Equality+-- import qualified Data.Typeable+-- import qualified Data.Typeable.Internal+-- import qualified Data.Unique+-- import qualified Data.Version+-- import qualified Data.Void+-- import qualified Data.Word+import qualified Debug.Trace+-- import qualified Foreign.C+-- import qualified Foreign.C.Error+-- import qualified Foreign.C.String+-- import qualified Foreign.C.Types+-- import qualified Foreign.Concurrent+-- import qualified Foreign.ForeignPtr+-- import qualified Foreign.ForeignPtr.Unsafe+-- import qualified Foreign.Marshal+-- import qualified Foreign.Marshal.Alloc+-- import qualified Foreign.Marshal.Array+-- import qualified Foreign.Marshal.Error+-- import qualified Foreign.Marshal.Pool+-- import qualified Foreign.Marshal.Unsafe+-- import qualified Foreign.Marshal.Utils+-- import qualified Foreign.Ptr+-- import qualified Foreign.StablePtr+-- import qualified Foreign.Storable+import qualified Numeric+import qualified Numeric.Natural+-- import qualified System.CPUTime+-- import qualified System.Console.GetOpt+-- import qualified System.Environment+-- import qualified System.Exit+import qualified System.IO+-- import qualified System.IO.Error+-- import qualified System.IO.Unsafe+-- import qualified System.Info+-- import qualified System.Mem+-- import qualified System.Mem.StableName+-- import qualified System.Mem.Weak+-- import qualified System.Posix.Types+-- import qualified System.Timeout+-- import qualified Text.ParserCombinators.ReadP+-- import qualified Text.ParserCombinators.ReadPrec+-- import qualified Text.Printf+-- import qualified Text.Read+-- import qualified Text.Read.Lex+-- import qualified Text.Show+-- import qualified Text.Show.Functions+import qualified Unsafe.Coerce++-- import qualified Control.Arrow as Arrow+-- import qualified Control.Category as Category+-- import qualified Control.Concurrent as Concurrent+-- import qualified Control.Concurrent.Chan as Chan+-- import qualified Control.Concurrent.MVar as MVar+-- import qualified Control.Exception as Exception+-- import qualified Control.Exception.Base as Exception.Base+-- import qualified Control.Monad as Monad+-- import qualified Data.Bits as Bits+import qualified Data.Bool as Bool+-- import qualified Data.Char as Char+-- import qualified Data.Complex as Complex+-- import qualified Data.Either as Either+-- import qualified Data.Eq as Eq+import qualified Data.Foldable as Foldable+-- import qualified Data.Fixed as Fixed+-- import qualified Data.Functor.Identity as Identity+-- import qualified Data.IORef as IORef+-- import qualified Data.Int as Int+-- import qualified Data.Ix as Ix+-- import qualified Data.Maybe as Maybe+-- import qualified Data.Monoid as Monoid+-- import qualified Data.Ord as Ord+-- import qualified Data.Proxy as Proxy+-- import qualified Data.Traversable as Traversable+-- import qualified Data.Void as Void+import qualified GHC.OldList as List+-- import qualified Text.Printf as Printf++import qualified Data.Semigroup as Semigroup++import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as ByteStringL++-- import qualified Data.IntMap as IntMap+import qualified Data.IntMap.Lazy as IntMapL+import qualified Data.IntMap.Strict as IntMapS+-- import qualified Data.IntSet as IntSet+import qualified Data.Map as Map+-- import qualified Data.Map.Lazy as MapL+-- import qualified Data.Map.Strict as MapS+import qualified Data.Sequence as Seq+import qualified Data.Set as Set++import qualified Control.Monad.RWS.Class as RWS.Class+import qualified Control.Monad.Reader.Class as Reader.Class+import qualified Control.Monad.State.Class as State.Class+import qualified Control.Monad.Writer.Class as Writer.Class++import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text.Encoding+import qualified Data.Text.IO as Text.IO+import qualified Data.Text.Lazy as TextL+import qualified Data.Text.Lazy.Encoding as TextL.Encoding+import qualified Data.Text.Lazy.IO as TextL.IO++-- import qualified Control.Monad.Trans.Class as Trans.Class+-- import qualified Control.Monad.Trans.Maybe as Trans.Maybe+-- import qualified Control.Monad.Trans.RWS as RWS+-- import qualified Control.Monad.Trans.RWS.Lazy as RWSL+-- import qualified Control.Monad.Trans.RWS.Strict as RWSS+-- import qualified Control.Monad.Trans.Reader as Reader+import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.State.Lazy as StateL+import qualified Control.Monad.Trans.State.Strict as StateS+-- import qualified Control.Monad.Trans.Writer as Writer+-- import qualified Control.Monad.Trans.Writer.Lazy as WriterL+-- import qualified Control.Monad.Trans.Writer.Strict as Writer+import qualified Control.Monad.Trans.Either as EitherT++import qualified Data.Strict.Maybe as Strict++import qualified Safe as Safe++import Data.Functor.Identity ( Identity(..) )+import Control.Concurrent.Chan ( Chan )+import Control.Concurrent.MVar ( MVar )+import Data.Int ( Int )+import Data.Word ( Word )+import Prelude ( Integer, Float, Double )+import Control.Monad.ST ( ST )+import Data.Bool ( Bool(..) )+import Data.Char ( Char )+import Data.Either ( Either(..) )+import Data.IORef ( IORef )+import Data.Maybe ( Maybe(..) )+import Data.Semigroup ( Option(..) )+import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), Alt(..), )+import Data.Ord ( Ordering(..), Down(..) )+import Data.Ratio ( Ratio, Rational )+import Data.String ( String )+import Data.Void ( Void )+import System.IO ( IO )+import Data.Proxy ( Proxy(..) )+import Data.Sequence ( Seq )++import Data.Map ( Map )+import Data.Set ( Set )++import Data.Text ( Text )++import Prelude                            ( Char+                                          , String+                                          , Int+                                          , Integer+                                          , Float+                                          , Double+                                          , Bool (..)+                                          , undefined+                                          , Eq (..)+                                          , Ord (..)+                                          , Enum (..)+                                          , Bounded (..)+                                          , Maybe (..)+                                          , Either (..)+                                          , IO+                                          , (<$>)+                                          , (.)+                                          , ($)+                                          , ($!)+                                          , Num (..)+                                          , Integral (..)+                                          , Fractional (..)+                                          , Floating (..)+                                          , RealFrac (..)+                                          , RealFloat (..)+                                          , fromIntegral+                                          , error+                                          , foldr+                                          , foldl+                                          , foldr1+                                          , id+                                          , map+                                          , subtract+                                          , putStrLn+                                          , putStr+                                          , Show (..)+                                          , print+                                          , fst+                                          , snd+                                          , (++)+                                          , not+                                          , (&&)+                                          , (||)+                                          , curry+                                          , uncurry+                                          , Ordering (..)+                                          , flip+                                          , const+                                          , seq+                                          , reverse+                                          , otherwise+                                          , traverse+                                          , realToFrac+                                          , or+                                          , and+                                          , head+                                          , any+                                          , (^)+                                          , Foldable+                                          , Traversable+                                          )++import Data.Function                      ( fix+                                          )++import Data.Foldable                      ( foldl'+                                          , foldr'+                                          , fold+                                          , asum+                                          )++import Data.List                          ( partition+                                          , null+                                          , elem+                                          , notElem+                                          , minimum+                                          , maximum+                                          , length+                                          , all+                                          , take+                                          , drop+                                          , find+                                          , sum+                                          , zip+                                          , zip3+                                          , zipWith+                                          , repeat+                                          , replicate+                                          , iterate+                                          , nub+                                          , filter+                                          , intersperse+                                          , intercalate+                                          , isSuffixOf+                                          , isPrefixOf+                                          , dropWhile+                                          , takeWhile+                                          , unzip+                                          , break+                                          , transpose+                                          , sortBy+                                          , mapAccumL+                                          , mapAccumR+                                          , uncons+                                          )++import Data.Tuple                         ( swap+                                          )++import Data.Char                          ( ord+                                          , chr+                                          )++import Data.Maybe                         ( fromMaybe+                                          , maybe+                                          , listToMaybe+                                          , maybeToList+                                          , catMaybes+                                          )++import Data.Word                          ( Word32+                                          )++import Data.Ord                           ( comparing+                                          , Down (..)+                                          )++import Data.Either                        ( either+                                          )++import Data.Ratio                         ( Ratio+                                          , (%)+                                          , numerator+                                          , denominator+                                          )++import Text.Read                          ( readMaybe+                                          )++import Control.Monad                      ( Functor (..)+                                          , Monad (..)+                                          , MonadPlus (..)+                                          , mapM+                                          , mapM_+                                          , forM+                                          , forM_+                                          , sequence+                                          , sequence_+                                          , (=<<)+                                          , (>=>)+                                          , (<=<)+                                          , forever+                                          , void+                                          , join+                                          , replicateM+                                          , replicateM_+                                          , guard+                                          , when+                                          , unless+                                          , liftM+                                          , liftM2+                                          , liftM3+                                          , liftM4+                                          , liftM5+                                          , filterM+                                          , (<$!>)+                                          )++import Control.Applicative                ( Applicative (..)+                                          , Alternative (..)+                                          )++import Foreign.Storable                   ( Storable )+import GHC.Exts                           ( Constraint )++import Control.Concurrent                 ( threadDelay+                                          , forkIO+                                          , forkOS+                                          )++import Control.Concurrent.MVar            ( MVar+                                          , newEmptyMVar+                                          , newMVar+                                          , putMVar+                                          , readMVar+                                          , takeMVar+                                          , swapMVar+                                          )++import Control.Exception                  ( evaluate+                                          , bracket+                                          , assert+                                          )++import Debug.Trace                        ( trace+                                          , traceId+                                          , traceShowId+                                          , traceShow+                                          , traceStack+                                          , traceShowId+                                          , traceIO+                                          , traceM+                                          , traceShowM+                                          )++import Foreign.ForeignPtr                 ( ForeignPtr+                                          )++import Data.Monoid                        ( (<>)+                                          , mconcat+                                          , Monoid (..)+                                          )++import Data.Bifunctor                     ( bimap )+import Data.Functor                       ( (<$), ($>) )+import Data.Function                      ( (&) )+import System.IO                          ( hFlush+                                          , stdout+                                          )++import Data.Typeable                      ( Typeable+                                          )++import Control.Arrow                      ( first+                                          , second+                                          , (***)+                                          , (&&&)+                                          , (>>>)+                                          , (<<<)+                                          )++import Data.Functor.Identity              ( Identity (..)+                                          )++import Data.Proxy                         ( Proxy (..)+                                          )++import Data.Version                       ( showVersion+                                          )++import Data.List.Extra                    ( nubOrd+                                          , stripSuffix+                                          )+import Control.Monad.Extra                ( whenM+                                          , unlessM+                                          , ifM+                                          , notM+                                          , orM+                                          , andM+                                          , anyM+                                          , allM+                                          )++import Data.Tree                          ( Tree(..)+                                          )++import Control.Monad.Trans.MultiRWS       ( -- MultiRWST (..)+                                          -- , MultiRWSTNull+                                          -- , MultiRWS+                                          -- , +                                            MonadMultiReader(..)+                                          , MonadMultiWriter(..)+                                          , MonadMultiState(..)+                                          -- , runMultiRWST+                                          -- , runMultiRWSTASW+                                          -- , runMultiRWSTW+                                          -- , runMultiRWSTAW+                                          -- , runMultiRWSTSW+                                          -- , runMultiRWSTNil+                                          -- , runMultiRWSTNil_+                                          -- , withMultiReader+                                          -- , withMultiReader_+                                          -- , withMultiReaders+                                          -- , withMultiReaders_+                                          -- , withMultiWriter+                                          -- , withMultiWriterAW+                                          -- , withMultiWriterWA+                                          -- , withMultiWriterW+                                          -- , withMultiWriters+                                          -- , withMultiWritersAW+                                          -- , withMultiWritersWA+                                          -- , withMultiWritersW+                                          -- , withMultiState+                                          -- , withMultiStateAS+                                          -- , withMultiStateSA+                                          -- , withMultiStateA+                                          -- , withMultiStateS+                                          -- , withMultiState_+                                          -- , withMultiStates+                                          -- , withMultiStatesAS+                                          -- , withMultiStatesSA+                                          -- , withMultiStatesA+                                          -- , withMultiStatesS+                                          -- , withMultiStates_+                                          -- , inflateReader+                                          -- , inflateMultiReader+                                          -- , inflateWriter+                                          -- , inflateMultiWriter+                                          -- , inflateState+                                          -- , inflateMultiState+                                          -- , mapMultiRWST+                                          -- , mGetRawR+                                          -- , mGetRawW+                                          -- , mGetRawS+                                          -- , mPutRawR+                                          -- , mPutRawW+                                          -- , mPutRawS+                                          )++import Control.Monad.Trans.MultiReader    ( runMultiReaderTNil+                                          , runMultiReaderTNil_+                                          , MultiReaderT (..)+                                          , MultiReader+                                          , MultiReaderTNull+                                          )++import Data.Text                          ( Text )++import Control.Monad.IO.Class             ( MonadIO (..)+                                          )++import Control.Monad.Trans.Class          ( lift+                                          )+import Control.Monad.Trans.Maybe          ( MaybeT (..)+                                          )++import Language.Haskell.Brittany.Internal.Prelude++import Data.Data                          ( toConstr+                                          )