diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,661 @@ + GNU AFFERO GENERAL PUBLIC LICENSE + Version 3, 19 November 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + 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. + + + Copyright (C) + + 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 . + +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 +. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 . diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/brittany.cabal b/brittany.cabal new file mode 100644 --- /dev/null +++ b/brittany.cabal @@ -0,0 +1,402 @@ +name: brittany +version: 0.8.0.2 +synopsis: Haskell source code formatter +description: { + See + + If you are interested in the implementation, have a look at ; + + The implementation is documented in more detail . +} +license: AGPL-3 +license-file: LICENSE +author: Lennart Spitzner +maintainer: Lennart Spitzner +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" + } diff --git a/doc/implementation/bridoc-api.md b/doc/implementation/bridoc-api.md new file mode 100644 --- /dev/null +++ b/doc/implementation/bridoc-api.md @@ -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 + diff --git a/doc/implementation/bridoc-design.md b/doc/implementation/bridoc-design.md new file mode 100644 --- /dev/null +++ b/doc/implementation/bridoc-design.md @@ -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). diff --git a/doc/implementation/dataflow.md b/doc/implementation/dataflow.md new file mode 100644 --- /dev/null +++ b/doc/implementation/dataflow.md @@ -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: + + + +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: + + + +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: + + + + +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` + diff --git a/doc/implementation/index.md b/doc/implementation/index.md new file mode 100644 --- /dev/null +++ b/doc/implementation/index.md @@ -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). + diff --git a/doc/implementation/output-example-01.md b/doc/implementation/output-example-01.md new file mode 100644 --- /dev/null +++ b/doc/implementation/output-example-01.md @@ -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 +~~~~ + diff --git a/doc/implementation/output-example-02.md b/doc/implementation/output-example-02.md new file mode 100644 --- /dev/null +++ b/doc/implementation/output-example-02.md @@ -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 +~~~~ + diff --git a/doc/implementation/output-example-03.md b/doc/implementation/output-example-03.md new file mode 100644 --- /dev/null +++ b/doc/implementation/output-example-03.md @@ -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 +~~~~ + diff --git a/doc/implementation/theory.md b/doc/implementation/theory.md new file mode 100644 --- /dev/null +++ b/doc/implementation/theory.md @@ -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. + diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs new file mode 100644 --- /dev/null +++ b/src-brittany/Main.hs @@ -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" + , "." + ] + ] + +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 diff --git a/src-libinterfacetests/Main.hs b/src-libinterfacetests/Main.hs new file mode 100644 --- /dev/null +++ b/src-libinterfacetests/Main.hs @@ -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 + diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs new file mode 100644 --- /dev/null +++ b/src-literatetests/Main.hs @@ -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 [] + } + } + diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs new file mode 100644 --- /dev/null +++ b/src-unittests/AsymptoticPerfTests.hs @@ -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 diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs new file mode 100644 --- /dev/null +++ b/src-unittests/TestMain.hs @@ -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 diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs new file mode 100644 --- /dev/null +++ b/src-unittests/TestUtils.hs @@ -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 [] + } + } diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany.hs @@ -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 + diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -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 $ () diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -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) + diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -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 !") 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) + diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -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 + diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -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 + ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot @@ -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)) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -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 "_" diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Indent.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Par.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -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 diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc new file mode 100644 --- /dev/null +++ b/srcinc/prelude.inc @@ -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 + )