diff --git a/COPYING.AGPL3 b/COPYING.AGPL3 new file mode 100644 --- /dev/null +++ b/COPYING.AGPL3 @@ -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/COPYING.BSD3 b/COPYING.BSD3 new file mode 100644 --- /dev/null +++ b/COPYING.BSD3 @@ -0,0 +1,29 @@ +Copyright (c) 2009, IIJ Innovation Institute Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,33 +1,144 @@ +2017-05-26 v5.8.0.0 + * Fix logic bug in fix for excessive use of `map-file` + * Bump HLint to 2.x + * Reorganize Cabal file to make maintanance easier + * Merge #872, Do not log warning when Stack project is preferred + * Merge #873, Fix build on case-insensitive filesystems + * Fix 'debug' command when ghc(-pkg) not on PATH + * Rework README + * Reorganize modules as preparation for splitting off ghc-mod-core + * Remove dependency on 'pretty' and use GHC's pretty printer instead + * Merge #854, Fix for "ghc-mod doc" when usind with stack + * Merge #858, Fix Gap.fromTyThing returning GHC internal + representation instead of the user readable representation of + types + * Fix #774, 'find*File' searching all the way up to / + * Fix #778, Check directory permissions before reading in + findFileInParentsP + * Merge #817, fix #779, bad "ghc-mod check" performance + +2017-01-16 v5.7.0.0 + * Bump cabal-helper to 0.7.3.0 to support Cabal-1.24.1.0 + * Bump haskell-src-exts, optparse-applicative, pipes and extra + to be compatible with stackage. + +2016-07-29 v5.6.0.0 + * Bump cabal-helper to 0.7, adds support for Cabal-1.24 + * Merge #737, `map-file` caching issues + * Merge #767, Add `browse` option to show symbol "parents" + * Merge #731, Type constraints + * Fix #69 (via #731), Missing type constraints + * Fix #438, Case splitting not working + * Fix #790, Don't try to use 'cabal' or 'stack' when it's not installed + * Add support for GHC 8.0 + +2016-01-19 v5.5.0.0 + * Fix #660, cabal-helper errors when no global GHC is installed (Stack) + * Fix #665, Reinstate internally managed CWD (no more `ghc-mod root` + requirement for frontends) + * Merge #707, Support for spaces in file names when using + legacy-interactive + * Merge #694, #706, #703, Rewrite command line parser using + optparse-applicative. Thanks @lierdakil! + * Merge #693, Fix slowdown and bugs caused by excessive use of + `map-file` + * Fix #678, "No instance nor default method for class operation put" + * Fix #683, #684, a variety of caching related issues + * Fix #666, The issue of the beast >:3 + * Merge #649, elisp: Add ghc-report-errors to inhibit *GHC Error* + logging + * Fix #621, Preserve Cabal flag selection across automatic + reconfiguration + +2015-09-16 v5.4.0.0 + * Add support for the Stack build tool + * Fix #554, `module not interpreted` errors when using the `type` + command + * Merge #484, support for file redirection + * Add support for file redirection to Emacs frontend so + all commands should work even with unsaved files now! + * Support inserting holes in type signatures + * Merge #543, Fix URL anchors being dropped in OS X + * Fix GHC session always being dropped in interactive mode (caused + super slowness) + * Expose all internal modules because API will get a major + redesign soon anyways + * ghc-mod(i) executable must now be run in project directory for + commands other than `root` + * Add --line-prefix option for multiplexing stdout/err onto one stream + +2015-08-14 v5.3.0.0 + * Re-license majority of code under the AGPL-3 + * Add support for GHC 7.10 and Cabal 1.22 + * Remove `cabalDependPackages', `cabalAllTargets' + * Merge #434, Fix finding sandbox config file and directory. + * Merge #431, Re-add output line separator global option for expand + command. + * Merge #470, Support for overriding the package-db stack + * Merge #486, Fix ineffective cache invalidation for `find` + +2014-12-31 v5.2.1.2 + * Merge #377, Fix `browse` erroneously thinking haskell2010 identifiers + are operators + * Fix incompatibility with monad-control >= 1.0.0 + * Fix temporary directories not being removed properly + * Merge #405, #408, a race condition in the Emacs frontend + * Merge #403, Support unicode quotes in module regexp + +2014-11-03 v5.2.1.1 + * Fix `findCabalFiles` thinking `$HOME/.cabal` is a cabal file. + * Support `where` clauses, `let` bindings and `case` expressions + in case splitting, #400 + +2014-11-02 v5.2.1.0 + * Fix `newTempDir` on Windows + * GhcModT's liftIO instance now converts GhcMOdError exceptions + into monadic failures + +2014-10-30 v5.2.0.0 + * Return type of `loadSymbolDb` is now in GhcModT + * Function `dumpSymbol` now takes the path of the target directory + * Fix #387, Pattern match failure in GhcPkg + * Fix #386, `ghc-mod version` should not check `cabal configure` + * Fix #391, Error on command `-g` when used before command despite + --help output saying this is valid + * Fix formatting of `ghc-version` constant in the elisp code. in + version 5.1.1.0 the string was "v5.1.1.0" instead of "5.1.1.0". + +2014-10-04 v5.1.1.0 + * Handle various consistency related issues: #222, #224, #326, #332 + * Add `isOutdated` to Language.Haskell.GhcMod + 2014-09-17 v5.1.0.2 - * Fix building with haskell-src-exts < 1.16.0 + * Fix building with haskell-src-exts < 1.16.0 2014-09-16 v5.1.0.1 - * Fix building with haskell-src-exts-1.16.0 - * Loosen monad-journal dependency + * Fix building with haskell-src-exts-1.16.0 + * Loosen monad-journal dependency 2014-09-12 v5.1.0.0 - * GhcModError is now a recursive data type (`GMECabalConfigure`'s - type changed) - * GhcModT's MonadIO instance now converts IOError's to failures in - the ErrorT part of GhcModT on `liftIO`. - * Make `loadSymbolDb` polimorphic in the return types's monad. - * Add `hoistGhcModT` to Language.Haskell.GhcMod.Internal - * Fix `check` command for modules using `-XPatternSynonyms` - * Merge #364, Support cabal configuration flags + * GhcModError is now a recursive data type (`GMECabalConfigure`'s + type changed) + * GhcModT's MonadIO instance now converts IOError's to failures in + the ErrorT part of GhcModT on `liftIO`. + * Make `loadSymbolDb` polimorphic in the return types's monad. + * Add `hoistGhcModT` to Language.Haskell.GhcMod.Internal + * Fix `check` command for modules using `-XPatternSynonyms` + * Merge #364, Support cabal configuration flags 2014-08-29 v5.0.1.2 - * Merge #345, Try fixing duplicate errors - * Merge #344, elisp: Use advice to check syntax on save-buffer - * Merge #341, support `browse -d` in ghc-modi - * Merge #352, elisp: Fix C-u accidentally getting turned into a - prefix command + * Merge #345, Try fixing duplicate errors + * Merge #344, elisp: Use advice to check syntax on save-buffer + * Merge #341, support `browse -d` in ghc-modi + * Merge #352, elisp: Fix C-u accidentally getting turned into a + prefix command 2014-08-24 v5.0.1.1 - * Fix CaseSplitting faliure when using "fancy types" (see #336) - * Print error information in "spec" test suite when using `extract` + * Fix CaseSplitting faliure when using "fancy types" (see #336) + * Print error information in "spec" test suite when using `extract` 2014-08-20 v5.0.1 - * Fix missing file in "Data-Files" + * Fix missing file in "Data-Files" 2014-08-20 v5.0.0 * ghc-mod consumes much less memory than ghc-mod-4.1. diff --git a/GhcMod.hs b/GhcMod.hs new file mode 100644 --- /dev/null +++ b/GhcMod.hs @@ -0,0 +1,92 @@ +-- | The ghc-mod library. + +module GhcMod ( + -- * Cradle + Cradle(..) + , Project(..) + , findCradle + -- * Options + , Options(..) + , LineSeparator(..) + , OutputStyle(..) + , FileMapping(..) + , defaultOptions + -- * Logging + , GmLogLevel + , increaseLogLevel + , decreaseLogLevel + , gmSetLogLevel + , gmLog + -- * Types + , ModuleString + , Expression(..) + , GhcPkgDb + , Symbol + , SymbolDb + , GhcModError(..) + -- * Monad Types + , GhcModT + , IOish + -- * Monad utilities + , runGhcModT + , withOptions + , dropSession + -- * 'GhcMod' utilities + , boot + , browse + , check + , checkSyntax + , debugInfo + , componentInfo + , expandTemplate + , info + , lint + , pkgDoc + , rootInfo + , types + , test + , splits + , sig + , refine + , auto + , modules + , languages + , flags + , findSymbol + , lookupSymbol + , dumpSymbol + -- * SymbolDb + , loadSymbolDb + , isOutdated + -- * Output + , gmPutStr + , gmErrStr + , gmPutStrLn + , gmErrStrLn + -- * FileMapping + , loadMappedFile + , loadMappedFileSource + , unloadMappedFile + ) where + +import GhcMod.Exe.Boot +import GhcMod.Exe.Browse +import GhcMod.Exe.CaseSplit +import GhcMod.Exe.Check +import GhcMod.Exe.Debug +import GhcMod.Exe.FillSig +import GhcMod.Exe.Find +import GhcMod.Exe.Flag +import GhcMod.Exe.Info +import GhcMod.Exe.Lang +import GhcMod.Exe.Lint +import GhcMod.Exe.Modules +import GhcMod.Exe.PkgDoc +import GhcMod.Exe.Test +import GhcMod.Cradle +import GhcMod.FileMapping +import GhcMod.Logging +import GhcMod.Monad +import GhcMod.Output +import GhcMod.Target +import GhcMod.Types diff --git a/GhcMod/Exe/Boot.hs b/GhcMod/Exe/Boot.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Boot.hs @@ -0,0 +1,29 @@ +module GhcMod.Exe.Boot where + +import Control.Applicative +import Prelude + +import GhcMod.Exe.Browse +import GhcMod.Exe.Flag +import GhcMod.Exe.Lang +import GhcMod.Exe.Modules +import GhcMod.Monad +import GhcMod.Types (defaultBrowseOpts) + +-- | Printing necessary information for front-end booting. +boot :: IOish m => GhcModT m String +boot = concat <$> sequence ms + where + ms = [modules False, languages, flags, concat <$> mapM (browse defaultBrowseOpts) preBrowsedModules] + +preBrowsedModules :: [String] +preBrowsedModules = [ + "Prelude" + , "Control.Applicative" + , "Control.Exception" + , "Control.Monad" + , "Data.Char" + , "Data.List" + , "Data.Maybe" + , "System.IO" + ] diff --git a/GhcMod/Exe/Browse.hs b/GhcMod/Exe/Browse.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Browse.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE CPP #-} +module GhcMod.Exe.Browse ( + browse, + BrowseOpts(..) + ) where + +import Safe +import Control.Applicative +import Control.Exception (SomeException(..)) +import Data.Char +import Data.List +import Data.Maybe +import FastString +import GHC +import HscTypes +import qualified GHC as G +import GhcMod.Convert +import GhcMod.Doc (showPage, styleUnqualified) +import GhcMod.Gap as Gap +import GhcMod.Types +import GhcMod.Monad +import GhcMod.Logging +import Name (getOccString) +import Outputable +import TyCon (isAlgTyCon) +import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) +import Exception (ExceptionMonad, ghandle) +import Prelude +#if __GLASGOW_HASKELL__ >= 800 +import PatSyn (pprPatSynType) +#endif + +---------------------------------------------------------------- + +-- | Getting functions, classes, etc from a module. +browse :: forall m. IOish m + => BrowseOpts -- ^ Configuration parameters + -> String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude") + -> GhcModT m String +browse opts pkgmdl = do + convert' . sort =<< go + where + -- TODO: Add API to Gm.Target to check if module is home module without + -- bringing up a GHC session as well then this can be made a lot cleaner + go = ghandle (\ex@(SomeException _) -> logException ex >> return []) $ do + goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule) + + logException ex = + gmLog GmException "browse" $ showToDoc ex + + goPkgModule = do + runGmPkgGhc $ + processExports opts =<< tryModuleInfo =<< G.findModule mdlname mpkgid + + goHomeModule = runGmlT [Right mdlname] $ do + processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing + + tryModuleInfo m = fromJustNote "browse, tryModuleInfo" <$> G.getModuleInfo m + + (mpkg, mdl) = splitPkgMdl pkgmdl + mdlname = G.mkModuleName mdl + mpkgid = mkFastString <$> mpkg + +-- | +-- +-- >>> splitPkgMdl "base:Prelude" +-- (Just "base","Prelude") +-- >>> splitPkgMdl "Prelude" +-- (Nothing,"Prelude") +splitPkgMdl :: String -> (Maybe String,String) +splitPkgMdl pkgmdl = + case break (==':') pkgmdl of + (mdl, "") -> (Nothing, mdl) + (pkg, _:mdl) -> (Just pkg, mdl) + +-- Haskell 2010: +-- small -> ascSmall | uniSmall | _ +-- ascSmall -> a | b | ... | z +-- uniSmall -> any Unicode lowercase letter +-- varid -> (small {small | large | digit | ' }) + +isNotOp :: String -> Bool +isNotOp (h:_) = isAlpha h || (h == '_') +isNotOp _ = error "isNotOp" + +processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m) + => BrowseOpts -> ModuleInfo -> m [String] +processExports opt minfo = do + let + removeOps + | optBrowseOperators opt = id + | otherwise = filter (isNotOp . getOccString) + mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo + +showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m) + => BrowseOpts -> ModuleInfo -> Name -> m String +showExport opt minfo e = do + mtype' <- mtype + return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] + where + mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt + mtype :: m (Maybe String) + mtype + | optBrowseDetailed opt || optBrowseParents opt = do + tyInfo <- G.modInfoLookupName minfo e + -- If nothing found, load dependent module and lookup global + tyResult <- maybe (inOtherModule e) (return . Just) tyInfo + dflag <- G.getSessionDynFlags + let sig = do + typeName <- tyResult >>= showThing dflag + (" :: " ++ typeName) `justIf` optBrowseDetailed opt + let parent = do + thing <- fmap getOccString $ tyResult >>= tyThingParent_maybe + (" -- from:" ++ thing) `justIf` optBrowseParents opt + return $ case concat $ catMaybes [sig, parent] of + [] -> Nothing + x -> Just x + | otherwise = return Nothing + formatOp nm + | null nm = error "formatOp" + | isNotOp nm = nm + | otherwise = "(" ++ nm ++ ")" + inOtherModule :: Name -> m (Maybe TyThing) + inOtherModule nm = do + G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm + justIf :: a -> Bool -> Maybe a + justIf x True = Just x + justIf _ False = Nothing + +showThing :: DynFlags -> TyThing -> Maybe String +showThing dflag tything = showThing' dflag (fromTyThing tything) + +showThing' :: DynFlags -> GapThing -> Maybe String +showThing' dflag (GtA a) = Just $ formatType dflag a +showThing' _ (GtT t) = unwords . toList <$> tyType t + where + toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t) +#if __GLASGOW_HASKELL__ >= 800 +showThing' dflag (GtPatSyn p) = Just $ showSDoc dflag $ pprPatSynType p +#endif +showThing' _ _ = Nothing + +formatType :: DynFlags -> Type -> String +formatType dflag a = showOutputable dflag (removeForAlls a) + +tyType :: TyCon -> Maybe String +tyType typ + | isAlgTyCon typ + && not (G.isNewTyCon typ) + && not (G.isClassTyCon typ) = Just "data" + | G.isNewTyCon typ = Just "newtype" + | G.isClassTyCon typ = Just "class" + | Gap.isSynTyCon typ = Just "type" + | otherwise = Nothing + +removeForAlls :: Type -> Type +removeForAlls ty = removeForAlls' ty' tty' + where + ty' = dropForAlls ty + tty' = splitFunTy_maybe ty' + +removeForAlls' :: Type -> Maybe (Type, Type) -> Type +removeForAlls' ty Nothing = ty +removeForAlls' ty (Just (pre, ftype)) + | isPredTy pre = mkFunTy pre (dropForAlls ftype) + | otherwise = ty + +showOutputable :: Outputable a => DynFlags -> a -> String +showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr diff --git a/GhcMod/Exe/CaseSplit.hs b/GhcMod/Exe/CaseSplit.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/CaseSplit.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE CPP #-} + +module GhcMod.Exe.CaseSplit ( + splits + ) where + +import Data.List (find, intercalate) +import Data.Maybe (isJust) +import qualified Data.Text as T +import qualified Data.Text.IO as T (readFile) +import System.FilePath +import Prelude + +import qualified DataCon as Ty +import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) +import qualified GHC as G +import Outputable (PprStyle) +import qualified TyCon as Ty +import qualified Type as Ty +import Exception + +import GhcMod.Convert +import GhcMod.DynFlags +import qualified GhcMod.Gap as Gap +import GhcMod.Monad +import GhcMod.SrcUtils +import GhcMod.Doc +import GhcMod.Logging +import GhcMod.Types +import GhcMod.Utils (withMappedFile) +import GhcMod.FileMapping (fileModSummaryWithMapping) +import Control.DeepSeq + +---------------------------------------------------------------- +-- CASE SPLITTING +---------------------------------------------------------------- + +data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan] + | TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind) +data SplitToTextInfo = SplitToTextInfo { sVarName :: String + , sBindingSpan :: SrcSpan + , sVarSpan :: SrcSpan + , sTycons :: [String] + } + +-- | Splitting a variable in a equation. +splits :: IOish m + => FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> GhcModT m String +splits file lineNo colNo = + ghandle handler $ runGmlT' [Left file] deferErrors $ do + oopts <- outputOpts + crdl <- cradle + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) + whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> do + let (varName, bndLoc, (varLoc,varT)) + | (SplitInfo vn bl vlvt _matches) <- x + = (vn, bl, vlvt) + | (TySplitInfo vn bl vlvt) <- x + = (vn, bl, vlvt) + varName' = showName dflag style varName -- Convert name to string + t <- withMappedFile file $ \file' -> + genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $ + getTyCons dflag style varName varT) + return $!! (fourInts bndLoc, t) + where + handler (SomeException ex) = do + gmLog GmException "splits" $ + text "" $$ nest 4 (showToDoc ex) + emptyResult =<< outputOpts + +---------------------------------------------------------------- +-- a. Code for getting the information of the variable + +getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForSplit modSum lineNo colNo = do + fn <- getSrcSpanTypeForFnSplit modSum lineNo colNo + if isJust fn + then return fn + else getSrcSpanTypeForTypeSplit modSum lineNo colNo + +-- Information for a function case split +getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForFnSplit modSum lineNo colNo = do + p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum + tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p + let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id) + match = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI + case varPat of + Nothing -> return Nothing + Just varPat' -> do + varT <- Gap.getType tcm varPat' -- Finally we get the type of the var + case varT of + Just varT' -> +#if __GLASGOW_HASKELL__ >= 710 + let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match +#else + let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match +#endif + in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) ) + _ -> return Nothing + +isPatternVar :: LPat Id -> Bool +isPatternVar (L _ (G.VarPat _)) = True +isPatternVar _ = False + +getPatternVarName :: LPat Id -> G.Name +#if __GLASGOW_HASKELL__ >= 800 +getPatternVarName (L _ (G.VarPat (L _ vName))) = G.getName vName +#else +getPatternVarName (L _ (G.VarPat vName)) = G.getName vName +#endif +getPatternVarName _ = error "This should never happened" + +-- TODO: Information for a type family case split +getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing + +---------------------------------------------------------------- +-- b. Code for getting the possible constructors + +getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type -> [String] +getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty = + let name' = showName dflag style name -- Convert name to string + in getTyCon dflag style name' tyCon +getTyCons dflag style name _ = [showName dflag style name] + +-- Write cases for one type +getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String] +-- 1. Non-matcheable type constructors +getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name] +-- 2. Special cases +-- 2.1. Tuples +getTyCon _ _ name tyCon | Ty.isTupleTyCon tyCon = + let [uniqueDataCon] = Ty.tyConDataCons tyCon + tupleArity = Ty.dataConSourceArity uniqueDataCon + -- Deal with both boxed and unboxed tuples + isUnboxed = Ty.isUnboxedTupleTyCon tyCon + startSign = if isUnboxed then "(#" else "(" + endSign = if isUnboxed then "#)" else ")" + in [ startSign ++ intercalate "," (map (\n -> name ++ show n) [1 .. tupleArity]) ++ endSign ] +-- 3. General case +getTyCon dflag style name tyCon = map (getDataCon dflag style name) (Ty.tyConDataCons tyCon) + +-- These type constructors should not be matched against +isNotMatcheableTyCon :: Ty.TyCon -> Bool +isNotMatcheableTyCon ty = Ty.isPrimTyCon ty -- Primitive types, such as Int# + || Ty.isFunTyCon ty -- Function types + +-- Write case for one constructor +getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String +-- 1. Infix constructors +getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon = + let dName = showName dflag style $ Ty.dataConName dcon + in case Ty.dataConSourceArity dcon of + 0 -> dName + 1 -> vName ++ dName + n -> if dName == ":" -- Special case for lists + then vName ++ ":" ++ vName ++ "s" + else newVar vName 1 ++ " " ++ dName ++ " " ++ newVars vName 2 (n-1) +-- 2. Non-record, non-infix syntax +getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon = + let dName = showName dflag style $ Ty.dataConName dcon + in if last dName == '#' -- Special case for I#, C# and so on + then vName + else case Ty.dataConSourceArity dcon of + 0 -> dName + _ -> dName ++ " " ++ newVarsSpecialSingleton vName 1 (Ty.dataConSourceArity dcon) +-- 3. Records +getDataCon dflag style vName dcon = + let dName = showName dflag style $ Ty.dataConName dcon +#if __GLASGOW_HASKELL__ >= 800 + flds = map Ty.flSelector $ Ty.dataConFieldLabels dcon +#else + flds = Ty.dataConFieldLabels dcon +#endif + in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }" + +-- Create a new variable by adjoining a number +newVar :: String -> Int -> String +newVar v n = v ++ show n + +-- Create a list of variables which start with the same prefix +newVars :: String -> Int -> Int -> String +newVars _ _ 0 = "" +newVars v s 1 = newVar v s +newVars v s m = newVar v s ++ " " ++ newVars v (s+1) (m-1) + +-- Create a list of variables which start with the same prefix +-- Special case for a single variable, in which case no number is adjoint +newVarsSpecialSingleton :: String -> Int -> Int -> String +newVarsSpecialSingleton v _ 1 = v +newVarsSpecialSingleton v start n = newVars v start n + +showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String +showFieldNames _ _ _ [] = "" -- This should never happen +showFieldNames dflag style v (x:xs) = let fName = showName dflag style x + fAcc = fName ++ " = " ++ v ++ "_" ++ fName + in case xs of + [] -> fAcc + _ -> fAcc ++ ", " ++ showFieldNames dflag style v xs + +---------------------------------------------------------------- +-- c. Code for performing the case splitting + +genCaseSplitTextFile :: (MonadIO m, GhcMonad m) => + FilePath -> SplitToTextInfo -> m String +genCaseSplitTextFile file info = liftIO $ do + t <- T.readFile file + return $ getCaseSplitText (T.lines t) info + +getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String +getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS + , sVarSpan = sVS, sTycons = sT } = + let bindingText = getBindingText t sBS + difference = srcSpanDifference sBS sVS + replaced = map (replaceVarWithTyCon bindingText difference sVN) sT + -- The newly generated bindings need to be indented to align with the + -- original binding. + replaced' = head replaced : map (indentBindingTo sBS) (tail replaced) + in T.unpack $ T.intercalate (T.pack "\n") (concat replaced') + +getBindingText :: [T.Text] -> SrcSpan -> [T.Text] +getBindingText t srcSpan = + let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan + lines_ = drop (sl - 1) $ take el t + in if sl == el + then -- only one line + [T.drop (sc - 1) $ T.take ec $ head lines_] + else -- several lines + let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_) + in T.drop (sc - 1) first : rest ++ [T.take ec last_] + +srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int) +srcSpanDifference b v = + let Just (bsl,bsc,_ ,_) = Gap.getSrcSpan b + Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v + in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line + +replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text] +replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon = + let tycon' = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon + lengthDiff = length tycon' - length varname + tycon'' = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon' + spacesToAdd = if lengthDiff < 0 then 0 else lengthDiff + in zipWith (\n line -> if n < vsl + then line -- before variable starts + else if n == vsl + then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line + else T.replicate spacesToAdd (T.pack " ") `T.append` line) + [0 ..] t + +indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text] +indentBindingTo bndLoc binds = + let Just (_,sl,_,_) = Gap.getSrcSpan bndLoc + indent = (T.replicate (sl - 1) (T.pack " ") `T.append`) + in indent (head binds) : tail binds diff --git a/GhcMod/Exe/Check.hs b/GhcMod/Exe/Check.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Check.hs @@ -0,0 +1,57 @@ +module GhcMod.Exe.Check ( + checkSyntax + , check + , expandTemplate + , expand + ) where + +import Control.Applicative +import Prelude +import GhcMod.DynFlags +import qualified GhcMod.Gap as Gap +import GhcMod.Logger +import GhcMod.Monad + +---------------------------------------------------------------- + +-- | Checking syntax of a target file using GHC. +-- Warnings and errors are returned. +checkSyntax :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m String +checkSyntax [] = return "" +checkSyntax files = either id id <$> check files + +---------------------------------------------------------------- + +-- | Checking syntax of a target file using GHC. +-- Warnings and errors are returned. +check :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m (Either String String) +check files = + runGmlTWith + (map Left files) + return + ((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings) + (return ()) + +---------------------------------------------------------------- + +-- | Expanding Haskell Template. +expandTemplate :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m String +expandTemplate [] = return "" +expandTemplate files = either id id <$> expand files + +---------------------------------------------------------------- + +-- | Expanding Haskell Template. +expand :: IOish m => [FilePath] -> GhcModT m (Either String String) +expand files = + runGmlTWith + (map Left files) + return + ((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags)) + (return ()) diff --git a/GhcMod/Exe/Debug.hs b/GhcMod/Exe/Debug.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Debug.hs @@ -0,0 +1,182 @@ +module GhcMod.Exe.Debug (debugInfo, rootInfo, componentInfo) where + +import Control.Arrow (first) +import Control.Applicative +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Char +import Data.Maybe +import Data.Version +import Data.List.Split +import System.Directory + +import GhcMod.Exe.Internal +import GhcMod.Cradle +import GhcMod.Monad +import GhcMod.Output +import GhcMod.Pretty +import GhcMod.Stack +import GhcMod.Target +import GhcMod.Types +import GhcMod.Utils + +import Paths_ghc_mod (version) + +import Config (cProjectVersion) +import Pretty + +---------------------------------------------------------------- + +-- | Obtaining debug information. +debugInfo :: IOish m => GhcModT m String +debugInfo = do + Options {..} <- options + Cradle {..} <- cradle + + [ghcPath, ghcPkgPath] <- liftIO $ + case cradleProject of + StackProject se -> + catMaybes <$> sequence [getStackGhcPath se, getStackGhcPkgPath se] + _ -> + return ["ghc", "ghc-pkg"] + + cabal <- + case cradleProject of + CabalProject -> cabalDebug ghcPkgPath + StackProject {} -> (++) <$> stackPaths <*> cabalDebug ghcPkgPath + _ -> return [] + + pkgOpts <- packageGhcOptions + + readProc <- gmReadProcess + + ghcVersion <- liftIO $ + dropWhileEnd isSpace <$> readProc ghcPath ["--numeric-version"] "" + + return $ unlines $ + [ "Version: ghc-mod-" ++ showVersion version + , "Library GHC Version: " ++ cProjectVersion + , "System GHC Version: " ++ ghcVersion + , "Root directory: " ++ cradleRootDir + , "Current directory: " ++ cradleCurrentDir + , "GHC Package flags:\n" ++ renderGm (nest 4 $ + fsep $ map text pkgOpts) + , "GHC System libraries: " ++ ghcLibDir + ] ++ cabal + +stackPaths :: IOish m => GhcModT m [String] +stackPaths = do + Cradle { cradleProject = StackProject senv } <- cradle + ghc <- getStackGhcPath senv + ghcPkg <- getStackGhcPkgPath senv + return $ + [ "Stack ghc executable: " ++ show ghc + , "Stack ghc-pkg executable:" ++ show ghcPkg + ] + +cabalDebug :: IOish m => FilePath -> GhcModT m [String] +cabalDebug ghcPkgPath = do + Cradle {..} <- cradle + mcs <- cabalResolvedComponents + let entrypoints = Map.map gmcEntrypoints mcs + graphs = Map.map gmcHomeModuleGraph mcs + opts = Map.map gmcGhcOpts mcs + srcOpts = Map.map gmcGhcSrcOpts mcs + + readProc <- gmReadProcess + cabalExists <- liftIO $ (/=Nothing) <$> findExecutable "cabal" + + cabalInstVersion <- + if cabalExists + then liftIO $ + dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] "" + else return "" + + packages <- liftIO $ readProc ghcPkgPath ["list", "--simple-output"] "" + let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages + + return $ + [ "cabal-install Version: " ++ cabalInstVersion + , "Cabal Library Versions:\n" ++ renderGm (nest 4 $ + fsep $ map text cabalPackages) + , "Cabal file: " ++ show cradleCabalFile + , "Project: " ++ show cradleProject + , "Cabal entrypoints:\n" ++ renderGm (nest 4 $ + mapDoc gmComponentNameDoc smpDoc entrypoints) + , "Cabal components:\n" ++ renderGm (nest 4 $ + mapDoc gmComponentNameDoc graphDoc graphs) + , "GHC Cabal options:\n" ++ renderGm (nest 4 $ + mapDoc gmComponentNameDoc (fsep . map text) opts) + , "GHC search path options:\n" ++ renderGm (nest 4 $ + mapDoc gmComponentNameDoc (fsep . map text) srcOpts) + ] + +componentInfo :: IOish m => [String] -> GhcModT m String +componentInfo ts = do + -- TODO: most of this is copypasta of targetGhcOptions. Factor out more + -- useful function from there. + crdl <- cradle + sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts + mcs <- cabalResolvedComponents + let + mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn + candidates = findCandidates $ map snd mdlcs + cn = pickComponent candidates + opts <- targetGhcOptions crdl sefnmn + + return $ unlines $ + [ "Matching Components:\n" ++ renderGm (nest 4 $ + alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs) + , "Picked Component:\n" ++ renderGm (nest 4 $ + gmComponentNameDoc cn) + , "GHC Cabal options:\n" ++ renderGm (nest 4 $ fsep $ map text opts) + ] + where + zipMap f l = l `zip` (f `map` l) + +guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName) +guessModuleFile m + | (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m = + return $ Right $ mkModuleName m + where + infixr 1 .||. + infixr 2 .&&. + (.||.) = liftA2 (||) + (.&&.) = liftA2 (&&) + +guessModuleFile str = Left `liftM` liftIO (canonFilePath str) + +graphDoc :: GmModuleGraph -> Doc +graphDoc GmModuleGraph{..} = + mapDoc mpDoc smpDoc' gmgGraph + where + smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp + mpDoc' = text . moduleNameString . mpModule + +setDoc :: (a -> Doc) -> Set.Set a -> Doc +setDoc f s = vcat $ map f $ Set.toList s + +smpDoc :: Set.Set ModulePath -> Doc +smpDoc smp = setDoc mpDoc smp + +mpDoc :: ModulePath -> Doc +mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn) + +mnDoc :: ModuleName -> Doc +mnDoc mn = text (moduleNameString mn) + +alistDoc :: Ord k => (k -> Doc) -> (a -> Doc) -> [(k, a)] -> Doc +alistDoc fk fa alist = mapDoc fk fa (Map.fromList alist) + +mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc +mapDoc kd ad m = vcat $ + map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m +---------------------------------------------------------------- + +-- | Obtaining root information. +rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String +rootInfo = do + crdl <- findCradleNoLog =<< (optPrograms <$> options) + liftIO $ cleanupCradle crdl + return $ cradleRootDir crdl ++ "\n" diff --git a/GhcMod/Exe/FillSig.hs b/GhcMod/Exe/FillSig.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/FillSig.hs @@ -0,0 +1,590 @@ +{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} + +module GhcMod.Exe.FillSig ( + sig + , refine + , auto + ) where + +import Data.Char (isSymbol) +import Data.Function (on) +import Data.Functor +import Data.List (find, nub, sortBy) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Prelude + +import Exception (ghandle, SomeException(..)) +import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, + SrcSpan, Type, GenLocated(L)) +import Pretty (($$), text, nest) +import qualified GHC as G +import qualified Name as G +import Outputable (PprStyle) +import qualified Type as Ty +import qualified HsBinds as Ty +import qualified Class as Ty +import qualified Var as Ty +import qualified HsPat as Ty +import qualified Language.Haskell.Exts as HE +import Djinn.GHC + +import qualified GhcMod.Gap as Gap +import GhcMod.Convert +import GhcMod.DynFlags +import GhcMod.Monad +import GhcMod.SrcUtils +import GhcMod.Logging (gmLog) +import GhcMod.Pretty (showToDoc) +import GhcMod.Doc +import GhcMod.Types +import GhcMod.FileMapping (fileModSummaryWithMapping) + +#if __GLASGOW_HASKELL__ >= 710 +import GHC (unLoc) +#endif + +---------------------------------------------------------------- +-- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE +---------------------------------------------------------------- + +-- Possible signatures we can find: function or instance +data SigInfo + = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName) + | InstanceDecl SrcSpan G.Class + | TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName] + +-- Signature for fallback operation via haskell-src-exts +data HESigInfo + = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo) + | HEFamSignature + HE.SrcSpan + TyFamType + (HE.Name HE.SrcSpanInfo) + [HE.Name HE.SrcSpanInfo] + +data TyFamType = Closed | Open | Data +initialTyFamString :: TyFamType -> (String, String) +initialTyFamString Closed = ("instance", "") +initialTyFamString Open = ("function", "type instance ") +initialTyFamString Data = ("function", "data instance ") + +-- | Create a initial body from a signature. +sig :: IOish m + => FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> GhcModT m String +sig file lineNo colNo = + runGmlT' [Left file] deferErrors $ ghandle fallback $ do + oopts <- outputOpts + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- fileModSummaryWithMapping file + whenFound oopts (getSignature modSum lineNo colNo) $ \s -> + case s of + Signature loc names ty -> + ("function", fourInts loc, map (initialBody dflag style ty) names) + + InstanceDecl loc cls -> + let body x = initialBody dflag style (G.idType x) x + in ("instance", fourInts loc, body `map` Ty.classMethods cls) + + TyFamDecl loc name flavour vars -> + let (rTy, initial) = initialTyFamString flavour + body = initialFamBody dflag style name vars + in (rTy, fourInts loc, [initial ++ body]) + where + fallback (SomeException _) = do + oopts <- outputOpts + -- Code cannot be parsed by ghc module + -- Fallback: try to get information via haskell-src-exts + whenFound oopts (getSignatureFromHE file lineNo colNo) $ \x -> case x of + HESignature loc names ty -> + ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names) + HEFamSignature loc flavour name vars -> + let (rTy, initial) = initialTyFamString flavour + in (rTy, fourIntsHE loc, [initial ++ initialFamBody undefined undefined name vars]) + +---------------------------------------------------------------- +-- a. Code for getting the information + +-- Get signature from ghc parsing and typechecking +getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo) +getSignature modSum lineNo colNo = do + p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum + -- Inspect the parse tree to find the signature + case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of +#if __GLASGOW_HASKELL__ >= 800 + [L loc (G.SigD (Ty.TypeSig names (G.HsIB _ (G.HsWC _ _ (L _ ty)))))] -> +#elif __GLASGOW_HASKELL__ >= 710 + [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] -> +#else + [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] -> +#endif + -- We found a type signature + return $ Just $ Signature loc (map G.unLoc names) ty + [L _ (G.InstD _)] -> do + -- We found an instance declaration + TypecheckedModule{tm_renamed_source = Just tcs + ,tm_checked_module_info = minfo} <- G.typecheckModule p + let lst = listifyRenamedSpans tcs (lineNo, colNo) + case Gap.getClass lst of + Just (clsName,loc) -> obtainClassInfo minfo clsName loc + _ -> return Nothing +#if __GLASGOW_HASKELL__ >= 800 + [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _)))] -> do +#elif __GLASGOW_HASKELL__ >= 708 + [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do +#elif __GLASGOW_HASKELL__ >= 706 + [L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do +#else + [L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do +#endif +#if __GLASGOW_HASKELL__ >= 708 + let flavour = case info of + G.ClosedTypeFamily _ -> Closed + G.OpenTypeFamily -> Open + G.DataFamily -> Data +#else + let flavour = case info of -- Closed type families where introduced in GHC 7.8 + G.TypeFamily -> Open + G.DataFamily -> Data +#endif + +#if __GLASGOW_HASKELL__ >= 800 + getTyFamVarName x = case x of + L _ (G.UserTyVar (G.L _ n)) -> n + L _ (G.KindedTyVar (G.L _ n) _) -> n +#elif __GLASGOW_HASKELL__ >= 710 + getTyFamVarName x = case x of + L _ (G.UserTyVar n) -> n + L _ (G.KindedTyVar (G.L _ n) _) -> n +#elif __GLASGOW_HASKELL__ >= 706 + getTyFamVarName x = case x of + L _ (G.UserTyVar n) -> n + L _ (G.KindedTyVar n _) -> n +#else + getTyFamVarName x = case x of -- In GHC 7.4, HsTyVarBndr's have an extra arg + L _ (G.UserTyVar n _) -> n + L _ (G.KindedTyVar n _ _) -> n +#endif + in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars) + _ -> return Nothing + where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo) + obtainClassInfo minfo clsName loc = do + tyThing <- G.modInfoLookupName minfo clsName + return $ do Ty.ATyCon clsCon <- tyThing -- In Maybe + cls <- G.tyConClass_maybe clsCon + return $ InstanceDecl loc cls + +-- Get signature from haskell-src-exts +getSignatureFromHE :: (MonadIO m, GhcMonad m) => + FilePath -> Int -> Int -> m (Maybe HESigInfo) +getSignatureFromHE file lineNo colNo = do + presult <- liftIO $ HE.parseFile file + return $ case presult of + HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do + decl <- find (typeSigInRangeHE lineNo colNo) mdecls + case decl of + HE.TypeSig (HE.SrcSpanInfo s _) names ty -> + return $ HESignature s names ty + + HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ _ -> + let (name, tys) = dHeadTyVars declHead in + return $ HEFamSignature s Open name (map cleanTyVarBind tys) + + HE.DataFamDecl (HE.SrcSpanInfo s _) _ declHead _ -> + let (name, tys) = dHeadTyVars declHead in + return $ HEFamSignature s Open name (map cleanTyVarBind tys) + _ -> fail "" + _ -> Nothing + where cleanTyVarBind (HE.KindedVar _ n _) = n + cleanTyVarBind (HE.UnkindedVar _ n) = n + +#if MIN_VERSION_haskell_src_exts(1,16,0) + dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l]) + dHeadTyVars (HE.DHead _ name) = (name, []) + dHeadTyVars (HE.DHApp _ r ty) = (++[ty]) `fmap` (dHeadTyVars r) + dHeadTyVars (HE.DHInfix _ ty name) = (name, [ty]) + dHeadTyVars (HE.DHParen _ r) = dHeadTyVars r +#else + dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l]) + dHeadTyVars (HE.DHead _ n tys) = (n, tys) +#endif + +---------------------------------------------------------------- +-- b. Code for generating initial code + +-- A list of function arguments, and whether they are functions or normal +-- arguments is built from either a function signature or an instance signature +data FnArg = FnArgFunction | FnArgNormal | FnExplicitName String + +initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String +initialBody dflag style ty name = + initialBody' (getFnName dflag style name) (getFnArgs ty) + +initialBody' :: String -> [FnArg] -> String +initialBody' fname args = + initialHead fname args ++ " = " ++ n ++ "_body" + where n = if isSymbolName fname then "" else '_':fname + +initialFamBody :: FnArgsInfo ty name + => DynFlags -> PprStyle -> name -> [name] -> String +initialFamBody dflag style name args = + initialHead fnName fnArgs ++ " = ()" + where fnName = getFnName dflag style name + fnArgs = map (FnExplicitName . getFnName dflag style) args + +initialHead :: String -> [FnArg] -> String +initialHead fname args = + case initialBodyArgs args infiniteVars infiniteFns of + [] -> fname + arglist -> if isSymbolName fname + then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) + else fname ++ " " ++ unwords arglist + +initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String] +initialBodyArgs [] _ _ = [] +initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs +initialBodyArgs (FnArgNormal:xs) (v:vs) fs = v : initialBodyArgs xs vs fs +initialBodyArgs (FnExplicitName n:xs) vs fs = n : initialBodyArgs xs vs fs +initialBodyArgs _ _ _ = + error "initialBodyArgs: This should never happen" -- Lists are infinite + +initialHead1 :: String -> [FnArg] -> [String] -> String +initialHead1 fname args elts = + case initialBodyArgs1 args elts of + [] -> fname + arglist + | isSymbolName fname -> + head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) + | otherwise -> + fname ++ " " ++ unwords arglist + +initialBodyArgs1 :: [FnArg] -> [String] -> [String] +initialBodyArgs1 args elts = take (length args) elts + +-- Getting the initial body of function and instances differ +-- This is because for functions we only use the parsed file +-- (so the full file doesn't have to be type correct) +-- but for instances we need to get information about the class + +class FnArgsInfo ty name | ty -> name, name -> ty where + getFnName :: DynFlags -> PprStyle -> name -> String + getFnArgs :: ty -> [FnArg] + +instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where + getFnName dflag style name = showOccName dflag style $ Gap.occName name +#if __GLASGOW_HASKELL__ >= 800 + getFnArgs (G.HsForAllTy _ (L _ iTy)) +#elif __GLASGOW_HASKELL__ >= 710 + getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy)) +#else + getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) +#endif + = getFnArgs iTy + + getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy + getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = + (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy + where fnarg ty = case ty of +#if __GLASGOW_HASKELL__ >= 800 + (G.HsForAllTy _ (L _ iTy)) -> +#elif __GLASGOW_HASKELL__ >= 710 + (G.HsForAllTy _ _ _ _ (L _ iTy)) -> +#else + (G.HsForAllTy _ _ _ (L _ iTy)) -> +#endif + fnarg iTy + + (G.HsParTy (L _ iTy)) -> fnarg iTy + (G.HsFunTy _ _) -> True + _ -> False + getFnArgs _ = [] + +instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where + getFnName _ _ (HE.Ident _ s) = s + getFnName _ _ (HE.Symbol _ s) = s + getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy + getFnArgs (HE.TyParen _ iTy) = getFnArgs iTy + getFnArgs (HE.TyFun _ lTy rTy) = + (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy + where fnarg ty = case ty of + (HE.TyForall _ _ _ iTy) -> fnarg iTy + (HE.TyParen _ iTy) -> fnarg iTy + (HE.TyFun _ _ _) -> True + _ -> False + getFnArgs _ = [] + +instance FnArgsInfo Type Id where + getFnName dflag style method = showOccName dflag style $ G.getOccName method + getFnArgs = getFnArgs' . Ty.dropForAlls + where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty = + maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy) + (\_ -> FnArgFunction:getFnArgs' rTy) + $ Ty.splitFunTy_maybe lTy + + getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty = + getFnArgs' iTy + + getFnArgs' _ = [] + +-- Infinite supply of variable and function variable names +infiniteVars, infiniteFns :: [String] +infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"] +infiniteFns = infiniteSupply ["f","g","h"] +infiniteSupply :: [String] -> [String] +infiniteSupply initialSupply = + initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply) + ([1 .. ] :: [Integer]) + +-- Check whether a String is a symbol name +isSymbolName :: String -> Bool +isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c +isSymbolName [] = error "This should never happen" + + +---------------------------------------------------------------- +-- REWRITE A HOLE / UNDEFINED VIA A FUNCTION +---------------------------------------------------------------- + +refine :: IOish m + => FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> Expression -- ^ A Haskell expression. + -> GhcModT m String +refine file lineNo colNo (Expression expr) = + ghandle handler $ + runGmlT' [Left file] deferErrors $ do + oopts <- outputOpts + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- fileModSummaryWithMapping file + p <- G.parseModule modSum + tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p + ety <- G.exprType expr + whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $ + \(loc, name, rty, paren) -> + let eArgs = getFnArgs ety + rArgs = getFnArgs rty + diffArgs' = length eArgs - length rArgs + diffArgs = if diffArgs' < 0 then 0 else diffArgs' + iArgs = take diffArgs eArgs + txt = initialHead1 expr iArgs (infinitePrefixSupply name) + in (fourInts loc, doParen paren txt) + where + handler (SomeException ex) = do + gmLog GmException "refining" $ + text "" $$ nest 4 (showToDoc ex) + emptyResult =<< outputOpts + +-- Look for the variable in the specified position +findVar + :: GhcMonad m + => DynFlags + -> PprStyle + -> G.TypecheckedModule + -> G.TypecheckedSource + -> Int + -> Int + -> m (Maybe (SrcSpan, String, Type, Bool)) +findVar dflag style tcm tcs lineNo colNo = + case lst of +#if __GLASGOW_HASKELL__ >= 800 + e@(L _ (G.HsVar (L _ i))):others -> do +#else + e@(L _ (G.HsVar i)):others -> do +#endif + tyInfo <- Gap.getType tcm e + case tyInfo of + Just (s, typ) + | name == "undefined" || head name == '_' -> + return $ Just (s, name, typ, b) + where + name = getFnName dflag style i + -- If inside an App, we need parenthesis + b = case others of + L _ (G.HsApp (L _ a1) (L _ a2)):_ -> + isSearchedVar i a1 || isSearchedVar i a2 + _ -> False + _ -> return Nothing + _ -> return Nothing + where + lst :: [G.LHsExpr Id] + lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) + +infinitePrefixSupply :: String -> [String] +infinitePrefixSupply "undefined" = repeat "undefined" +infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer]) + +doParen :: Bool -> String -> String +doParen False s = s +doParen True s = if ' ' `elem` s then '(':s ++ ")" else s + +isSearchedVar :: Id -> G.HsExpr Id -> Bool +#if __GLASGOW_HASKELL__ >= 800 +isSearchedVar i (G.HsVar (L _ i2)) = i == i2 +#else +isSearchedVar i (G.HsVar i2) = i == i2 +#endif +isSearchedVar _ _ = False + + +---------------------------------------------------------------- +-- REFINE AUTOMATICALLY +---------------------------------------------------------------- + +auto :: IOish m + => FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> GhcModT m String +auto file lineNo colNo = + ghandle handler $ runGmlT' [Left file] deferErrors $ do + oopts <- outputOpts + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- fileModSummaryWithMapping file + p <- G.parseModule modSum + tcm@TypecheckedModule { + tm_typechecked_source = tcs + , tm_checked_module_info = minfo + } <- G.typecheckModule p + whenFound' oopts (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do + topLevel <- getEverythingInTopLevel minfo + let (f,pats) = getPatsForVariable tcs (lineNo,colNo) + -- Remove self function to prevent recursion, and id to trim + -- cases + filterFn (n,_) = let funName = G.getOccString n + recName = G.getOccString (G.getName f) + in funName `notElem` recName:notWantedFuns + -- Find without using other functions in top-level + localBnds = M.unions $ + map (\(L _ pat) -> getBindingsForPat pat) pats + lbn = filter filterFn (M.toList localBnds) + djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000 + let -- Find with the entire top-level + almostEnv = M.toList $ M.union localBnds topLevel + env = filter filterFn almostEnv + djinns <- djinn True (Just minfo) env rty (Max 10) 100000 + return ( fourInts loc + , map (doParen paren) $ nub (djinnsEmpty ++ djinns)) + where + handler (SomeException ex) = do + gmLog GmException "auto-refining" $ + text "" $$ nest 4 (showToDoc ex) + emptyResult =<< outputOpts + +-- Functions we do not want in completions +notWantedFuns :: [String] +notWantedFuns = ["id", "asTypeOf", "const"] + +-- Get all things defined in top-level +getEverythingInTopLevel :: GhcMonad m => G.ModuleInfo -> m (M.Map G.Name Type) +getEverythingInTopLevel m = do + let modInfo = tyThingsToInfo (G.modInfoTyThings m) + topNames = G.modInfoTopLevelScope m + case topNames of + Just topNames' -> do topThings <- mapM G.lookupGlobalName topNames' + let topThings' = catMaybes topThings + topInfo = tyThingsToInfo topThings' + return $ M.union modInfo topInfo + Nothing -> return modInfo + +tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type +tyThingsToInfo [] = M.empty +tyThingsToInfo (G.AnId i : xs) = + M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs) +-- Getting information about constructors is not needed +-- because they will be added by djinn-ghc when traversing types +-- #if __GLASGOW_HASKELL__ >= 708 +-- tyThingToInfo (G.AConLike (G.RealDataCon con)) = return [(Ty.dataConName con, Ty.dataConUserType con)] +-- #else +-- tyThingToInfo (G.AConLike con) = return [(Ty.dataConName con, Ty.dataConUserType con)] +-- #endif +tyThingsToInfo (_:xs) = tyThingsToInfo xs + +-- Find the Id of the function and the pattern where the hole is located +getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id]) +getPatsForVariable tcs (lineNo, colNo) = + let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $ + listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id] + in case bnd of + G.PatBind { Ty.pat_lhs = L ploc pat } -> case pat of + Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat]) + _ -> (error "This should never happen", []) + G.FunBind { Ty.fun_id = L _ funId } -> + let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) +#if __GLASGOW_HASKELL__ >= 708 + :: [G.LMatch Id (G.LHsExpr Id)] +#else + :: [G.LMatch Id] +#endif +#if __GLASGOW_HASKELL__ >= 710 + (L _ (G.Match _ pats _ _):_) = m +#else + (L _ (G.Match pats _ _):_) = m +#endif + in (funId, pats) + _ -> (error "This should never happen", []) + +getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type +#if __GLASGOW_HASKELL__ >= 800 +getBindingsForPat (Ty.VarPat (L _ i)) = M.singleton (G.getName i) (Ty.varType i) +#else +getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i) +#endif +getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l +getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b +getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) = + M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i) +#if __GLASGOW_HASKELL__ >= 708 +getBindingsForPat (Ty.ListPat l _ _) = + M.unions $ map (\(L _ i) -> getBindingsForPat i) l +#else +getBindingsForPat (Ty.ListPat l _) = + M.unions $ map (\(L _ i) -> getBindingsForPat i) l +#endif +getBindingsForPat (Ty.TuplePat l _ _) = + M.unions $ map (\(L _ i) -> getBindingsForPat i) l +getBindingsForPat (Ty.PArrPat l _) = + M.unions $ map (\(L _ i) -> getBindingsForPat i) l +getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i +getBindingsForPat (Ty.SigPatIn (L _ i) _) = getBindingsForPat i +getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i +getBindingsForPat (Ty.ConPatIn (L _ i) d) = + M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d) +getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d +getBindingsForPat _ = M.empty + +getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type +#if __GLASGOW_HASKELL__ >= 800 +getBindingsForRecPat (G.PrefixCon args) = +#else +getBindingsForRecPat (Ty.PrefixCon args) = +#endif + M.unions $ map (\(L _ i) -> getBindingsForPat i) args +#if __GLASGOW_HASKELL__ >= 800 +getBindingsForRecPat (G.InfixCon (L _ a1) (L _ a2)) = +#else +getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) = +#endif + M.union (getBindingsForPat a1) (getBindingsForPat a2) +#if __GLASGOW_HASKELL__ >= 800 +getBindingsForRecPat (G.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = +#else +getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = +#endif + getBindingsForRecFields (map unLoc' fields) + where +#if __GLASGOW_HASKELL__ >= 710 + unLoc' = unLoc +#else + unLoc' = id +#endif + getBindingsForRecFields [] = M.empty + getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) = + M.union (getBindingsForPat a) (getBindingsForRecFields fs) diff --git a/GhcMod/Exe/Find.hs b/GhcMod/Exe/Find.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Find.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE CPP, BangPatterns, TupleSections, DeriveGeneric #-} + +module GhcMod.Exe.Find + ( Symbol + , SymbolDb + , loadSymbolDb + , lookupSymbol + , dumpSymbol + , findSymbol + , lookupSym + , isOutdated + -- * Load 'SymbolDb' asynchronously + , AsyncSymbolDb + , newAsyncSymbolDb + , getAsyncSymbolDb + ) where + +import qualified GHC as G +import FastString +import Module +import OccName +import HscTypes +import Exception + +import GhcMod.Convert +import GhcMod.Gap +import GhcMod.Monad +import GhcMod.Output +import GhcMod.Types +import GhcMod.Utils +import GhcMod.World +import GhcMod.LightGhc + +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import Control.Monad.Trans.Control +import Control.Concurrent + +import Data.List +import Data.Binary +import Data.Function +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.IORef + +import System.Directory.ModTime +import System.IO.Unsafe + +import GHC.Generics (Generic) + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import GhcMod.PathsAndFiles +import System.Directory +import Prelude + +---------------------------------------------------------------- + +-- | Type of function and operation names. +type Symbol = BS.ByteString +type ModuleNameBS = BS.ByteString + +-- | Database from 'Symbol' to \['ModuleString'\]. +data SymbolDb = SymbolDb + { sdTable :: Map Symbol (Set ModuleNameBS) + , sdTimestamp :: ModTime + } deriving (Generic) + +#if __GLASGOW_HASKELL__ >= 708 +instance Binary SymbolDb +#else +instance Binary SymbolDb where + put (SymbolDb a b) = put a >> put b + get = do + a <- get + b <- get + return (SymbolDb a b) +#endif +instance NFData SymbolDb + +isOutdated :: IOish m => SymbolDb -> GhcModT m Bool +isOutdated db = + isOlderThan (sdTimestamp db) <$> timedPackageCaches + +---------------------------------------------------------------- + +-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] +-- which will be concatenated. 'loadSymbolDb' is called internally. +findSymbol :: IOish m => String -> GhcModT m String +findSymbol sym = loadSymbolDb' >>= lookupSymbol sym + +-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] +-- which will be concatenated. +lookupSymbol :: IOish m => String -> SymbolDb -> GhcModT m String +lookupSymbol sym db = convert' $ lookupSym (fastStringToByteString $ mkFastString sym) db + +lookupSym :: Symbol -> SymbolDb -> [ModuleString] +lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ S.toList $ M.findWithDefault S.empty sym $ sdTable db + +--------------------------------------------------------------- + +loadSymbolDb' :: IOish m => GhcModT m SymbolDb +loadSymbolDb' = do + cache <- symbolCache <$> cradle + let doLoad True = do + db <- decode <$> liftIO (LBS.readFile cache) + outdated <- isOutdated db + if outdated + then doLoad False + else return db + doLoad False = do + db <- loadSymbolDb + liftIO $ LBS.writeFile cache $ encode db + return db + doLoad =<< liftIO (doesFileExist cache) + +-- | Loading a file and creates 'SymbolDb'. +loadSymbolDb :: IOish m => GhcModT m SymbolDb +loadSymbolDb = do + ghcMod <- liftIO ghcModExecutable + readProc <- gmReadProcess' + out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] "" + return $!! decode out + +---------------------------------------------------------------- +-- used 'ghc-mod dumpsym' + +-- | Dumps a 'Binary' representation of 'SymbolDb' to stdout +dumpSymbol :: IOish m => GhcModT m () +dumpSymbol = do + ts <- liftIO getCurrentModTime + st <- runGmPkgGhc $ getGlobalSymbolTable + liftIO . LBS.putStr $ encode SymbolDb { + sdTable = st + , sdTimestamp = ts + } + +-- | Check whether given file is older than any file from the given set. +-- Returns True if given file does not exist. +isOlderThan :: ModTime -> [TimedFile] -> Bool +isOlderThan tCache files = + any (tCache <=) $ map tfTime files -- including equal just in case + +-- | Browsing all functions in all system modules. +getGlobalSymbolTable :: (G.GhcMonad m, MonadIO m) + => m (Map Symbol (Set ModuleNameBS)) +getGlobalSymbolTable = + foldM extend M.empty =<< (listVisibleModules <$> G.getSessionDynFlags) + +extend :: (G.GhcMonad m, MonadIO m) + => Map Symbol (Set ModuleNameBS) + -> Module + -> m (Map Symbol (Set ModuleNameBS)) +extend mm mdl = do + hsc_env <- G.getSession + eps <- liftIO $ readIORef $ hsc_EPS hsc_env + modinfo <- liftIO $ unsafeInterleaveIO $ runLightGhc hsc_env $ do + G.getModuleInfo mdl <* liftIO (writeIORef (hsc_EPS hsc_env) eps) + return $ M.unionWith S.union mm $ extractBindings modinfo mdl + +extractBindings :: Maybe G.ModuleInfo + -> G.Module + -> Map Symbol (Set ModuleNameBS) +extractBindings Nothing _ = M.empty +extractBindings (Just inf) mdl = M.fromList $ do + name <- G.modInfoExports inf + let sym = fastStringToByteString $ occNameFS $ G.getOccName name + mdls = S.singleton $ fastStringToByteString $ moduleNameFS $ moduleName mdl + return (sym, mdls) + +mkFastStringByteString' :: BS.ByteString -> FastString +#if !MIN_VERSION_ghc(7,8,0) +fastStringToByteString :: FastString -> BS.ByteString +fastStringToByteString = BS.pack . bytesFS + +mkFastStringByteString' = mkFastStringByteList . BS.unpack +#elif __GLASGOW_HASKELL__ == 708 +mkFastStringByteString' = unsafePerformIO . mkFastStringByteString +#else +mkFastStringByteString' = mkFastStringByteString +#endif + +---------------------------------------------------------------- + +data AsyncSymbolDb = AsyncSymbolDb (MVar (Either SomeException SymbolDb)) + +asyncLoadSymbolDb :: IOish m + => MVar (Either SomeException SymbolDb) + -> GhcModT m () +asyncLoadSymbolDb mv = void $ + liftBaseWith $ \run -> forkIO $ void $ run $ do + edb <- gtry loadSymbolDb + liftIO $ putMVar mv edb + +newAsyncSymbolDb :: IOish m => GhcModT m AsyncSymbolDb +newAsyncSymbolDb = do + mv <- liftIO newEmptyMVar + asyncLoadSymbolDb mv + return $ AsyncSymbolDb mv + +getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb +getAsyncSymbolDb (AsyncSymbolDb mv) = do + db <- liftIO $ handleEx <$> takeMVar mv + outdated <- isOutdated db + if outdated + then do + asyncLoadSymbolDb mv + liftIO $ handleEx <$> readMVar mv + else do + liftIO $ putMVar mv $ Right db + return db + where + handleEx edb = + case edb of + Left ex -> throw ex + Right db -> db diff --git a/GhcMod/Exe/Flag.hs b/GhcMod/Exe/Flag.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Flag.hs @@ -0,0 +1,9 @@ +module GhcMod.Exe.Flag where + +import qualified GhcMod.Gap as Gap +import GhcMod.Convert +import GhcMod.Monad + +-- | Listing of GHC flags, same as @ghc@\'s @--show-options@ with @ghc >= 7.10@. +flags :: IOish m => GhcModT m String +flags = convert' Gap.ghcCmdOptions diff --git a/GhcMod/Exe/Info.hs b/GhcMod/Exe/Info.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Info.hs @@ -0,0 +1,79 @@ +module GhcMod.Exe.Info ( + info + , types + ) where + +import Data.Function (on) +import Data.List (sortBy) +import System.FilePath +import Exception (ghandle, SomeException(..)) +import GHC (GhcMonad, SrcSpan) +import Prelude +import qualified GHC as G + +import qualified GhcMod.Gap as Gap +import GhcMod.Convert +import GhcMod.Doc +import GhcMod.DynFlags +import GhcMod.Gap +import GhcMod.Logging +import GhcMod.Monad +import GhcMod.SrcUtils +import GhcMod.Types +import GhcMod.Utils (mkRevRedirMapFunc) +import GhcMod.FileMapping (fileModSummaryWithMapping) + +---------------------------------------------------------------- + +-- | Obtaining information of a target expression. (GHCi's info:) +info :: IOish m + => FilePath -- ^ A target file. + -> Expression -- ^ A Haskell expression. + -> GhcModT m String +info file expr = + ghandle handler $ + runGmlT' [Left file] deferErrors $ + withInteractiveContext $ do + convert' =<< body + where + handler (SomeException ex) = do + gmLog GmException "info" $ text "" $$ nest 4 (showToDoc ex) + convert' "Cannot show info" + + body :: (GhcMonad m, GmState m, GmEnv m) => m String + body = do + m <- mkRevRedirMapFunc + sdoc <- Gap.infoThing m expr + st <- getStyle + dflag <- G.getSessionDynFlags + return $ showPage dflag st sdoc + +---------------------------------------------------------------- + +-- | Obtaining type of a target expression. (GHCi's type:) +types :: IOish m + => Bool -- ^ Include constraints into type signature + -> FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> GhcModT m String +types withConstraints file lineNo colNo = + ghandle handler $ + runGmlT' [Left file] deferErrors $ + withInteractiveContext $ do + crdl <- cradle + modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) + srcSpanTypes <- getSrcSpanType withConstraints modSum lineNo colNo + dflag <- G.getSessionDynFlags + st <- getStyle + convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes + where + handler (SomeException ex) = do + gmLog GmException "types" $ showToDoc ex + return [] + +getSrcSpanType :: (GhcMonad m) => Bool -> G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)] +getSrcSpanType withConstraints modSum lineNo colNo = + G.parseModule modSum + >>= G.typecheckModule + >>= flip (collectSpansTypes withConstraints) (lineNo, colNo) diff --git a/GhcMod/Exe/Internal.hs b/GhcMod/Exe/Internal.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Internal.hs @@ -0,0 +1,73 @@ +-- | Low level access to the ghc-mod library. + +module GhcMod.Exe.Internal ( + -- * Types + GHCOption + , IncludeDir + , GmlT(..) + , MonadIO(..) + , GmEnv(..) + -- * Various Paths + , ghcLibDir + , ghcModExecutable + -- * Logging + , withLogger + , setNoWarningFlags + , setAllWarningFlags + -- * Environment, state and logging + , GhcModEnv(..) + , GhcModState + , GhcModLog + , GmLog(..) + , GmLogLevel(..) + , gmSetLogLevel + -- * Monad utilities + , runGhcModT' + , hoistGhcModT + , runGmlT + , runGmlT' + , gmlGetSession + , gmlSetSession + , loadTargets + , cabalResolvedComponents + -- ** Accessing 'GhcModEnv' and 'GhcModState' + , options + , cradle + , targetGhcOptions + , withOptions + -- * 'GhcModError' + , gmeDoc + -- * World + , World + , getCurrentWorld + , didWorldChange + -- * Cabal Helper + , ModulePath(..) + , GmComponent(..) + , GmComponentType(..) + , GmModuleGraph(..) + , prepareCabalHelper + -- * Misc stuff + , GHandler(..) + , gcatches + -- * FileMapping + , module GhcMod.FileMapping + ) where + +import GHC.Paths (libdir) + +import GhcMod.Target +import GhcMod.DynFlags +import GhcMod.Error +import GhcMod.Logger +import GhcMod.Logging +import GhcMod.Monad +import GhcMod.Types +import GhcMod.Utils +import GhcMod.World +import GhcMod.CabalHelper +import GhcMod.FileMapping + +-- | Obtaining the directory for ghc system libraries. +ghcLibDir :: FilePath +ghcLibDir = libdir diff --git a/GhcMod/Exe/Lang.hs b/GhcMod/Exe/Lang.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Lang.hs @@ -0,0 +1,10 @@ +module GhcMod.Exe.Lang where + +import DynFlags (supportedLanguagesAndExtensions) +import GhcMod.Convert +import GhcMod.Monad + +-- | Listing language extensions. + +languages :: IOish m => GhcModT m String +languages = convert' supportedLanguagesAndExtensions diff --git a/GhcMod/Exe/Lint.hs b/GhcMod/Exe/Lint.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Lint.hs @@ -0,0 +1,30 @@ +module GhcMod.Exe.Lint where + +import Exception (ghandle) +import Control.Exception (SomeException(..)) +import GhcMod.Logger (checkErrorPrefix) +import GhcMod.Convert +import GhcMod.Types +import GhcMod.Monad +import Language.Haskell.HLint3 + +import GhcMod.Utils (withMappedFile) +import Language.Haskell.Exts.SrcLoc (SrcSpan(..)) + +-- | Checking syntax of a target file using hlint. +-- Warnings and errors are returned. +lint :: IOish m + => LintOpts -- ^ Configuration parameters + -> FilePath -- ^ A target file. + -> GhcModT m String +lint opt file = ghandle handler $ + withMappedFile file $ \tempfile -> do + res <- liftIO $ hlint $ "--quiet" : tempfile : optLintHlintOpts opt + pack . map (show . substFile file tempfile) $ res + where + pack = convert' . map init -- init drops the last \n. + handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n" + substFile orig temp idea + | srcSpanFilename (ideaSpan idea) == temp + = idea{ideaSpan=(ideaSpan idea){srcSpanFilename = orig}} + substFile _ _ idea = idea diff --git a/GhcMod/Exe/Modules.hs b/GhcMod/Exe/Modules.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Modules.hs @@ -0,0 +1,27 @@ +module GhcMod.Exe.Modules (modules) where + +import Control.Arrow +import Data.List +import GhcMod.Convert +import GhcMod.Types +import GhcMod.Monad +import GhcMod.Gap ( listVisibleModuleNames + , lookupModulePackageInAllPackages + ) + +import qualified GHC as G + +---------------------------------------------------------------- + +-- | Listing installed modules. +modules :: (IOish m, Gm m) + => Bool -- ^ 'detailed', if 'True', also prints packages that modules belong to. + -> m String +modules detailed = do + df <- runGmPkgGhc G.getSessionDynFlags + let mns = listVisibleModuleNames df + pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns) + convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn + | (mn, pkgs) <- pmnss, pkg <- pkgs ] + where + modulePkg df = lookupModulePackageInAllPackages df diff --git a/GhcMod/Exe/PkgDoc.hs b/GhcMod/Exe/PkgDoc.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/PkgDoc.hs @@ -0,0 +1,29 @@ +module GhcMod.Exe.PkgDoc (pkgDoc) where + +import GhcMod.Types +import GhcMod.GhcPkg +import GhcMod.Monad +import GhcMod.Output + +import Control.Applicative +import Prelude + +-- | Obtaining the package name and the doc path of a module. +pkgDoc :: IOish m => String -> GhcModT m String +pkgDoc mdl = do + ghcPkg <- getGhcPkgProgram + readProc <- gmReadProcess + pkgDbStack <- getPackageDbStack + pkg <- liftIO $ trim <$> readProc ghcPkg (toModuleOpts pkgDbStack) "" + if pkg == "" then + return "\n" + else do + htmlpath <- liftIO $ readProc ghcPkg (toDocDirOpts pkg pkgDbStack) "" + let ret = pkg ++ " " ++ drop 14 htmlpath + return ret + where + toModuleOpts dbs = ["find-module", mdl, "--simple-output"] + ++ ghcPkgDbStackOpts dbs + toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"] + ++ ghcPkgDbStackOpts dbs + trim = takeWhile (`notElem` " \n") diff --git a/GhcMod/Exe/Test.hs b/GhcMod/Exe/Test.hs new file mode 100644 --- /dev/null +++ b/GhcMod/Exe/Test.hs @@ -0,0 +1,45 @@ +module GhcMod.Exe.Test where + +import Control.Applicative +import Data.List +import System.FilePath +import System.Directory +import Prelude + +import GhcMod.Types +import GhcMod.Monad +import GhcMod.DynFlags + +import GHC +import GHC.Exception +import OccName + +test :: IOish m + => FilePath -> GhcModT m String +test f = runGmlT' [Left f] (fmap setHscInterpreted . deferErrors) $ do + mg <- getModuleGraph + root <- cradleRootDir <$> cradle + f' <- makeRelative root <$> liftIO (canonicalizePath f) + let Just ms = find ((==Just f') . ml_hs_file . ms_location) mg + mdl = ms_mod ms + mn = moduleName mdl + + Just mi <- getModuleInfo mdl + let exs = map (occNameString . getOccName) $ modInfoExports mi + cqs = filter ("prop_" `isPrefixOf`) exs + + setContext [ IIDecl $ simpleImportDecl mn + , IIDecl $ simpleImportDecl $ mkModuleName "Test.QuickCheck" + ] + + _res <- mapM runTest cqs + + return "" + +runTest :: GhcMonad m => String -> m (Maybe SomeException) +runTest fn = do + res <- runStmt ("quickCheck " ++ fn) RunToCompletion + return $ case res of + RunOk [] -> Nothing + RunException se -> Just se + _ -> error "runTest" diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,29 +0,0 @@ -Copyright (c) 2009, IIJ Innovation Institute Inc. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - * Neither the name of the copyright holders nor the names of its - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS -FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, -BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod.hs +++ /dev/null @@ -1,66 +0,0 @@ --- | The ghc-mod library. - -module Language.Haskell.GhcMod ( - -- * Cradle - Cradle(..) - , findCradle - -- * Options - , Options(..) - , LineSeparator(..) - , OutputStyle(..) - , defaultOptions - -- * Types - , ModuleString - , Expression - , GhcPkgDb - , Symbol - , SymbolDb - , GhcModError(..) - -- * Monad Types - , GhcModT - , IOish - -- * Monad utilities - , runGhcModT - , withOptions - -- * 'GhcMod' utilities - , boot - , browse - , check - , checkSyntax - , debugInfo - , expandTemplate - , info - , lint - , pkgDoc - , rootInfo - , types - , splits - , sig - , refine - , auto - , modules - , languages - , flags - , findSymbol - , lookupSymbol - , dumpSymbol - -- * SymbolDb - , loadSymbolDb - ) where - -import Language.Haskell.GhcMod.Boot -import Language.Haskell.GhcMod.Browse -import Language.Haskell.GhcMod.CaseSplit -import Language.Haskell.GhcMod.Check -import Language.Haskell.GhcMod.Cradle -import Language.Haskell.GhcMod.Debug -import Language.Haskell.GhcMod.FillSig -import Language.Haskell.GhcMod.Find -import Language.Haskell.GhcMod.Flag -import Language.Haskell.GhcMod.Info -import Language.Haskell.GhcMod.Lang -import Language.Haskell.GhcMod.Lint -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Modules -import Language.Haskell.GhcMod.PkgDoc -import Language.Haskell.GhcMod.Types diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Boot.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Language.Haskell.GhcMod.Boot where - -import Control.Applicative -import Language.Haskell.GhcMod.Browse -import Language.Haskell.GhcMod.Flag -import Language.Haskell.GhcMod.Lang -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Modules - --- | Printing necessary information for front-end booting. -boot :: IOish m => GhcModT m String -boot = concat <$> sequence [modules, languages, flags, - concat <$> mapM browse preBrowsedModules] - -preBrowsedModules :: [String] -preBrowsedModules = [ - "Prelude" - , "Control.Applicative" - , "Control.Exception" - , "Control.Monad" - , "Data.Char" - , "Data.List" - , "Data.Maybe" - , "System.IO" - ] diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ /dev/null @@ -1,136 +0,0 @@ -module Language.Haskell.GhcMod.Browse ( - browse - ) where - -import Control.Applicative ((<$>)) -import Control.Exception (SomeException(..)) -import Data.Char (isAlpha) -import Data.List (sort) -import Data.Maybe (catMaybes) -import Exception (ghandle) -import FastString (mkFastString) -import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon) -import qualified GHC as G -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified) -import Language.Haskell.GhcMod.Gap -import Language.Haskell.GhcMod.Monad (GhcModT, options) -import Language.Haskell.GhcMod.Target (setTargetFiles) -import Language.Haskell.GhcMod.Types -import Name (getOccString) -import Outputable (ppr, Outputable) -import TyCon (isAlgTyCon) -import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) - ----------------------------------------------------------------- - --- | Getting functions, classes, etc from a module. --- If 'detailed' is 'True', their types are also obtained. --- If 'operators' is 'True', operators are also returned. -browse :: IOish m - => ModuleString -- ^ A module name. (e.g. \"Data.List\") - -> GhcModT m String -browse pkgmdl = convert' . sort =<< (listExports =<< getModule) - where - (mpkg,mdl) = splitPkgMdl pkgmdl - mdlname = G.mkModuleName mdl - mpkgid = mkFastString <$> mpkg - listExports Nothing = return [] - listExports (Just mdinfo) = processExports mdinfo - -- findModule works only for package modules, moreover, - -- you cannot load a package module. On the other hand, - -- to browse a local module you need to load it first. - -- If CmdLineError is signalled, we assume the user - -- tried browsing a local module. - getModule = browsePackageModule `G.gcatch` fallback `G.gcatch` handler - browsePackageModule = G.findModule mdlname mpkgid >>= G.getModuleInfo - browseLocalModule = ghandle handler $ do - setTargetFiles [mdl] - G.findModule mdlname Nothing >>= G.getModuleInfo - fallback (CmdLineError _) = browseLocalModule - fallback _ = return Nothing - handler (SomeException _) = return Nothing --- | --- --- >>> splitPkgMdl "base:Prelude" --- (Just "base","Prelude") --- >>> splitPkgMdl "Prelude" --- (Nothing,"Prelude") -splitPkgMdl :: String -> (Maybe String,String) -splitPkgMdl pkgmdl = case break (==':') pkgmdl of - (mdl,"") -> (Nothing,mdl) - (pkg,_:mdl) -> (Just pkg,mdl) - -processExports :: IOish m => ModuleInfo -> GhcModT m [String] -processExports minfo = do - opt <- options - let - removeOps - | operators opt = id - | otherwise = filter (isAlpha . head . getOccString) - mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo - -showExport :: IOish m => Options -> ModuleInfo -> Name -> GhcModT m String -showExport opt minfo e = do - mtype' <- mtype - return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] - where - mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt - mtype :: IOish m => GhcModT m (Maybe String) - mtype - | detailed opt = do - tyInfo <- G.modInfoLookupName minfo e - -- If nothing found, load dependent module and lookup global - tyResult <- maybe (inOtherModule e) (return . Just) tyInfo - dflag <- G.getSessionDynFlags - return $ do - typeName <- tyResult >>= showThing dflag - (" :: " ++ typeName) `justIf` detailed opt - | otherwise = return Nothing - formatOp nm@(n:_) - | isAlpha n = nm - | otherwise = "(" ++ nm ++ ")" - formatOp "" = error "formatOp" - inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing) - inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm - justIf :: a -> Bool -> Maybe a - justIf x True = Just x - justIf _ False = Nothing - -showThing :: DynFlags -> TyThing -> Maybe String -showThing dflag tything = showThing' dflag (fromTyThing tything) - -showThing' :: DynFlags -> GapThing -> Maybe String -showThing' dflag (GtA a) = Just $ formatType dflag a -showThing' _ (GtT t) = unwords . toList <$> tyType t - where - toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t) -showThing' _ _ = Nothing - -formatType :: DynFlags -> Type -> String -formatType dflag a = showOutputable dflag (removeForAlls a) - -tyType :: TyCon -> Maybe String -tyType typ - | isAlgTyCon typ - && not (G.isNewTyCon typ) - && not (G.isClassTyCon typ) = Just "data" - | G.isNewTyCon typ = Just "newtype" - | G.isClassTyCon typ = Just "class" - | G.isSynTyCon typ = Just "type" - | otherwise = Nothing - -removeForAlls :: Type -> Type -removeForAlls ty = removeForAlls' ty' tty' - where - ty' = dropForAlls ty - tty' = splitFunTy_maybe ty' - -removeForAlls' :: Type -> Maybe (Type, Type) -> Type -removeForAlls' ty Nothing = ty -removeForAlls' ty (Just (pre, ftype)) - | isPredTy pre = mkFunTy pre (dropForAlls ftype) - | otherwise = ty - -showOutputable :: Outputable a => DynFlags -> a -> String -showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr diff --git a/Language/Haskell/GhcMod/Cabal16.hs b/Language/Haskell/GhcMod/Cabal16.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Cabal16.hs +++ /dev/null @@ -1,45 +0,0 @@ --- Copyright : Isaac Jones 2003-2004 -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - - --- | ComponentLocalBuildInfo for Cabal <= 1.16 -module Language.Haskell.GhcMod.Cabal16 ( - ComponentLocalBuildInfo - , componentPackageDeps - ) where - -import Distribution.Package (InstalledPackageId, PackageIdentifier) - --- From Cabal <= 1.16 -data ComponentLocalBuildInfo = ComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageIdentifier)] - } - deriving (Read, Show) diff --git a/Language/Haskell/GhcMod/Cabal18.hs b/Language/Haskell/GhcMod/Cabal18.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Cabal18.hs +++ /dev/null @@ -1,58 +0,0 @@ --- Copyright : Isaac Jones 2003-2004 -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - --- | ComponentLocalBuildInfo for Cabal >= 1.18 -module Language.Haskell.GhcMod.Cabal18 ( - ComponentLocalBuildInfo - , componentPackageDeps - , componentLibraries - ) where - -import Distribution.Package (InstalledPackageId, PackageId) - -data LibraryName = LibraryName String - deriving (Read, Show) - -data ComponentLocalBuildInfo - = LibComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)], - componentLibraries :: [LibraryName] - } - | ExeComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - | TestComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - | BenchComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - deriving (Read, Show) diff --git a/Language/Haskell/GhcMod/Cabal21.hs b/Language/Haskell/GhcMod/Cabal21.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Cabal21.hs +++ /dev/null @@ -1,73 +0,0 @@ --- Copyright : Isaac Jones 2003-2004 -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - --- | ComponentLocalBuildInfo for Cabal >= 1.21 -module Language.Haskell.GhcMod.Cabal21 ( - ComponentLocalBuildInfo - , PackageIdentifier(..) - , PackageName(..) - , componentPackageDeps - , componentLibraries - ) where - -import Distribution.Package (InstalledPackageId) -import Data.Version (Version) - -data LibraryName = LibraryName String - deriving (Read, Show) - -newtype PackageName = PackageName { unPackageName :: String } - deriving (Read, Show) - -data PackageIdentifier - = PackageIdentifier { - pkgName :: PackageName, - pkgVersion :: Version - } - deriving (Read, Show) - -type PackageId = PackageIdentifier - -data ComponentLocalBuildInfo - = LibComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)], - componentLibraries :: [LibraryName] - } - | ExeComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - | TestComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - | BenchComponentLocalBuildInfo { - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - deriving (Read, Show) diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} - -module Language.Haskell.GhcMod.CabalApi ( - getCompilerOptions - , parseCabalFile - , cabalAllBuildInfo - , cabalDependPackages - , cabalSourceDirs - , cabalAllTargets - , cabalConfigDependencies - ) where - -import Language.Haskell.GhcMod.CabalConfig -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets, - toModuleString) -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.Types - -import MonadUtils (liftIO) -import Control.Applicative ((<$>)) -import qualified Control.Exception as E -import Control.Monad (filterM) -import Data.Maybe (maybeToList) -import Data.Set (fromList, toList) -import Distribution.Package (Dependency(Dependency) - , PackageName(PackageName)) -import qualified Distribution.Package as C -import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable) -import qualified Distribution.PackageDescription as P -import Distribution.PackageDescription.Configuration (finalizePackageDescription) -import Distribution.PackageDescription.Parse (readPackageDescription) -import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..)) -import Distribution.Simple.Program (ghcProgram) -import Distribution.Simple.Program.Types (programName, programFindVersion) -import Distribution.System (buildPlatform) -import Distribution.Text (display) -import Distribution.Verbosity (silent) -import Distribution.Version (Version) -import System.Directory (doesFileExist) -import System.FilePath (()) ----------------------------------------------------------------- - --- | Getting necessary 'CompilerOptions' from three information sources. -getCompilerOptions :: (IOish m, MonadError GhcModError m) - => [GHCOption] - -> Cradle - -> PackageDescription - -> m CompilerOptions -getCompilerOptions ghcopts cradle pkgDesc = do - gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos - depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc) - return $ CompilerOptions gopts idirs depPkgs - where - wdir = cradleCurrentDir cradle - rdir = cradleRootDir cradle - buildInfos = cabalAllBuildInfo pkgDesc - idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos - ----------------------------------------------------------------- --- Include directories for modules - -cabalBuildDirs :: [FilePath] -cabalBuildDirs = ["dist/build", "dist/build/autogen"] - -includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath] -includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir]) - where - extdirs = map expand $ dirs ++ cabalBuildDirs - expand "." = cdir - expand subdir = cdir subdir - ----------------------------------------------------------------- - --- | Parse a cabal file and return a 'PackageDescription'. -parseCabalFile :: (IOish m, MonadError GhcModError m) - => Cradle - -> FilePath - -> m PackageDescription -parseCabalFile cradle file = do - cid <- liftIO getGHCId - epgd <- liftIO $ readPackageDescription silent file - flags <- cabalConfigFlags cradle - case toPkgDesc cid flags epgd of - Left deps -> fail $ show deps ++ " are not installed" - Right (pd,_) -> if nullPkg pd - then fail $ file ++ " is broken" - else return pd - where - toPkgDesc cid flags = - finalizePackageDescription flags (const True) buildPlatform cid [] - nullPkg pd = name == "" - where - PackageName name = C.pkgName (P.package pd) - ----------------------------------------------------------------- - -getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption] -getGHCOptions ghcopts cradle rdir binfo = do - cabalCpp <- cabalCppOptions rdir - let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp - return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps - where - pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle - lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo - libDirs = map ("-L" ++) $ P.extraLibDirs binfo - exts = map (("-X" ++) . display) $ P.usedExtensions binfo - libs = map ("-l" ++) $ P.extraLibs binfo - -cabalCppOptions :: FilePath -> IO [String] -cabalCppOptions dir = do - exist <- doesFileExist cabalMacro - return $ if exist then - ["-include", cabalMacro] - else - [] - where - cabalMacro = dir "dist/build/autogen/cabal_macros.h" - ----------------------------------------------------------------- - --- | Extracting all 'BuildInfo' for libraries, executables, and tests. -cabalAllBuildInfo :: PackageDescription -> [BuildInfo] -cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI - where - libBI = map P.libBuildInfo $ maybeToList $ P.library pd - execBI = map P.buildInfo $ P.executables pd - testBI = map P.testBuildInfo $ P.testSuites pd - benchBI = benchmarkBuildInfo pd - ----------------------------------------------------------------- - --- | Extracting package names of dependency. -cabalDependPackages :: [BuildInfo] -> [PackageBaseName] -cabalDependPackages bis = uniqueAndSort pkgs - where - pkgs = map getDependencyPackageName $ concatMap P.targetBuildDepends bis - getDependencyPackageName (Dependency (PackageName nm) _) = nm - ----------------------------------------------------------------- - --- | Extracting include directories for modules. -cabalSourceDirs :: [BuildInfo] -> [IncludeDir] -cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis - ----------------------------------------------------------------- - -uniqueAndSort :: [String] -> [String] -uniqueAndSort = toList . fromList - ----------------------------------------------------------------- - -getGHCId :: IO CompilerId -getGHCId = CompilerId GHC <$> getGHC - -getGHC :: IO Version -getGHC = do - mv <- programFindVersion ghcProgram silent (programName ghcProgram) - case mv of - -- TODO: MonadError it up - Nothing -> E.throwIO $ userError "ghc not found" - Just v -> return v - ----------------------------------------------------------------- - --- | Extracting all 'Module' 'FilePath's for libraries, executables, --- tests and benchmarks. -cabalAllTargets :: PackageDescription -> IO ([String],[String],[String],[String]) -cabalAllTargets pd = do - exeTargets <- mapM getExecutableTarget $ P.executables pd - testTargets <- mapM getTestTarget $ P.testSuites pd - return (libTargets,concat exeTargets,concat testTargets,benchTargets) - where - lib = case P.library pd of - Nothing -> [] - Just l -> P.libModules l - - libTargets = map toModuleString lib - benchTargets = benchmarkTargets pd - - getTestTarget :: TestSuite -> IO [String] - getTestTarget ts = - case P.testInterface ts of - (TestSuiteExeV10 _ filePath) -> do - let maybeTests = [p e | p <- P.hsSourceDirs $ P.testBuildInfo ts, e <- [filePath]] - liftIO $ filterM doesFileExist maybeTests - (TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName] - (TestSuiteUnsupported _) -> return [] - - getExecutableTarget :: Executable -> IO [String] - getExecutableTarget exe = do - let maybeExes = [p e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]] - liftIO $ filterM doesFileExist maybeExes diff --git a/Language/Haskell/GhcMod/CabalConfig.hs b/Language/Haskell/GhcMod/CabalConfig.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/CabalConfig.hs +++ /dev/null @@ -1,177 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | This module facilitates extracting information from Cabal's on-disk --- 'LocalBuildInfo' (@dist/setup-config@). -module Language.Haskell.GhcMod.CabalConfig ( - CabalConfig - , cabalConfigDependencies - , cabalConfigFlags - ) where - -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.Read -import Language.Haskell.GhcMod.Types - -import qualified Language.Haskell.GhcMod.Cabal16 as C16 -import qualified Language.Haskell.GhcMod.Cabal18 as C18 -import qualified Language.Haskell.GhcMod.Cabal21 as C21 - -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(x,y,z) 1 -#endif - -import Control.Applicative ((<$>)) -import Control.Monad (mplus) -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except () -#else -import Control.Monad.Error () -#endif -import Data.Maybe () -import Data.Set () -import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) -import Distribution.Package (InstalledPackageId(..) - , PackageIdentifier(..) - , PackageName(..)) -import Distribution.PackageDescription (FlagAssignment) -import Distribution.Simple.BuildPaths (defaultDistPref) -import Distribution.Simple.Configure (localBuildInfoFile) -import Distribution.Simple.LocalBuildInfo (ComponentName) -import MonadUtils (liftIO) -import System.FilePath (()) - ----------------------------------------------------------------- - --- | 'Show'ed cabal 'LocalBuildInfo' string -type CabalConfig = String - --- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't --- exist run @cabal configure@ i.e. configure with default options like @cabal --- build@ would do. -getConfig :: (IOish m, MonadError GhcModError m) - => Cradle - -> m CabalConfig -getConfig cradle = liftIO (readFile path) `tryFix` \_ -> - configure `modifyError'` GMECabalConfigure - where - prjDir = cradleRootDir cradle - path = prjDir configPath - - configure :: (IOish m, MonadError GhcModError m) => m () - configure = - withDirectory_ prjDir $ readProcess' "cabal" ["configure"] >> return () - - --- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ -configPath :: FilePath -configPath = localBuildInfoFile defaultDistPref - --- | Get list of 'Package's needed by all components of the current package -cabalConfigDependencies :: (IOish m, MonadError GhcModError m) - => Cradle - -> PackageIdentifier - -> m [Package] -cabalConfigDependencies cradle thisPkg = - configDependencies thisPkg <$> getConfig cradle - --- | Extract list of depencenies for all components from 'CabalConfig' -configDependencies :: PackageIdentifier -> CabalConfig -> [Package] -configDependencies thisPkg config = map fromInstalledPackageId deps - where - deps :: [InstalledPackageId] - deps = case deps21 `mplus` deps18 `mplus` deps16 of - Right ps -> ps - Left msg -> error msg - - -- True if this dependency is an internal one (depends on the library - -- defined in the same package). - internal pkgid = pkgid == thisPkg - - -- Cabal >= 1.21 - deps21 :: Either String [InstalledPackageId] - deps21 = - map fst - <$> filterInternal21 - <$> (readEither =<< extractField config "componentsConfigs") - - filterInternal21 - :: [(ComponentName, C21.ComponentLocalBuildInfo, [ComponentName])] - -> [(InstalledPackageId, C21.PackageIdentifier)] - - filterInternal21 ccfg = [ (ipkgid, pkgid) - | (_,clbi,_) <- ccfg - , (ipkgid, pkgid) <- C21.componentPackageDeps clbi - , not (internal . packageIdentifierFrom21 $ pkgid) ] - - packageIdentifierFrom21 :: C21.PackageIdentifier -> PackageIdentifier - packageIdentifierFrom21 (C21.PackageIdentifier (C21.PackageName myName) myVersion) = - PackageIdentifier (PackageName myName) myVersion - - -- Cabal >= 1.18 && < 1.21 - deps18 :: Either String [InstalledPackageId] - deps18 = - map fst - <$> filterInternal - <$> (readEither =<< extractField config "componentsConfigs") - - filterInternal - :: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])] - -> [(InstalledPackageId, PackageIdentifier)] - - filterInternal ccfg = [ (ipkgid, pkgid) - | (_,clbi,_) <- ccfg - , (ipkgid, pkgid) <- C18.componentPackageDeps clbi - , not (internal pkgid) ] - - -- Cabal 1.16 and below - deps16 :: Either String [InstalledPackageId] - deps16 = map fst <$> filter (not . internal . snd) . nub <$> do - cbi <- concat <$> sequence [ extract "executableConfigs" - , extract "testSuiteConfigs" - , extract "benchmarkConfigs" ] - :: Either String [(String, C16.ComponentLocalBuildInfo)] - - return $ maybe [] C16.componentPackageDeps libraryConfig - ++ concatMap (C16.componentPackageDeps . snd) cbi - where - libraryConfig :: Maybe C16.ComponentLocalBuildInfo - libraryConfig = do - field <- find ("libraryConfig" `isPrefixOf`) (tails config) - clbi <- stripPrefix " = " field - if "Nothing" `isPrefixOf` clbi - then Nothing - else case readMaybe =<< stripPrefix "Just " clbi of - Just x -> x - Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi) - - extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)] - extract field = readConfigs field <$> extractField config field - - readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)] - readConfigs f s = case readEither s of - Right x -> x - Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")" - --- | Get the flag assignment from the local build info of the given cradle -cabalConfigFlags :: (IOish m, MonadError GhcModError m) - => Cradle - -> m FlagAssignment -cabalConfigFlags cradle = do - config <- getConfig cradle - case configFlags config of - Right x -> return x - Left msg -> throwError (GMECabalFlags (GMEString msg)) - --- | Extract the cabal flags from the 'CabalConfig' -configFlags :: CabalConfig -> Either String FlagAssignment -configFlags config = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags" - --- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable --- error message with lots of context on failure. -extractField :: CabalConfig -> String -> Either String String -extractField config field = - case extractParens <$> find (field `isPrefixOf`) (tails config) of - Just f -> Right f - Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Language.Haskell.GhcMod.CaseSplit ( - splits - ) where - -import Data.List (find, intercalate) -import Data.Maybe (isJust) -import qualified Data.Text as T -import qualified Data.Text.IO as T (readFile) -import qualified DataCon as Ty -import Exception (ghandle, SomeException(..)) -import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) -import qualified GHC as G -import Language.Haskell.GhcMod.Convert -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.SrcUtils -import Outputable (PprStyle) -import qualified TyCon as Ty -import qualified Type as Ty - ----------------------------------------------------------------- --- CASE SPLITTING ----------------------------------------------------------------- - -data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan] - | TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind) -data SplitToTextInfo = SplitToTextInfo { sVarName :: String - , sBindingSpan :: SrcSpan - , sVarSpan :: SrcSpan - , sTycons :: [String] - } - --- | Splitting a variable in a equation. -splits :: IOish m - => FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> GhcModT m String -splits file lineNo colNo = ghandle handler body - where - body = inModuleContext file $ \dflag style -> do - opt <- options - modSum <- Gap.fileModSummary file - whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of - (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do - let varName' = showName dflag style varName -- Convert name to string - text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ - getTyCons dflag style varName varT) - return (fourInts bndLoc, text) - (TySplitInfo varName bndLoc (varLoc,varT)) -> do - let varName' = showName dflag style varName -- Convert name to string - text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ - getTyCons dflag style varName varT) - return (fourInts bndLoc, text) - handler (SomeException _) = emptyResult =<< options - ----------------------------------------------------------------- --- a. Code for getting the information of the variable - -getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) -getSrcSpanTypeForSplit modSum lineNo colNo = do - fn <- getSrcSpanTypeForFnSplit modSum lineNo colNo - if isJust fn - then return fn - else getSrcSpanTypeForTypeSplit modSum lineNo colNo - --- Information for a function case split -getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) -getSrcSpanTypeForFnSplit modSum lineNo colNo = do - p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum - tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id) - match:_ = listifySpans tcs (lineNo, colNo) :: [Gap.GLMatchI] - case varPat of - Nothing -> return Nothing - Just varPat' -> do - varT <- Gap.getType tcm varPat' -- Finally we get the type of the var - case varT of - Just varT' -> - let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match - in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) ) - _ -> return Nothing - -isPatternVar :: LPat Id -> Bool -isPatternVar (L _ (G.VarPat _)) = True -isPatternVar _ = False - -getPatternVarName :: LPat Id -> G.Name -getPatternVarName (L _ (G.VarPat vName)) = G.getName vName -getPatternVarName _ = error "This should never happened" - --- TODO: Information for a type family case split -getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) -getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing - ----------------------------------------------------------------- --- b. Code for getting the possible constructors - -getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type -> [String] -getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty = - let name' = showName dflag style name -- Convert name to string - in getTyCon dflag style name' tyCon -getTyCons dflag style name _ = [showName dflag style name] - --- Write cases for one type -getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String] --- 1. Non-matcheable type constructors -getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name] --- 2. Special cases --- 2.1. Tuples -getTyCon _ _ name tyCon | Ty.isTupleTyCon tyCon = - let [uniqueDataCon] = Ty.tyConDataCons tyCon - tupleArity = Ty.dataConSourceArity uniqueDataCon - -- Deal with both boxed and unboxed tuples - isUnboxed = Ty.isUnboxedTupleTyCon tyCon - startSign = if isUnboxed then "(#" else "(" - endSign = if isUnboxed then "#)" else ")" - in [ startSign ++ intercalate "," (map (\n -> name ++ show n) [1 .. tupleArity]) ++ endSign ] --- 3. General case -getTyCon dflag style name tyCon = map (getDataCon dflag style name) (Ty.tyConDataCons tyCon) - --- These type constructors should not be matched against -isNotMatcheableTyCon :: Ty.TyCon -> Bool -isNotMatcheableTyCon ty = Ty.isPrimTyCon ty -- Primitive types, such as Int# - || Ty.isFunTyCon ty -- Function types - --- Write case for one constructor -getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String --- 1. Infix constructors -getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon = - let dName = showName dflag style $ Ty.dataConName dcon - in case Ty.dataConSourceArity dcon of - 0 -> dName - 1 -> vName ++ dName - n -> if dName == ":" -- Special case for lists - then vName ++ ":" ++ vName ++ "s" - else newVar vName 1 ++ " " ++ dName ++ " " ++ newVars vName 2 (n-1) --- 2. Non-record, non-infix syntax -getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon = - let dName = showName dflag style $ Ty.dataConName dcon - in if last dName == '#' -- Special case for I#, C# and so on - then vName - else case Ty.dataConSourceArity dcon of - 0 -> dName - _ -> dName ++ " " ++ newVarsSpecialSingleton vName 1 (Ty.dataConSourceArity dcon) --- 3. Records -getDataCon dflag style vName dcon = - let dName = showName dflag style $ Ty.dataConName dcon - flds = Ty.dataConFieldLabels dcon - in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }" - --- Create a new variable by adjoining a number -newVar :: String -> Int -> String -newVar v n = v ++ show n - --- Create a list of variables which start with the same prefix -newVars :: String -> Int -> Int -> String -newVars _ _ 0 = "" -newVars v s 1 = newVar v s -newVars v s m = newVar v s ++ " " ++ newVars v (s+1) (m-1) - --- Create a list of variables which start with the same prefix --- Special case for a single variable, in which case no number is adjoint -newVarsSpecialSingleton :: String -> Int -> Int -> String -newVarsSpecialSingleton v _ 1 = v -newVarsSpecialSingleton v start n = newVars v start n - -showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String -showFieldNames _ _ _ [] = "" -- This should never happen -showFieldNames dflag style v (x:xs) = let fName = showName dflag style x - fAcc = fName ++ " = " ++ v ++ "_" ++ fName - in case xs of - [] -> fAcc - _ -> fAcc ++ ", " ++ showFieldNames dflag style v xs - ----------------------------------------------------------------- --- c. Code for performing the case splitting - -genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String -genCaseSplitTextFile file info = liftIO $ do - text <- T.readFile file - return $ getCaseSplitText (T.lines text) info - -getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String -getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS - , sVarSpan = sVS, sTycons = sT }) = - let bindingText = getBindingText text sBS - difference = srcSpanDifference sBS sVS - replaced = concatMap (replaceVarWithTyCon bindingText difference sVN) sT - in T.unpack $ T.intercalate (T.pack "\n") replaced - -getBindingText :: [T.Text] -> SrcSpan -> [T.Text] -getBindingText text srcSpan = - let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan - lines_ = drop (sl - 1) $ take el text - in if sl == el - then -- only one line - [T.drop (sc - 1) $ T.take ec $ head lines_] - else -- several lines - let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_) - in T.drop (sc - 1) first : rest ++ [T.take ec last_] - -srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int) -srcSpanDifference b v = - let Just (bsl,bsc,_ ,_) = Gap.getSrcSpan b - Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v - in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line - -replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text] -replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon = - let tycon' = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon - lengthDiff = length tycon' - length varname - tycon'' = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon' - spacesToAdd = if lengthDiff < 0 then 0 else lengthDiff - in zipWith (\n line -> if n < vsl - then line -- before variable starts - else if n == vsl - then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line - else T.replicate spacesToAdd (T.pack " ") `T.append` line) - [0 ..] text diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Language.Haskell.GhcMod.Check ( - checkSyntax - , check - , expandTemplate - , expand - ) where - -import Control.Applicative ((<$>)) -import Language.Haskell.GhcMod.DynFlags -import qualified Language.Haskell.GhcMod.Gap as Gap -import qualified GHC as G -import Language.Haskell.GhcMod.Logger -import Language.Haskell.GhcMod.Monad (IOish, GhcModT, overrideGhcUserOptions) -import Language.Haskell.GhcMod.Target (setTargetFiles) - ----------------------------------------------------------------- - --- | Checking syntax of a target file using GHC. --- Warnings and errors are returned. -checkSyntax :: IOish m - => [FilePath] -- ^ The target files. - -> GhcModT m String -checkSyntax [] = return "" -checkSyntax files = either id id <$> check files - ----------------------------------------------------------------- - --- | Checking syntax of a target file using GHC. --- Warnings and errors are returned. -check :: IOish m - => [FilePath] -- ^ The target files. - -> GhcModT m (Either String String) -check fileNames = overrideGhcUserOptions $ \ghcOpts -> do - withLogger (setAllWarningFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do - _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags - setTargetFiles fileNames - ----------------------------------------------------------------- - --- | Expanding Haskell Template. -expandTemplate :: IOish m - => [FilePath] -- ^ The target files. - -> GhcModT m String -expandTemplate [] = return "" -expandTemplate files = either id id <$> expand files - ----------------------------------------------------------------- - --- | Expanding Haskell Template. -expand :: IOish m - => [FilePath] -- ^ The target files. - -> GhcModT m (Either String String) -expand fileNames = withLogger (Gap.setDumpSplices . setNoWarningFlags) $ - setTargetFiles fileNames diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-} - -module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where - -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Types - -import Control.Applicative ((<$>)) - -type Builder = String -> String - --- | --- --- >>> replace '"' "\\\"" "foo\"bar" "" --- "foo\\\"bar" -replace :: Char -> String -> String -> Builder -replace _ _ [] = id -replace c cs (x:xs) - | x == c = (cs ++) . replace c cs xs - | otherwise = (x :) . replace c cs xs - -inter :: Char -> [Builder] -> Builder -inter _ [] = id -inter c bs = foldr1 (\x y -> x . (c:) . y) bs - -convert' :: (ToString a, IOish m) => a -> GhcModT m String -convert' x = flip convert x <$> options - -convert :: ToString a => Options -> a -> String -convert opt@Options { outputStyle = LispStyle } x = toLisp opt x "\n" -convert opt@Options { outputStyle = PlainStyle } x - | str == "\n" = "" - | otherwise = str - where - str = toPlain opt x "\n" - -class ToString a where - toLisp :: Options -> a -> Builder - toPlain :: Options -> a -> Builder - -lineSep :: Options -> String -lineSep opt = interpret lsep - where - interpret s = read $ "\"" ++ s ++ "\"" - LineSeparator lsep = lineSeparator opt - --- | --- --- >>> toLisp defaultOptions "fo\"o" "" --- "\"fo\\\"o\"" --- >>> toPlain defaultOptions "foo" "" --- "foo" -instance ToString String where - toLisp opt = quote opt - toPlain opt = replace '\n' (lineSep opt) - --- | --- --- >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] "" --- "(\"foo\" \"bar\" \"ba\\\"z\")" --- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" --- "foo\nbar\nbaz" -instance ToString [String] where - toLisp opt = toSexp1 opt - toPlain opt = inter '\n' . map (toPlain opt) - --- | --- --- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] --- >>> toLisp defaultOptions inp "" --- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))" --- >>> toPlain defaultOptions inp "" --- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" -instance ToString [((Int,Int,Int,Int),String)] where - toLisp opt = toSexp2 . map toS - where - toS x = ('(' :) . tupToString opt x . (')' :) - toPlain opt = inter '\n' . map (tupToString opt) - -instance ToString ((Int,Int,Int,Int),String) where - toLisp opt x = ('(' :) . tupToString opt x . (')' :) - toPlain opt x = tupToString opt x - -instance ToString ((Int,Int,Int,Int),[String]) where - toLisp opt (x,s) = ('(' :) . fourIntsToString opt x . - (' ' :) . toLisp opt s . (')' :) - toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s - -instance ToString (String, (Int,Int,Int,Int),[String]) where - toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y] - toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y] - -toSexp1 :: Options -> [String] -> Builder -toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) - -toSexp2 :: [Builder] -> Builder -toSexp2 ss = ('(' :) . inter ' ' ss . (')' :) - -fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder -fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :) - . (show b ++) . (' ' :) - . (show c ++) . (' ' :) - . (show d ++) - -tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder -tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :) - . (show b ++) . (' ' :) - . (show c ++) . (' ' :) - . (show d ++) . (' ' :) - . quote opt s -- fixme: quote is not necessary - -quote :: Options -> String -> Builder -quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++) - where - lsep = lineSep opt - quote' [] = [] - quote' (x:xs) - | x == '\n' = lsep ++ quote' xs - | x == '\\' = "\\\\" ++ quote' xs - | x == '"' = "\\\"" ++ quote' xs - | otherwise = x : quote' xs - ----------------------------------------------------------------- - --- Empty result to be returned when no info can be gathered -emptyResult :: Monad m => Options -> m String -emptyResult opt = return $ convert opt ([] :: [String]) - --- Return an emptyResult when Nothing -whenFound :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> b) -> m String -whenFound opt from f = maybe (emptyResult opt) (return . convert opt . f) =<< from - --- Return an emptyResult when Nothing, inside a monad -whenFound' :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> m b) -> m String -whenFound' opt from f = maybe (emptyResult opt) (\x -> do y <- f x ; return (convert opt y)) =<< from diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ /dev/null @@ -1,109 +0,0 @@ -module Language.Haskell.GhcMod.Cradle ( - findCradle - , findCradle' - , findCradleWithoutSandbox - ) where - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.GhcPkg - -import Control.Applicative ((<$>)) -import qualified Control.Exception as E -import Control.Exception.IOChoice ((||>)) -import Control.Monad (filterM) -import Data.List (isSuffixOf) -import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist) -import System.FilePath ((), takeDirectory) - ----------------------------------------------------------------- - --- | Finding 'Cradle'. --- Find a cabal file by tracing ancestor directories. --- Find a sandbox according to a cabal sandbox config --- in a cabal directory. -findCradle :: IO Cradle -findCradle = findCradle' =<< getCurrentDirectory - -findCradle' :: FilePath -> IO Cradle -findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir - -cabalCradle :: FilePath -> IO Cradle -cabalCradle wdir = do - (rdir,cfile) <- cabalDir wdir - pkgDbStack <- getPackageDbStack rdir - return Cradle { - cradleCurrentDir = wdir - , cradleRootDir = rdir - , cradleCabalFile = Just cfile - , cradlePkgDbStack = pkgDbStack - } - -sandboxCradle :: FilePath -> IO Cradle -sandboxCradle wdir = do - rdir <- getSandboxDir wdir - pkgDbStack <- getPackageDbStack rdir - return Cradle { - cradleCurrentDir = wdir - , cradleRootDir = rdir - , cradleCabalFile = Nothing - , cradlePkgDbStack = pkgDbStack - } - -plainCradle :: FilePath -> IO Cradle -plainCradle wdir = return Cradle { - cradleCurrentDir = wdir - , cradleRootDir = wdir - , cradleCabalFile = Nothing - , cradlePkgDbStack = [GlobalDb, UserDb] - } - --- Just for testing -findCradleWithoutSandbox :: IO Cradle -findCradleWithoutSandbox = do - cradle <- findCradle - return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME - ----------------------------------------------------------------- - -cabalSuffix :: String -cabalSuffix = ".cabal" - -cabalSuffixLength :: Int -cabalSuffixLength = length cabalSuffix - --- Finding a Cabal file up to the root directory --- Input: a directly to investigate --- Output: (the path to the directory containing a Cabal file --- ,the path to the Cabal file) -cabalDir :: FilePath -> IO (FilePath,FilePath) -cabalDir dir = do - cnts <- getCabalFiles dir - case cnts of - [] | dir' == dir -> E.throwIO $ userError "cabal files not found" - | otherwise -> cabalDir dir' - cfile:_ -> return (dir,dir cfile) - where - dir' = takeDirectory dir - -getCabalFiles :: FilePath -> IO [FilePath] -getCabalFiles dir = getFiles >>= filterM doesCabalFileExist - where - isCabal name = cabalSuffix `isSuffixOf` name - && length name > cabalSuffixLength - getFiles = filter isCabal <$> getDirectoryContents dir - doesCabalFileExist file = doesFileExist $ dir file - ----------------------------------------------------------------- - -getSandboxDir :: FilePath -> IO FilePath -getSandboxDir dir = do - exist <- doesFileExist sfile - if exist then - return dir - else if dir == dir' then - E.throwIO $ userError "sandbox not found" - else - getSandboxDir dir' - where - sfile = dir "cabal.sandbox.config" - dir' = takeDirectory dir diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where - -import Control.Applicative ((<$>)) -import Data.List (intercalate) -import Data.Maybe (isJust, fromJust) -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Internal - ----------------------------------------------------------------- - --- | Obtaining debug information. -debugInfo :: IOish m => GhcModT m String -debugInfo = cradle >>= \c -> convert' =<< do - CompilerOptions gopts incDir pkgs <- - if isJust $ cradleCabalFile c then - fromCabalFile c ||> simpleCompilerOption - else - simpleCompilerOption - return [ - "Root directory: " ++ cradleRootDir c - , "Current directory: " ++ cradleCurrentDir c - , "Cabal file: " ++ show (cradleCabalFile c) - , "GHC options: " ++ unwords gopts - , "Include directories: " ++ unwords incDir - , "Dependent packages: " ++ intercalate ", " (map showPkg pkgs) - , "System libraries: " ++ ghcLibDir - ] - where - simpleCompilerOption = options >>= \op -> - return $ CompilerOptions (ghcUserOptions op) [] [] - fromCabalFile c = options >>= \opts -> do - pkgDesc <- parseCabalFile c $ fromJust $ cradleCabalFile c - getCompilerOptions (ghcUserOptions opts) c pkgDesc - ----------------------------------------------------------------- - --- | Obtaining root information. -rootInfo :: IOish m => GhcModT m String -rootInfo = convert' =<< cradleRootDir <$> cradle diff --git a/Language/Haskell/GhcMod/Doc.hs b/Language/Haskell/GhcMod/Doc.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Doc.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Language.Haskell.GhcMod.Doc where - -import GHC (DynFlags, GhcMonad) -import qualified GHC as G -import Language.Haskell.GhcMod.Gap (withStyle, showDocWith) -import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify) -import Pretty (Mode(..)) - -showPage :: DynFlags -> PprStyle -> SDoc -> String -showPage dflag style = showDocWith dflag PageMode . withStyle dflag style - -showOneLine :: DynFlags -> PprStyle -> SDoc -> String -showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style - -getStyle :: GhcMonad m => m PprStyle -getStyle = do - unqual <- G.getPrintUnqual - return $ mkUserStyle unqual AllTheWay - -styleUnqualified :: PprStyle -styleUnqualified = mkUserStyle neverQualify AllTheWay diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/DynFlags.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Language.Haskell.GhcMod.DynFlags where - -import Control.Applicative ((<$>)) -import Control.Monad (void) -import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..)) -import qualified GHC as G -import GHC.Paths (libdir) -import GhcMonad -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Types -import System.IO.Unsafe (unsafePerformIO) - -data Build = CabalPkg | SingleFile deriving Eq - -setEmptyLogger :: DynFlags -> DynFlags -setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return () - --- * Fast --- * Friendly to foreign export --- * Not friendly to -XTemplateHaskell and -XPatternSynonyms --- * Uses little memory -setModeSimple :: DynFlags -> DynFlags -setModeSimple df = df { - ghcMode = CompManager - , ghcLink = NoLink - , hscTarget = HscNothing - , optLevel = 0 - } - --- * Slow --- * Not friendly to foreign export --- * Friendly to -XTemplateHaskell and -XPatternSynonyms --- * Uses lots of memory -setModeIntelligent :: DynFlags -> DynFlags -setModeIntelligent df = df { - ghcMode = CompManager - , ghcLink = LinkInMemory - , hscTarget = HscInterpreted - , optLevel = 0 - } - -setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags -setIncludeDirs idirs df = df { importPaths = idirs } - -setBuildEnv :: Build -> DynFlags -> DynFlags -setBuildEnv build = setHideAllPackages build . setCabalPackage build - --- | With ghc-7.8 this option simply makes GHC print a message suggesting users --- add hiddend packages to the build-depends field in their cabal file when the --- user tries to import a module form a hidden package. -setCabalPackage :: Build -> DynFlags -> DynFlags -setCabalPackage CabalPkg df = Gap.setCabalPkg df -setCabalPackage _ df = df - --- | Enable hiding of all package not explicitly exposed (like Cabal does) -setHideAllPackages :: Build -> DynFlags -> DynFlags -setHideAllPackages CabalPkg df = Gap.setHideAllPackages df -setHideAllPackages _ df = df - --- | Parse command line ghc options and add them to the 'DynFlags' passed -addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags -addCmdOpts cmdOpts df = - tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts) - where - tfst (a,_,_) = a - ----------------------------------------------------------------- - --- | Return the 'DynFlags' currently in use in the GHC session. -getDynamicFlags :: IO DynFlags -getDynamicFlags = G.runGhc (Just libdir) G.getSessionDynFlags - -withDynFlags :: GhcMonad m - => (DynFlags -> DynFlags) - -> m a - -> m a -withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body) - where - setup = do - dflags <- G.getSessionDynFlags - void $ G.setSessionDynFlags (setFlags dflags) - return dflags - teardown = void . G.setSessionDynFlags - -withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a -withCmdFlags flags body = G.gbracket setup teardown (\_ -> body) - where - setup = do - dflags <- G.getSessionDynFlags - void $ G.setSessionDynFlags =<< addCmdOpts flags dflags - return dflags - teardown = void . G.setSessionDynFlags - ----------------------------------------------------------------- - --- | Set 'DynFlags' equivalent to "-w:". -setNoWarningFlags :: DynFlags -> DynFlags -setNoWarningFlags df = df { warningFlags = Gap.emptyWarnFlags} - --- | Set 'DynFlags' equivalent to "-Wall". -setAllWarningFlags :: DynFlags -> DynFlags -setAllWarningFlags df = df { warningFlags = allWarningFlags } - -allWarningFlags :: Gap.WarnFlags -allWarningFlags = unsafePerformIO $ - G.runGhc (Just libdir) $ do - df <- G.getSessionDynFlags - df' <- addCmdOpts ["-Wall"] df - return $ G.warningFlags df' - ----------------------------------------------------------------- - --- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings". -setNoMaxRelevantBindings :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing } -#else -setNoMaxRelevantBindings = id -#endif diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} -module Language.Haskell.GhcMod.Error ( - GhcModError(..) - , modifyError - , modifyError' - , tryFix - , module Control.Monad.Error - , module Exception - ) where - -import Control.Monad.Error (MonadError(..), Error(..)) -import Exception - -data GhcModError = GMENoMsg - -- ^ Unknown error - | GMEString String - -- ^ Some Error with a message. These are produced mostly by - -- 'fail' calls on GhcModT. - | GMECabalConfigure GhcModError - -- ^ Configuring a cabal project failed. - | GMECabalFlags GhcModError - -- ^ Retrieval of the cabal configuration flags failed. - | GMEProcess [String] GhcModError - -- ^ Launching an operating system process failed. The first - -- field is the command. - deriving (Eq,Show) - -instance Error GhcModError where - noMsg = GMENoMsg - strMsg = GMEString - -modifyError :: MonadError e m => (e -> e) -> m a -> m a -modifyError f action = action `catchError` \e -> throwError $ f e - -infixr 0 `modifyError'` -modifyError' :: MonadError e m => m a -> (e -> e) -> m a -modifyError' = flip modifyError - -tryFix :: MonadError e m => m a -> (e -> m ()) -> m a -tryFix action fix = do - action `catchError` \e -> fix e >> action diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ /dev/null @@ -1,484 +0,0 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} - -module Language.Haskell.GhcMod.FillSig ( - sig - , refine - , auto - ) where - -import Data.Char (isSymbol) -import Data.Function (on) -import Data.List (find, nub, sortBy) -import qualified Data.Map as M -import Data.Maybe (isJust, catMaybes) -import Exception (ghandle, SomeException(..)) -import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, - SrcSpan, Type, GenLocated(L)) -import qualified GHC as G -import qualified Name as G -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.SrcUtils -import Language.Haskell.GhcMod.Types -import Outputable (PprStyle) -import qualified Type as Ty -import qualified HsBinds as Ty -import qualified Class as Ty -import qualified Var as Ty -import qualified HsPat as Ty -import qualified Language.Haskell.Exts.Annotated as HE -import Djinn.GHC - ----------------------------------------------------------------- --- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE ----------------------------------------------------------------- - --- Possible signatures we can find: function or instance -data SigInfo - = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName) - | InstanceDecl SrcSpan G.Class - | TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName] - --- Signature for fallback operation via haskell-src-exts -data HESigInfo - = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo) - | HEFamSignature - HE.SrcSpan - TyFamType - (HE.Name HE.SrcSpanInfo) - [HE.Name HE.SrcSpanInfo] - -data TyFamType = Closed | Open | Data -initialTyFamString :: TyFamType -> (String, String) -initialTyFamString Closed = ("instance", "") -initialTyFamString Open = ("function", "type instance ") -initialTyFamString Data = ("function", "data instance ") - --- | Create a initial body from a signature. -sig :: IOish m - => FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> GhcModT m String -sig file lineNo colNo = ghandle handler body - where - body = inModuleContext file $ \dflag style -> do - opt <- options - modSum <- Gap.fileModSummary file - whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of - Signature loc names ty -> - ("function", fourInts loc, map (initialBody dflag style ty) names) - InstanceDecl loc cls -> - ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x) - (Ty.classMethods cls)) - TyFamDecl loc name flavour vars -> - let (rTy, initial) = initialTyFamString flavour - in (rTy, fourInts loc, [initial ++ initialFamBody dflag style name vars]) - - handler (SomeException _) = do - opt <- options - -- Code cannot be parsed by ghc module - -- Fallback: try to get information via haskell-src-exts - whenFound opt (getSignatureFromHE file lineNo colNo) $ \x -> case x of - HESignature loc names ty -> - ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names) - HEFamSignature loc flavour name vars -> - let (rTy, initial) = initialTyFamString flavour - in (rTy, fourIntsHE loc, [initial ++ initialFamBody undefined undefined name vars]) - ----------------------------------------------------------------- --- a. Code for getting the information - --- Get signature from ghc parsing and typechecking -getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo) -getSignature modSum lineNo colNo = do - p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum - -- Inspect the parse tree to find the signature - case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of - [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] -> - -- We found a type signature - return $ Just $ Signature loc (map G.unLoc names) ty - [L _ (G.InstD _)] -> do - -- We found an instance declaration - TypecheckedModule{tm_renamed_source = Just tcs - ,tm_checked_module_info = minfo} <- G.typecheckModule p - let lst = listifyRenamedSpans tcs (lineNo, colNo) - case Gap.getClass lst of - Just (clsName,loc) -> obtainClassInfo minfo clsName loc - _ -> return Nothing -#if __GLASGOW_HASKELL__ >= 708 - [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do -#elif __GLASGOW_HASKELL__ >= 706 - [L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do -#else - [L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do -#endif -#if __GLASGOW_HASKELL__ >= 708 - let flavour = case info of - G.ClosedTypeFamily _ -> Closed - G.OpenTypeFamily -> Open - G.DataFamily -> Data -#else - let flavour = case info of -- Closed type families where introduced in GHC 7.8 - G.TypeFamily -> Open - G.DataFamily -> Data -#endif -#if __GLASGOW_HASKELL__ >= 706 - getTyFamVarName x = case x of - L _ (G.UserTyVar n) -> n - L _ (G.KindedTyVar n _) -> n -#else - getTyFamVarName x = case x of -- In GHC 7.4, HsTyVarBndr's have an extra arg - L _ (G.UserTyVar n _) -> n - L _ (G.KindedTyVar n _ _) -> n -#endif - in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars) - _ -> return Nothing - where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo) - obtainClassInfo minfo clsName loc = do - tyThing <- G.modInfoLookupName minfo clsName - return $ do Ty.ATyCon clsCon <- tyThing -- In Maybe - cls <- G.tyConClass_maybe clsCon - return $ InstanceDecl loc cls - --- Get signature from haskell-src-exts -getSignatureFromHE :: GhcMonad m => FilePath -> Int -> Int -> m (Maybe HESigInfo) -getSignatureFromHE file lineNo colNo = do - presult <- liftIO $ HE.parseFile file - return $ case presult of - HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do - decl <- find (typeSigInRangeHE lineNo colNo) mdecls - case decl of - HE.TypeSig (HE.SrcSpanInfo s _) names ty -> - return $ HESignature s names ty - - HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ -> - let (name, tys) = dHeadTyVars declHead in - return $ HEFamSignature s Open name (map cleanTyVarBind tys) - - HE.DataFamDecl (HE.SrcSpanInfo s _) _ declHead _ -> - let (name, tys) = dHeadTyVars declHead in - return $ HEFamSignature s Open name (map cleanTyVarBind tys) - _ -> fail "" - _ -> Nothing - where cleanTyVarBind (HE.KindedVar _ n _) = n - cleanTyVarBind (HE.UnkindedVar _ n) = n - -#if MIN_VERSION_haskell_src_exts(1,16,0) - dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l]) - dHeadTyVars (HE.DHead _ name) = (name, []) - dHeadTyVars (HE.DHApp _ r ty) = (++[ty]) `fmap` (dHeadTyVars r) - dHeadTyVars (HE.DHInfix _ ty name) = (name, [ty]) - dHeadTyVars (HE.DHParen _ r) = dHeadTyVars r -#else - dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l]) - dHeadTyVars (HE.DHead _ n tys) = (n, tys) -#endif - ----------------------------------------------------------------- --- b. Code for generating initial code - --- A list of function arguments, and whether they are functions or normal --- arguments is built from either a function signature or an instance signature -data FnArg = FnArgFunction | FnArgNormal | FnExplicitName String - -initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String -initialBody dflag style ty name = - initialBody' (getFnName dflag style name) (getFnArgs ty) - -initialBody' :: String -> [FnArg] -> String -initialBody' fname args = - initialHead fname args ++ " = " ++ n ++ "_body" - where n = if isSymbolName fname then "" else '_':fname - -initialFamBody :: FnArgsInfo ty name - => DynFlags -> PprStyle -> name -> [name] -> String -initialFamBody dflag style name args = - initialHead fnName fnArgs ++ " = ()" - where fnName = getFnName dflag style name - fnArgs = map (FnExplicitName . getFnName dflag style) args - -initialHead :: String -> [FnArg] -> String -initialHead fname args = - case initialBodyArgs args infiniteVars infiniteFns of - [] -> fname - arglist -> if isSymbolName fname - then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) - else fname ++ " " ++ unwords arglist - -initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String] -initialBodyArgs [] _ _ = [] -initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs -initialBodyArgs (FnArgNormal:xs) (v:vs) fs = v : initialBodyArgs xs vs fs -initialBodyArgs (FnExplicitName n:xs) vs fs = n : initialBodyArgs xs vs fs -initialBodyArgs _ _ _ = - error "initialBodyArgs: This should never happen" -- Lists are infinite - -initialHead1 :: String -> [FnArg] -> [String] -> String -initialHead1 fname args elts = - case initialBodyArgs1 args elts of - [] -> fname - arglist -> if isSymbolName fname - then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) - else fname ++ " " ++ unwords arglist - -initialBodyArgs1 :: [FnArg] -> [String] -> [String] -initialBodyArgs1 args elts = take (length args) elts - --- Getting the initial body of function and instances differ --- This is because for functions we only use the parsed file --- (so the full file doesn't have to be type correct) --- but for instances we need to get information about the class - -class FnArgsInfo ty name | ty -> name, name -> ty where - getFnName :: DynFlags -> PprStyle -> name -> String - getFnArgs :: ty -> [FnArg] - -instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where - getFnName dflag style name = showOccName dflag style $ Gap.occName name - getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) = getFnArgs iTy - getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy - getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = - (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy - where fnarg ty = case ty of - (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy - (G.HsParTy (L _ iTy)) -> fnarg iTy - (G.HsFunTy _ _) -> True - _ -> False - getFnArgs _ = [] - -instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where - getFnName _ _ (HE.Ident _ s) = s - getFnName _ _ (HE.Symbol _ s) = s - getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy - getFnArgs (HE.TyParen _ iTy) = getFnArgs iTy - getFnArgs (HE.TyFun _ lTy rTy) = - (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy - where fnarg ty = case ty of - (HE.TyForall _ _ _ iTy) -> fnarg iTy - (HE.TyParen _ iTy) -> fnarg iTy - (HE.TyFun _ _ _) -> True - _ -> False - getFnArgs _ = [] - -instance FnArgsInfo Type Id where - getFnName dflag style method = showOccName dflag style $ G.getOccName method - getFnArgs = getFnArgs' . Ty.dropForAlls - where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty = - maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy) - (\_ -> FnArgFunction:getFnArgs' rTy) - $ Ty.splitFunTy_maybe lTy - - getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty = - getFnArgs' iTy - - getFnArgs' _ = [] - --- Infinite supply of variable and function variable names -infiniteVars, infiniteFns :: [String] -infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"] -infiniteFns = infiniteSupply ["f","g","h"] -infiniteSupply :: [String] -> [String] -infiniteSupply initialSupply = - initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply) - ([1 .. ] :: [Integer]) - --- Check whether a String is a symbol name -isSymbolName :: String -> Bool -isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c -isSymbolName [] = error "This should never happen" - - ----------------------------------------------------------------- --- REWRITE A HOLE / UNDEFINED VIA A FUNCTION ----------------------------------------------------------------- - -refine :: IOish m - => FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> Expression -- ^ A Haskell expression. - -> GhcModT m String -refine file lineNo colNo expr = ghandle handler body - where - body = inModuleContext file $ \dflag style -> do - opt <- options - modSum <- Gap.fileModSummary file - p <- G.parseModule modSum - tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - ety <- G.exprType expr - whenFound opt (findVar dflag style tcm tcs lineNo colNo) $ - \(loc, name, rty, paren) -> - let eArgs = getFnArgs ety - rArgs = getFnArgs rty - diffArgs' = length eArgs - length rArgs - diffArgs = if diffArgs' < 0 then 0 else diffArgs' - iArgs = take diffArgs eArgs - text = initialHead1 expr iArgs (infinitePrefixSupply name) - in (fourInts loc, doParen paren text) - - handler (SomeException _) = emptyResult =<< options - --- Look for the variable in the specified position -findVar :: GhcMonad m => DynFlags -> PprStyle - -> G.TypecheckedModule -> G.TypecheckedSource - -> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool)) -findVar dflag style tcm tcs lineNo colNo = - let lst = sortBy (cmp `on` G.getLoc) $ - listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id] - in case lst of - e@(L _ (G.HsVar i)):others -> - do tyInfo <- Gap.getType tcm e - let name = getFnName dflag style i - if (name == "undefined" || head name == '_') && isJust tyInfo - then let Just (s,t) = tyInfo - b = case others of -- If inside an App, we need - -- parenthesis - [] -> False - L _ (G.HsApp (L _ a1) (L _ a2)):_ -> - isSearchedVar i a1 || isSearchedVar i a2 - _ -> False - in return $ Just (s, name, t, b) - else return Nothing - _ -> return Nothing - -infinitePrefixSupply :: String -> [String] -infinitePrefixSupply "undefined" = repeat "undefined" -infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer]) - -doParen :: Bool -> String -> String -doParen False s = s -doParen True s = if ' ' `elem` s then '(':s ++ ")" else s - -isSearchedVar :: Id -> G.HsExpr Id -> Bool -isSearchedVar i (G.HsVar i2) = i == i2 -isSearchedVar _ _ = False - - ----------------------------------------------------------------- --- REFINE AUTOMATICALLY ----------------------------------------------------------------- - -auto :: IOish m - => FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> GhcModT m String -auto file lineNo colNo = ghandle handler body - where - body = inModuleContext file $ \dflag style -> do - opt <- options - modSum <- Gap.fileModSummary file - p <- G.parseModule modSum - tcm@TypecheckedModule { - tm_typechecked_source = tcs - , tm_checked_module_info = minfo - } <- G.typecheckModule p - whenFound' opt (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do - topLevel <- getEverythingInTopLevel minfo - let (f,pats) = getPatsForVariable tcs (lineNo,colNo) - -- Remove self function to prevent recursion, and id to trim - -- cases - filterFn (n,_) = let funName = G.getOccString n - recName = G.getOccString (G.getName f) - in funName `notElem` recName:notWantedFuns - -- Find without using other functions in top-level - localBnds = M.unions $ - map (\(L _ pat) -> getBindingsForPat pat) pats - lbn = filter filterFn (M.toList localBnds) - djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000 - let -- Find with the entire top-level - almostEnv = M.toList $ M.union localBnds topLevel - env = filter filterFn almostEnv - djinns <- djinn True (Just minfo) env rty (Max 10) 100000 - return ( fourInts loc - , map (doParen paren) $ nub (djinnsEmpty ++ djinns)) - - handler (SomeException _) = emptyResult =<< options - --- Functions we do not want in completions -notWantedFuns :: [String] -notWantedFuns = ["id", "asTypeOf", "const"] - --- Get all things defined in top-level -getEverythingInTopLevel :: GhcMonad m => G.ModuleInfo -> m (M.Map G.Name Type) -getEverythingInTopLevel m = do - let modInfo = tyThingsToInfo (G.modInfoTyThings m) - topNames = G.modInfoTopLevelScope m - case topNames of - Just topNames' -> do topThings <- mapM G.lookupGlobalName topNames' - let topThings' = catMaybes topThings - topInfo = tyThingsToInfo topThings' - return $ M.union modInfo topInfo - Nothing -> return modInfo - -tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type -tyThingsToInfo [] = M.empty -tyThingsToInfo (G.AnId i : xs) = - M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs) --- Getting information about constructors is not needed --- because they will be added by djinn-ghc when traversing types --- #if __GLASGOW_HASKELL__ >= 708 --- tyThingToInfo (G.AConLike (G.RealDataCon con)) = return [(Ty.dataConName con, Ty.dataConUserType con)] --- #else --- tyThingToInfo (G.AConLike con) = return [(Ty.dataConName con, Ty.dataConUserType con)] --- #endif -tyThingsToInfo (_:xs) = tyThingsToInfo xs - --- Find the Id of the function and the pattern where the hole is located -getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id]) -getPatsForVariable tcs (lineNo, colNo) = - let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $ - listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id] - in case bnd of - G.PatBind { Ty.pat_lhs = L ploc pat } -> case pat of - Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat]) - _ -> (error "This should never happen", []) - G.FunBind { Ty.fun_id = L _ funId } -> - let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) -#if __GLASGOW_HASKELL__ >= 708 - :: [G.LMatch Id (G.LHsExpr Id)] -#else - :: [G.LMatch Id] -#endif - (L _ (G.Match pats _ _):_) = m - in (funId, pats) - _ -> (error "This should never happen", []) - -getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type -getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i) -getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l -getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b -getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) = - M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i) -#if __GLASGOW_HASKELL__ >= 708 -getBindingsForPat (Ty.ListPat l _ _) = - M.unions $ map (\(L _ i) -> getBindingsForPat i) l -#else -getBindingsForPat (Ty.ListPat l _) = - M.unions $ map (\(L _ i) -> getBindingsForPat i) l -#endif -getBindingsForPat (Ty.TuplePat l _ _) = - M.unions $ map (\(L _ i) -> getBindingsForPat i) l -getBindingsForPat (Ty.PArrPat l _) = - M.unions $ map (\(L _ i) -> getBindingsForPat i) l -getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i -getBindingsForPat (Ty.SigPatIn (L _ i) _) = getBindingsForPat i -getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i -getBindingsForPat (Ty.ConPatIn (L _ i) d) = - M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d) -getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d -getBindingsForPat _ = M.empty - -getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type -getBindingsForRecPat (Ty.PrefixCon args) = - M.unions $ map (\(L _ i) -> getBindingsForPat i) args -getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) = - M.union (getBindingsForPat a1) (getBindingsForPat a2) -getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = - getBindingsForRecFields fields - where getBindingsForRecFields [] = M.empty - getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) = - M.union (getBindingsForPat a) (getBindingsForRecFields fs) diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Language.Haskell.GhcMod.Find -#ifndef SPEC - ( - Symbol - , SymbolDb - , loadSymbolDb - , lookupSymbol - , dumpSymbol - , findSymbol - , lookupSym - ) -#endif - where - -import Config (cProjectVersion,cTargetPlatformString) -import Control.Applicative ((<$>)) -import Control.Monad (when, void) -import Control.Monad.Error.Class -import Data.Function (on) -import Data.List (groupBy, sort) -import Data.List.Split (splitOn) -import Data.Maybe (fromMaybe) -import DynFlags (DynFlags(..), systemPackageConfig) -import Exception (handleIO) -import qualified GHC as G -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.Types -import Name (getOccString) -import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime) -import System.FilePath ((), takeDirectory) -import System.IO -import System.Environment - -#ifndef MIN_VERSION_containers -#define MIN_VERSION_containers(x,y,z) 1 -#endif - -#if MIN_VERSION_containers(0,5,0) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -#else -import Data.Map (Map) -import qualified Data.Map as M -#endif - ----------------------------------------------------------------- - --- | Type of function and operation names. -type Symbol = String --- | Database from 'Symbol' to \['ModuleString'\]. -newtype SymbolDb = SymbolDb (Map Symbol [ModuleString]) - deriving (Show) - ----------------------------------------------------------------- - --- | When introducing incompatible changes to the 'symbolCache' file format --- increment this version number. -symbolCacheVersion :: Integer -symbolCacheVersion = 0 - --- | Filename of the symbol table cache file. -symbolCache :: String -symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache" - -packageCache :: String -packageCache = "package.cache" - -packageConfDir :: String -packageConfDir = "package.conf.d" - ----------------------------------------------------------------- - --- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] --- which will be concatenated. 'loadSymbolDb' is called internally. -findSymbol :: IOish m => Symbol -> GhcModT m String -findSymbol sym = loadSymbolDb >>= lookupSymbol sym - --- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] --- which will be concatenated. -lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String -lookupSymbol sym db = convert' $ lookupSym sym db - -lookupSym :: Symbol -> SymbolDb -> [ModuleString] -lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db - ---------------------------------------------------------------- - --- | Loading a file and creates 'SymbolDb'. -loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb -loadSymbolDb = SymbolDb <$> readSymbolDb - --- | Returns the path to the currently running ghc-mod executable. With ghc<7.6 --- this is a guess but >=7.6 uses 'getExecutablePath'. -ghcModExecutable :: IO FilePath -#ifndef SPEC -ghcModExecutable = do - dir <- getExecutablePath' - return $ dir "ghc-mod" -#else -ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when - -- compiling spec - return "dist/build/ghc-mod/ghc-mod" -#endif - where - getExecutablePath' :: IO FilePath -# if __GLASGOW_HASKELL__ >= 706 - getExecutablePath' = takeDirectory <$> getExecutablePath -# else - getExecutablePath' = return "" -# endif - -readSymbolDb :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString]) -readSymbolDb = do - ghcMod <- liftIO ghcModExecutable - file <- chop <$> readProcess' ghcMod ["dumpsym"] - M.fromAscList . map conv . lines <$> liftIO (readFile file) - where - conv :: String -> (Symbol,[ModuleString]) - conv = read - chop "" = "" - chop xs = init xs - ----------------------------------------------------------------- --- used 'ghc-mod dumpsym' - -getSymbolCachePath :: IOish m => GhcModT m FilePath -getSymbolCachePath = do - u:_ <- filter (/= GlobalDb) . cradlePkgDbStack <$> cradle - Just db <- (liftIO . flip resolvePackageDb u) =<< G.getSessionDynFlags - return db - `catchError` const (fail "Couldn't find non-global package database for symbol cache") - --- | Dumping a set of ('Symbol',\['ModuleString'\]) to a file --- if the file does not exist or is invalid. --- The file name is printed. - -dumpSymbol :: IOish m => GhcModT m String -dumpSymbol = do - dir <- getSymbolCachePath - let cache = dir symbolCache - pkgdb = dir packageCache - - create <- liftIO $ cache `isNewerThan` pkgdb - when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable - return $ unlines [cache] - -writeSymbolCache :: FilePath - -> [(Symbol,[ModuleString])] - -> IO () -writeSymbolCache cache sm = - void . withFile cache WriteMode $ \hdl -> - mapM (hPrint hdl) sm - -isNewerThan :: FilePath -> FilePath -> IO Bool -isNewerThan ref file = do - exist <- doesFileExist ref - if not exist then - return True - else do - tRef <- getModificationTime ref - tFile <- getModificationTime file - return $ tRef <= tFile -- including equal just in case - --- | Browsing all functions in all system/user modules. -getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])] -getSymbolTable = do - ghcModules <- G.packageDbModules True - moduleInfos <- mapM G.getModuleInfo ghcModules - let modules = do - m <- ghcModules - let moduleName = G.moduleNameString $ G.moduleName m --- modulePkg = G.packageIdString $ G.modulePackageId m - return moduleName - - return $ collectModules - $ extractBindings `concatMap` (moduleInfos `zip` modules) - -extractBindings :: (Maybe G.ModuleInfo, ModuleString) - -> [(Symbol, ModuleString)] -extractBindings (Nothing,_) = [] -extractBindings (Just inf,mdlname) = - map (\name -> (getOccString name, mdlname)) names - where - names = G.modInfoExports inf - -collectModules :: [(Symbol,ModuleString)] - -> [(Symbol,[ModuleString])] -collectModules = map tieup . groupBy ((==) `on` fst) . sort - where - tieup x = (head (map fst x), map snd x) - ---- Copied from ghc module `Packages' unfortunately it's not exported :/ -resolvePackageDb :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath) -resolvePackageDb df GlobalDb = return $ Just (systemPackageConfig df) -resolvePackageDb _ (PackageDb name) = return $ Just name -resolvePackageDb _ UserDb = handleIO (\_ -> return Nothing) $ do - appdir <- getAppUserDataDirectory "ghc" - let dir = appdir (target_arch ++ '-':target_os ++ '-':cProjectVersion) - pkgconf = dir packageConfDir - exist <- doesDirectoryExist pkgconf - return $ if exist then Just pkgconf else Nothing - where - [target_arch,_,target_os] = splitOn "-" cTargetPlatformString diff --git a/Language/Haskell/GhcMod/Flag.hs b/Language/Haskell/GhcMod/Flag.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Flag.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Language.Haskell.GhcMod.Flag where - -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Monad - --- | Listing GHC flags. (e.g -fno-warn-orphans) - -flags :: IOish m => GhcModT m String -flags = convert' [ "-f" ++ prefix ++ option - | option <- Gap.fOptions - , prefix <- ["","no-"] - ] diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.GhcMod.GHCApi ( - ghcPkgDb - , package - , modules - , findModule - , moduleInfo - , localModuleInfo - , bindings - ) where - -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.Monad (GhcModT) -import Language.Haskell.GhcMod.Target (setTargetFiles) -import Language.Haskell.GhcMod.Types - -import Control.Applicative ((<$>)) -import Distribution.Package (InstalledPackageId(..)) -import qualified Data.Map as M -import GHC (DynFlags(..)) -import qualified GHC as G -import GhcMonad -import qualified Packages as G -import qualified Module as G -import qualified OccName as G - ----------------------------------------------------------------- --- get Packages,Modules,Bindings - -ghcPkgDb :: GhcMonad m => m PkgDb -ghcPkgDb = M.fromList <$> - maybe [] (map toKv . filterInternal) <$> pkgDatabase <$> G.getSessionDynFlags - where - toKv pkg = (fromInstalledPackageId $ G.installedPackageId pkg, pkg) - filterInternal = - filter ((/= InstalledPackageId "builtin_rts") . G.installedPackageId) - -package :: G.PackageConfig -> Package -package = fromInstalledPackageId . G.installedPackageId - -modules :: G.PackageConfig -> [ModuleString] -modules = map G.moduleNameString . G.exposedModules - -findModule :: ModuleString -> PkgDb -> [Package] -findModule m db = M.elems $ package `M.map` (containsModule `M.filter` db) - where - containsModule :: G.PackageConfig -> Bool - containsModule pkgConf = - G.mkModuleName m `elem` G.exposedModules pkgConf - - -ghcPkgId :: Package -> G.PackageId -ghcPkgId (name,_,_) = - -- TODO: Adding the package version too breaks 'findModule' for some reason - -- this isn't a big deal since in the common case where we're in a cabal - -- project we just use cabal's view of package dependencies anyways so we're - -- guaranteed to only have one version of each package exposed. However when - -- we're operating without a cabal project this will probaly cause trouble. - G.stringToPackageId name - -type Binding = String - --- | @moduleInfo mpkg module@. @mpkg@ should be 'Nothing' iff. moduleInfo --- should look for @module@ in the working directory. --- --- To map a 'ModuleString' to a package see 'findModule' -moduleInfo :: IOish m - => Maybe Package - -> ModuleString - -> GhcModT m (Maybe G.ModuleInfo) -moduleInfo mpkg mdl = do - let mdlName = G.mkModuleName mdl - mfsPkgId = G.packageIdFS . ghcPkgId <$> mpkg - loadLocalModule - G.findModule mdlName mfsPkgId >>= G.getModuleInfo - where - loadLocalModule = case mpkg of - Just _ -> return () - Nothing -> setTargetFiles [mdl] - -localModuleInfo :: IOish m => ModuleString -> GhcModT m (Maybe G.ModuleInfo) -localModuleInfo mdl = moduleInfo Nothing mdl - -bindings :: G.ModuleInfo -> [Binding] -bindings minfo = map (G.occNameString . G.getOccName) $ G.modInfoExports minfo diff --git a/Language/Haskell/GhcMod/GHCChoice.hs b/Language/Haskell/GhcMod/GHCChoice.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/GHCChoice.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.GhcMod.GHCChoice where - -import Control.Exception (IOException) -import CoreMonad (liftIO) -import qualified Exception as GE -import GHC (GhcMonad) - ----------------------------------------------------------------- - --- | Try the left 'Ghc' action. If 'IOException' occurs, try --- the right 'Ghc' action. -(||>) :: GhcMonad m => m a -> m a -> m a -x ||> y = x `GE.gcatch` (\(_ :: IOException) -> y) - --- | Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'. -goNext :: GhcMonad m => m a -goNext = liftIO . GE.throwIO $ userError "goNext" - --- | Run any one 'Ghc' monad. -runAnyOne :: GhcMonad m => [m a] -> m a -runAnyOne = foldr (||>) goNext diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ /dev/null @@ -1,475 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-} - -module Language.Haskell.GhcMod.Gap ( - Language.Haskell.GhcMod.Gap.ClsInst - , mkTarget - , withStyle - , setLogAction - , getSrcSpan - , getSrcFile - , withContext - , fOptions - , toStringBuffer - , showSeverityCaption - , setCabalPkg - , setHideAllPackages - , addPackageFlags - , setDeferTypeErrors - , setWarnTypedHoles - , setDumpSplices - , isDumpSplices - , filterOutChildren - , infoThing - , pprInfo - , HasType(..) - , errorMsgSpan - , typeForUser - , nameForUser - , occNameForUser - , deSugar - , showDocWith - , GapThing(..) - , fromTyThing - , fileModSummary - , WarnFlags - , emptyWarnFlags - , benchmarkBuildInfo - , benchmarkTargets - , toModuleString - , GLMatch - , GLMatchI - , getClass - , occName - , setFlags - ) where - -import Control.Applicative hiding (empty) -import Control.Monad (filterM) -import CoreSyn (CoreExpr) -import Data.List (intersperse) -import Data.Maybe (catMaybes) -import Data.Time.Clock (UTCTime) -import DataCon (dataConRepType) -import Desugar (deSugarExpr) -import DynFlags -import ErrUtils -import FastString -import GhcMonad -import HscTypes -import Language.Haskell.GhcMod.GHCChoice -import Language.Haskell.GhcMod.Types -import NameSet -import OccName -import Outputable -import PprTyThing -import StringBuffer -import TcType -import Var (varType) - -import qualified Distribution.PackageDescription as P -import qualified InstEnv -import qualified Pretty -import qualified StringBuffer as SB - -#if __GLASGOW_HASKELL__ >= 708 -import FamInstEnv -import ConLike (ConLike(..)) -import PatSyn (patSynType) -#else -import TcRnTypes -#endif - -#if __GLASGOW_HASKELL__ >= 706 -import GHC hiding (ClsInst) -#else -import GHC hiding (Instance) -import Control.Arrow hiding ((<+>)) -import Data.Convertible -import RdrName (rdrNameOcc) -#endif - -#if __GLASGOW_HASKELL__ >= 704 -import qualified Data.IntSet as I (IntSet, empty) -import qualified Distribution.ModuleName as M (ModuleName,toFilePath) -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- --- -#if __GLASGOW_HASKELL__ >= 706 -type ClsInst = InstEnv.ClsInst -#else -type ClsInst = InstEnv.Instance -#endif - -mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target -#if __GLASGOW_HASKELL__ >= 706 -mkTarget = Target -#else -mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc -#if __GLASGOW_HASKELL__ >= 706 -withStyle = withPprStyleDoc -#else -withStyle _ = withPprStyleDoc -#endif - -setLogAction :: DynFlags - -> (DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()) - -> DynFlags -setLogAction df f = -#if __GLASGOW_HASKELL__ >= 706 - df { log_action = f } -#else - df { log_action = f df } -#endif - -showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String -#if __GLASGOW_HASKELL__ >= 708 --- Pretty.showDocWith disappeard. --- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc -showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags) -#else -showDocWith _ = Pretty.showDocWith -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) -#if __GLASGOW_HASKELL__ >= 702 -getSrcSpan (RealSrcSpan spn) -#else -getSrcSpan spn | isGoodSrcSpan spn -#endif - = Just (srcSpanStartLine spn - , srcSpanStartCol spn - , srcSpanEndLine spn - , srcSpanEndCol spn) -getSrcSpan _ = Nothing - -getSrcFile :: SrcSpan -> Maybe String -#if __GLASGOW_HASKELL__ >= 702 -getSrcFile (RealSrcSpan spn) = Just . unpackFS . srcSpanFile $ spn -#else -getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn -#endif -getSrcFile _ = Nothing - ----------------------------------------------------------------- - -toStringBuffer :: GhcMonad m => [String] -> m StringBuffer -#if __GLASGOW_HASKELL__ >= 702 -toStringBuffer = return . stringToStringBuffer . unlines -#else -toStringBuffer = liftIO . stringToStringBuffer . unlines -#endif - ----------------------------------------------------------------- - -fOptions :: [String] -#if __GLASGOW_HASKELL__ >= 704 -fOptions = [option | (option,_,_) <- fFlags] - ++ [option | (option,_,_) <- fWarningFlags] - ++ [option | (option,_,_) <- fLangFlags] -#else -fOptions = [option | (option,_,_,_) <- fFlags] - ++ [option | (option,_,_,_) <- fWarningFlags] - ++ [option | (option,_,_,_) <- fLangFlags] -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -fileModSummary :: GhcMonad m => FilePath -> m ModSummary -fileModSummary file = do - mss <- getModuleGraph - let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss - return ms - -withContext :: GhcMonad m => m a -> m a -withContext action = gbracket setup teardown body - where - setup = getContext - teardown = setCtx - body _ = do - topImports >>= setCtx - action - topImports = do - mss <- getModuleGraph - ms <- map modName <$> filterM isTop mss -#if __GLASGOW_HASKELL__ >= 704 - return ms -#else - return (ms,[]) -#endif - isTop mos = lookupMod mos ||> returnFalse - lookupMod mos = lookupModule (ms_mod_name mos) Nothing >> return True - returnFalse = return False -#if __GLASGOW_HASKELL__ >= 706 - modName = IIModule . moduleName . ms_mod - setCtx = setContext -#elif __GLASGOW_HASKELL__ >= 704 - modName = IIModule . ms_mod - setCtx = setContext -#else - modName = ms_mod - setCtx = uncurry setContext -#endif - -showSeverityCaption :: Severity -> String -#if __GLASGOW_HASKELL__ >= 706 -showSeverityCaption SevWarning = "Warning: " -showSeverityCaption _ = "" -#else -showSeverityCaption = const "" -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -setCabalPkg :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage -#else -setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage -#endif - ----------------------------------------------------------------- - -setHideAllPackages :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setHideAllPackages df = gopt_set df Opt_HideAllPackages -#else -setHideAllPackages df = dopt_set df Opt_HideAllPackages -#endif - -addPackageFlags :: [Package] -> DynFlags -> DynFlags -addPackageFlags pkgs df = - df { packageFlags = packageFlags df ++ expose `map` pkgs } - where - expose pkg = ExposePackageId $ showPkgId pkg - ----------------------------------------------------------------- - -setDumpSplices :: DynFlags -> DynFlags -setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices - -isDumpSplices :: DynFlags -> Bool -isDumpSplices dflag = dopt Opt_D_dump_splices dflag - ----------------------------------------------------------------- - - -setDeferTypeErrors :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors -#elif __GLASGOW_HASKELL__ >= 706 -setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors -#else -setDeferTypeErrors = id -#endif - -setWarnTypedHoles :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles -#else -setWarnTypedHoles = id -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -class HasType a where - getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type)) - - -instance HasType (LHsBind Id) where -#if __GLASGOW_HASKELL__ >= 708 - getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ) - where in_tys = mg_arg_tys m - out_typ = mg_res_ty m - typ = mkFunTys in_tys out_typ -#else - getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ) -#endif - getType _ _ = return Nothing - ----------------------------------------------------------------- ----------------------------------------------------------------- --- from ghc/InteractiveUI.hs - -filterOutChildren :: (a -> TyThing) -> [a] -> [a] -filterOutChildren get_thing xs - = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] - where - implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] - -infoThing :: GhcMonad m => String -> m SDoc -infoThing str = do - names <- parseName str -#if __GLASGOW_HASKELL__ >= 708 - mb_stuffs <- mapM (getInfo False) names - let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs) -#else - mb_stuffs <- mapM getInfo names - let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) -#endif - return $ vcat (intersperse (text "") $ map (pprInfo False) filtered) - -#if __GLASGOW_HASKELL__ >= 708 -pprInfo :: Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc -pprInfo _ (thing, fixity, insts, famInsts) - = pprTyThingInContextLoc thing - $$ show_fixity fixity - $$ InstEnv.pprInstances insts - $$ pprFamInsts famInsts - where - show_fixity fx - | fx == defaultFixity = Outputable.empty - | otherwise = ppr fx <+> ppr (getName thing) -#else -pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc -pprInfo pefas (thing, fixity, insts) - = pprTyThingInContextLoc pefas thing - $$ show_fixity fixity - $$ vcat (map pprInstance insts) - where - show_fixity fx - | fx == defaultFixity = Outputable.empty - | otherwise = ppr fx <+> ppr (getName thing) -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -errorMsgSpan :: ErrMsg -> SrcSpan -#if __GLASGOW_HASKELL__ >= 708 -errorMsgSpan = errMsgSpan -#else -errorMsgSpan = head . errMsgSpans -#endif - -typeForUser :: Type -> SDoc -#if __GLASGOW_HASKELL__ >= 708 -typeForUser = pprTypeForUser -#else -typeForUser = pprTypeForUser False -#endif - -nameForUser :: Name -> SDoc -nameForUser = pprOccName . getOccName - -occNameForUser :: OccName -> SDoc -occNameForUser = pprOccName - -deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv - -> IO (Maybe CoreExpr) -#if __GLASGOW_HASKELL__ >= 708 -deSugar _ e hs_env = snd <$> deSugarExpr hs_env e -#else -deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e - where - modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm - tcgEnv = fst $ tm_internals_ tcm - rn_env = tcg_rdr_env tcgEnv - ty_env = tcg_type_env tcgEnv -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -data GapThing = GtA Type | GtT TyCon | GtN - -fromTyThing :: TyThing -> GapThing -fromTyThing (AnId i) = GtA $ varType i -#if __GLASGOW_HASKELL__ >= 708 -fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConRepType d -fromTyThing (AConLike (PatSynCon p)) = GtA $ patSynType p -#else -fromTyThing (ADataCon d) = GtA $ dataConRepType d -#endif -fromTyThing (ATyCon t) = GtT t -fromTyThing _ = GtN - ----------------------------------------------------------------- ----------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 704 -type WarnFlags = I.IntSet -emptyWarnFlags :: WarnFlags -emptyWarnFlags = I.empty -#else -type WarnFlags = [WarningFlag] -emptyWarnFlags :: WarnFlags -emptyWarnFlags = [] -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -benchmarkBuildInfo :: P.PackageDescription -> [P.BuildInfo] -#if __GLASGOW_HASKELL__ >= 704 -benchmarkBuildInfo pd = map P.benchmarkBuildInfo $ P.benchmarks pd -#else -benchmarkBuildInfo pd = [] -#endif - -benchmarkTargets :: P.PackageDescription -> [String] -#if __GLASGOW_HASKELL__ >= 704 -benchmarkTargets pd = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd -#else -benchmarkTargets = [] -#endif - -toModuleString :: M.ModuleName -> String -toModuleString mn = fromFilePath $ M.toFilePath mn - where - fromFilePath :: FilePath -> String - fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp - ----------------------------------------------------------------- ----------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 708 -type GLMatch = LMatch RdrName (LHsExpr RdrName) -type GLMatchI = LMatch Id (LHsExpr Id) -#else -type GLMatch = LMatch RdrName -type GLMatchI = LMatch Id -#endif - -getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) -#if __GLASGOW_HASKELL__ >= 708 --- Instance declarations of sort 'instance F (G a)' -getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc) --- Instance declarations of sort 'instance F G' (no variables) -getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc) -#elif __GLASGOW_HASKELL__ >= 706 -getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc) -getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc) -#else -getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc) -getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc) -#endif -getClass _ = Nothing - -#if __GLASGOW_HASKELL__ < 706 -occName :: RdrName -> OccName -occName = rdrNameOcc -#endif - ----------------------------------------------------------------- ----------------------------------------------------------------- - -setFlags :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setFlags df = df `gopt_unset` Opt_SpecConstr -- consume memory if -O2 -#else -setFlags = id -#endif diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-} -module Language.Haskell.GhcMod.GhcPkg ( - ghcPkgDbOpt - , ghcPkgDbStackOpts - , ghcDbStackOpts - , ghcDbOpt - , fromInstalledPackageId - , fromInstalledPackageId' - , getSandboxDb - , getPackageDbStack - ) where - -import Config (cProjectVersionInt) -import Control.Applicative ((<$>)) -import Control.Exception (SomeException(..)) -import qualified Control.Exception as E -import Data.Char (isSpace) -import Data.List (isPrefixOf, intercalate) -import Data.List.Split (splitOn) -import Distribution.Package (InstalledPackageId(..)) -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils -import System.FilePath (()) - -ghcVersion :: Int -ghcVersion = read cProjectVersionInt - --- | Get path to sandbox package db -getSandboxDb :: FilePath -- ^ Path to the cabal package root directory - -- (containing the @cabal.sandbox.config@ file) - -> IO FilePath -getSandboxDb cdir = getSandboxDbDir (cdir "cabal.sandbox.config") - --- | Extract the sandbox package db directory from the cabal.sandbox.config file. --- Exception is thrown if the sandbox config file is broken. -getSandboxDbDir :: FilePath -- ^ Path to the @cabal.sandbox.config@ file - -> IO FilePath -getSandboxDbDir sconf = do - -- Be strict to ensure that an error can be caught. - !path <- extractValue . parse <$> readFile sconf - return path - where - key = "package-db:" - keyLen = length key - - parse = head . filter (key `isPrefixOf`) . lines - extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen - -getPackageDbStack :: FilePath -- ^ Project Directory (where the - -- cabal.sandbox.config file would be if it - -- exists) - -> IO [GhcPkgDb] -getPackageDbStack cdir = - (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db]) - `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb] - -fromInstalledPackageId' :: InstalledPackageId -> Maybe Package -fromInstalledPackageId' pid = let - InstalledPackageId pkg = pid - in case reverse $ splitOn "-" pkg of - i:v:rest -> Just (intercalate "-" (reverse rest), v, i) - _ -> Nothing - -fromInstalledPackageId :: InstalledPackageId -> Package -fromInstalledPackageId pid = - case fromInstalledPackageId' pid of - Just p -> p - Nothing -> error $ - "fromInstalledPackageId: `"++show pid++"' is not a valid package-id" - --- | Get options needed to add a list of package dbs to ghc-pkg's db stack -ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack - -> [String] -ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs - --- | Get options needed to add a list of package dbs to ghc's db stack -ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack - -> [String] -ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs - -ghcPkgDbOpt :: GhcPkgDb -> [String] -ghcPkgDbOpt GlobalDb = ["--global"] -ghcPkgDbOpt UserDb = ["--user"] -ghcPkgDbOpt (PackageDb pkgDb) - | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb] - | otherwise = ["--no-user-package-db", "--package-db=" ++ pkgDb] - -ghcDbOpt :: GhcPkgDb -> [String] -ghcDbOpt GlobalDb - | ghcVersion < 706 = ["-global-package-conf"] - | otherwise = ["-global-package-db"] -ghcDbOpt UserDb - | ghcVersion < 706 = ["-user-package-conf"] - | otherwise = ["-user-package-db"] -ghcDbOpt (PackageDb pkgDb) - | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb] - | otherwise = ["-no-user-package-db", "-package-db", pkgDb] diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ /dev/null @@ -1,65 +0,0 @@ -module Language.Haskell.GhcMod.Info ( - info - , types - ) where - -import Control.Applicative ((<$>)) -import Data.Function (on) -import Data.List (sortBy) -import Data.Maybe (catMaybes) -import Exception (ghandle, SomeException(..)) -import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) -import qualified GHC as G -import Language.Haskell.GhcMod.Doc (showPage) -import Language.Haskell.GhcMod.Gap (HasType(..)) -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.SrcUtils -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Convert - ----------------------------------------------------------------- - --- | Obtaining information of a target expression. (GHCi's info:) -info :: IOish m - => FilePath -- ^ A target file. - -> Expression -- ^ A Haskell expression. - -> GhcModT m String -info file expr = do - opt <- options - convert opt <$> ghandle handler body - where - body = inModuleContext file $ \dflag style -> do - sdoc <- Gap.infoThing expr - return $ showPage dflag style sdoc - handler (SomeException _) = return "Cannot show info" - ----------------------------------------------------------------- - --- | Obtaining type of a target expression. (GHCi's type:) -types :: IOish m - => FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> GhcModT m String -types file lineNo colNo = do - opt <- options - convert opt <$> ghandle handler body - where - body = inModuleContext file $ \dflag style -> do - modSum <- Gap.fileModSummary file - srcSpanTypes <- getSrcSpanType modSum lineNo colNo - return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes - handler (SomeException _) = return [] - -getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] -getSrcSpanType modSum lineNo colNo = do - p <- G.parseModule modSum - tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p - let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] - es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id] - ps = listifySpans tcs (lineNo, colNo) :: [LPat Id] - bts <- mapM (getType tcm) bs - ets <- mapM (getType tcm) es - pts <- mapM (getType tcm) ps - return $ catMaybes $ concat [ets, bts, pts] diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ /dev/null @@ -1,63 +0,0 @@ --- | Low level access to the ghc-mod library. - -module Language.Haskell.GhcMod.Internal ( - -- * Types - GHCOption - , Package - , PackageBaseName - , PackageVersion - , PackageId - , IncludeDir - , CompilerOptions(..) - -- * Cabal API - , parseCabalFile - , getCompilerOptions - , cabalAllBuildInfo - , cabalDependPackages - , cabalSourceDirs - , cabalAllTargets - -- * GHC.Paths - , ghcLibDir - -- * IO - , getDynamicFlags - -- * Targets - , setTargetFiles - -- * Logging - , withLogger - , setNoWarningFlags - , setAllWarningFlags - -- * Environment, state and logging - , GhcModEnv(..) - , newGhcModEnv - , GhcModState - , defaultState - , CompilerMode(..) - , GhcModLog - -- * Monad utilities - , runGhcModT' - , hoistGhcModT - -- ** Accessing 'GhcModEnv' and 'GhcModState' - , options - , cradle - , getCompilerMode - , setCompilerMode - , withOptions - -- * 'GhcMonad' Choice - , (||>) - , goNext - , runAnyOne - ) where - -import GHC.Paths (libdir) - -import Language.Haskell.GhcMod.CabalApi -import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.GHCChoice -import Language.Haskell.GhcMod.Logger -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Target -import Language.Haskell.GhcMod.Types - --- | Obtaining the directory for ghc system libraries. -ghcLibDir :: FilePath -ghcLibDir = libdir diff --git a/Language/Haskell/GhcMod/Lang.hs b/Language/Haskell/GhcMod/Lang.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Lang.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Language.Haskell.GhcMod.Lang where - -import DynFlags (supportedLanguagesAndExtensions) -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Monad - --- | Listing language extensions. - -languages :: IOish m => GhcModT m String -languages = convert' supportedLanguagesAndExtensions diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Lint.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Language.Haskell.GhcMod.Lint where - -import Exception (ghandle) -import Control.Exception (SomeException(..)) -import Language.Haskell.GhcMod.Logger (checkErrorPrefix) -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Types -import Language.Haskell.HLint (hlint) - --- | Checking syntax of a target file using hlint. --- Warnings and errors are returned. -lint :: IOish m - => FilePath -- ^ A target file. - -> GhcModT m String -lint file = do - opt <- options - ghandle handler . pack =<< liftIO (hlint $ file : "--quiet" : hlintOpts opt) - where - pack = convert' . map (init . show) -- init drops the last \n. - handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n" diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ /dev/null @@ -1,232 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Language.Haskell.GhcMod.Logger ( - withLogger - , withLoggerTwice - , checkErrorPrefix - ) where - -import Bag (Bag, bagToList, emptyBag, consBag, filterBag, unionBags) -import Control.Applicative ((<$>)) -import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) -import Data.List (isPrefixOf, find, nub, isInfixOf) -import Data.Maybe (fromMaybe, isJust) -import ErrUtils (ErrMsg, WarnMsg, errMsgShortDoc, errMsgExtraInfo, mkWarnMsg) -import Exception (ghandle) -import GHC (DynFlags, SrcSpan, Severity(SevError)) -import qualified GHC as G -import HscTypes (SourceError, srcErrorMessages) -import Language.Haskell.GhcMod.Doc (showPage, getStyle) -import Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags) -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Convert (convert') -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Types -import Outputable (PprStyle, SDoc, qualName, qualModule, mkErrStyle, neverQualify) -import System.FilePath (normalise) - ----------------------------------------------------------------- - -type Builder = [String] -> [String] - -data Log = Log [String] Builder - -newtype LogRef = LogRef (IORef Log) - -emptyLog :: Log -emptyLog = Log [] id - -newLogRef :: IO LogRef -newLogRef = LogRef <$> newIORef emptyLog - -readAndClearLogRef :: IOish m => LogRef -> GhcModT m String -readAndClearLogRef (LogRef ref) = do - Log _ b <- liftIO $ readIORef ref - liftIO $ writeIORef ref emptyLog - convert' (b []) - -appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () -appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update - where - l = ppMsg src sev df style msg - update lg@(Log ls b) - | l `elem` ls = lg - | otherwise = Log (l:ls) (b . (l:)) - ----------------------------------------------------------------- - -data LogBag = LogBag (Bag WarnMsg) -newtype LogBagRef = LogBagRef (IORef LogBag) - -emptyLogBag :: LogBag -emptyLogBag = LogBag emptyBag - -newLogBagRef :: IO LogBagRef -newLogBagRef = LogBagRef <$> newIORef emptyLogBag - -readAndClearLogBagRef :: IOish m => LogBagRef -> GhcModT m (Bag WarnMsg) -readAndClearLogBagRef (LogBagRef ref) = do - LogBag b <- liftIO $ readIORef ref - liftIO $ writeIORef ref emptyLogBag - return b - -appendLogBagRef :: DynFlags -> LogBagRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () -appendLogBagRef df (LogBagRef ref) _ _ src style msg = modifyIORef ref update - where - qstyle = (qualName style, qualModule style) -#if __GLASGOW_HASKELL__ >= 706 - warnMsg = mkWarnMsg df src qstyle msg -#else - warnMsg = mkWarnMsg src qstyle msg -#endif - warnBag = consBag warnMsg emptyBag - update (LogBag b) = let (b1,b2) = mergeErrors df style b warnBag - in LogBag $ b1 `unionBags` b2 - ----------------------------------------------------------------- - --- | Set the session flag (e.g. "-Wall" or "-w:") then --- executes a body. Logged messages are returned as 'String'. --- Right is success and Left is failure. -withLogger :: IOish m - => (DynFlags -> DynFlags) - -> GhcModT m () - -> GhcModT m (Either String String) -withLogger setDF body = ghandle sourceError $ do - logref <- liftIO newLogRef - wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options - withDynFlags (setLogger logref . setDF) $ - withCmdFlags wflags $ do - body - Right <$> readAndClearLogRef logref - where - setLogger logref df = Gap.setLogAction df $ appendLogRef df logref - -withLoggerTwice :: IOish m - => (DynFlags -> DynFlags) - -> GhcModT m () - -> (DynFlags -> DynFlags) - -> GhcModT m () - -> GhcModT m (Either String String) -withLoggerTwice setDF1 body1 setDF2 body2 = do - err1 <- ghandle sourceErrorBag $ do - logref <- liftIO newLogBagRef - wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options - withDynFlags (setLogger logref . setDF1) $ - withCmdFlags wflags $ do - body1 - Right <$> readAndClearLogBagRef logref - err2 <- ghandle sourceErrorBag $ do - logref <- liftIO newLogBagRef - wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options - withDynFlags (setLogger logref . setDF2) $ - withCmdFlags wflags $ do - body2 - Right <$> readAndClearLogBagRef logref - -- Merge errors and warnings - dflags <- G.getSessionDynFlags - style <- getStyle - case (err1, err2) of - (Right b1, Right b2) -> do let (warn1,_) = mergeErrors dflags style b1 b2 - errAndWarnBagToStr Right emptyBag (warn1 `unionBags` b2) - (Left b1, Right b2) -> do let (err,warn) = mergeErrors dflags style b1 b2 - errAndWarnBagToStr Right err warn - (Right b1, Left b2) -> do let (err,warn) = mergeErrors dflags style b2 b1 - errAndWarnBagToStr Right err warn - (Left b1, Left b2) -> do let (err1',err2') = mergeErrors dflags style b1 b2 - errAndWarnBagToStr Right (err1' `unionBags` err2') emptyBag - where - setLogger logref df = Gap.setLogAction df $ appendLogBagRef df logref - ----------------------------------------------------------------- - --- | Converting 'SourceError' to 'String'. -sourceError :: IOish m => SourceError -> GhcModT m (Either String String) -sourceError err = errBagToStr (srcErrorMessages err) - -errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String) -errBagToStr = errBagToStr' Left - -errBagToStr' :: IOish m => (String -> a) -> Bag ErrMsg -> GhcModT m a -errBagToStr' f err = do - dflags <- G.getSessionDynFlags - style <- getStyle - ret <- convert' (errBagToStrList dflags style err) - return $ f ret - -errAndWarnBagToStr :: IOish m => (String -> a) -> Bag ErrMsg -> Bag WarnMsg -> GhcModT m a -errAndWarnBagToStr f err warn = do - dflags <- G.getSessionDynFlags - -- style <- toGhcModT getStyle -#if __GLASGOW_HASKELL__ >= 706 - let style = mkErrStyle dflags neverQualify -#else - let style = mkErrStyle neverQualify -#endif - ret <- convert' $ nub (errBagToStrList dflags style err ++ warnBagToStrList dflags style warn) - return $ f ret - -errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] -errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList - -warnBagToStrList :: DynFlags -> PprStyle -> Bag WarnMsg -> [String] -warnBagToStrList dflag style = map (ppWarnMsg dflag style) . reverse . bagToList - -sourceErrorBag :: IOish m => SourceError -> GhcModT m (Either (Bag ErrMsg) (Bag WarnMsg)) -sourceErrorBag err = return $ Left (srcErrorMessages err) - -mergeErrors :: DynFlags -> PprStyle -> Bag ErrMsg -> Bag ErrMsg -> (Bag ErrMsg, Bag ErrMsg) -mergeErrors dflag style b1 b2 = - let b1Msgs = map (\err1 -> let m = ppWarnMsg dflag style err1 in (m, head $ lines m)) - (bagToList b1) - mustBeB2 = \err2 -> let msg2 = ppWarnMsg dflag style err2 - line2 = head $ lines msg2 - in not . isJust $ find (\(msg1, line1) -> msg1 == msg2 || (line1 == line2 && isHoleMsg line1)) b1Msgs - in (b1, filterBag mustBeB2 b2) - -isHoleMsg :: String -> Bool -isHoleMsg = isInfixOf "Found hole" - ----------------------------------------------------------------- - -ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String -ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ (if null ext then "" else "\n" ++ ext) - where - spn = Gap.errorMsgSpan err - msg = errMsgShortDoc err - ext = showPage dflag style (errMsgExtraInfo err) - -ppWarnMsg :: DynFlags -> PprStyle -> ErrMsg -> String -ppWarnMsg dflag style err = ppMsg spn G.SevWarning dflag style msg ++ (if null ext then "" else "\n" ++ ext) - where - spn = Gap.errorMsgSpan err - msg = errMsgShortDoc err - ext = showPage dflag style (errMsgExtraInfo err) - -ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String -ppMsg spn sev dflag style msg = prefix ++ cts - where - cts = showPage dflag style msg - prefix = ppMsgPrefix spn sev dflag style cts - -ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String -ppMsgPrefix spn sev dflag _style cts = - let defaultPrefix - | Gap.isDumpSplices dflag = "" - | otherwise = checkErrorPrefix - in fromMaybe defaultPrefix $ do - (line,col,_,_) <- Gap.getSrcSpan spn - file <- normalise <$> Gap.getSrcFile spn - let severityCaption = Gap.showSeverityCaption sev - pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes) - = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" - | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption - return pref0 - -checkErrorPrefix :: String -checkErrorPrefix = "Dummy:0:0:Error:" - -warningAsErrorPrefixes :: [String] -warningAsErrorPrefixes = ["Couldn't match expected type" - , "Couldn't match type" - , "No instance for"] diff --git a/Language/Haskell/GhcMod/Modules.hs b/Language/Haskell/GhcMod/Modules.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Modules.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Language.Haskell.GhcMod.Modules (modules) where - -import Control.Applicative ((<$>)) -import Control.Exception (SomeException(..)) -import Data.List (nub, sort) -import qualified GHC as G -import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Types -import Packages (pkgIdMap, exposedModules, sourcePackageId, display) -import UniqFM (eltsUFM) - ----------------------------------------------------------------- - --- | Listing installed modules. -modules :: IOish m => GhcModT m String -modules = do - opt <- options - convert opt . arrange opt <$> (getModules `G.gcatch` handler) - where - getModules = getExposedModules <$> G.getSessionDynFlags - getExposedModules = concatMap exposedModules' - . eltsUFM . pkgIdMap . G.pkgState - exposedModules' p = - map G.moduleNameString (exposedModules p) - `zip` - repeat (display $ sourcePackageId p) - arrange opt = nub . sort . map (dropPkgs opt) - dropPkgs opt (name, pkg) - | detailed opt = name ++ " " ++ pkg - | otherwise = name - handler (SomeException _) = return [] diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ /dev/null @@ -1,432 +0,0 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} -{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Haskell.GhcMod.Monad ( - -- * Monad Types - GhcModT - , IOish - -- ** Environment, state and logging - , GhcModEnv(..) - , newGhcModEnv - , GhcModState(..) - , defaultState - , CompilerMode(..) - , GhcModLog - , GhcModError(..) - -- * Monad utilities - , runGhcModT - , runGhcModT' - , hoistGhcModT - -- ** Accessing 'GhcModEnv' and 'GhcModState' - , gmsGet - , gmsPut - , options - , cradle - , getCompilerMode - , setCompilerMode - , withOptions - , withTempSession - , overrideGhcUserOptions - -- ** Re-exporting convenient stuff - , liftIO - , module Control.Monad.Reader.Class - , module Control.Monad.Journal.Class - ) where - -#if __GLASGOW_HASKELL__ < 708 --- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different --- classes before ghc 7.8 -#define DIFFERENT_MONADIO 1 - --- RWST doen't have a MonadIO instance before ghc 7.8 -#define MONADIO_INSTANCES 1 -#endif - - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.Cradle -import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.CabalApi -import qualified Language.Haskell.GhcMod.Gap as Gap - -import DynFlags -import GHC -import qualified GHC as G -import GHC.Paths (libdir) -import GhcMonad hiding (withTempSession) -#if __GLASGOW_HASKELL__ <= 702 -import HscTypes -#endif - --- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. --- RWST does not automatically become an instance of MonadIO. --- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. --- So, RWST automatically becomes an instance of MonadIO. -import MonadUtils - -#if DIFFERENT_MONADIO -import Control.Monad.Trans.Class (lift) -import qualified Control.Monad.IO.Class -import Data.Monoid (Monoid) -#endif - -import Control.Applicative (Alternative) -import Control.Arrow (first) -import Control.Monad (MonadPlus, void, liftM) -import Control.Monad.Base (MonadBase, liftBase) - --- Monad transformer stuff -import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, - control, liftBaseOp, liftBaseOp_) - -import Control.Monad.Trans.Class -import Control.Monad.Reader.Class -import Control.Monad.Writer.Class (MonadWriter) -import Control.Monad.State.Class (MonadState(..)) - -import Control.Monad.Error (ErrorT, runErrorT) -import Control.Monad.Reader (ReaderT, runReaderT) -import Control.Monad.State.Strict (StateT, runStateT) -import Control.Monad.Trans.Journal (JournalT, runJournalT) -#ifdef MONADIO_INSTANCES -import Control.Monad.Trans.Maybe (MaybeT) -import Control.Monad.Error (Error(..)) -#endif -import Control.Monad.Journal.Class - -import Data.Maybe (fromJust, isJust) -import Data.IORef (IORef, readIORef, writeIORef, newIORef) -import System.Directory (getCurrentDirectory) -import System.IO.Error (tryIOError) - ----------------------------------------------------------------- - -data GhcModEnv = GhcModEnv { - gmGhcSession :: !(IORef HscEnv) - , gmOptions :: Options - , gmCradle :: Cradle - } - -type GhcModLog = () - -data GhcModState = GhcModState { - gmCompilerMode :: CompilerMode - } deriving (Eq,Show,Read) - -data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read) - -defaultState :: GhcModState -defaultState = GhcModState Simple - ----------------------------------------------------------------- - --- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT' --- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that --- means you can run (almost) all functions from the GHC API on top of 'GhcModT' --- transparently. --- --- The inner monad @m@ should have instances for 'MonadIO' and --- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@ --- monads already have 'MonadBaseControl' 'IO' instances, see the --- @monad-control@ package. -newtype GhcModT m a = GhcModT { - unGhcModT :: StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) a - } deriving ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus -#if DIFFERENT_MONADIO - , Control.Monad.IO.Class.MonadIO -#endif - , MonadReader GhcModEnv -- TODO: make MonadReader instance - -- pass-through like MonadState - , MonadWriter w - , MonadError GhcModError - ) - -instance MonadIO m => MonadIO (GhcModT m) where - liftIO action = do - res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ tryIOError action - case res of - Right a -> return a - Left e -> case show e of - "" -> throwError $ noMsg - msg -> throwError $ strMsg msg - -instance MonadTrans (GhcModT) where - lift = GhcModT . lift . lift . lift . lift - -instance MonadState s m => MonadState s (GhcModT m) where - get = GhcModT $ lift $ lift $ lift get - put = GhcModT . lift . lift . lift . put - state = GhcModT . lift . lift . lift . state - - -#if MONADIO_INSTANCES -instance MonadIO m => MonadIO (StateT s m) where - liftIO = lift . liftIO - -instance MonadIO m => MonadIO (ReaderT r m) where - liftIO = lift . liftIO - -instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where - liftIO = lift . liftIO - -instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where - liftIO = lift . liftIO - -instance MonadIO m => MonadIO (MaybeT m) where - liftIO = lift . liftIO -#endif - ----------------------------------------------------------------- - --- | Initialize the 'DynFlags' relating to the compilation of a single --- file or GHC session according to the 'Cradle' and 'Options' --- provided. -initializeFlagsWithCradle :: (IOish m, GhcMonad m, MonadError GhcModError m) - => Options - -> Cradle - -> m () -initializeFlagsWithCradle opt c - | cabal = withCabal - | otherwise = withSandbox - where - mCradleFile = cradleCabalFile c - cabal = isJust mCradleFile - ghcopts = ghcUserOptions opt - withCabal = do - pkgDesc <- parseCabalFile c $ fromJust mCradleFile - compOpts <- getCompilerOptions ghcopts c pkgDesc - initSession CabalPkg opt compOpts - withSandbox = initSession SingleFile opt compOpts - where - importDirs = [".","..","../..","../../..","../../../..","../../../../.."] - pkgOpts = ghcDbStackOpts $ cradlePkgDbStack c - compOpts - | null pkgOpts = CompilerOptions ghcopts importDirs [] - | otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] [] - wdir = cradleCurrentDir c - rdir = cradleRootDir c - -initSession :: GhcMonad m - => Build - -> Options - -> CompilerOptions - -> m () -initSession build Options {..} CompilerOptions {..} = do - df <- G.getSessionDynFlags - void $ G.setSessionDynFlags =<< addCmdOpts ghcOptions - ( setModeSimple - $ Gap.setFlags - $ setIncludeDirs includeDirs - $ setBuildEnv build - $ setEmptyLogger - $ Gap.addPackageFlags depPackages df) - ----------------------------------------------------------------- - -newGhcModEnv :: Options -> FilePath -> IO GhcModEnv -newGhcModEnv opt dir = do - session <- newIORef (error "empty session") - c <- findCradle' dir - return GhcModEnv { - gmGhcSession = session - , gmOptions = opt - , gmCradle = c - } - --- | Run a @GhcModT m@ computation. -runGhcModT :: IOish m - => Options - -> GhcModT m a - -> m (Either GhcModError a, GhcModLog) -runGhcModT opt action = do - env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory - first (fst <$>) <$> (runGhcModT' env defaultState $ do - dflags <- getSessionDynFlags - defaultCleanupHandler dflags $ do - initializeFlagsWithCradle opt (gmCradle env) - action) - --- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT --- computation. Note that if the computation that returned @result@ modified the --- state part of GhcModT this cannot be restored. -hoistGhcModT :: IOish m - => (Either GhcModError a, GhcModLog) - -> GhcModT m a -hoistGhcModT (r,l) = do - GhcModT (lift $ lift $ journal l) >> case r of - Left e -> throwError e - Right a -> return a - --- | Run a computation inside @GhcModT@ providing the RWST environment and --- initial state. This is a low level function, use it only if you know what to --- do with 'GhcModEnv' and 'GhcModState'. --- --- You should probably look at 'runGhcModT' instead. -runGhcModT' :: IOish m - => GhcModEnv - -> GhcModState - -> GhcModT m a - -> m (Either GhcModError (a, GhcModState), GhcModLog) -runGhcModT' r s a = do - (res, w') <- - flip runReaderT r $ runJournalT $ runErrorT $ - runStateT (unGhcModT $ initGhcMonad (Just libdir) >> a) s - return (res, w') ----------------------------------------------------------------- --- | Make a copy of the 'gmGhcSession' IORef, run the action and restore the --- original 'HscEnv'. -withTempSession :: IOish m => GhcModT m a -> GhcModT m a -withTempSession action = do - session <- gmGhcSession <$> ask - savedHscEnv <- liftIO $ readIORef session - a <- action - liftIO $ writeIORef session savedHscEnv - return a - --- | This is a very ugly workaround don't use it. -overrideGhcUserOptions :: IOish m => ([GHCOption] -> GhcModT m b) -> GhcModT m b -overrideGhcUserOptions action = withTempSession $ do - env <- ask - opt <- options - let ghcOpts = ghcUserOptions opt - opt' = opt { ghcUserOptions = [] } - - initializeFlagsWithCradle opt' (gmCradle env) - - action ghcOpts - ----------------------------------------------------------------- - -gmeAsk :: IOish m => GhcModT m GhcModEnv -gmeAsk = ask - -gmsGet :: IOish m => GhcModT m GhcModState -gmsGet = GhcModT get - -gmsPut :: IOish m => GhcModState -> GhcModT m () -gmsPut = GhcModT . put - -options :: IOish m => GhcModT m Options -options = gmOptions <$> gmeAsk - -cradle :: IOish m => GhcModT m Cradle -cradle = gmCradle <$> gmeAsk - -getCompilerMode :: IOish m => GhcModT m CompilerMode -getCompilerMode = gmCompilerMode <$> gmsGet - -setCompilerMode :: IOish m => CompilerMode -> GhcModT m () -setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet - ----------------------------------------------------------------- - -withOptions :: IOish m => (Options -> Options) -> GhcModT m a -> GhcModT m a -withOptions changeOpt action = local changeEnv action - where - changeEnv e = e { gmOptions = changeOpt opt } - where - opt = gmOptions e - ----------------------------------------------------------------- - -instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where - liftBase = GhcModT . liftBase - -instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where - newtype StM (GhcModT m) a = StGhcMod { - unStGhcMod :: StM (StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) ) a } - liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> - f $ liftM StGhcMod . runInBase . unGhcModT - - restoreM = GhcModT . restoreM . unStGhcMod - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} - --- GHC cannot prove the following instances to be decidable automatically using --- the FlexibleContexts extension as they violate the second Paterson Condition, --- namely that: The assertion has fewer constructors and variables (taken --- together and counting repetitions) than the head. Specifically the --- @MonadBaseControl IO m@ constraint is causing this violation. --- --- Proof of termination: --- --- Assuming all constraints containing the variable `m' exist and are decidable --- we show termination by manually replacing the current set of constraints with --- their own set of constraints and show that this, after a finite number of --- steps, results in the empty set, i.e. not having to check any more --- constraints. --- --- We start by setting the constraints to be those immediate constraints of the --- instance declaration which cannot be proven decidable automatically for the --- type under consideration. --- --- @ --- { MonadBaseControl IO m } --- @ --- --- Classes used: --- --- * @class MonadBase b m => MonadBaseControl b m@ --- --- @ --- { MonadBase IO m } --- @ --- --- Classes used: --- --- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@ --- --- @ --- { Applicative IO, Applicative m, Monad IO, Monad m } --- @ --- --- Classes used: --- --- * @class Monad m@ --- * @class Applicative f => Functor f@ --- --- @ --- { Functor m } --- @ --- --- Classes used: --- --- * @class Functor f@ --- --- @ --- { } --- @ --- ∎ - -instance (Functor m, MonadIO m, MonadBaseControl IO m) - => GhcMonad (GhcModT m) where - getSession = (liftIO . readIORef) . gmGhcSession =<< ask - setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask - -#if __GLASGOW_HASKELL__ >= 706 -instance (Functor m, MonadIO m, MonadBaseControl IO m) - => HasDynFlags (GhcModT m) where - getDynFlags = getSessionDynFlags -#endif - -instance (MonadIO m, MonadBaseControl IO m) - => ExceptionMonad (GhcModT m) where - gcatch act handler = control $ \run -> - run act `gcatch` (run . handler) - - gmask = liftBaseOp gmask . liftRestore - where liftRestore f r = f $ liftBaseOp_ r diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Language.Haskell.GhcMod.PkgDoc (pkgDoc) where - -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.GhcPkg -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Utils - -import Control.Applicative ((<$>)) - --- | Obtaining the package name and the doc path of a module. -pkgDoc :: IOish m => String -> GhcModT m String -pkgDoc mdl = do - c <- cradle - pkg <- trim <$> readProcess' "ghc-pkg" (toModuleOpts c) - if pkg == "" then - return "\n" - else do - htmlpath <- readProcess' "ghc-pkg" (toDocDirOpts pkg c) - let ret = pkg ++ " " ++ drop 14 htmlpath - return ret - where - toModuleOpts c = ["find-module", mdl, "--simple-output"] - ++ ghcPkgDbStackOpts (cradlePkgDbStack c) - toDocDirOpts pkg c = ["field", pkg, "haddock-html"] - ++ ghcPkgDbStackOpts (cradlePkgDbStack c) - trim = takeWhile (`notElem` " \n") diff --git a/Language/Haskell/GhcMod/Read.hs b/Language/Haskell/GhcMod/Read.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Read.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Language.Haskell.GhcMod.Read where - -import Text.Read (readPrec_to_S, readPrec, minPrec) -import qualified Text.ParserCombinators.ReadP as P -import Text.ParserCombinators.ReadPrec (lift) - --- This library (libraries/base) is derived from code from several --- sources: - --- * Code from the GHC project which is largely (c) The University of --- Glasgow, and distributable under a BSD-style license (see below), - --- * Code from the Haskell 98 Report which is (c) Simon Peyton Jones --- and freely redistributable (but see the full license for --- restrictions). - --- * Code from the Haskell Foreign Function Interface specification, --- which is (c) Manuel M. T. Chakravarty and freely redistributable --- (but see the full license for restrictions). - --- The full text of these licenses is reproduced below. All of the --- licenses are BSD-style or compatible. - --- ----------------------------------------------------------------------------- - --- The Glasgow Haskell Compiler License - --- Copyright 2004, The University Court of the University of Glasgow. --- All rights reserved. - --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: - --- - Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. - --- - Redistributions in binary form must reproduce the above copyright notice, --- this list of conditions and the following disclaimer in the documentation --- and/or other materials provided with the distribution. - --- - Neither name of the University nor the names of its contributors may be --- used to endorse or promote products derived from this software without --- specific prior written permission. - --- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF --- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, --- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND --- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE --- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT --- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY --- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH --- DAMAGE. - --- ----------------------------------------------------------------------------- - --- Code derived from the document "Report on the Programming Language --- Haskell 98", is distributed under the following license: - --- Copyright (c) 2002 Simon Peyton Jones - --- The authors intend this Report to belong to the entire Haskell --- community, and so we grant permission to copy and distribute it for --- any purpose, provided that it is reproduced in its entirety, --- including this Notice. Modified versions of this Report may also be --- copied and distributed for any purpose, provided that the modified --- version is clearly presented as such, and that it does not claim to --- be a definition of the Haskell 98 Language. - --- ----------------------------------------------------------------------------- - --- Code derived from the document "The Haskell 98 Foreign Function --- Interface, An Addendum to the Haskell 98 Report" is distributed under --- the following license: - --- Copyright (c) 2002 Manuel M. T. Chakravarty - --- The authors intend this Report to belong to the entire Haskell --- community, and so we grant permission to copy and distribute it for --- any purpose, provided that it is reproduced in its entirety, --- including this Notice. Modified versions of this Report may also be --- copied and distributed for any purpose, provided that the modified --- version is clearly presented as such, and that it does not claim to --- be a definition of the Haskell 98 Foreign Function Interface. - --- ----------------------------------------------------------------------------- - -readEither :: Read a => String -> Either String a -readEither s = - case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of - [x] -> Right x - [] -> Left "Prelude.read: no parse" - _ -> Left "Prelude.read: ambiguous parse" - where - read' = - do x <- readPrec - lift P.skipSpaces - return x - -readMaybe :: Read a => String -> Maybe a -readMaybe s = case readEither s of - Left _ -> Nothing - Right a -> Just a diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Haskell.GhcMod.SrcUtils where - -import Control.Applicative ((<$>)) -import CoreUtils (exprType) -import Data.Generics -import Data.Maybe (fromMaybe) -import Data.Ord as O -import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L)) -import qualified GHC as G -import GHC.SYB.Utils (Stage(..), everythingStaged) -import GhcMonad -import qualified Language.Haskell.Exts.Annotated as HE -import Language.Haskell.GhcMod.Doc (showOneLine, getStyle) -import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors) -import qualified Language.Haskell.GhcMod.Gap as Gap -import Language.Haskell.GhcMod.Monad (IOish, GhcModT) -import Language.Haskell.GhcMod.Target (setTargetFiles) -import OccName (OccName) -import Outputable (PprStyle) -import TcHsSyn (hsPatType) - ----------------------------------------------------------------- - -instance HasType (LHsExpr Id) where - getType tcm e = do - hs_env <- G.getSession - mbe <- liftIO $ Gap.deSugar tcm e hs_env - return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe - -instance HasType (LPat Id) where - getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat) - ----------------------------------------------------------------- - -listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] -listifySpans tcs lc = listifyStaged TypeChecker p tcs - where - p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc - -listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a] -listifyParsedSpans pcs lc = listifyStaged Parser p pcs - where - p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc - -listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a] -listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs - where - p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc - -listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] -listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) - -cmp :: SrcSpan -> SrcSpan -> Ordering -cmp a b - | a `G.isSubspanOf` b = O.LT - | b `G.isSubspanOf` a = O.GT - | otherwise = O.EQ - -toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String) -toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ) - -fourInts :: SrcSpan -> (Int,Int,Int,Int) -fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan - -fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int) -fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc - , HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc) - --- Check whether (line,col) is inside a given SrcSpanInfo -typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool -typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) = - HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) -typeSigInRangeHE lineNo colNo (HE.TypeFamDecl (HE.SrcSpanInfo s _) _ _) = - HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) -typeSigInRangeHE lineNo colNo (HE.DataFamDecl (HE.SrcSpanInfo s _) _ _ _) = - HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) -typeSigInRangeHE _ _ _= False - -pretty :: DynFlags -> PprStyle -> Type -> String -pretty dflag style = showOneLine dflag style . Gap.typeForUser - ----------------------------------------------------------------- - -inModuleContext :: IOish m - => FilePath - -> (DynFlags -> PprStyle -> GhcModT m a) - -> GhcModT m a -inModuleContext file action = - withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWarningFlags) $ do - setTargetFiles [file] - Gap.withContext $ do - dflag <- G.getSessionDynFlags - style <- getStyle - action dflag style - ----------------------------------------------------------------- - -showName :: DynFlags -> PprStyle -> G.Name -> String -showName dflag style name = showOneLine dflag style $ Gap.nameForUser name - -showOccName :: DynFlags -> PprStyle -> OccName -> String -showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE CPP #-} -module Language.Haskell.GhcMod.Target ( - setTargetFiles - ) where - -import Control.Applicative ((<$>)) -import Control.Monad (forM, void, (>=>)) -import DynFlags (ExtensionFlag(..), xopt) -import GHC (LoadHowMuch(..)) -import qualified GHC as G -import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.Monad - --- | Set the files as targets and load them. -setTargetFiles :: IOish m => [FilePath] -> GhcModT m () -setTargetFiles files = do - targets <- forM files $ \file -> G.guessTarget file Nothing - G.setTargets targets - mode <- getCompilerMode - if mode == Intelligent then - loadTargets Intelligent - else do - mdls <- G.depanal [] False - let fallback = needsFallback mdls - if fallback then do - resetTargets targets - setIntelligent - loadTargets Intelligent - else - loadTargets Simple - where - loadTargets Simple = do - -- Reporting error A and error B - void $ G.load LoadAllTargets - mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph - -- Reporting error B and error C - mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss - -- Error B duplicates. But we cannot ignore both error reportings, - -- sigh. So, the logger makes log messages unique by itself. - loadTargets Intelligent = do - df <- G.getSessionDynFlags - void $ G.setSessionDynFlags (setModeIntelligent df) - void $ G.load LoadAllTargets - resetTargets targets = do - G.setTargets [] - void $ G.load LoadAllTargets - G.setTargets targets - setIntelligent = do - newdf <- setModeIntelligent <$> G.getSessionDynFlags - void $ G.setSessionDynFlags newdf - setCompilerMode Intelligent - -needsFallback :: G.ModuleGraph -> Bool -needsFallback = any $ \ms -> - let df = G.ms_hspp_opts ms in - Opt_TemplateHaskell `xopt` df - || Opt_QuasiQuotes `xopt` df -#if __GLASGOW_HASKELL__ >= 708 - || (Opt_PatternSynonyms `xopt` df) -#endif diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ /dev/null @@ -1,122 +0,0 @@ -module Language.Haskell.GhcMod.Types where - -import Control.Monad.Trans.Control (MonadBaseControl) -import Data.List (intercalate) -import qualified Data.Map as M -import Exception (ExceptionMonad) -import MonadUtils (MonadIO) - -import PackageConfig (PackageConfig) - --- | A constraint alias (-XConstraintKinds) to make functions dealing with --- 'GhcModT' somewhat cleaner. --- --- Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and --- exception handling. Usually this will simply be 'IO' but we parametrise it in --- the exported API so users have the option to use a custom inner monad. -type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m) - --- | Output style. -data OutputStyle = LispStyle -- ^ S expression style. - | PlainStyle -- ^ Plain textstyle. - --- | The type for line separator. Historically, a Null string is used. -newtype LineSeparator = LineSeparator String - -data Options = Options { - outputStyle :: OutputStyle - , hlintOpts :: [String] - -- | GHC command line options set on the @ghc-mod@ command line - , ghcUserOptions:: [GHCOption] - -- | If 'True', 'browse' also returns operators. - , operators :: Bool - -- | If 'True', 'browse' also returns types. - , detailed :: Bool - -- | If 'True', 'browse' will return fully qualified name - , qualified :: Bool - -- | Line separator string. - , lineSeparator :: LineSeparator - } - --- | A default 'Options'. -defaultOptions :: Options -defaultOptions = Options { - outputStyle = PlainStyle - , hlintOpts = [] - , ghcUserOptions= [] - , operators = False - , detailed = False - , qualified = False - , lineSeparator = LineSeparator "\0" - } - ----------------------------------------------------------------- - --- | The environment where this library is used. -data Cradle = Cradle { - -- | The directory where this library is executed. - cradleCurrentDir :: FilePath - -- | The project root directory. - , cradleRootDir :: FilePath - -- | The file name of the found cabal file. - , cradleCabalFile :: Maybe FilePath - -- | Package database stack - , cradlePkgDbStack :: [GhcPkgDb] - } deriving (Eq, Show) - ----------------------------------------------------------------- - --- | GHC package database flags. -data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show) - --- | A single GHC command line option. -type GHCOption = String - --- | An include directory for modules. -type IncludeDir = FilePath - --- | A package name. -type PackageBaseName = String - --- | A package version. -type PackageVersion = String - --- | A package id. -type PackageId = String - --- | A package's name, verson and id. -type Package = (PackageBaseName, PackageVersion, PackageId) - -pkgName :: Package -> PackageBaseName -pkgName (n,_,_) = n - -pkgVer :: Package -> PackageVersion -pkgVer (_,v,_) = v - -pkgId :: Package -> PackageId -pkgId (_,_,i) = i - -showPkg :: Package -> String -showPkg (n,v,_) = intercalate "-" [n,v] - -showPkgId :: Package -> String -showPkgId (n,v,i) = intercalate "-" [n,v,i] - --- | Collection of packages -type PkgDb = (M.Map Package PackageConfig) - --- | Haskell expression. -type Expression = String - --- | Module name. -type ModuleString = String - --- | A Module -type Module = [String] - --- | Option information for GHC -data CompilerOptions = CompilerOptions { - ghcOptions :: [GHCOption] -- ^ Command line options - , includeDirs :: [IncludeDir] -- ^ Include directories for modules - , depPackages :: [Package] -- ^ Dependent package names - } deriving (Eq, Show) diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs deleted file mode 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Language.Haskell.GhcMod.Utils where - - -import Language.Haskell.GhcMod.Error -import MonadUtils (MonadIO, liftIO) -import System.Directory (getCurrentDirectory, setCurrentDirectory) -import System.Exit (ExitCode(..)) -import System.Process (readProcessWithExitCode) - --- dropWhileEnd is not provided prior to base 4.5.0.0. -dropWhileEnd :: (a -> Bool) -> [a] -> [a] -dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] - -extractParens :: String -> String -extractParens str = extractParens' str 0 - where - extractParens' :: String -> Int -> String - extractParens' [] _ = [] - extractParens' (s:ss) level - | s `elem` "([{" = s : extractParens' ss (level+1) - | level == 0 = extractParens' ss 0 - | s `elem` "}])" && level == 1 = [s] - | s `elem` "}])" = s : extractParens' ss (level-1) - | otherwise = s : extractParens' ss level - -readProcess' :: (MonadIO m, MonadError GhcModError m) - => String - -> [String] - -> m String -readProcess' cmd opts = do - (rv,output,err) <- liftIO (readProcessWithExitCode cmd opts "") - `modifyError'` GMEProcess ([cmd] ++ opts) - case rv of - ExitFailure val -> do - throwError $ GMEProcess ([cmd] ++ opts) $ strMsg $ - cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")" - ++ "\n" ++ err - ExitSuccess -> - return output - -withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a -withDirectory_ dir action = - gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) - (\_ -> liftIO (setCurrentDirectory dir) >> action) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,99 @@ +# ghc-mod: Happy Haskell Hacking +[![build status](https://gitlab.com/dxld/ghc-mod/badges/master/build.svg)](https://gitlab.com/dxld/ghc-mod/commits/master) + +ghc-mod provides editors/IDEs with support for Haskell compiler features, it +supports both Cabal and Stack based projects and integrations exist for Emacs, +Vim, Atom, IntelliJ and VSCode. + +- for [all Haskell developers (Using ghc-mod in your development environment)](#using-ghc-mod-in-your-development-environment) +- for [people developing Haskell IDEs (Using ghc-mod as an IDE backend program)](#using-ghc-mod-as-an-ide-backend-program) +- for [developing Haskell tooling (Using ghc-mod as a library)](#using-ghc-mod-as-a-library) + +## Overview + +### Using ghc-mod in your Development Environment + +To use `ghc-mod` in your development environment of choice you need two things: + + - The `ghc-mod` program included in the package of the same name, see [Installing](https://github.com/DanielG/ghc-mod/wiki/Installing) + - A ghc-mod frontend to integrate it into your development environment, see [Frontend](https://github.com/DanielG/ghc-mod/wiki/Frontend) + +### Using ghc-mod as an IDE Backend Program + +We provide two modes of operation for frontends: interactive and single shot +mode. The former is accessed by calling `$ ghc-mod legacy-interactive` this will +sit and wait for you to type a command and exit when an empty line is +entered. Interactive mode is pretty much always faster than single shot mode +since it gives ghc-mod the ability to cache the compiler session between +commands on the other hand it needs more memory because it keeps these things +cached. + +Single shot mode is pretty much only there for (backwards) compatibility with +Vim since it only recently got the ability to talk to background processes +without installing some external plugin. You can use single-shot mode by simply +calling the sub-comamnds of the `ghc-mod` program. Since re-compiling large +projects can be really, really slow you really shouldn't use this and use +interactive mode instead. + +As a rule of thumb all commands available in single shot mode are available in +interactive mode, a list of the former can be obtained by running +`$ ghc-mod --help`. + +If you're developing a new ghc-mod fronted we'd love to hear from you! Please +open an issue or e-mail the maintainer. Also we invite you to add installation +and configuration instructions to +[Frontend](https://github.com/DanielG/ghc-mod/wiki/Frontend). + +### Using ghc-mod as a Library + +Internally ghc-mod uses the Glasgow Haskell Compilers's API to implement most of +it's functionality. + +In order to provide a hassle free experience to users ghc-mod tries hard to +automatically, and correctly, detect and if needed tweak the environment GHC +needs. It also handles some of the more cumbersome parts of getting a working +compiler session up and running. + +This functionality can be very useful to all kinds of Haskell development tools +therefore want to expose all the useful abstractions ghc-mod provides. + +Right now the ghc-mod API is pretty messy; a result of major internal rewrites +and reorganization coupled with too little time for cleanups over the course of +almost 100 releases! We would like to make a cut during v6.0 or so and +completely re-do the API but we need more input from downstream tool writers to +do that properly, see [Library API Redesign](Library-API-Redesign.md). + +For example [The Haskell Refactorer (HaRe)](https://github.com/alanz/HaRe) uses +the build environment abstraction ghc-mod provides so it can concentrate on it's +core functionality instead of worrying about build environments and compiler +session setup. + +Recently the +[`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine) project +has sprung up and if you're planning to write any kind of tool that needs editor +integration eventually you should definetly look into that. `haskell-ide-engine` +uses `ghc-mod` at it's core so you'll want to be familliar with it either way. + +API "documentation" is here: +[Hackage docs](https://hackage.haskell.org/package/ghc-mod#modules). + +## Reporting Bugs + +Please report bugs on the GitHub issue tracker for ghc-mod: +https://github.com/DanielG/ghc-mod/issues + +Including general environment information like the operating system +(distribution, version) you're using and the output of `$ ghc-mod debug` run in +your project directory is probably a good idea. + +## IRC + +If you have any problems, suggestions, comments swing by +[\#ghc-mod (web client)](https://kiwiirc.com/client/irc.freenode.org/ghc-mod) on +Freenode. If you're reporting a bug please also create an issue +[here (GitHub issue tracker)](https://github.com/DanielG/ghc-mod/issues) so we +have a way to contact you if you don't have time to stay. + +Do hang around for a while if no one answers and repeat your question if you +still haven't gotten any answer after a day or so (the maintainer was probably +asleep). You're most likely to get an answer during the day in GMT+1. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,107 @@ +#!/usr/bin/env runhaskell +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} import Distribution.Simple -main = defaultMain +import Distribution.Simple.Utils +import Distribution.Simple.Setup +import Distribution.Simple.Install +import Distribution.Simple.Program +import Distribution.Simple.Register +import Distribution.Simple.BuildPaths +import qualified Distribution.Simple.InstallDirs as ID +import Distribution.Simple.LocalBuildInfo +import Distribution.PackageDescription + +import qualified Data.Map as M +import Data.Map (Map) + +import Control.Arrow +import Control.Applicative +import Control.Monad +import Data.List +import Data.Maybe +import Data.Version +import Data.Monoid +import System.Process +import System.Exit +import System.FilePath +import System.Directory (renameFile) + +main :: IO () +main = defaultMainWithHooks $ simpleUserHooks { + instHook = inst, + copyHook = copy, + buildHook = \pd lbi hooks flags -> (buildHook simpleUserHooks) pd (patchLibexecdir lbi) hooks flags, + hookedPrograms = [ simpleProgram "shelltest" ] + } + +patchLibexecdir :: LocalBuildInfo -> LocalBuildInfo +patchLibexecdir lbi = let + idirtpl = installDirTemplates lbi + libexecdir' = toPathTemplate $ fromPathTemplate (libexecdir idirtpl) "$abi/$pkgid" + lbi' = lbi { installDirTemplates = idirtpl { libexecdir = libexecdir' } } + in + lbi' + +-- mostly copypasta from 'defaultInstallHook' +inst :: + PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () +inst pd lbi _uf ifl = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref ifl, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity ifl + } + xInstallTarget pd lbi copyFlags (\pd' lbi' -> install pd' lbi' copyFlags) + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref ifl, + regInPlace = installInPlace ifl, + regPackageDB = installPackageDB ifl, + regVerbosity = installVerbosity ifl + } + when (hasLibs pd) $ register pd lbi registerFlags + +copy :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () +copy pd lbi _uh cf = + xInstallTarget pd lbi cf (\pd' lbi' -> install pd' lbi' cf) + +xInstallTarget :: PackageDescription + -> LocalBuildInfo + -> CopyFlags + -> (PackageDescription -> LocalBuildInfo -> IO ()) + -> IO () +xInstallTarget pd lbi cf fn = do + let (extended, regular) = partition isInternal (executables pd) + + let pd_regular = pd { executables = regular } + + _ <- flip mapM extended $ \exe -> do + let pd_extended = onlyExePackageDesc [exe] pd + fn pd_extended lbi + + let lbi' = patchLibexecdir lbi + copydest = fromFlag (copyDest cf) + verbosity = fromFlag (copyVerbosity cf) + InstallDirs { bindir, libexecdir } = absoluteInstallDirs pd lbi' copydest + progprefix = substPathTemplate (packageId pd) lbi (progPrefix lbi) + progsuffix = substPathTemplate (packageId pd) lbi (progSuffix lbi) + fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + + fixedExeFileName = bindir fixedExeBaseName <.> exeExtension + newExeFileName = libexecdir fixedExeBaseName <.> exeExtension + + when (exeName exe == "ghc-mod-real") $ do + createDirectoryIfMissingVerbose verbosity True libexecdir + renameFile fixedExeFileName newExeFileName + + fn pd_regular lbi + + where + isInternal :: Executable -> Bool + isInternal exe = + fromMaybe False $ (=="True") <$> lookup "x-internal" (customFieldsBI $ buildInfo exe) + +onlyExePackageDesc :: [Executable] -> PackageDescription -> PackageDescription +onlyExePackageDesc exes pd = emptyPackageDescription { + package = package pd + , executables = exes + } diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,30 @@ +import Criterion.Main +import GhcMod.Target +import GhcMod.Monad +import GhcMod.Types +import Dir +import System.IO.Temp +import System.Process hiding (env) +import Control.Monad + +main = defaultMain [ + env setup $ \dir -> bgroup "simple-cabal" [ + bench "nop" $ whnfIO (simpleCabalNop dir 1) + , bench "nop10" $ whnfIO (simpleCabalNop dir 10) + ] + ] + +setup = do + tdir <- createTempDirectory "/tmp" "ghc-mod-bench" + system $ "cp -rv \"bench/data/simple-cabal/\" \""++ tdir ++"\"" + + simpleCabalNop tdir 1 -- warmup dist/ + + return tdir + +simpleCabalNop :: FilePath -> Int -> IO () +simpleCabalNop dir n = withDirectory_ (dir "simple-cabal") $ do + _ <- runGhcModT defaultOptions $ + forM_ [1..n] $ \_ -> do + runGmlT [Left "Main.hs"] (return ()) + return () diff --git a/bench/data/simple-cabal/Main.hs b/bench/data/simple-cabal/Main.hs new file mode 100644 --- /dev/null +++ b/bench/data/simple-cabal/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/bench/data/simple-cabal/Setup.hs b/bench/data/simple-cabal/Setup.hs new file mode 100644 --- /dev/null +++ b/bench/data/simple-cabal/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/data/simple-cabal/simple-cabal.cabal b/bench/data/simple-cabal/simple-cabal.cabal new file mode 100644 --- /dev/null +++ b/bench/data/simple-cabal/simple-cabal.cabal @@ -0,0 +1,13 @@ +name: simple-cabal +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +author: Daniel Gröber +maintainer: dxld@darkboxed.org +build-type: Simple +cabal-version: >=1.10 + +executable simple-cabal + main-is: Main.hs + build-depends: base + default-language: Haskell2010 diff --git a/core/Data/Binary/Generic.hs b/core/Data/Binary/Generic.hs new file mode 100644 --- /dev/null +++ b/core/Data/Binary/Generic.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, + ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Generic +-- Copyright : Bryan O'Sullivan +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Bryan O'Sullivan +-- Stability : unstable +-- Portability : Only works with GHC 7.2 and newer +-- +-- Instances for supporting GHC generics. +-- +----------------------------------------------------------------------------- +module Data.Binary.Generic where + +import Control.Applicative +import Data.Binary +import Data.Bits +import GHC.Generics +import Prelude + +class GGBinary f where + ggput :: f t -> Put + ggget :: Get (f t) + +-- Type without constructors +instance GGBinary V1 where + ggput _ = return () + ggget = return undefined + +-- Constructor without arguments +instance GGBinary U1 where + ggput U1 = return () + ggget = return U1 + +-- Product: constructor with parameters +instance (GGBinary a, GGBinary b) => GGBinary (a :*: b) where + ggput (x :*: y) = ggput x >> ggput y + ggget = (:*:) <$> ggget <*> ggget + +-- Metadata (constructor name, etc) +instance GGBinary a => GGBinary (M1 i c a) where + ggput = ggput . unM1 + ggget = M1 <$> ggget + +-- Constants, additional parameters, and rank-1 recursion +instance Binary a => GGBinary (K1 i a) where + ggput = put . unK1 + ggget = K1 <$> get + +-- Borrowed from the cereal package. + +-- The following GGBinary instance for sums has support for serializing +-- types with up to 2^64-1 constructors. It will use the minimal +-- number of bytes needed to encode the constructor. For example when +-- a type has 2^8 constructors or less it will use a single byte to +-- encode the constructor. If it has 2^16 constructors or less it will +-- use two bytes, and so on till 2^64-1. + +#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) +#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) +#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) + +instance ( GSum a, GSum b + , SumSize a, SumSize b) => GGBinary (a :+: b) where + ggput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) + | otherwise = sizeError "encode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + {-# INLINE ggput #-} + + ggget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) + | otherwise = sizeError "decode" size + where + size = unTagged (sumSize :: Tagged (a :+: b) Word64) + {-# INLINE ggget #-} + +sizeError :: Show size => String -> size -> error +sizeError s size = + error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" + +------------------------------------------------------------------------ + +checkGetSum :: (Ord word, Num word, Bits word, GSum f) + => word -> word -> Get (f a) +checkGetSum size code | code < size = getSum code size + | otherwise = fail "Unknown encoding for constructor" +{-# INLINE checkGetSum #-} + +class GSum f where + getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) + putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put + +instance (GSum a, GSum b) => GSum (a :+: b) where + getSum !code !size | code < sizeL = L1 <$> getSum code sizeL + | otherwise = R1 <$> getSum (code - sizeL) sizeR + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + {-# INLINE getSum #-} + + putSum !code !size s = case s of + L1 x -> putSum code sizeL x + R1 x -> putSum (code + sizeL) sizeR x + where + sizeL = size `shiftR` 1 + sizeR = size - sizeL + {-# INLINE putSum #-} + +instance GGBinary a => GSum (C1 c a) where + getSum _ _ = ggget + {-# INLINE getSum #-} + + putSum !code _ x = put code *> ggput x + {-# INLINE putSum #-} + +------------------------------------------------------------------------ + +class SumSize f where + sumSize :: Tagged f Word64 + +newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} + +instance (SumSize a, SumSize b) => SumSize (a :+: b) where + sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + + unTagged (sumSize :: Tagged b Word64) + +instance SumSize (C1 c a) where + sumSize = Tagged 1 diff --git a/core/GhcMod/CabalHelper.hs b/core/GhcMod/CabalHelper.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/CabalHelper.hs @@ -0,0 +1,309 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE CPP #-} +module GhcMod.CabalHelper + ( getComponents + , getGhcMergedPkgOptions + , getCabalPackageDbStack + , prepareCabalHelper + , withAutogen + , withCabal + ) where + +import Control.Applicative +import Control.Monad +import Control.Category ((.)) +import Data.Maybe +import Data.Monoid +import Data.Version +import Data.Binary (Binary) +import Data.Traversable +import Distribution.Helper hiding (Programs(..)) +import qualified Distribution.Helper as CH +import qualified GhcMod.Types as T +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.Utils +import GhcMod.PathsAndFiles +import GhcMod.Logging +import GhcMod.Output +import GhcMod.CustomPackageDb +import GhcMod.Stack +import System.FilePath +import System.Process +import System.Exit +import Prelude hiding ((.)) + +import Paths_ghc_mod as GhcMod + +-- | Only package related GHC options, sufficient for things that don't need to +-- access home modules +getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m) + => m [GHCOption] +getGhcMergedPkgOptions = chCached $ \distdir -> Cached { + cacheLens = Just (lGmcMergedPkgOptions . lGmCaches), + cacheFile = mergedPkgOptsCacheFile distdir, + cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do + opts <- runCHQuery ghcMergedPkgOptions + return ([setupConfigPath distdir], opts) + } + +getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb] +getCabalPackageDbStack = chCached $ \distdir -> Cached { + cacheLens = Just (lGmcPackageDbStack . lGmCaches), + cacheFile = pkgDbStackCacheFile distdir, + cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do + crdl <- cradle + dbs <- map chPkgToGhcPkg <$> + runCHQuery packageDbStack + return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs) + } + +chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb +chPkgToGhcPkg ChPkgGlobal = GlobalDb +chPkgToGhcPkg ChPkgUser = UserDb +chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f + +-- | Primary interface to cabal-helper and intended single entrypoint to +-- constructing 'GmComponent's +-- +-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by +-- 'resolveGmComponents'. +getComponents :: (Applicative m, IOish m, Gm m) + => m [GmComponent 'GMCRaw ChEntrypoint] +getComponents = chCached $ \distdir -> Cached { + cacheLens = Just (lGmcComponents . lGmCaches), + cacheFile = cabalHelperCacheFile distdir, + cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do + runCHQuery $ do + q <- join7 + <$> ghcOptions + <*> ghcPkgOptions + <*> ghcSrcOptions + <*> ghcLangOptions + <*> entrypoints + <*> entrypoints + <*> sourceDirs + let cs = flip map q $ curry8 (GmComponent mempty) + return ([setupConfigPath distdir], cs) + } + where + curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h + + join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f + join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))] + join' lb lc = [ (a, (b, c)) + | (a, b) <- lb + , (a', c) <- lc + , a == a' + ] + +getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m QueryEnv +getQueryEnv = do + crdl <- cradle + progs <- patchStackPrograms crdl =<< (optPrograms <$> options) + readProc <- gmReadProcess + let projdir = cradleRootDir crdl + distdir = projdir cradleDistDir crdl + return (defaultQueryEnv projdir distdir) { + qeReadProcess = readProc + , qePrograms = helperProgs progs + } + +runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b +runCHQuery a = do + qe <- getQueryEnv + runQuery qe a + + +prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m () +prepareCabalHelper = do + crdl <- cradle + when (isCabalHelperProject $ cradleProject crdl) $ + withCabal $ prepare' =<< getQueryEnv + +withAutogen :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a +withAutogen action = do + gmLog GmDebug "" $ strDoc $ "making sure autogen files exist" + crdl <- cradle + let projdir = cradleRootDir crdl + distdir = projdir cradleDistDir crdl + + (pkgName', _) <- runCHQuery packageId + + mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl + mCabalMacroHeader <- liftIO $ timeMaybe (distdir macrosHeaderPath) + mCabalPathsModule <- liftIO $ timeMaybe (distdir autogenModulePath pkgName') + + when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do + gmLog GmDebug "" $ strDoc $ "autogen files out of sync" + writeAutogen + + action + + where + writeAutogen = do + gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" + writeAutogenFiles' =<< getQueryEnv + + +withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a +withCabal action = do + crdl <- cradle + mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl + mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) + mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl) + + let haveSetupConfig = isJust mCabalConfig + + cusPkgDb <- getCustomPkgDbStack + (flgs, pkgDbStackOutOfSync) <- do + if haveSetupConfig + then runCHQuery $ do + flgs <- nonDefaultConfigFlags + pkgDb <- map chPkgToGhcPkg <$> packageDbStack + return (flgs, fromMaybe False $ (pkgDb /=) <$> cusPkgDb) + else return ([], False) + + when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $ + gmLog GmDebug "" $ strDoc $ "setup configuration is out of date" + + when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ + gmLog GmDebug "" $ strDoc $ "sandbox configuration is out of date" + + when pkgDbStackOutOfSync $ + gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack" + + when ( isSetupConfigOutOfDate mCabalFile mCabalConfig + || pkgDbStackOutOfSync + || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ do + proj <- cradleProject <$> cradle + opts <- options + case proj of + CabalProject -> do + gmLog GmDebug "" $ strDoc "reconfiguring Cabal project" + cabalReconfigure (optPrograms opts) crdl flgs + StackProject {} -> do + gmLog GmDebug "" $ strDoc "reconfiguring Stack project" + -- TODO: we could support flags for stack too, but it seems + -- you're supposed to put those in stack.yaml so detecting which + -- flags to pass down would be more difficult + + -- "--flag PACKAGE:[-]FLAG Override flags set in stack.yaml + -- (applies to local packages and extra-deps)" + + stackReconfigure (optStackBuildDeps opts) crdl (optPrograms opts) + _ -> + error $ "withCabal: unsupported project type: " ++ show proj + + action + + where + cabalReconfigure progs crdl flgs = do + readProc <- gmReadProcess + withDirectory_ (cradleRootDir crdl) $ do + cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack + let progOpts = + [ "--with-ghc=" ++ T.ghcProgram progs ] + -- Only pass ghc-pkg if it was actually set otherwise we + -- might break cabal's guessing logic + ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions) + then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ] + else [] + ++ map pkgDbArg cusPkgStack + ++ flagOpt + + toFlag (f, True) = f + toFlag (f, False) = '-':f + flagOpt = ["--flags", unwords $ map toFlag flgs] + + liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) "" + stackReconfigure deps crdl progs = do + withDirectory_ (cradleRootDir crdl) $ do + supported <- haveStackSupport + if supported + then do + when deps $ + spawn [T.stackProgram progs, "build", "--only-dependencies", "."] + spawn [T.stackProgram progs, "build", "--only-configure", "."] + else + gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build' as your stack version is too old (need at least 0.1.4.0)" + + spawn [] = return () + spawn (exe:args) = do + readProc <- gmReadProcess + liftIO $ void $ readProc exe args "" + + haveStackSupport = do + (rv, _, _) <- + liftIO $ readProcessWithExitCode "stack" ["--numeric-version"] "" + case rv of + ExitSuccess -> return True + ExitFailure _ -> return False + + + +pkgDbArg :: GhcPkgDb -> String +pkgDbArg GlobalDb = "--package-db=global" +pkgDbArg UserDb = "--package-db=user" +pkgDbArg (PackageDb p) = "--package-db=" ++ p + +-- * Neither file exists -> should return False: +-- @Nothing < Nothing = False@ +-- (since we don't need to @cabal configure@ when no cabal file exists.) +-- +-- * Cabal file doesn't exist (impossible since cabal-helper is only used with +-- cabal projects) -> should return False +-- @Just cc < Nothing = False@ +-- +-- * dist/setup-config doesn't exist yet -> should return True: +-- @Nothing < Just cf = True@ +-- +-- * Both files exist +-- @Just cc < Just cf = cc < cf = cc `olderThan` cf@ +isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool +isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do + worldCabalConfig < worldCabalFile + +helperProgs :: Programs -> CH.Programs +helperProgs progs = CH.Programs { + cabalProgram = T.cabalProgram progs, + ghcProgram = T.ghcProgram progs, + ghcPkgProgram = T.ghcPkgProgram progs + } + +chCached :: (Applicative m, IOish m, Gm m, Binary a) + => (FilePath -> Cached m GhcModState ChCacheData a) -> m a +chCached c = do + projdir <- cradleRootDir <$> cradle + distdir <- (projdir ) . cradleDistDir <$> cradle + d <- cacheInputData projdir + withCabal $ cached projdir (c distdir) d + where + -- we don't need to include the distdir in the cache input because when it + -- changes the cache files will be gone anyways ;) + cacheInputData projdir = do + opts <- options + crdl <- cradle + progs' <- patchStackPrograms crdl (optPrograms opts) + return $ ( helperProgs progs' + , projdir + , (showVersion gmVer, chVer) + ) + + gmVer = GhcMod.version + chVer = VERSION_cabal_helper diff --git a/core/GhcMod/Caching.hs b/core/GhcMod/Caching.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Caching.hs @@ -0,0 +1,141 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . +{-# LANGUAGE CPP, OverloadedStrings #-} +module GhcMod.Caching ( + module GhcMod.Caching + , module GhcMod.Caching.Types + ) where + +import Control.Arrow (first) +import Control.Monad +import Control.Monad.Trans.Maybe +#if !MIN_VERSION_binary(0,7,0) +import Control.Exception +#endif +import Data.Maybe +import Data.Binary hiding (get) +import Data.Version +import Data.Label +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import System.FilePath +import System.Directory.ModTime +import Utils (TimedFile(..), timeMaybe, mightExist) +import Paths_ghc_mod (version) +import Prelude + +import GhcMod.Monad.Types +import GhcMod.Caching.Types +import GhcMod.Logging + +-- | Cache a MonadIO action with proper invalidation. +cached :: forall m a d. (Gm m, MonadIO m, Binary a, Eq d, Binary d, Show d) + => FilePath -- ^ Directory to prepend to 'cacheFile' + -> Cached m GhcModState d a -- ^ Cache descriptor + -> d + -> m a +cached dir cd d = do + mcc <- readCache + case mcc of + Nothing -> do + t <- liftIO $ getCurrentModTime + writeCache (TimedCacheFiles t []) Nothing "cache missing or unreadable" + Just (t, ifs, d', a) | d /= d' -> do + tcfs <- timeCacheInput dir ifs + writeCache (TimedCacheFiles t tcfs) (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d' + Just (t, ifs, _, a) -> do + tcfs <- timeCacheInput dir ifs + case invalidatingInputFiles $ TimedCacheFiles t tcfs of + [] -> return a + _ -> writeCache (TimedCacheFiles t tcfs) (Just a) "input files changed" + + where + cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n" + + lbsToStrict = BS.concat . LBS.toChunks + lbsFromStrict bs = LBS.fromChunks [bs] + + writeCache tcfs ma cause = do + (ifs', a) <- (cachedAction cd) tcfs d ma + t <- liftIO $ getCurrentModTime + gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) + <+> parens (text cause) + case cacheLens cd of + Nothing -> return () + Just label -> do + gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd) + setLabel label $ Just (t, ifs', d, a) + + let c = BS.append cacheHeader $ lbsToStrict $ encode (t, ifs', d, a) + + liftIO $ BS.writeFile (dir cacheFile cd) c + + return a + + setLabel l x = do + s <- gmsGet + gmsPut $ set l x s + + readCache :: m (Maybe (ModTime, [FilePath], d, a)) + readCache = runMaybeT $ do + case cacheLens cd of + Just label -> do + c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile + setLabel label $ Just c + return c + Nothing -> + readCacheFromFile + + readCacheFromFile :: MaybeT m (ModTime, [FilePath], d, a) + readCacheFromFile = do + f <- MaybeT $ liftIO $ mightExist $ cacheFile cd + readCacheFromFile' f + + readCacheFromFile' :: FilePath -> MaybeT m (ModTime, [FilePath], d, a) + readCacheFromFile' f = MaybeT $ do + gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd) + cc <- liftIO $ BS.readFile f + case first BS8.words $ BS8.span (/='\n') cc of + (["Written", "by", "ghc-mod", ver], rest) + | BS8.unpack ver == showVersion version -> + either (const Nothing) Just + `liftM` decodeE (lbsFromStrict $ BS.drop 1 rest) + _ -> return Nothing + + decodeE b = do +#if MIN_VERSION_binary(0,7,0) + return $ case decodeOrFail b of + Left (_rest, _offset, errmsg) -> Left errmsg + Right (_reset, _offset, a) -> Right a +#else + ea <- liftIO $ try $ evaluate $ decode b + return $ case ea of + Left (ErrorCall errmsg) -> Left errmsg + Right a -> Right a + +#endif + +timeCacheInput :: MonadIO m => FilePath -> [FilePath] -> m [TimedFile] +timeCacheInput dir ifs = liftIO $ do + ins <- (timeMaybe . (dir )) `mapM` ifs + return $ catMaybes ins + +invalidatingInputFiles :: TimedCacheFiles -> [FilePath] +invalidatingInputFiles (TimedCacheFiles tcreated tcfs) = + map tfPath $ + -- get input files older than tcfile + filter ((TimedFile "" tcreated)<) tcfs diff --git a/core/GhcMod/Caching/Types.hs b/core/GhcMod/Caching/Types.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Caching/Types.hs @@ -0,0 +1,67 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . +module GhcMod.Caching.Types where + +import Utils +import Data.Label +import System.Directory.ModTime +import Distribution.Helper + +type CacheContents d a = Maybe (ModTime, [FilePath], d, a) +type CacheLens s d a = s :-> CacheContents d a + +data Cached m s d a = Cached { + cacheFile :: FilePath, + cacheLens :: Maybe (CacheLens s d a), + cachedAction :: TimedCacheFiles + -> d + -> Maybe a + -> m ([FilePath], a) + + -- ^ @cachedAction tcf data ma@ + -- + -- * @tcf@: Input file timestamps. Not technically necessary, just an + -- optimizazion when knowing which input files changed can make updating the + -- cache faster + -- + -- * @data@: Arbitrary static input data to cache action. Can be used to + -- invalidate the cache using something other than file timestamps + -- i.e. environment tool version numbers + -- + -- * @ma@: Cached data if it existed + -- + -- Returns: + -- + -- * @fst@: Input files used in generating the cache + -- + -- * @snd@: Cache data, will be stored alongside the static input data in the + -- 'cacheFile' + -- + -- The cached action, will only run if one of the following is true: + -- + -- * 'cacheFile' doesn\'t exist yet + -- * 'cacheFile' exists and 'inputData' changed + -- * any files returned by the cached action changed + } + +data TimedCacheFiles = TimedCacheFiles { + tcCreated :: ModTime, + -- ^ 'cacheFile' timestamp + tcFiles :: [TimedFile] + -- ^ Timestamped files returned by the cached action + } deriving (Eq, Ord) + +type ChCacheData = (Programs, FilePath, (String, String)) diff --git a/core/GhcMod/Convert.hs b/core/GhcMod/Convert.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Convert.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-} + +module GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where + +import GhcMod.Monad.Types +import GhcMod.Types + +import Control.Applicative +import Prelude + +type Builder = String -> String + +-- | +-- +-- >>> replace '"' "\\\"" "foo\"bar" "" +-- "foo\\\"bar" +replace :: Char -> String -> String -> Builder +replace _ _ [] = id +replace c cs (x:xs) + | x == c = (cs ++) . replace c cs xs + | otherwise = (x :) . replace c cs xs + +inter :: Char -> [Builder] -> Builder +inter _ [] = id +inter c bs = foldr1 (\x y -> x . (c:) . y) bs + +convert' :: (ToString a, IOish m, GmEnv m) => a -> m String +convert' x = flip convert x . optOutput <$> options + +convert :: ToString a => OutputOpts -> a -> String +convert opt@OutputOpts { ooptStyle = LispStyle } x = toLisp opt x "\n" +convert opt@OutputOpts { ooptStyle = PlainStyle } x + | str == "\n" = "" + | otherwise = str + where + str = toPlain opt x "\n" + +class ToString a where + toLisp :: OutputOpts -> a -> Builder + toPlain :: OutputOpts -> a -> Builder + +lineSep :: OutputOpts -> String +lineSep oopts = interpret lsep + where + interpret s = read $ "\"" ++ s ++ "\"" + LineSeparator lsep = ooptLineSeparator oopts + +-- | +-- +-- >>> toLisp (optOutput defaultOptions) "fo\"o" "" +-- "\"fo\\\"o\"" +-- >>> toPlain (optOutput defaultOptions) "foo" "" +-- "foo" +instance ToString String where + toLisp oopts = quote oopts + toPlain oopts = replace '\n' (lineSep oopts) + +-- | +-- +-- >>> toLisp (optOutput defaultOptions) ["foo", "bar", "ba\"z"] "" +-- "(\"foo\" \"bar\" \"ba\\\"z\")" +-- >>> toPlain (optOutput defaultOptions) ["foo", "bar", "baz"] "" +-- "foo\nbar\nbaz" +instance ToString [String] where + toLisp oopts = toSexp1 oopts + toPlain oopts = inter '\n' . map (toPlain oopts) + +instance ToString [ModuleString] where + toLisp oopts = toLisp oopts . map getModuleString + toPlain oopts = toPlain oopts . map getModuleString + +-- | +-- +-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] +-- >>> toLisp (optOutput defaultOptions) inp "" +-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))" +-- >>> toPlain (optOutput defaultOptions) inp "" +-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" +instance ToString [((Int,Int,Int,Int),String)] where + toLisp oopts = toSexp2 . map toS + where + toS x = ('(' :) . tupToString oopts x . (')' :) + toPlain oopts = inter '\n' . map (tupToString oopts) + +instance ToString ((Int,Int,Int,Int),String) where + toLisp oopts x = ('(' :) . tupToString oopts x . (')' :) + toPlain oopts x = tupToString oopts x + +instance ToString ((Int,Int,Int,Int),[String]) where + toLisp oopts (x,s) = ('(' :) . fourIntsToString x . + (' ' :) . toLisp oopts s . (')' :) + toPlain oopts (x,s) = fourIntsToString x . ('\n' :) . toPlain oopts s + +instance ToString (String, (Int,Int,Int,Int),[String]) where + toLisp oopts (s,x,y) = toSexp2 [toLisp oopts s, ('(' :) . fourIntsToString x . (')' :), toLisp oopts y] + toPlain oopts (s,x,y) = inter '\n' [toPlain oopts s, fourIntsToString x, toPlain oopts y] + +toSexp1 :: OutputOpts -> [String] -> Builder +toSexp1 oopts ss = ('(' :) . inter ' ' (map (quote oopts) ss) . (')' :) + +toSexp2 :: [Builder] -> Builder +toSexp2 ss = ('(' :) . inter ' ' ss . (')' :) + +fourIntsToString :: (Int,Int,Int,Int) -> Builder +fourIntsToString (a,b,c,d) = (show a ++) . (' ' :) + . (show b ++) . (' ' :) + . (show c ++) . (' ' :) + . (show d ++) + +tupToString :: OutputOpts -> ((Int,Int,Int,Int),String) -> Builder +tupToString oopts ((a,b,c,d),s) = (show a ++) . (' ' :) + . (show b ++) . (' ' :) + . (show c ++) . (' ' :) + . (show d ++) . (' ' :) + . quote oopts s -- fixme: quote is not necessary + +quote :: OutputOpts -> String -> Builder +quote oopts str = ("\"" ++) . (quote' str ++) . ("\"" ++) + where + lsep = lineSep oopts + quote' [] = [] + quote' (x:xs) + | x == '\n' = lsep ++ quote' xs + | x == '\\' = "\\\\" ++ quote' xs + | x == '"' = "\\\"" ++ quote' xs + | otherwise = x : quote' xs + +---------------------------------------------------------------- + +-- Empty result to be returned when no info can be gathered +emptyResult :: Monad m => OutputOpts -> m String +emptyResult oopts = return $ convert oopts ([] :: [String]) + +-- Return an emptyResult when Nothing +whenFound :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> b) -> m String +whenFound oopts from f = maybe (emptyResult oopts) (return . convert oopts . f) =<< from + +-- Return an emptyResult when Nothing, inside a monad +whenFound' :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> m b) -> m String +whenFound' oopts from f = maybe (emptyResult oopts) (\x -> do y <- f x ; return (convert oopts y)) =<< from diff --git a/core/GhcMod/Cradle.hs b/core/GhcMod/Cradle.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Cradle.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE CPP #-} +module GhcMod.Cradle + ( findCradle + , findCradle' + , findCradleNoLog + , findSpecCradle + , cleanupCradle + + -- * for @spec@ + , plainCradle + ) where + +import GhcMod.PathsAndFiles +import GhcMod.Monad.Types +import GhcMod.Types +import GhcMod.Utils +import GhcMod.Stack +import GhcMod.Logging +import GhcMod.Error + +import Safe +import Control.Applicative +import Control.Monad.Trans.Maybe +import Data.Maybe +import System.Directory +import System.FilePath +import System.Environment +import Prelude +import Control.Monad.Trans.Journal (runJournalT) + +---------------------------------------------------------------- + +-- | Finding 'Cradle'. +-- Find a cabal file by tracing ancestor directories. +-- Find a sandbox according to a cabal sandbox config +-- in a cabal directory. +findCradle :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle +findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory + +findCradleNoLog :: forall m. (IOish m, GmOut m) => Programs -> m Cradle +findCradleNoLog progs = + fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog)) + +findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle +findCradle' Programs { stackProgram, cabalProgram } dir = run $ + msum [ stackCradle stackProgram dir + , cabalCradle cabalProgram dir + , sandboxCradle dir + , plainCradle dir + ] + where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a) + +findSpecCradle :: + (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle +findSpecCradle Programs { stackProgram, cabalProgram } dir = do + let cfs = [ stackCradleSpec stackProgram + , cabalCradle cabalProgram + , sandboxCradle + ] + cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs + gcs <- filterM isNotGmCradle cs + fillTempDir =<< case gcs of + [] -> fromJust <$> runMaybeT (plainCradle dir) + c:_ -> return c + where + isNotGmCradle crdl = + liftIO $ not <$> doesFileExist (cradleRootDir crdl "ghc-mod.cabal") + +cleanupCradle :: Cradle -> IO () +cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl + +fillTempDir :: IOish m => Cradle -> m Cradle +fillTempDir crdl = do + tmpDir <- liftIO $ newTempDir (cradleRootDir crdl) + return crdl { cradleTempDir = tmpDir } + +cabalCradle :: + (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle +cabalCradle cabalProg wdir = do + cabalFile <- MaybeT $ liftIO $ findCabalFile wdir + let cabalDir = takeDirectory cabalFile + + gmLog GmInfo "" $ text "Found Cabal project at" <+>: text cabalDir + + -- If cabal doesn't exist the user probably wants to use something else + whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do + gmLog GmInfo "" $ text "'cabal' executable wasn't found, trying next project type" + mzero + + gmLog GmInfo "" $ text "Using Cabal project at" <+>: text cabalDir + return Cradle { + cradleProject = CabalProject + , cradleCurrentDir = wdir + , cradleRootDir = cabalDir + , cradleTempDir = error "tmpDir" + , cradleCabalFile = Just cabalFile + , cradleDistDir = "dist" + } + +stackCradle :: + (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle +stackCradle stackProg wdir = do +#if __GLASGOW_HASKELL__ < 708 + -- GHC < 7.8 is not supported by stack + mzero +#endif + + cabalFile <- MaybeT $ liftIO $ findCabalFile wdir + let cabalDir = takeDirectory cabalFile + _stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir + + gmLog GmInfo "" $ text "Found Stack project at" <+>: text cabalDir + + stackExeSet <- liftIO $ isJust <$> lookupEnv "STACK_EXE" + stackExeExists <- liftIO $ isJust <$> findExecutable stackProg + setupCfgExists <- liftIO $ doesFileExist $ cabalDir setupConfigPath "dist" + + case (stackExeExists, stackExeSet) of + (False, True) -> do + gmLog GmWarning "" $ text "'stack' executable wasn't found but STACK_EXE is set, trying next project type" + mzero + + (False, False) -> do + gmLog GmInfo "" $ text "'stack' executable wasn't found, trying next project type" + mzero + + (True, True) -> do + gmLog GmInfo "" $ text "STACK_EXE set, preferring Stack project" + + (True, False) | setupCfgExists -> do + gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack project" + mzero + + (True, False) -> return () + + senv <- MaybeT $ getStackEnv cabalDir stackProg + + gmLog GmInfo "" $ text "Using Stack project at" <+>: text cabalDir + return Cradle { + cradleProject = StackProject senv + , cradleCurrentDir = wdir + , cradleRootDir = cabalDir + , cradleTempDir = error "tmpDir" + , cradleCabalFile = Just cabalFile + , cradleDistDir = seDistDir senv + } + +stackCradleSpec :: + (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle +stackCradleSpec stackProg wdir = do + crdl <- stackCradle stackProg wdir + case crdl of + Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do + b <- isGmDistDir seDistDir + when b mzero + return crdl + _ -> error "stackCradleSpec" + where + isGmDistDir dir = + liftIO $ not <$> doesFileExist (dir ".." "ghc-mod.cabal") + +sandboxCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle +sandboxCradle wdir = do + sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir + gmLog GmInfo "" $ text "Using sandbox project at" <+>: text sbDir + return Cradle { + cradleProject = SandboxProject + , cradleCurrentDir = wdir + , cradleRootDir = sbDir + , cradleTempDir = error "tmpDir" + , cradleCabalFile = Nothing + , cradleDistDir = "dist" + } + +plainCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle +plainCradle wdir = do + gmLog GmInfo "" $ text "Found no other project type, falling back to plain GHC project" + return $ Cradle { + cradleProject = PlainProject + , cradleCurrentDir = wdir + , cradleRootDir = wdir + , cradleTempDir = error "tmpDir" + , cradleCabalFile = Nothing + , cradleDistDir = "dist" + } diff --git a/core/GhcMod/CustomPackageDb.hs b/core/GhcMod/CustomPackageDb.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/CustomPackageDb.hs @@ -0,0 +1,38 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . +module GhcMod.CustomPackageDb where + +import Control.Applicative +import Control.Monad +import Control.Category ((.)) +import Data.Maybe +import Data.Traversable +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.PathsAndFiles +import Prelude hiding ((.)) + +parseCustomPackageDb :: String -> [GhcPkgDb] +parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src + where + parsePkgDb "global" = GlobalDb + parsePkgDb "user" = UserDb + parsePkgDb s = PackageDb s + +getCustomPkgDbStack :: (MonadIO m, GmEnv m) => m (Maybe [GhcPkgDb]) +getCustomPkgDbStack = do + mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle + return $ parseCustomPackageDb <$> mCusPkgDbFile diff --git a/core/GhcMod/DebugLogger.hs b/core/GhcMod/DebugLogger.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/DebugLogger.hs @@ -0,0 +1,138 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . +{-# LANGUAGE CPP, RankNTypes #-} +module GhcMod.DebugLogger where + +-- (c) The University of Glasgow 2005 +-- +-- The Glasgow Haskell Compiler License +-- +-- Copyright 2002, The University Court of the University of Glasgow. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- - Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright notice, +-- this list of conditions and the following disclaimer in the documentation +-- and/or other materials provided with the distribution. +-- +-- - Neither name of the University nor the names of its contributors may be +-- used to endorse or promote products derived from this software without +-- specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +-- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +-- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +-- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +-- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +-- DAMAGE. + +import GHC +import FastString +import Pretty +import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine) +import qualified Outputable +import ErrUtils + +import GhcMod.Error +import GhcMod.Gap +import Prelude + +debugLogAction :: (String -> IO ()) -> GmLogAction +debugLogAction putErr _reason dflags severity srcSpan style' msg + = case severity of + SevOutput -> printSDoc putErr msg style' + +#if __GLASGOW_HASKELL__ >= 706 + SevDump -> printSDoc putErr (msg Outputable.$$ blankLine) style' +#endif + +#if __GLASGOW_HASKELL__ >= 708 + SevInteractive -> let + putStrSDoc = debugLogActionHPutStrDoc dflags putErr + in + putStrSDoc msg style' +#endif + SevInfo -> printErrs putErr msg style' + SevFatal -> printErrs putErr msg style' + _ -> do putErr "\n" +#if __GLASGOW_HASKELL__ >= 706 + printErrs putErr (mkLocMessage severity srcSpan msg) style' +#else + printErrs putErr (mkLocMessage srcSpan msg) style' +#endif + -- careful (#2302): printErrs prints in UTF-8, + -- whereas converting to string first and using + -- hPutStr would just emit the low 8 bits of + -- each unicode char. + where +#if __GLASGOW_HASKELL__ >= 706 + printSDoc put = debugLogActionHPrintDoc dflags put + printErrs put = debugLogActionHPrintDoc dflags put +#endif + + +#if __GLASGOW_HASKELL__ >= 706 + +debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO () +debugLogActionHPrintDoc dflags put d sty + = debugLogActionHPutStrDoc dflags put (d Outputable.$$ Outputable.text "") sty + -- Adds a newline + +debugLogActionHPutStrDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO () +debugLogActionHPutStrDoc dflags put d sty + = gmPrintDoc_ Pretty.PageMode (pprCols dflags) put doc + where -- Don't add a newline at the end, so that successive + -- calls to this log-action can output all on the same line + doc = runSDoc d (initSDocContext dflags sty) + +#else + +printSDoc = printErrs + +printErrs :: (String -> IO ()) -> SDoc -> PprStyle -> IO () +printErrs put doc sty = do + gmPrintDoc PageMode 100 put (runSDoc doc (initSDocContext sty)) + +#endif + +gmPrintDoc :: Mode -> Int -> (String -> IO ()) -> Doc -> IO () +-- printDoc adds a newline to the end +gmPrintDoc mode cols put doc = gmPrintDoc_ mode cols put (doc $$ text "") + +gmPrintDoc_ :: Mode -> Int -> (String -> IO ()) -> Doc -> IO () +gmPrintDoc_ mode pprCols putS doc + = fullRender mode pprCols 1.5 put done doc + where + put (Chr c) next = putS [c] >> next + put (Str s) next = putS s >> next + put (PStr s) next = putS (unpackFS s) >> next +#if __GLASGOW_HASKELL__ >= 708 + put (ZStr s) next = putS (zString s) >> next +#endif + put (LStr s _l) next = putS (unpackLitString s) >> next + + done = return () -- hPutChar hdl '\n' diff --git a/core/GhcMod/Doc.hs b/core/GhcMod/Doc.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Doc.hs @@ -0,0 +1,20 @@ +module GhcMod.Doc where + +import GHC +import GhcMod.Gap (withStyle, showDocWith) +import Outputable +import Pretty (Mode(..)) + +showPage :: DynFlags -> PprStyle -> SDoc -> String +showPage dflag style = showDocWith dflag PageMode . withStyle dflag style + +showOneLine :: DynFlags -> PprStyle -> SDoc -> String +showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style + +getStyle :: GhcMonad m => m PprStyle +getStyle = do + unqual <- getPrintUnqual + return $ mkUserStyle unqual AllTheWay + +styleUnqualified :: PprStyle +styleUnqualified = mkUserStyle neverQualify AllTheWay diff --git a/core/GhcMod/DynFlags.hs b/core/GhcMod/DynFlags.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/DynFlags.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE TemplateHaskell #-} + +module GhcMod.DynFlags where + +import Control.Applicative +import Control.Monad +import GHC +import qualified GHC as G +import GHC.Paths (libdir) +import qualified GhcMod.Gap as Gap +import GhcMod.Types +import GhcMod.DebugLogger +import GhcMod.DynFlagsTH +import System.IO.Unsafe (unsafePerformIO) +import Prelude + +setEmptyLogger :: DynFlags -> DynFlags +setEmptyLogger df = + Gap.setLogAction df $ \_ _ _ _ _ _ -> return () + +setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags +setDebugLogger put df = do + Gap.setLogAction df (debugLogAction put) + +-- * Fast +-- * Friendly to foreign export +-- * Not friendly to -XTemplateHaskell and -XPatternSynonyms +-- * Uses little memory +setHscNothing :: DynFlags -> DynFlags +setHscNothing df = df { + ghcMode = CompManager + , ghcLink = NoLink + , hscTarget = HscNothing + , optLevel = 0 + } + +-- * Slow +-- * Not friendly to foreign export +-- * Friendly to -XTemplateHaskell and -XPatternSynonyms +-- * Uses lots of memory +setHscInterpreted :: DynFlags -> DynFlags +setHscInterpreted df = df { + ghcMode = CompManager + , ghcLink = LinkInMemory + , hscTarget = HscInterpreted + , optLevel = 0 + } + +-- | Parse command line ghc options and add them to the 'DynFlags' passed +addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags +addCmdOpts cmdOpts df = + fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts) + where + fst3 (a,_,_) = a + +---------------------------------------------------------------- + +withDynFlags :: GhcMonad m + => (DynFlags -> DynFlags) + -> m a + -> m a +withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body) + where + setup = do + dflags <- G.getSessionDynFlags + void $ G.setSessionDynFlags (setFlags dflags) + return dflags + teardown = void . G.setSessionDynFlags + +withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a +withCmdFlags flags body = G.gbracket setup teardown (\_ -> body) + where + setup = do + dflags <- G.getSessionDynFlags + void $ G.setSessionDynFlags =<< addCmdOpts flags dflags + return dflags + teardown = void . G.setSessionDynFlags + +---------------------------------------------------------------- + +-- | Set 'DynFlags' equivalent to "-w:". +setNoWarningFlags :: DynFlags -> DynFlags +setNoWarningFlags df = df { warningFlags = Gap.emptyWarnFlags} + +-- | Set 'DynFlags' equivalent to "-Wall". +setAllWarningFlags :: DynFlags -> DynFlags +setAllWarningFlags df = df { warningFlags = allWarningFlags } + +allWarningFlags :: Gap.WarnFlags +allWarningFlags = unsafePerformIO $ + G.runGhc (Just libdir) $ do + df <- G.getSessionDynFlags + df' <- addCmdOpts ["-Wall"] df + return $ G.warningFlags df' + +---------------------------------------------------------------- + +deferErrors :: Monad m => DynFlags -> m DynFlags +deferErrors df = return $ + Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $ + Gap.setDeferTypeErrors $ setNoWarningFlags df + +---------------------------------------------------------------- + +deriveEqDynFlags [d| + eqDynFlags :: DynFlags -> DynFlags -> Bool + eqDynFlags = undefined + |] diff --git a/core/GhcMod/DynFlagsTH.hs b/core/GhcMod/DynFlagsTH.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/DynFlagsTH.hs @@ -0,0 +1,144 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE CPP, TemplateHaskell #-} +module GhcMod.DynFlagsTH where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Control.Applicative +import Data.Maybe +import Data.Generics.Aliases +import Data.Generics.Schemes +import DynFlags +import Prelude + +deriveEqDynFlags :: Q [Dec] -> Q [Dec] +deriveEqDynFlags qds = do +#if __GLASGOW_HASKELL__ <= 710 + ~(TyConI (DataD [] _ [] [ctor] _ )) +#else + ~(TyConI (DataD [] _ [] _ [ctor] _ )) +#endif + <- reify ''DynFlags + let ~(RecC _ fs) = ctor + + a <- newName "a" + b <- newName "b" + + e <- AppE (VarE 'and) . ListE <$> sequence (catMaybes $ map (eq a b) fs) + + tysig@(SigD n _) :_ <- qds + + return $ [tysig, FunD n [Clause [VarP a, VarP b] (NormalB e) []]] + + where + eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp) + eq a b (fun@(Name (OccName fon) _), _, ft) + | not (isUneqable || isIgnored) = Just expr + | otherwise = Nothing + where + isUneqable = everything (||) (mkQ False hasUnEqable) ft + + hasUnEqable (AppT (ConT (Name (OccName on) _)) _) + | any (==on) ignoredConstructorNames = True + hasUnEqable (ConT (Name (OccName on) _)) + | any (==on) ignoredTypeNames = True + | any (==on) ignoredTypeOccNames = True + hasUnEqable _ = False + + isIgnored = fon `elem` ignoredNames + + ignoredConstructorNames = [ "IORef" ] + + ignoredNames = [ "pkgDatabase" -- 7.8 +#if __GLASGOW_HASKELL__ <= 706 + , "ways" -- 'Ways' is not exported :/ +#endif + ] + ignoredTypeNames = + [ "LogAction" + , "PackageState" + , "Hooks" + , "FlushOut" + , "FlushErr" + , "Settings" -- I think these can't cange at runtime + ] + ignoredTypeOccNames = [ "OnOff" ] + + fa = AppE (VarE fun) (VarE a) + fb = AppE (VarE fun) (VarE b) + expr = + case fon of + "rtsOptsEnabled" -> do + let eqfn = [| let fn RtsOptsNone RtsOptsNone = True + fn RtsOptsSafeOnly RtsOptsSafeOnly = True + fn RtsOptsAll RtsOptsAll = True + fn _ _ = False + in fn + |] + [e| $(eqfn) $(return fa) $(return fb) |] + + "extraPkgConfs" -> do + let eqfn = [| let fn a' b' = and (zipWith eqpr (a' []) (b' [])) + && length (a' []) == length (b' []) + eqpr GlobalPkgConf GlobalPkgConf = True + eqpr UserPkgConf UserPkgConf = True + eqpr (PkgConfFile pa) (PkgConfFile pb) = pa == pb + eqpr _ _ = False + in fn + |] + [e| $(eqfn) $(return fa) $(return fb) |] + +#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800 + "sigOf" -> do + let eqfn = [| let fn NotSigOf NotSigOf = True + fn (SigOf a') (SigOf b') = a' == b' + fn (SigOfMap a') (SigOfMap b') = a' == b' + fn _ _ = False + in fn + |] + [e| $(eqfn) $(return fa) $(return fb) |] +#endif + +#if __GLASGOW_HASKELL <= 706 + "profAuto" -> do + let eqfn = [| let fn NoProfAuto NoProfAuto = True + fn ProfAutoAll ProfAutoAll = True + fn ProfAutoTop ProfAutoTop = True + fn ProfAutoExports ProfAutoExports = True + fn ProfAutoCalls ProfAutoCalls = True + fn _ _ = False + in fn + |] + [e| $(eqfn) $(return fa) $(return fb) |] +#endif + +#if __GLASGOW_HASKELL__ >= 706 + "language" -> do + let eqfn = [| let fn (Just Haskell98) (Just Haskell98) = True + fn (Just Haskell2010) (Just Haskell2010) = True + fn Nothing Nothing = True + fn _ _ = False + in fn + |] + [e| $(eqfn) $(return fa) $(return fb) |] +#endif + + _ -> + [e| $(return fa) == $(return fb) |] + +-- expr' = [e| trace (if $(expr) == True then "" else show ($(litE $ StringL fon), $(expr))) $(expr) |] diff --git a/core/GhcMod/Error.hs b/core/GhcMod/Error.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Error.hs @@ -0,0 +1,160 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE ExistentialQuantification #-} +module GhcMod.Error ( + GhcModError(..) + , GmError + , gmeDoc + , ghcExceptionDoc + , liftMaybe + , overrideError + , modifyError + , modifyError' + , modifyGmError + , tryFix + , GHandler(..) + , gcatches + , module Control.Monad.Error + , module Control.Exception + ) where + +import Control.Arrow hiding ((<+>)) +import Control.Exception +import Control.Monad.Error hiding (MonadIO, liftIO) +import qualified Data.Set as Set +import Data.List +import Data.Version +import System.Process (showCommandForUser) +import Text.Printf + +import Exception +import Panic +import Pretty +import Config (cProjectVersion, cHostPlatformString) +import Paths_ghc_mod (version) + +import GhcMod.Types +import GhcMod.Pretty + +type GmError m = MonadError GhcModError m + +gmeDoc :: GhcModError -> Doc +gmeDoc e = case e of + GMENoMsg -> + text "Unknown error" + GMEString msg -> + text msg + GMECabalConfigure msg -> + text "Configuring cabal project failed" <+>: gmeDoc msg + GMEStackConfigure msg -> + text "Configuring stack project failed" <+>: gmeDoc msg + GMEStackBootstrap msg -> + text "Bootstrapping stack project environment failed" <+>: gmeDoc msg + GMECabalCompAssignment ctx -> + text "Could not find a consistent component assignment for modules:" $$ + (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$ + text "" $$ + (if all (Set.null . snd) ctx + then noComponentSuggestions + else empty) $$ + text "- To find out which components ghc-mod knows about try:" $$ + nest 4 (backticks $ text "ghc-mod debug") + + where + noComponentSuggestions = + text "- Are some of these modules part of a test and or benchmark?\ + \ Try enabling them:" $$ + nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]") + + backticks d = char '`' <> d <> char '`' + ctxDoc = moduleDoc *** compsDoc + >>> first (<> colon) >>> uncurry (flip hang 4) + + moduleDoc (Left fn) = + text "File " <> quotes (text fn) + moduleDoc (Right mdl) = + text "Module " <> quotes (text $ moduleNameString mdl) + + compsDoc sc | Set.null sc = text "has no known components" + compsDoc sc = fsep $ punctuate comma $ + map gmComponentNameDoc $ Set.toList sc + GMEProcess _fn cmd args emsg -> let c = showCommandForUser cmd args in + case emsg of + Right err -> + text (printf "Launching system command `%s` failed: " c) + <> gmeDoc err + Left rv -> text $ + printf "Launching system command `%s` failed (exited with %d)" c rv + GMENoCabalFile -> + text "No cabal file found." + GMETooManyCabalFiles cfs -> + text $ "Multiple cabal files found. Possible cabal files: \"" + ++ intercalate "\", \"" cfs ++"\"." + +ghcExceptionDoc :: GhcException -> Doc +ghcExceptionDoc e@(CmdLineError _) = + text $ ": " ++ showGhcException e "" +ghcExceptionDoc (UsageError str) = strDoc str +ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\ +\GHC panic! (the 'impossible' happened)\n\ +\ ghc-mod version %s\n\ +\ GHC library version %s for %s:\n\ +\ %s\n\ +\\n\ +\Please report this as a bug: %s\n" + gmVer ghcVer platform msg url + where + gmVer = showVersion version + ghcVer = cProjectVersion + platform = cHostPlatformString + url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String + +ghcExceptionDoc e = text $ showGhcException e "" + +liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a +liftMaybe e action = maybe (throwError e) return =<< action + +overrideError :: MonadError e m => e -> m a -> m a +overrideError e action = modifyError (const e) action + +modifyError :: MonadError e m => (e -> e) -> m a -> m a +modifyError f action = action `catchError` \e -> throwError $ f e + +infixr 0 `modifyError'` +modifyError' :: MonadError e m => m a -> (e -> e) -> m a +modifyError' = flip modifyError + +modifyGmError :: (MonadIO m, ExceptionMonad m) + => (GhcModError -> GhcModError) -> m a -> m a +modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex) + +tryFix :: MonadError e m => m a -> (e -> m ()) -> m a +tryFix action f = do + action `catchError` \e -> f e >> action + +data GHandler m a = forall e . Exception e => GHandler (e -> m a) + +gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a +gcatches io handlers = io `gcatch` gcatchesHandler handlers + +gcatchesHandler :: (MonadIO m, ExceptionMonad m) + => [GHandler m a] -> SomeException -> m a +gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers + where tryHandler (GHandler handler) res + = case fromException e of + Just e' -> handler e' + Nothing -> res diff --git a/core/GhcMod/FileMapping.hs b/core/GhcMod/FileMapping.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/FileMapping.hs @@ -0,0 +1,104 @@ +module GhcMod.FileMapping + ( loadMappedFile + , loadMappedFileSource + , unloadMappedFile + , mapFile + , fileModSummaryWithMapping + ) where + +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.Gap +import GhcMod.HomeModuleGraph +import GhcMod.Utils + +import System.IO +import System.FilePath +import System.Directory + +import Control.Monad.Trans.Maybe +import GHC +import Control.Monad + +{- | maps 'FilePath', given as first argument to take source from +'FilePath' given as second argument. Works exactly the same as +first form of `--map-file` CLI option. + +\'from\' can be either full path, or path relative to project root. +\'to\' has to be either relative to project root, or full path (preferred) +-} +loadMappedFile :: IOish m + => FilePath -- ^ \'from\', file that will be mapped + -> FilePath -- ^ \'to\', file to take source from + -> GhcModT m () +loadMappedFile from to = loadMappedFile' from to False + +{- | +maps 'FilePath', given as first argument to have source as given +by second argument. + +\'from\' may or may not exist, and should be either full path, +or relative to project root. +-} +loadMappedFileSource :: IOish m + => FilePath -- ^ \'from\', file that will be mapped + -> String -- ^ \'src\', source + -> GhcModT m () +loadMappedFileSource from src = do + tmpdir <- cradleTempDir `fmap` cradle + enc <- liftIO . mkTextEncoding . optEncoding =<< options + to <- liftIO $ do + (fn, h) <- openTempFile tmpdir (takeFileName from) + hSetEncoding h enc + hPutStr h src + hClose h + return fn + loadMappedFile' from to True + +loadMappedFile' :: IOish m => FilePath -> FilePath -> Bool -> GhcModT m () +loadMappedFile' from to isTemp = do + cfn <- getCanonicalFileNameSafe from + unloadMappedFile' cfn + crdl <- cradle + let to' = makeRelative (cradleRootDir crdl) to + addMMappedFile cfn (FileMapping to' isTemp) + +mapFile :: (IOish m, GmState m) => HscEnv -> Target -> m Target +mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do + mapping <- lookupMMappedFile filePath + return $ mkMappedTarget (Just filePath) tid taoc mapping +mapFile env (Target tid@(TargetModule moduleName) taoc _) = do + (fp, mapping) <- do + filePath <- fmap (fmap mpPath) (liftIO $ findModulePath env moduleName) + mmf <- runMaybeT $ MaybeT (return filePath) >>= MaybeT . lookupMMappedFile + return (filePath, mmf) + return $ mkMappedTarget fp tid taoc mapping + +mkMappedTarget :: Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> Target +mkMappedTarget _ _ taoc (Just to) = + mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing +mkMappedTarget _ tid taoc _ = + mkTarget tid taoc Nothing + +{-| +unloads previously mapped file \'file\', so that it's no longer mapped, +and removes any temporary files created when file was +mapped. + +\'file\' should be either full path, or relative to project root. +-} +unloadMappedFile :: IOish m + => FilePath -- ^ \'file\', file to unmap + -> GhcModT m () +unloadMappedFile = getCanonicalFileNameSafe >=> unloadMappedFile' + +unloadMappedFile' :: IOish m => FilePath -> GhcModT m () +unloadMappedFile' cfn = void $ runMaybeT $ do + fm <- MaybeT $ lookupMMappedFile cfn + liftIO $ when (fmTemp fm) $ removeFile (fmPath fm) + delMMappedFile cfn + +fileModSummaryWithMapping :: (IOish m, GmState m, GhcMonad m, GmEnv m) => + FilePath -> m ModSummary +fileModSummaryWithMapping fn = + withMappedFile fn $ \fn' -> fileModSummary fn' diff --git a/core/GhcMod/Gap.hs b/core/GhcMod/Gap.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Gap.hs @@ -0,0 +1,723 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-} + +module GhcMod.Gap ( + GhcMod.Gap.ClsInst + , mkTarget + , withStyle + , GmLogAction + , setLogAction + , getSrcSpan + , getSrcFile + , withInteractiveContext + , ghcCmdOptions + , toStringBuffer + , showSeverityCaption + , setCabalPkg + , setHideAllPackages + , setDeferTypeErrors + , setDeferTypedHoles + , setWarnTypedHoles + , setDumpSplices + , setNoMaxRelevantBindings + , isDumpSplices + , filterOutChildren + , infoThing + , pprInfo + , HasType(..) + , errorMsgSpan + , setErrorMsgSpan + , typeForUser + , nameForUser + , occNameForUser + , deSugar + , showDocWith + , renderGm + , GapThing(..) + , fromTyThing + , fileModSummary + , WarnFlags + , emptyWarnFlags + , GLMatch + , GLMatchI + , getClass + , occName + , listVisibleModuleNames + , listVisibleModules + , lookupModulePackageInAllPackages + , GhcMod.Gap.isSynTyCon + , parseModuleHeader + , mkErrStyle' + , everythingStagedWithContext + , withCleanupSession + ) where + +import Control.Applicative hiding (empty) +import Control.Monad (filterM) +import CoreSyn (CoreExpr) +import Data.List (intersperse) +import Data.Maybe (catMaybes) +import Data.Time.Clock (UTCTime) +import Data.Traversable hiding (mapM) +import DataCon (dataConUserType) +import Desugar (deSugarExpr) +import DynFlags +import ErrUtils +import Exception +import FastString +import GhcMonad +import HscTypes +import NameSet +import OccName +import Outputable +import PprTyThing +import StringBuffer +import TcType +import Var (varType) +import System.Directory +import SysTools +#if __GLASGOW_HASKELL__ >= 800 +import GHCi (stopIServ) +#endif + +import qualified Name +import qualified InstEnv +import qualified Pretty +import qualified StringBuffer as SB + +#if __GLASGOW_HASKELL__ >= 710 +import CoAxiom (coAxiomTyCon) +#endif + +#if __GLASGOW_HASKELL__ >= 708 +import FamInstEnv +import ConLike (ConLike(..)) +import PatSyn +#else +import TcRnTypes +#endif + +-- GHC 7.8 doesn't define this macro, nor does GHC 7.10.0 +-- It IS defined from 7.10.1 and up though. +-- So we can only test for 7.10.1.0 and up with it. +#if __GLASGOW_HASKELL__ < 710 +#ifndef MIN_VERSION_GLASGOW_HASKELL +#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) FALSE +#endif +#endif + +#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117) +import GHC hiding (ClsInst, withCleanupSession) +import qualified GHC (withCleanupSession) +#elif __GLASGOW_HASKELL__ >= 706 +import GHC hiding (ClsInst) +#else +import GHC hiding (Instance) +import Control.Arrow hiding ((<+>)) +import Data.Convertible +import RdrName (rdrNameOcc) +#endif + +#if __GLASGOW_HASKELL__ < 710 +import UniqFM (eltsUFM) +import Module +#endif + +#if __GLASGOW_HASKELL__ >= 704 +import qualified Data.IntSet as I (IntSet, empty) +#endif + +#if __GLASGOW_HASKELL__ < 706 +import Control.DeepSeq (NFData(rnf)) +import Data.ByteString.Lazy.Internal (ByteString(..)) +#endif + +import Bag +import Lexer as L +import Parser +import SrcLoc +import Packages +import Data.Generics (GenericQ, extQ, gmapQ) +import GHC.SYB.Utils (Stage(..)) + +import GhcMod.Types (Expression(..)) +import Prelude + +---------------------------------------------------------------- +---------------------------------------------------------------- +-- +#if __GLASGOW_HASKELL__ >= 706 +type ClsInst = InstEnv.ClsInst +#else +type ClsInst = InstEnv.Instance +#endif + +mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target +#if __GLASGOW_HASKELL__ >= 706 +mkTarget = Target +#else +mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc +#if __GLASGOW_HASKELL__ >= 706 +withStyle = withPprStyleDoc +#else +withStyle _ = withPprStyleDoc +#endif + +#if __GLASGOW_HASKELL__ >= 800 +-- flip LogAction +type GmLogAction = WarnReason -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () +#elif __GLASGOW_HASKELL__ >= 706 +type GmLogAction = forall a. a -> LogAction +#else +type GmLogAction = forall a. a -> DynFlags -> LogAction +#endif + +-- DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () + +setLogAction :: DynFlags -> GmLogAction -> DynFlags +setLogAction df f = +#if __GLASGOW_HASKELL__ >= 800 + df { log_action = flip f } +#elif __GLASGOW_HASKELL__ >= 706 + df { log_action = f (error "setLogAction") } +#else + df { log_action = f (error "setLogAction") df } +#endif + +showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String +#if __GLASGOW_HASKELL__ >= 800 +showDocWith dflags mode = Pretty.renderStyle mstyle where + mstyle = Pretty.style { Pretty.mode = mode, Pretty.lineLength = pprCols dflags } +#elif __GLASGOW_HASKELL__ >= 708 +-- Pretty.showDocWith disappeard. +-- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc +showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags) +#else +showDocWith _ = Pretty.showDocWith +#endif + +renderGm :: Pretty.Doc -> String +#if __GLASGOW_HASKELL__ >= 800 +renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt "" +#else +renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt "" +#endif + where + string_txt :: Pretty.TextDetails -> String -> String + string_txt (Pretty.Chr c) s = c:s + string_txt (Pretty.Str s1) s2 = s1 ++ s2 + string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2 + string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2 +#if __GLASGOW_HASKELL__ >= 708 + string_txt (Pretty.ZStr s1) s2 = zString s1 ++ s2 +#endif + + +---------------------------------------------------------------- +---------------------------------------------------------------- + +getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) +#if __GLASGOW_HASKELL__ >= 702 +getSrcSpan (RealSrcSpan spn) +#else +getSrcSpan spn | isGoodSrcSpan spn +#endif + = Just (srcSpanStartLine spn + , srcSpanStartCol spn + , srcSpanEndLine spn + , srcSpanEndCol spn) +getSrcSpan _ = Nothing + +getSrcFile :: SrcSpan -> Maybe String +#if __GLASGOW_HASKELL__ >= 702 +getSrcFile (RealSrcSpan spn) = Just . unpackFS . srcSpanFile $ spn +#else +getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn +#endif +getSrcFile _ = Nothing + +---------------------------------------------------------------- + +toStringBuffer :: GhcMonad m => [String] -> m StringBuffer +#if __GLASGOW_HASKELL__ >= 702 +toStringBuffer = return . stringToStringBuffer . unlines +#else +toStringBuffer = liftIO . stringToStringBuffer . unlines +#endif + +---------------------------------------------------------------- + +ghcCmdOptions :: [String] +#if __GLASGOW_HASKELL__ >= 710 +-- this also includes -X options and all sorts of other things so the +ghcCmdOptions = flagsForCompletion False +#else +ghcCmdOptions = [ "-f" ++ prefix ++ option + | option <- opts + , prefix <- ["","no-"] + ] +# if __GLASGOW_HASKELL__ >= 704 + where opts = + [option | (option,_,_) <- fFlags] + ++ [option | (option,_,_) <- fWarningFlags] + ++ [option | (option,_,_) <- fLangFlags] +# else + where opts = + [option | (option,_,_,_) <- fFlags] + ++ [option | (option,_,_,_) <- fWarningFlags] + ++ [option | (option,_,_,_) <- fLangFlags] +# endif +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +fileModSummary :: GhcMonad m => FilePath -> m ModSummary +fileModSummary file' = do + mss <- getModuleGraph + file <- liftIO $ canonicalizePath file' + [ms] <- liftIO $ flip filterM mss $ \m -> + (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m) + return ms + +withInteractiveContext :: GhcMonad m => m a -> m a +withInteractiveContext action = gbracket setup teardown body + where + setup = getContext + teardown = setCtx + body _ = do + topImports >>= setCtx + action + topImports = do + ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph + let iis = map (IIModule . modName) ms +#if __GLASGOW_HASKELL__ >= 704 + return iis +#else + return (iis,[]) +#endif +#if __GLASGOW_HASKELL__ >= 706 + modName = moduleName + setCtx = setContext +#elif __GLASGOW_HASKELL__ >= 704 + modName = id + setCtx = setContext +#else + modName = ms_mod + setCtx = uncurry setContext +#endif + +showSeverityCaption :: Severity -> String +#if __GLASGOW_HASKELL__ >= 706 +showSeverityCaption SevWarning = "Warning: " +showSeverityCaption _ = "" +#else +showSeverityCaption = const "" +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +setCabalPkg :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 708 +setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage +#else +setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage +#endif + +---------------------------------------------------------------- + +setHideAllPackages :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 708 +setHideAllPackages df = gopt_set df Opt_HideAllPackages +#else +setHideAllPackages df = dopt_set df Opt_HideAllPackages +#endif + +---------------------------------------------------------------- + +setDumpSplices :: DynFlags -> DynFlags +setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices + +isDumpSplices :: DynFlags -> Bool +isDumpSplices dflag = dopt Opt_D_dump_splices dflag + +---------------------------------------------------------------- + + +setDeferTypeErrors :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 708 +setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors +#elif __GLASGOW_HASKELL__ >= 706 +setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors +#else +setDeferTypeErrors = id +#endif + +setDeferTypedHoles :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 710 +setDeferTypedHoles dflag = gopt_set dflag Opt_DeferTypedHoles +#else +setDeferTypedHoles = id +#endif + +setWarnTypedHoles :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 708 +setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles +#else +setWarnTypedHoles = id +#endif + +---------------------------------------------------------------- + +-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings". +setNoMaxRelevantBindings :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 708 +setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing } +#else +setNoMaxRelevantBindings = id +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +class HasType a where + getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type)) + + +instance HasType (LHsBind Id) where +#if __GLASGOW_HASKELL__ >= 708 + getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ) + where in_tys = mg_arg_tys m + out_typ = mg_res_ty m + typ = mkFunTys in_tys out_typ +#else + getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ) +#endif + getType _ _ = return Nothing + +---------------------------------------------------------------- +---------------------------------------------------------------- +-- from ghc/InteractiveUI.hs + +filterOutChildren :: (a -> TyThing) -> [a] -> [a] +filterOutChildren get_thing xs + = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] + where + implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] + +infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc +infoThing m (Expression str) = do + names <- parseName str +#if __GLASGOW_HASKELL__ >= 708 + mb_stuffs <- mapM (getInfo False) names + let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs) +#else + mb_stuffs <- mapM getInfo names + let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) +#endif + return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered) + +#if __GLASGOW_HASKELL__ >= 708 +pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc +pprInfo m _ (thing, fixity, insts, famInsts) + = pprTyThingInContextLoc' thing + $$ show_fixity fixity + $$ vcat (map pprInstance' insts) + $$ vcat (map pprFamInst' famInsts) +#else +pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc +pprInfo m pefas (thing, fixity, insts) + = pprTyThingInContextLoc' pefas thing + $$ show_fixity fixity + $$ vcat (map pprInstance' insts) +#endif + where + show_fixity fx + | fx == defaultFixity = Outputable.empty + | otherwise = ppr fx <+> ppr (getName thing) +#if __GLASGOW_HASKELL__ >= 708 + pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing') +#if __GLASGOW_HASKELL__ >= 710 + pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc }) + = pprTyThingInContextLoc (ATyCon rep_tc) + + pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom + , fi_tys = lhs_tys, fi_rhs = rhs }) + = showWithLoc (pprDefinedAt' (getName axiom)) $ + hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) + 2 (equals <+> ppr rhs) +#else + pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec) +#endif +#else + pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing') +#endif + showWithLoc loc doc + = hang doc 2 (char '\t' <> comment <+> loc) + -- The tab tries to make them line up a bit + where + comment = ptext (sLit "--") + pprInstance' ispec = hang (pprInstanceHdr ispec) + 2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec)) + pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') + pprNameDefnLoc' name + = case Name.nameSrcLoc name of + RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s) + UnhelpfulLoc s + | Name.isInternalName name || Name.isSystemName name + -> ptext (sLit "at") <+> ftext s + | otherwise + -> ptext (sLit "in") <+> quotes (ppr (nameModule name)) + where subst s = mkRealSrcLoc (realFP s) (srcLocLine s) (srcLocCol s) + realFP = mkFastString . m . unpackFS . srcLocFile + +---------------------------------------------------------------- +---------------------------------------------------------------- + +errorMsgSpan :: ErrMsg -> SrcSpan +#if __GLASGOW_HASKELL__ >= 708 +errorMsgSpan = errMsgSpan +#else +errorMsgSpan = head . errMsgSpans +#endif + +setErrorMsgSpan :: ErrMsg -> SrcSpan -> ErrMsg +#if __GLASGOW_HASKELL__ >= 708 +setErrorMsgSpan err s = err { errMsgSpan = s } +#else +setErrorMsgSpan err s = err { errMsgSpans = [s] } +#endif + +typeForUser :: Type -> SDoc +#if __GLASGOW_HASKELL__ >= 708 +typeForUser = pprTypeForUser +#else +typeForUser = pprTypeForUser False +#endif + +nameForUser :: Name -> SDoc +nameForUser = pprOccName . getOccName + +occNameForUser :: OccName -> SDoc +occNameForUser = pprOccName + +deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv + -> IO (Maybe CoreExpr) +#if __GLASGOW_HASKELL__ >= 708 +deSugar _ e hs_env = snd <$> deSugarExpr hs_env e +#else +deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e + where + modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm + tcgEnv = fst $ tm_internals_ tcm + rn_env = tcg_rdr_env tcgEnv + ty_env = tcg_type_env tcgEnv +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +data GapThing = GtA Type + | GtT TyCon + | GtN +#if __GLASGOW_HASKELL__ >= 800 + | GtPatSyn PatSyn +#endif + +fromTyThing :: TyThing -> GapThing +fromTyThing (AnId i) = GtA $ varType i +#if __GLASGOW_HASKELL__ >= 708 +fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConUserType d +#if __GLASGOW_HASKELL__ >= 800 +fromTyThing (AConLike (PatSynCon p)) = GtPatSyn p +#else +fromTyThing (AConLike (PatSynCon p)) = GtA $ patSynType p +#endif +#else +fromTyThing (ADataCon d) = GtA $ dataConUserType d +#endif +fromTyThing (ATyCon t) = GtT t +fromTyThing _ = GtN + +---------------------------------------------------------------- +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 704 +type WarnFlags = I.IntSet +emptyWarnFlags :: WarnFlags +emptyWarnFlags = I.empty +#else +type WarnFlags = [WarningFlag] +emptyWarnFlags :: WarnFlags +emptyWarnFlags = [] +#endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 708 +type GLMatch = LMatch RdrName (LHsExpr RdrName) +type GLMatchI = LMatch Id (LHsExpr Id) +#else +type GLMatch = LMatch RdrName +type GLMatchI = LMatch Id +#endif + +getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) +#if __GLASGOW_HASKELL__ >= 800 +-- Instance declarations of sort 'instance F (G a)' +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsForAllTy _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))))}))] = Just (className, loc) +-- Instance declarations of sort 'instance F G' (no variables) +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))}))] = Just (className, loc) +#elif __GLASGOW_HASKELL__ >= 710 +-- Instance declarations of sort 'instance F (G a)' +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc) +-- Instance declarations of sort 'instance F G' (no variables) +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc) +#elif __GLASGOW_HASKELL__ >= 708 +-- Instance declarations of sort 'instance F (G a)' +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc) +-- Instance declarations of sort 'instance F G' (no variables) +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc) +#elif __GLASGOW_HASKELL__ >= 706 +getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc) +getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc) +#else +getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc) +getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc) +#endif +getClass _ = Nothing + +#if __GLASGOW_HASKELL__ < 706 +occName :: RdrName -> OccName +occName = rdrNameOcc +#endif + +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ < 710 +-- Copied from ghc/InteractiveUI.hs +allExposedPackageConfigs :: DynFlags -> [PackageConfig] +allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df + +allExposedModules :: DynFlags -> [ModuleName] +allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df + +listVisibleModuleNames :: DynFlags -> [ModuleName] +listVisibleModuleNames = allExposedModules +#endif + +lookupModulePackageInAllPackages :: + DynFlags -> ModuleName -> [String] +lookupModulePackageInAllPackages df mn = +#if __GLASGOW_HASKELL__ >= 710 + unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn + where + unpackSPId (SourcePackageId fs) = unpackFS fs +#else + unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn + where + unpackPId pid = packageIdString $ mkPackageId pid +-- n ++ "-" ++ showVersion v +#endif + +listVisibleModules :: DynFlags -> [GHC.Module] +listVisibleModules df = let +#if __GLASGOW_HASKELL__ >= 710 + modNames = listVisibleModuleNames df + mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ] +#else + pkgCfgs = allExposedPackageConfigs df + mods = [ mkModule pid modname | p <- pkgCfgs + , let pid = packageConfigId p + , modname <- exposedModules p ] +#endif + in mods + +isSynTyCon :: TyCon -> Bool +#if __GLASGOW_HASKELL__ >= 710 +isSynTyCon = GHC.isTypeSynonymTyCon +#else +isSynTyCon = GHC.isSynTyCon +#endif + + +parseModuleHeader + :: String -- ^ Haskell module source text (full Unicode is supported) + -> DynFlags + -> FilePath -- ^ the filename (for source locations) + -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) +parseModuleHeader str dflags filename = + let + loc = mkRealSrcLoc (mkFastString filename) 1 1 + buf = stringToStringBuffer str + in + case L.unP Parser.parseHeader (mkPState dflags buf loc) of + + PFailed sp err -> +#if __GLASGOW_HASKELL__ >= 706 + Left (unitBag (mkPlainErrMsg dflags sp err)) +#else + Left (unitBag (mkPlainErrMsg sp err)) +#endif + + POk pst rdr_module -> + let (warns,_) = getMessages pst in + Right (warns, rdr_module) + +mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle +#if __GLASGOW_HASKELL__ >= 706 +mkErrStyle' = Outputable.mkErrStyle +#else +mkErrStyle' _ = Outputable.mkErrStyle +#endif + +#if __GLASGOW_HASKELL__ < 706 +instance NFData ByteString where + rnf Empty = () + rnf (Chunk _ b) = rnf b +#endif + +-- | Like 'everything', but avoid known potholes, based on the 'Stage' that +-- generated the Ast. +everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r +everythingStagedWithContext stage s0 f z q x + | (const False +#if __GLASGOW_HASKELL__ <= 708 + `extQ` postTcType +#endif + `extQ` fixity `extQ` nameSet) x = z + | otherwise = foldl f r (gmapQ (everythingStagedWithContext stage s' f z q) x) + where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool +#if __GLASGOW_HASKELL__ <= 708 + postTcType = const (stage Bool +#endif + fixity = const (stage Bool + (r, s') = q x s0 + +withCleanupSession :: GhcMonad m => m a -> m a +#if __GLASGOW_HASKELL__ >= 800 +#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117) +withCleanupSession = GHC.withCleanupSession +#else +withCleanupSession ghc = ghc `gfinally` cleanup + where + cleanup = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + liftIO $ do + cleanTempFiles dflags + cleanTempDirs dflags + stopIServ hsc_env +#endif +#else +withCleanupSession action = do + df <- getSessionDynFlags + GHC.defaultCleanupHandler df action +#endif diff --git a/core/GhcMod/GhcPkg.hs b/core/GhcMod/GhcPkg.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/GhcPkg.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-} +module GhcMod.GhcPkg ( + ghcPkgDbOpt + , ghcPkgDbStackOpts + , ghcDbStackOpts + , ghcDbOpt + , getPackageDbStack + , getPackageCachePaths + , getGhcPkgProgram + ) where + +import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) +import Control.Applicative +import Data.List.Split (splitOn) +import Data.Maybe +import Exception (handleIO) +import System.Directory (doesDirectoryExist, getAppUserDataDirectory) +import System.FilePath (()) +import Prelude + +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.CabalHelper +import GhcMod.PathsAndFiles +import GhcMod.CustomPackageDb +import GhcMod.Stack + +ghcVersion :: Int +ghcVersion = read cProjectVersionInt + +---------------------------------------------------------------- + +-- | Get options needed to add a list of package dbs to ghc-pkg's db stack +ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack + -> [String] +ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs + +-- | Get options needed to add a list of package dbs to ghc's db stack +ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack + -> [String] +ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs + +---------------------------------------------------------------- + +ghcPkgDbOpt :: GhcPkgDb -> [String] +ghcPkgDbOpt GlobalDb = ["--global"] +ghcPkgDbOpt UserDb = ["--user"] +ghcPkgDbOpt (PackageDb pkgDb) + | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb] + | otherwise = ["--no-user-package-db", "--package-db=" ++ pkgDb] + +ghcDbOpt :: GhcPkgDb -> [String] +ghcDbOpt GlobalDb + | ghcVersion < 706 = ["-global-package-conf"] + | otherwise = ["-global-package-db"] +ghcDbOpt UserDb + | ghcVersion < 706 = ["-user-package-conf"] + | otherwise = ["-user-package-db"] +ghcDbOpt (PackageDb pkgDb) + | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb] + | otherwise = ["-no-user-package-db", "-package-db", pkgDb] + +---------------------------------------------------------------- + +getGhcPkgProgram :: IOish m => GhcModT m FilePath +getGhcPkgProgram = do + crdl <- cradle + progs <- optPrograms <$> options + case cradleProject crdl of + (StackProject senv) -> do + Just ghcPkg <- getStackGhcPkgPath senv + return ghcPkg + _ -> + return $ ghcPkgProgram progs + +getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb] +getPackageDbStack = do + crdl <- cradle + mCusPkgStack <- getCustomPkgDbStack + stack <- case cradleProject crdl of + PlainProject -> + return [GlobalDb, UserDb] + SandboxProject -> do + Just db <- liftIO $ getSandboxDb crdl + return $ [GlobalDb, db] + CabalProject -> + getCabalPackageDbStack + (StackProject StackEnv {..}) -> + return $ [GlobalDb, PackageDb seSnapshotPkgDb, PackageDb seLocalPkgDb] + return $ fromMaybe stack mCusPkgStack + +getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath] +getPackageCachePaths sysPkgCfg = do + pkgDbStack <- getPackageDbStack + catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack + +-- TODO: use PkgConfRef +--- Copied from ghc module `Packages' unfortunately it's not exported :/ +resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath) +resolvePackageConfig sysPkgCfg GlobalDb = return $ Just sysPkgCfg +resolvePackageConfig _ UserDb = handleIO (\_ -> return Nothing) $ do + appdir <- getAppUserDataDirectory "ghc" + let dir = appdir (target_arch ++ '-':target_os ++ '-':cProjectVersion) + pkgconf = dir "package.conf.d" + exist <- doesDirectoryExist pkgconf + return $ if exist then Just pkgconf else Nothing + where + [target_arch,_,target_os] = splitOn "-" cTargetPlatformString +resolvePackageConfig _ (PackageDb name) = return $ Just name diff --git a/core/GhcMod/HomeModuleGraph.hs b/core/GhcMod/HomeModuleGraph.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/HomeModuleGraph.hs @@ -0,0 +1,271 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-} +module GhcMod.HomeModuleGraph ( + GmModuleGraph(..) + , ModulePath(..) + , mkFileMap + , mkModuleMap + , mkMainModulePath + , findModulePath + , findModulePathSet + , fileModuleName + , canonicalizeModulePath + , homeModuleGraph + , updateHomeModuleGraph + , canonicalizeModuleGraph + , reachable + , moduleGraphToDot + ) where + +import DriverPipeline +import DynFlags +import ErrUtils +import Exception +import Finder +import GHC +import HscTypes +import Pretty + +import Control.Arrow ((&&&)) +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Control.Monad.State.Strict (execStateT) +import Control.Monad.State.Class +import Data.Maybe +import Data.Monoid as Monoid +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import System.FilePath +import System.Directory +import System.IO +import Prelude + +import GhcMod.Logging +import GhcMod.Logger +import GhcMod.Monad.Types +import GhcMod.Types +import GhcMod.Utils (withMappedFile) +import GhcMod.Gap (parseModuleHeader) + +-- | Turn module graph into a graphviz dot file +-- +-- @dot -Tpng -o modules.png modules.dot@ +moduleGraphToDot :: GmModuleGraph -> String +moduleGraphToDot GmModuleGraph { gmgGraph } = + "digraph {\n" ++ concatMap edges (Map.toList graph) ++ "}\n" + where + graph = Map.map (Set.mapMonotonic mpPath) + $ Map.mapKeysMonotonic mpPath gmgGraph + edges :: (FilePath, (Set FilePath)) -> String + edges (f, sf) = + concatMap (\f' -> " \""++ f ++"\" -> \""++ f' ++"\"\n") (Set.toList sf) + +data S = S { + sErrors :: [(ModulePath, ErrorMessages)], + sWarnings :: [(ModulePath, WarningMessages)], + sGraph :: GmModuleGraph +} + +defaultS :: S +defaultS = S [] [] mempty + +putErr :: MonadState S m + => (ModulePath, ErrorMessages) -> m () +putErr e = do + s <- get + put s { sErrors = e:sErrors s} + +putWarn :: MonadState S m + => (ModulePath, ErrorMessages) -> m () +putWarn w = do + s <- get + put s { sWarnings = w:sWarnings s} + +gmgLookupMP :: MonadState S m => ModulePath -> m (Maybe (Set ModulePath)) +gmgLookupMP k = (Map.lookup k . gmgGraph . sGraph) `liftM` get + +graphUnion :: MonadState S m => GmModuleGraph -> m () +graphUnion gmg = do + s <- get + put s { sGraph = sGraph s `mappend` gmg } + +reachable :: Set ModulePath -> GmModuleGraph -> Set ModulePath +reachable smp0 GmModuleGraph {..} = go smp0 + where + go smp = let + δsmp = Set.unions $ + collapseMaybeSet . flip Map.lookup gmgGraph <$> Set.toList smp + smp' = smp `Set.union` δsmp + in if smp == smp' then smp' else go smp' + +pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph +pruneUnreachable smp0 gmg@GmModuleGraph {..} = let + r = reachable smp0 gmg + in + GmModuleGraph { + gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph + } + +collapseMaybeSet :: Maybe (Set a) -> Set a +collapseMaybeSet = maybe Set.empty id + +homeModuleGraph :: (IOish m, Gm m) + => HscEnv -> Set ModulePath -> m GmModuleGraph +homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp + +mkMainModulePath :: FilePath -> ModulePath +mkMainModulePath = ModulePath (mkModuleName "Main") + +findModulePath :: HscEnv -> ModuleName -> IO (Maybe ModulePath) +findModulePath env mn = do + fmap (ModulePath mn) <$> find env mn + +findModulePathSet :: HscEnv -> [ModuleName] -> IO (Set ModulePath) +findModulePathSet env mns = do + Set.fromList . catMaybes <$> findModulePath env `mapM` mns + +find :: MonadIO m => HscEnv -> ModuleName -> m (Maybe FilePath) +find env mn = liftIO $ do + res <- findHomeModule env mn + case res of + -- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc + Found loc@ModLocation { ml_hs_file = Just _ } _mod -> + return $ normalise <$> ml_hs_file loc + _ -> return Nothing + + +canonicalizeModulePath :: ModulePath -> IO ModulePath +canonicalizeModulePath (ModulePath mn fp) = ModulePath mn <$> canonicalizePath fp + +canonicalizeModuleGraph :: MonadIO m => GmModuleGraph -> m GmModuleGraph +canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do + GmModuleGraph . Map.fromList <$> mapM fmg (Map.toList gmgGraph) + where + fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp)) + + +updateHomeModuleGraph :: (IOish m, Gm m) + => HscEnv + -> GmModuleGraph + -> Set ModulePath -- ^ Initial set of modules + -> Set ModulePath -- ^ Updated set of modules + -> m GmModuleGraph +updateHomeModuleGraph env GmModuleGraph {..} smp sump = do + -- TODO: It would be good if we could retain information about modules that + -- stop to compile after we've already successfully parsed them at some + -- point. Figure out a way to delete the modules about to be updated only + -- after we're sure they won't fail to parse .. or something. Should probably + -- push this whole prune logic deep into updateHomeModuleGraph' + (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env sump) + where + runS = flip execStateT defaultS { sGraph = graph' } + graph' = GmModuleGraph { + gmgGraph = Set.foldr Map.delete gmgGraph sump + } + +mkFileMap :: Set ModulePath -> Map FilePath ModulePath +mkFileMap smp = Map.fromList $ map (mpPath &&& id) $ Set.toList smp + +mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath +mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp + +updateHomeModuleGraph' + :: forall m. (MonadState S m, IOish m, Gm m) + => HscEnv + -> Set ModulePath -- ^ Initial set of modules + -> m () +updateHomeModuleGraph' env smp0 = do + go `mapM_` Set.toList smp0 + where + go :: ModulePath -> m () + go mp = do + msmp <- gmgLookupMP mp + case msmp of + Just _ -> return () + Nothing -> do + smp <- collapseMaybeSet `liftM` step mp + + graphUnion GmModuleGraph { + gmgGraph = Map.singleton mp smp + } + + mapM_ go (Set.toList smp) + + step :: ModulePath -> m (Maybe (Set ModulePath)) + step mp = runMaybeT $ do + (dflags, ppsrc_fn) <- MaybeT preprocess' + src <- liftIO $ readFile ppsrc_fn + imports mp src dflags + where + preprocess' :: m (Maybe (DynFlags, FilePath)) + preprocess' = do + let fn = mpPath mp + ep <- preprocessFile env fn + case ep of + Right (_, x) -> return $ Just x + Left errs -> do + -- TODO: Remember these and present them as proper errors if this is + -- the file the user is looking at. + gmLog GmWarning ("preprocess " ++ show fn) $ Pretty.empty $+$ (vcat $ map text errs) + return Nothing + + + imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath) + imports mp@ModulePath {..} src dflags = + case parseModuleHeader src dflags mpPath of + Left err -> do + putErr (mp, err) + mzero + + Right (ws, lmdl) -> do + putWarn (mp, ws) + let HsModule {..} = unLoc lmdl + mns = map (unLoc . ideclName) + $ filter (isNothing . ideclPkgQual) + $ map unLoc hsmodImports + -- TODO: handle package qualifier "this" + liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns + +preprocessFile :: (IOish m, GmEnv m, GmState m) => + HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath))) +preprocessFile env file = + withLogger' env $ \setDf -> do + withMappedFile file $ \fn -> do + let env' = env { hsc_dflags = setDf (hsc_dflags env) } + liftIO $ preprocess env' (fn, Nothing) + +fileModuleName :: (IOish m, GmEnv m, GmState m) => + HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName)) +fileModuleName env fn = do + let handler = liftIO . handle (\(_ :: SomeException) -> return $ Right Nothing) + ep <- preprocessFile env fn + case ep of + Left errs -> do + return $ Left errs + Right (_warns, (dflags, procdFile)) -> leftM (errBagToStrList env) =<< handler (do + src <- readFile procdFile + case parseModuleHeader src dflags procdFile of + Left errs -> return $ Left errs + Right (_, lmdl) -> do + let HsModule {..} = unLoc lmdl + return $ Right $ unLoc <$> hsmodName) + where + leftM f = either (return . Left <=< f) (return . Right) diff --git a/core/GhcMod/LightGhc.hs b/core/GhcMod/LightGhc.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/LightGhc.hs @@ -0,0 +1,60 @@ +module GhcMod.LightGhc where + +import Control.Monad +import Control.Monad.Reader (runReaderT) +import Data.IORef + +import GHC +import GHC.Paths (libdir) +import StaticFlags +import SysTools +import DynFlags +import HscMain +import HscTypes + +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.DynFlags +import qualified GhcMod.Gap as Gap + +-- We have to be more careful about tearing down 'HscEnv's since GHC 8 added an +-- out of process GHCI server which has to be shutdown. +newLightEnv :: IOish m => (DynFlags -> LightGhc DynFlags) -> m HscEnv +newLightEnv mdf = do + df <- liftIO $ do + initStaticOpts + settings <- initSysTools (Just libdir) + initDynFlags $ defaultDynFlags settings + + hsc_env <- liftIO $ newHscEnv df + df' <- runLightGhc hsc_env $ mdf df + return $ hsc_env { + hsc_dflags = df', + hsc_IC = (hsc_IC hsc_env) { ic_dflags = df' } + } + +teardownLightEnv :: MonadIO m => HscEnv -> m () +teardownLightEnv env = runLightGhc env $ do + Gap.withCleanupSession $ return () + +withLightHscEnv' + :: IOish m => (DynFlags -> LightGhc DynFlags) -> (HscEnv -> m a) -> m a +withLightHscEnv' mdf action = gbracket (newLightEnv mdf) teardownLightEnv action + +withLightHscEnv :: IOish m => [GHCOption] -> (HscEnv -> m a) -> m a +withLightHscEnv opts = withLightHscEnv' (f <=< liftIO . newHscEnv) + where + f env = runLightGhc env $ do + -- HomeModuleGraph and probably all other clients get into all sorts of + -- trouble if the package state isn't initialized here + _ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags + getSessionDynFlags + +runLightGhc :: MonadIO m => HscEnv -> LightGhc a -> m a +runLightGhc env action = liftIO $ do + renv <- newIORef env + flip runReaderT renv $ unLightGhc action + +runLightGhc' :: MonadIO m => IORef HscEnv -> LightGhc a -> m a +runLightGhc' renv action = liftIO $ do + flip runReaderT renv $ unLightGhc action diff --git a/core/GhcMod/Logger.hs b/core/GhcMod/Logger.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Logger.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP, RankNTypes #-} + +module GhcMod.Logger ( + withLogger + , withLogger' + , checkErrorPrefix + , errsToStr + , errBagToStrList + ) where + +import Control.Arrow +import Control.Applicative +import Data.Ord +import Data.List +import Data.Maybe +import Data.Function +import Control.Monad.Reader (Reader, ask, runReader) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) +import System.FilePath (normalise) + +import ErrUtils +import GHC +import HscTypes +import Outputable +import qualified GHC as G +import Bag +import SrcLoc +import FastString + +import GhcMod.Convert +import GhcMod.Doc (showPage) +import GhcMod.DynFlags (withDynFlags) +import GhcMod.Monad.Types +import GhcMod.Error +import GhcMod.Pretty +import GhcMod.Utils (mkRevRedirMapFunc) +import qualified GhcMod.Gap as Gap +import Prelude + +type Builder = [String] -> [String] + +data Log = Log [String] Builder + +newtype LogRef = LogRef (IORef Log) + +data GmPprEnv = GmPprEnv { gpeDynFlags :: DynFlags + , gpeMapFile :: FilePath -> FilePath + } + +type GmPprEnvM a = Reader GmPprEnv a + +emptyLog :: Log +emptyLog = Log [] id + +newLogRef :: IO LogRef +newLogRef = LogRef <$> newIORef emptyLog + +readAndClearLogRef :: LogRef -> IO [String] +readAndClearLogRef (LogRef ref) = do + Log _ b <- readIORef ref + writeIORef ref emptyLog + return $ b [] + +appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction +appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do + modifyIORef ref update + where + -- TODO: get rid of ppMsg and just do more or less what ghc's + -- defaultLogAction does + l = ppMsg map_file df st src sev msg + + update lg@(Log ls b) + | l `elem` ls = lg + | otherwise = Log (l:ls) (b . (l:)) + +---------------------------------------------------------------- + +-- | Logged messages are returned as 'String'. +-- Right is success and Left is failure. +withLogger :: (GmGhc m, GmEnv m, GmOut m, GmState m) + => (DynFlags -> DynFlags) + -> m a + -> m (Either String (String, a)) +withLogger f action = do + env <- G.getSession + oopts <- outputOpts + let conv = convert oopts + eres <- withLogger' env $ \setDf -> + withDynFlags (f . setDf) action + return $ either (Left . conv) (Right . first conv) eres + +withLogger' :: (IOish m, GmState m, GmEnv m) + => HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a)) +withLogger' env action = do + logref <- liftIO $ newLogRef + + rfm <- mkRevRedirMapFunc + + let setLogger df = Gap.setLogAction df $ appendLogRef rfm df logref + handlers = [ + GHandler $ \ex -> return $ Left $ runReader (sourceError ex) gpe, + GHandler $ \ex -> return $ Left [renderGm $ ghcExceptionDoc ex] + ] + gpe = GmPprEnv { + gpeDynFlags = hsc_dflags env + , gpeMapFile = rfm + } + + a <- gcatches (Right <$> action setLogger) handlers + ls <- liftIO $ readAndClearLogRef logref + + return ((,) ls <$> a) + +errBagToStrList :: (IOish m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String] +errBagToStrList env errs = do + rfm <- mkRevRedirMapFunc + return $ runReader + (errsToStr (sortMsgBag errs)) + GmPprEnv{ gpeDynFlags = hsc_dflags env, gpeMapFile = rfm } + +---------------------------------------------------------------- + +-- | Converting 'SourceError' to 'String'. +sourceError :: SourceError -> GmPprEnvM [String] +sourceError = errsToStr . sortMsgBag . srcErrorMessages + +errsToStr :: [ErrMsg] -> GmPprEnvM [String] +errsToStr = mapM ppErrMsg + +sortMsgBag :: Bag ErrMsg -> [ErrMsg] +sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag + +---------------------------------------------------------------- + +ppErrMsg :: ErrMsg -> GmPprEnvM String +ppErrMsg err = do + GmPprEnv {..} <- ask + let unqual = errMsgContext err + st = Gap.mkErrStyle' gpeDynFlags unqual + err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err) + return $ showPage gpeDynFlags st $ pprLocErrMsg err' + +mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan +mapSrcSpanFile map_file (RealSrcSpan s) = + RealSrcSpan $ mapRealSrcSpanFile map_file s +mapSrcSpanFile _ (UnhelpfulSpan s) = + UnhelpfulSpan s + +mapRealSrcSpanFile :: (FilePath -> FilePath) -> RealSrcSpan -> RealSrcSpan +mapRealSrcSpanFile map_file s = let + start = mapRealSrcLocFile map_file $ realSrcSpanStart s + end = mapRealSrcLocFile map_file $ realSrcSpanEnd s + in + mkRealSrcSpan start end + +mapRealSrcLocFile :: (FilePath -> FilePath) -> RealSrcLoc -> RealSrcLoc +mapRealSrcLocFile map_file l = let + file = mkFastString $ map_file $ unpackFS $ srcLocFile l + line = srcLocLine l + col = srcLocCol l + in + mkRealSrcLoc file line col + +ppMsg :: (FilePath -> FilePath) -> DynFlags -> PprStyle -> SrcSpan -> Severity -> SDoc -> String +ppMsg map_file df st spn sev msg = let + cts = showPage df st msg + in + ppMsgPrefix map_file df spn sev cts ++ cts + +ppMsgPrefix :: (FilePath -> FilePath) -> DynFlags -> SrcSpan -> Severity -> String -> String +ppMsgPrefix map_file df spn sev cts = + let + defaultPrefix = if Gap.isDumpSplices df then "" else checkErrorPrefix + in + fromMaybe defaultPrefix $ do + (line,col,_,_) <- Gap.getSrcSpan spn + file <- map_file <$> normalise <$> Gap.getSrcFile spn + return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ + if or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes) + then "" + else Gap.showSeverityCaption sev + +checkErrorPrefix :: String +checkErrorPrefix = "Dummy:0:0:Error:" + +warningAsErrorPrefixes :: [String] +warningAsErrorPrefixes = [ "Couldn't match expected type" + , "Couldn't match type" + , "No instance for"] diff --git a/core/GhcMod/Logging.hs b/core/GhcMod/Logging.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Logging.hs @@ -0,0 +1,115 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GhcMod.Logging ( + module GhcMod.Logging + , module GhcMod.Pretty + , GmLogLevel(..) + , module Data.Monoid + , module Pretty + ) where + +import Control.Applicative hiding (empty) +import Control.Monad +import Control.Monad.Trans.Class +import Data.List +import Data.Char +import Data.Monoid +import Data.Maybe +import System.IO +import System.FilePath +import Prelude + +import Pretty hiding (style, (<>)) + +import GhcMod.Monad.Types +import GhcMod.Types +import GhcMod.Pretty +import GhcMod.Output + +gmSetLogLevel :: GmLog m => GmLogLevel -> m () +gmSetLogLevel level = + gmlJournal $ GhcModLog (Just level) (Last Nothing) [] + +gmGetLogLevel :: forall m. GmLog m => m GmLogLevel +gmGetLogLevel = do + GhcModLog { gmLogLevel = Just level } <- gmlHistory + return level + +gmSetDumpLevel :: GmLog m => Bool -> m () +gmSetDumpLevel level = + gmlJournal $ GhcModLog Nothing (Last (Just level)) [] + + +increaseLogLevel :: GmLogLevel -> GmLogLevel +increaseLogLevel l | l == maxBound = l +increaseLogLevel l = succ l + +decreaseLogLevel :: GmLogLevel -> GmLogLevel +decreaseLogLevel l | l == minBound = l +decreaseLogLevel l = pred l + +-- | +-- >>> Just GmDebug <= Nothing +-- False +-- >>> Just GmException <= Just GmDebug +-- True +-- >>> Just GmDebug <= Just GmException +-- False +gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m () +gmLog level loc' doc = do + GhcModLog { gmLogLevel = Just level' } <- gmlHistory + + let loc | loc' == "" = empty + | otherwise = text loc' <+>: empty + msgDoc = sep [loc, doc] + msg = dropWhileEnd isSpace $ renderGm $ gmLogLevelDoc level <+>: msgDoc + + when (level <= level') $ gmErrStrLn msg + gmLogQuiet level loc' doc + +gmLogQuiet :: GmLog m => GmLogLevel -> String -> Doc -> m () +gmLogQuiet level loc doc = + gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc, doc)]) + +gmAppendLogQuiet :: GmLog m => GhcModLog -> m () +gmAppendLogQuiet GhcModLog { gmLogMessages } = + forM_ gmLogMessages $ \(level, loc, doc) -> gmLogQuiet level loc doc + +gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m () +gmVomit filename doc content = do + gmLog GmVomit "" $ doc <+>: text content + + GhcModLog { gmLogVomitDump = Last mdump } + <- gmlHistory + + dir <- cradleTempDir `liftM` cradle + when (fromMaybe False mdump) $ + liftIO $ writeFile (dir filename) content + + +newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a } + deriving (Functor, Applicative, Monad) + +instance MonadTrans LogDiscardT where + lift = LogDiscardT + +instance Monad m => GmLog (LogDiscardT m) where + gmlJournal = const $ return () + gmlHistory = return mempty + gmlClear = return () diff --git a/core/GhcMod/Monad.hs b/core/GhcMod/Monad.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad.hs @@ -0,0 +1,148 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE CPP #-} +module GhcMod.Monad ( + runGmOutT + , runGmOutT' + , runGhcModT + , runGhcModT' + , hoistGhcModT + , runGmlT + , runGmlT' + , runGmlTWith + , runGmPkgGhc + , withGhcModEnv + , withGhcModEnv' + , module GhcMod.Monad.Types + ) where + +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.Error +import GhcMod.Logging +import GhcMod.Cradle +import GhcMod.Target +import GhcMod.Output + +import Control.Arrow (first) +import Control.Applicative + +import Control.Concurrent + +import Control.Monad.Reader (runReaderT) +import Control.Monad.State.Strict (runStateT) +import Control.Monad.Trans.Journal (runJournalT) + +import Exception + +import System.Directory +import System.IO.Unsafe +import Prelude + +withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a +withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f + where + withCradle dir' = + gbracket + (runJournalT $ do + gmSetLogLevel $ ooptLogLevel $ optOutput opts + findCradle' (optPrograms opts) dir') + (liftIO . cleanupCradle . fst) + + + +cwdLock :: MVar ThreadId +cwdLock = unsafePerformIO $ newEmptyMVar +{-# NOINLINE cwdLock #-} + +withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> ((Cradle, GhcModLog) -> m a) -> m a) -> FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a +withGhcModEnv' withCradle dir opts f = + withCradle dir $ \(crdl,lg) -> + withCradleRootDir crdl $ + f (GhcModEnv opts crdl, lg) + where + swapCurrentDirectory ndir = do + odir <- canonicalizePath =<< getCurrentDirectory + setCurrentDirectory ndir + return odir + + withCradleRootDir (cradleRootDir -> projdir) a = do + success <- liftIO $ tryPutMVar cwdLock =<< myThreadId + if not success + then error "withGhcModEnv': using ghc-mod from multiple threads is not supported!" + else gbracket setup teardown (const a) + where + setup = liftIO $ swapCurrentDirectory projdir + + teardown odir = liftIO $ do + setCurrentDirectory odir + void $ takeMVar cwdLock + +runGmOutT :: IOish m => Options -> GmOutT m a -> m a +runGmOutT opts ma = do + gmo@GhcModOut{..} <- GhcModOut (optOutput opts) <$> liftIO newChan + let action = runGmOutT' gmo ma + case ooptLinePrefix $ optOutput opts of + Nothing -> action + Just pfxs -> + gbracket_ (liftIO $ forkIO $ stdoutGateway pfxs gmoChan) + (const $ liftIO $ flushStdoutGateway gmoChan) + action + +runGmOutT' :: GhcModOut -> GmOutT m a -> m a +runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma + +-- | Run a @GhcModT m@ computation. +runGhcModT :: IOish m + => Options + -> GhcModT m a + -> m (Either GhcModError a, GhcModLog) +runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do + runGmOutT opt $ + withGhcModEnv dir' opt $ \(env,lg) -> + first (fst <$>) <$> runGhcModT' env defaultGhcModState (do + gmSetLogLevel (ooptLogLevel $ optOutput opt) + gmAppendLogQuiet lg + action) + +-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT +-- computation. Note that if the computation that returned @result@ modified the +-- state part of GhcModT this cannot be restored. +hoistGhcModT :: IOish m + => (Either GhcModError a, GhcModLog) + -> GhcModT m a +hoistGhcModT (r,l) = do + gmlJournal l >> case r of + Left e -> throwError e + Right a -> return a + + +-- | Run a computation inside @GhcModT@ providing the RWST environment and +-- initial state. This is a low level function, use it only if you know what to +-- do with 'GhcModEnv' and 'GhcModState'. +-- +-- You should probably look at 'runGhcModT' instead. +runGhcModT' :: IOish m + => GhcModEnv + -> GhcModState + -> GhcModT m a + -> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog) +runGhcModT' r s a = do + flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGmT a) s + +gbracket_ :: ExceptionMonad m => m a -> (a -> m b) -> m c -> m c +gbracket_ ma mb mc = gbracket ma mb (const mc) diff --git a/core/GhcMod/Monad/Compat.hs_h b/core/GhcMod/Monad/Compat.hs_h new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Compat.hs_h @@ -0,0 +1,28 @@ +-- ghc-mod: Making Haskell development *more* fun +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. +-- RWST does not automatically become an instance of MonadIO. +-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. +-- So, RWST automatically becomes an instance of +#if __GLASGOW_HASKELL__ < 708 +-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different +-- classes before ghc 7.8 +#define DIFFERENT_MONADIO 1 + +-- RWST doen't have a MonadIO instance before ghc 7.8 +#define MONADIO_INSTANCES 1 +#endif diff --git a/core/GhcMod/Monad/Env.hs b/core/GhcMod/Monad/Env.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Env.hs @@ -0,0 +1,68 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module GhcMod.Monad.Env where + +import GhcMod.Types +import GhcMod.Monad.Newtypes + +import Control.Monad +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Error (ErrorT(..)) +import Control.Monad.Reader.Class +import Control.Monad.Trans.Class (MonadTrans(..)) +import Prelude + +class Monad m => GmEnv m where + gmeAsk :: m GhcModEnv + gmeAsk = gmeReader id + + gmeReader :: (GhcModEnv -> a) -> m a + gmeReader f = f `liftM` gmeAsk + + gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a + {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-} + +instance Monad m => GmEnv (GmT m) where + gmeAsk = GmT ask + gmeReader = GmT . reader + gmeLocal f a = GmT $ local f (unGmT a) + +instance GmEnv m => GmEnv (GmOutT m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) + +instance GmEnv m => GmEnv (StateT s m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) + +instance GmEnv m => GmEnv (JournalT GhcModLog m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) + +instance GmEnv m => GmEnv (ErrorT GhcModError m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) + +deriving instance (Monad m, GmEnv (GhcModT m)) => GmEnv (GmlT m) diff --git a/core/GhcMod/Monad/Log.hs b/core/GhcMod/Monad/Log.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Log.hs @@ -0,0 +1,71 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module GhcMod.Monad.Log where + +import GhcMod.Types +import GhcMod.Monad.Newtypes + +import Control.Monad +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Error (Error, ErrorT(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Journal.Class (MonadJournal(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Prelude + +class Monad m => GmLog m where + gmlJournal :: GhcModLog -> m () + gmlHistory :: m GhcModLog + gmlClear :: m () + +instance Monad m => GmLog (JournalT GhcModLog m) where + gmlJournal = journal + gmlHistory = history + gmlClear = clear + +instance Monad m => GmLog (GmT m) where + gmlJournal = GmT . lift . lift . journal + gmlHistory = GmT $ lift $ lift history + gmlClear = GmT $ lift $ lift clear + +instance (Monad m, GmLog m) => GmLog (ReaderT r m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +instance (Monad m, GmLog m) => GmLog (StateT s m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +instance (Monad m, GmLog m, Error e) => GmLog (ErrorT e m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +instance (Monad m, GmLog m) => GmLog (MaybeT m) where + gmlJournal = lift . gmlJournal + gmlHistory = lift gmlHistory + gmlClear = lift gmlClear + +deriving instance GmLog m => GmLog (GmOutT m) +deriving instance (Monad m, GmLog (GhcModT m)) => GmLog (GmlT m) diff --git a/core/GhcMod/Monad/Newtypes.hs b/core/GhcMod/Monad/Newtypes.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Newtypes.hs @@ -0,0 +1,176 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE RankNTypes, FlexibleInstances #-} + +module GhcMod.Monad.Newtypes where + +#include "Compat.hs_h" + +import GhcMod.Types + +import GHC + +import Control.Applicative +import Control.Monad + +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.Error (ErrorT(..), MonadError(..)) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Reader.Class +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Journal.Class (MonadJournal(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Control +import Control.Monad.Base (MonadBase(..), liftBase) + +import Data.IORef +import Prelude + +type GhcModT m = GmT (GmOutT m) + +newtype GmOutT m a = GmOutT { + unGmOutT :: ReaderT GhcModOut m a + } deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadTrans + ) + +newtype GmT m a = GmT { + unGmT :: StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) a + } deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadError GhcModError + ) + +newtype GmlT m a = GmlT { unGmlT :: GhcModT m a } + deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadError GhcModError + ) + +newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a } + deriving ( Functor + , Applicative + , Monad + ) + +-- GmOutT ---------------------------------------- +instance (MonadBaseControl IO m) => MonadBase IO (GmOutT m) where + liftBase = GmOutT . liftBase + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GmOutT m) where + type StM (GmOutT m) a = StM (ReaderT GhcModEnv m) a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadTransControl GmOutT where + type StT GmOutT a = StT (ReaderT GhcModEnv) a + liftWith = defaultLiftWith GmOutT unGmOutT + restoreT = defaultRestoreT GmOutT + + +-- GmlT ------------------------------------------ +instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where + liftBase = GmlT . liftBase + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where + type StM (GmlT m) a = StM (GmT m) a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadTransControl GmlT where + type StT GmlT a = StT GmT a + liftWith f = GmlT $ + liftWith $ \runGm -> + liftWith $ \runEnv -> + f $ \ma -> runEnv $ runGm $ unGmlT ma + restoreT = GmlT . restoreT . restoreT + +instance MonadTrans GmlT where + lift = GmlT . lift . lift + +-- GmT ------------------------------------------ + +instance MonadReader r m => MonadReader r (GmT m) where + local f ma = gmLiftWithInner (\run -> local f (run ma)) + ask = gmLiftInner ask + +instance MonadState s m => MonadState s (GmT m) where + get = GmT $ lift $ lift $ lift get + put = GmT . lift . lift . lift . put + state = GmT . lift . lift . lift . state + +instance Monad m => MonadJournal GhcModLog (GmT m) where + journal w = GmT $ lift $ lift $ (journal w) + history = GmT $ lift $ lift $ history + clear = GmT $ lift $ lift $ clear + +instance (MonadBaseControl IO m) => MonadBase IO (GmT m) where + liftBase = GmT . liftBase + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GmT m) where + type StM (GmT m) a = + StM (StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) ) a + liftBaseWith f = GmT (liftBaseWith $ \runInBase -> + f $ runInBase . unGmT) + restoreM = GmT . restoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadTransControl GmT where + type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog) + liftWith f = GmT $ + liftWith $ \runS -> + liftWith $ \runE -> + liftWith $ \runJ -> + liftWith $ \runR -> + f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma + restoreT = GmT . restoreT . restoreT . restoreT . restoreT + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} + +instance MonadTrans GmT where + lift = GmT . lift . lift . lift . lift + +gmLiftInner :: Monad m => m a -> GmT m a +gmLiftInner = GmT . lift . lift . lift . lift + +gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m)) + => (Run t -> m (StT t a)) -> t m a +gmLiftWithInner f = liftWith f >>= restoreT . return diff --git a/core/GhcMod/Monad/Orphans.hs b/core/GhcMod/Monad/Orphans.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Orphans.hs @@ -0,0 +1,83 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE CPP, UndecidableInstances, StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module GhcMod.Monad.Orphans where + +#include "Compat.hs_h" + +import GhcMod.Types +import GhcMod.Monad.Newtypes + +#if DIFFERENT_MONADIO +import qualified MonadUtils as GHC (MonadIO(..)) +#endif +import qualified Control.Monad.IO.Class as MTL + +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Error (Error(..), ErrorT(..)) + +-------------------------------------------------- +-- Miscellaneous instances + +#if DIFFERENT_MONADIO +instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where + liftIO = MTL.liftIO +instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where + liftIO = MTL.liftIO +deriving instance MTL.MonadIO m => GHC.MonadIO (GmOutT m) +deriving instance MTL.MonadIO m => GHC.MonadIO (GmT m) +deriving instance MTL.MonadIO m => GHC.MonadIO (GmlT m) +deriving instance GHC.MonadIO LightGhc +#endif + +deriving instance MTL.MonadIO m => MTL.MonadIO (GmOutT m) +deriving instance MTL.MonadIO m => MTL.MonadIO (GmT m) +deriving instance MTL.MonadIO m => MTL.MonadIO (GmlT m) +deriving instance MTL.MonadIO LightGhc + +instance MonadIO IO where + liftIO = id +instance MonadIO m => MonadIO (ReaderT x m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (StateT x m) where + liftIO = MTL.liftIO +instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (JournalT x m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (MaybeT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GmOutT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GmT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GmlT m) where + liftIO = MTL.liftIO +instance MonadIO LightGhc where + liftIO = MTL.liftIO diff --git a/core/GhcMod/Monad/Out.hs b/core/GhcMod/Monad/Out.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Out.hs @@ -0,0 +1,52 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} + +module GhcMod.Monad.Out where + +import GhcMod.Types +import GhcMod.Monad.Newtypes + +import Control.Monad +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Reader.Class +import Control.Monad.Trans.Class (MonadTrans(..)) +import Prelude + +class Monad m => GmOut m where + gmoAsk :: m GhcModOut + +instance Monad m => GmOut (GmOutT m) where + gmoAsk = GmOutT ask + +instance Monad m => GmOut (GmlT m) where + gmoAsk = GmlT $ lift $ GmOutT ask + +instance GmOut m => GmOut (GmT m) where + gmoAsk = lift gmoAsk + +instance GmOut m => GmOut (StateT s m) where + gmoAsk = lift gmoAsk + +instance GmOut m => GmOut (JournalT w m) where + gmoAsk = lift gmoAsk + +instance GmOut m => GmOut (MaybeT m) where + gmoAsk = lift gmoAsk diff --git a/core/GhcMod/Monad/State.hs b/core/GhcMod/Monad/State.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/State.hs @@ -0,0 +1,67 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015,2016 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module GhcMod.Monad.State where + +import GhcMod.Types +import GhcMod.Monad.Newtypes + +import Control.Monad +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Prelude + +class Monad m => GmState m where + gmsGet :: m GhcModState + gmsGet = gmsState (\s -> (s, s)) + + gmsPut :: GhcModState -> m () + gmsPut s = gmsState (\_ -> ((), s)) + + gmsState :: (GhcModState -> (a, GhcModState)) -> m a + gmsState f = do + s <- gmsGet + let ~(a, s') = f s + gmsPut s' + return a + {-# MINIMAL gmsState | gmsGet, gmsPut #-} + +instance GmState m => GmState (StateT s m) where + gmsGet = lift gmsGet + gmsPut = lift . gmsPut + gmsState = lift . gmsState + +instance Monad m => GmState (StateT GhcModState m) where + gmsGet = get + gmsPut = put + gmsState = state + +instance Monad m => GmState (GmT m) where + gmsGet = GmT get + gmsPut = GmT . put + gmsState = GmT . state + +instance GmState m => GmState (MaybeT m) where + gmsGet = MaybeT $ Just `liftM` gmsGet + gmsPut = MaybeT . (Just `liftM`) . gmsPut + gmsState = MaybeT . (Just `liftM`) . gmsState + +deriving instance (Monad m, GmState (GhcModT m)) => GmState (GmlT m) diff --git a/core/GhcMod/Monad/Types.hs b/core/GhcMod/Monad/Types.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Monad/Types.hs @@ -0,0 +1,239 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GhcMod.Monad.Types ( + -- * Monad Types + GhcModT + , GmOutT(..) + , GmT(..) + , GmlT(..) + , LightGhc(..) + , GmGhc + , IOish + -- * Environment, state and logging + , GhcModEnv(..) + , GhcModState(..) + , GhcModCaches(..) + , defaultGhcModState + , GmGhcSession(..) + , GmComponent(..) + -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog' + , GmLogLevel(..) + , GhcModLog(..) + , GhcModError(..) + , Gm + , GmEnv(..) + , GmState(..) + , GmLog(..) + , GmOut(..) + , cradle + , options + , outputOpts + , withOptions + , getMMappedFiles + , setMMappedFiles + , addMMappedFile + , delMMappedFile + , lookupMMappedFile + , getMMappedFilePaths + -- * Re-exporting convenient stuff + , MonadIO + , liftIO + , gmlGetSession + , gmlSetSession + ) where + +#include "Compat.hs_h" + +import GhcMod.Types + +import GhcMod.Monad.Env +import GhcMod.Monad.State +import GhcMod.Monad.Log +import GhcMod.Monad.Out +import GhcMod.Monad.Newtypes +import GhcMod.Monad.Orphans () + +import Safe + +import GHC +import DynFlags +import Exception +import HscTypes + +import Control.Applicative +import Control.Monad + +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.State.Strict (StateT(..)) +import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Trans.Maybe (MaybeT) + +import Control.Monad.Trans.Control + +import Control.Monad.Reader.Class + +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import Data.IORef +import Prelude + +type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m) + +-------------------------------------------------- +-- GHC API instances ----------------------------- + +-- GHC cannot prove the following instances to be decidable automatically using +-- the FlexibleContexts extension as they violate the second Paterson Condition, +-- namely that: The assertion has fewer constructors and variables (taken +-- together and counting repetitions) than the head. Specifically the +-- @MonadBaseControl IO m@ constraint in 'IOish' is causing this violation. + +type GmGhc m = (IOish m, GhcMonad m) + +instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where + getSession = gmlGetSession + setSession = gmlSetSession + +-- | Get the underlying GHC session +gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv +gmlGetSession = do + ref <- gmgsSession . fromJustNote "gmlGetSession" . gmGhcSession <$> gmsGet + liftIO $ readIORef ref + +-- | Set the underlying GHC session +gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m () +gmlSetSession a = do + ref <- gmgsSession . fromJustNote "gmlSetSession" . gmGhcSession <$> gmsGet + liftIO $ flip writeIORef a ref + +instance GhcMonad LightGhc where + getSession = (liftIO . readIORef) =<< LightGhc ask + setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask + +#if __GLASGOW_HASKELL__ >= 706 +instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where + getDynFlags = hsc_dflags <$> getSession + +instance HasDynFlags LightGhc where + getDynFlags = hsc_dflags <$> getSession +#endif + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmOutT m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmT m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmlT m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance ExceptionMonad LightGhc where + gcatch act handl = + LightGhc $ unLightGhc act `gcatch` \e -> unLightGhc (handl e) + gmask f = + LightGhc $ gmask $ \io_restore ->let + g_restore (LightGhc m) = LightGhc $ io_restore m + in + unLightGhc (f g_restore) + + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (StateT s m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (ReaderT s m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance (Monoid w, MonadIO m, MonadBaseControl IO m) => ExceptionMonad (JournalT w m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (MaybeT m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r + + +---------------------------------------------------------------- + +options :: GmEnv m => m Options +options = gmOptions `liftM` gmeAsk + +outputOpts :: GmOut m => m OutputOpts +outputOpts = gmoOptions `liftM` gmoAsk + +cradle :: GmEnv m => m Cradle +cradle = gmCradle `liftM` gmeAsk + +getMMappedFiles :: GmState m => m FileMappingMap +getMMappedFiles = gmMMappedFiles `liftM` gmsGet + +setMMappedFiles :: GmState m => FileMappingMap -> m () +setMMappedFiles mf = (\s -> gmsPut s { gmMMappedFiles = mf } ) =<< gmsGet + +addMMappedFile :: GmState m => FilePath -> FileMapping -> m () +addMMappedFile t fm = + getMMappedFiles >>= setMMappedFiles . M.insert t fm + +delMMappedFile :: GmState m => FilePath -> m () +delMMappedFile t = + getMMappedFiles >>= setMMappedFiles . M.delete t + +lookupMMappedFile :: GmState m => FilePath -> m (Maybe FileMapping) +lookupMMappedFile t = + M.lookup t `liftM` getMMappedFiles + +getMMappedFilePaths :: GmState m => m [FilePath] +getMMappedFilePaths = M.keys `liftM` getMMappedFiles + +withOptions :: GmEnv m => (Options -> Options) -> m a -> m a +withOptions changeOpt action = gmeLocal changeEnv action + where + changeEnv e = e { gmOptions = changeOpt opt } + where + opt = gmOptions e diff --git a/core/GhcMod/Options/DocUtils.hs b/core/GhcMod/Options/DocUtils.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Options/DocUtils.hs @@ -0,0 +1,48 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- 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 . + +module GhcMod.Options.DocUtils ( + ($$), + ($$$), + (<=>), + (<$$>), + (<||>) +) where + +import Options.Applicative +import Data.Monoid +import Prelude + +infixl 6 <||> +infixr 7 <$$> +infixr 7 $$ +infixr 8 <=> +infixr 9 $$$ + +($$) :: (a -> b) -> a -> b +($$) = ($) + +($$$) :: (a -> b) -> a -> b +($$$) = ($) + +(<||>) :: Alternative a => a b -> a b -> a b +(<||>) = (<|>) + +(<=>) :: Monoid m => m -> m -> m +(<=>) = (<>) + +(<$$>) :: Functor f => (a -> b) -> f a -> f b +(<$$>) = (<$>) diff --git a/core/GhcMod/Options/Help.hs b/core/GhcMod/Options/Help.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Options/Help.hs @@ -0,0 +1,79 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- 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 . +{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-} + +module GhcMod.Options.Help where + +import Options.Applicative +import Options.Applicative.Help.Pretty (Doc) +import qualified Options.Applicative.Help.Pretty as PP +import Control.Monad.State +import GHC.Exts( IsString(..) ) +import Data.Maybe +import Data.Monoid +import Prelude + +newtype MyDocM s a = MyDoc {unwrapState :: State s a} + deriving (Monad, Functor, Applicative, MonadState s) +type MyDoc = MyDocM (Maybe Doc) () + +instance IsString (MyDocM (Maybe Doc) a) where + fromString = append . para + +instance Monoid (MyDocM (Maybe Doc) ()) where + mappend a b = append $ doc a <> doc b + mempty = append PP.empty + +para :: String -> Doc +para = PP.fillSep . map PP.text . words + +append :: Doc -> MyDocM (Maybe Doc) a +append s = modify m >> return undefined + where + m :: Maybe Doc -> Maybe Doc + m Nothing = Just s + m (Just old) = Just $ old PP..$. s + +infixr 7 \\ +(\\) :: MyDoc -> MyDoc -> MyDoc +(\\) a b = append $ doc a PP.<+> doc b + +doc :: MyDoc -> Doc +doc = fromMaybe PP.empty . flip execState Nothing . unwrapState + +help' :: MyDoc -> Mod f a +help' = helpDoc . Just . doc + +desc :: MyDoc -> InfoMod a +desc = footerDoc . Just . doc . indent 2 + +code :: MyDoc -> MyDoc +code x = do + _ <- " " + indent 4 x + " " + +progDesc' :: MyDoc -> InfoMod a +progDesc' = progDescDoc . Just . doc + +indent :: Int -> MyDoc -> MyDoc +indent n = append . PP.indent n . doc + +int' :: Int -> MyDoc +int' = append . PP.int + +para' :: String -> MyDoc +para' = append . para diff --git a/core/GhcMod/Options/Options.hs b/core/GhcMod/Options/Options.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Options/Options.hs @@ -0,0 +1,177 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- 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 . +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module GhcMod.Options.Options ( + globalArgSpec + , parseCmdLineOptions +) where + +import Options.Applicative +import Options.Applicative.Types +import GhcMod.Types +import Control.Arrow +import Data.Char (toUpper, toLower) +import Data.List (intercalate) +import GhcMod.Read +import GhcMod.Options.DocUtils +import GhcMod.Options.Help +import Data.Monoid +import Prelude + +-- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing +-- @Options@ set accordingly. +parseCmdLineOptions :: [String] -> Maybe Options +parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty) + +splitOn :: Eq a => a -> [a] -> ([a], [a]) +splitOn c = second (drop 1) . break (==c) + +logLevelParser :: Parser GmLogLevel +logLevelParser = + logLevelSwitch <*> + logLevelOption + <||> silentSwitch + where + logLevelOption = + option parseLL + $$ long "verbose" + <=> metavar "LEVEL" + <=> value GmWarning + <=> showDefaultWith showLL + <=> help' $$$ do + "Set log level (" + <> int' (fromEnum (minBound :: GmLogLevel)) + <> "-" + <> int' (fromEnum (maxBound :: GmLogLevel)) + <> ")" + "You can also use strings (case-insensitive):" + para' + $ intercalate ", " + $ map showLL ([minBound..maxBound] :: [GmLogLevel]) + logLevelSwitch = + repeatAp succ' . length <$> many $$ flag' () + $$ short 'v' + <=> help "Increase log level" + silentSwitch = flag' GmSilent + $$ long "silent" + <=> short 's' + <=> help "Be silent, set log level to 'silent'" + showLL = drop 2 . map toLower . show + repeatAp f n = foldr (.) id (replicate n f) + succ' x | x == maxBound = x + | otherwise = succ x + parseLL = do + v <- readerAsk + let + il'= toEnum . min maxBound <$> readMaybe v + ll' = readMaybe ("Gm" ++ capFirst v) + maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il' + capFirst (h:t) = toUpper h : map toLower t + capFirst [] = [] + +outputOptsSpec :: Parser OutputOpts +outputOptsSpec = OutputOpts + <$> logLevelParser + <*> flag PlainStyle LispStyle + $$ long "tolisp" + <=> short 'l' + <=> help "Format output as an S-Expression" + <*> LineSeparator <$$> strOption + $$ long "boundary" + <=> long "line-separator" + <=> short 'b' + <=> metavar "SEP" + <=> value "\0" + <=> showDefault + <=> help "Output line separator" + <*> optional $$ splitOn ',' <$$> strOption + $$ long "line-prefix" + <=> metavar "OUT,ERR" + <=> help "Output prefixes" + +programsArgSpec :: Parser Programs +programsArgSpec = Programs + <$> strOption + $$ long "with-ghc" + <=> value "ghc" + <=> showDefault + <=> help "GHC executable to use" + <*> strOption + $$ long "with-ghc-pkg" + <=> value "ghc-pkg" + <=> showDefault + <=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)" + <*> strOption + $$ long "with-cabal" + <=> value "cabal" + <=> showDefault + <=> help "cabal-install executable to use" + <*> strOption + $$ long "with-stack" + <=> value "stack" + <=> showDefault + <=> help "stack executable to use" + +-- | An optparse-applicative @Parser@ sepcification for @Options@ so that +-- applications making use of the ghc-mod API can have a consistent way of +-- parsing global options. +globalArgSpec :: Parser Options +globalArgSpec = Options + <$> outputOptsSpec + <*> programsArgSpec + <*> many $$ strOption + $$ long "ghcOpt" + <=> long "ghc-option" + <=> short 'g' + <=> metavar "OPT" + <=> help "Option to be passed to GHC" + <*> many fileMappingSpec + <*> strOption + $$ long "encoding" + <=> value "UTF-8" + <=> showDefault + <=> help "I/O encoding" + <*> switch + $$ long "stack-build-deps" + <=> showDefault + <=> help "Build dependencies if needed when using stack" + where + fileMappingSpec = + getFileMapping . splitOn '=' <$> strOption + $$ long "map-file" + <=> metavar "MAPPING" + <=> fileMappingHelp + fileMappingHelp = help' $ do + "Redirect one file to another" + "--map-file \"file1.hs=file2.hs\"" + indent 4 $ do + "can be used to tell ghc-mod" + \\ "that it should take source code" + \\ "for `file1.hs` from `file2.hs`." + "`file1.hs` can be either full path," + \\ "or path relative to project root." + "`file2.hs` has to be either relative to project root," + \\ "or full path (preferred)" + "--map-file \"file.hs\"" + indent 4 $ do + "can be used to tell ghc-mod that it should take" + \\ "source code for `file.hs` from stdin. File end" + \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`." + \\ "`file.hs` may or may not exist, and should be" + \\ "either full path, or relative to project root." + getFileMapping = second (\i -> if null i then Nothing else Just i) diff --git a/core/GhcMod/Output.hs b/core/GhcMod/Output.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Output.hs @@ -0,0 +1,243 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +-- Derived from process:System.Process +-- Copyright (c) The University of Glasgow 2004-2008 + +{-# LANGUAGE FlexibleInstances #-} +module GhcMod.Output ( + gmPutStr + , gmErrStr + , gmPutStrLn + , gmErrStrLn + + , gmPutStrIO + , gmErrStrIO + + , gmReadProcess + , gmReadProcess' + + , stdoutGateway + , flushStdoutGateway + ) where + +import Data.List +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BS +import qualified Data.Label as L +import qualified Data.Label.Base as LB +import System.IO +import System.Exit +import System.Process +import Control.Monad +import Control.Monad.State.Strict +import Control.DeepSeq +import Control.Exception +import Control.Concurrent (forkIO, killThread) +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import Pipes +import Pipes.Lift +import Prelude + +import GhcMod.Types hiding (LineSeparator, MonadIO(..)) +import GhcMod.Monad.Types hiding (MonadIO(..)) +import GhcMod.Gap () + +class ProcessOutput a where + hGetContents' :: Handle -> IO a + +instance ProcessOutput String where + hGetContents' = hGetContents + +instance ProcessOutput ByteString where + hGetContents' = BS.hGetContents + +outputFns :: (GmOut m, MonadIO m') + => m (String -> m' (), String -> m' ()) +outputFns = + outputFns' `liftM` gmoAsk + +outputFns' :: + MonadIO m => GhcModOut -> (String -> m (), String -> m ()) +outputFns' (GhcModOut oopts c) = let + OutputOpts {..} = oopts + in + case ooptLinePrefix of + Nothing -> stdioOutputFns + Just _ -> chanOutputFns c + +stdioOutputFns :: MonadIO m => (String -> m (), String -> m ()) +stdioOutputFns = + ( liftIO . putStr + , liftIO . hPutStr stderr + ) + +chanOutputFns :: MonadIO m + => Chan (Either (MVar ()) (GmStream, String)) + -> (String -> m (), String -> m ()) +chanOutputFns c = (write GmOutStream, write GmErrStream) + where + write stream s = liftIO $ writeChan c $ Right $ (stream,s) + +gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn + :: (MonadIO m, GmOut m) => String -> m () + +gmPutStr str = do + putOut <- gmPutStrIO + putOut str + +gmErrStr str = do + putErr <- gmErrStrIO + putErr str + +gmPutStrLn = gmPutStr . (++"\n") +gmErrStrLn = gmErrStr . (++"\n") + +gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ()) + +gmPutStrIO = fst `liftM` outputFns +gmErrStrIO = snd `liftM` outputFns + + +gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String) +gmReadProcess = do + GhcModOut {..} <- gmoAsk + case ooptLinePrefix gmoOptions of + Just _ -> + readProcessStderrChan + Nothing -> + return $ readProcess + +gmReadProcess' :: GmOut m => m (FilePath -> [String] -> String -> IO ByteString) +gmReadProcess' = readProcessStderrChan + +flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO () +flushStdoutGateway c = do + mv <- newEmptyMVar + writeChan c $ Left mv + takeMVar mv + +type Line = String + +stdoutGateway :: (String, String) -> Chan (Either (MVar ()) (GmStream, String)) -> IO () +stdoutGateway (outPf, errPf) chan = do + runEffect $ commandProc >-> evalStateP ("","") seperateStreams + where + commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO () + commandProc = do + cmd <- liftIO $ readChan chan + case cmd of + Left mv -> do + yield $ Left mv + Right input -> do + yield $ Right input + commandProc + + seperateStreams :: Consumer (Either (MVar ()) (GmStream, String)) (StateT (String, String) IO) () + seperateStreams = do + ecmd <- await + case ecmd of + Left mv -> do + -- flush buffers + (\s -> lift $ zoom (streamLens s) $ sGetLine Nothing) + `mapM_` [GmOutStream, GmErrStream] + + liftIO $ putMVar mv () + Right (stream, str) -> do + ls <- lift $ zoom (streamLens stream) $ sGetLine (Just str) + case ls of + [] -> return () + _ -> liftIO $ putStr $ unlines $ map (streamPf stream++) ls + + liftIO $ hFlush stdout + seperateStreams + + sGetLine :: (Maybe String) -> StateT String IO [Line] + sGetLine mstr' = do + buf <- get + let mstr = (buf++) `liftM` mstr' + case mstr of + Nothing -> put "" >> return [buf] + Just "" -> return [] + Just s | last s == '\n' -> put "" >> return (lines s) + | otherwise -> do + let (p:ls') = reverse $ lines s + put p + return $ reverse $ ls' + + streamLens GmOutStream = LB.fst + streamLens GmErrStream = LB.snd + + streamPf GmOutStream = outPf + streamPf GmErrStream = errPf + +zoom :: Monad m => (f L.:-> o) -> StateT o m a -> StateT f m a +zoom l (StateT a) = + StateT $ \f -> do + (a', s') <- a $ L.get l f + return (a', L.set l s' f) + +readProcessStderrChan :: + (GmOut m, ProcessOutput a, NFData a) => m (FilePath -> [String] -> String -> IO a) +readProcessStderrChan = do + (_, e :: String -> IO ()) <- outputFns + return $ readProcessStderrChan' e + +readProcessStderrChan' :: (ProcessOutput a, NFData a) => + (String -> IO ()) -> FilePath -> [String] -> String -> IO a +readProcessStderrChan' putErr exe args input = do + let cp = (proc exe args) { + std_out = CreatePipe + , std_err = CreatePipe + , std_in = CreatePipe + } + (Just i, Just o, Just e, h) <- createProcess cp + + _ <- forkIO $ reader e + + output <- hGetContents' o + withForkWait (evaluate $ rnf output) $ \waitOut -> do + + -- now write any input + unless (null input) $ + ignoreSEx $ hPutStr i input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + ignoreSEx $ hClose i + + -- wait on the output + waitOut + hClose o + + res <- waitForProcess h + case res of + ExitFailure rv -> + throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv + ExitSuccess -> + return output + where + ignoreSEx = handle (\(SomeException _) -> return ()) + reader h = ignoreSEx $ do + putErr . (++"\n") =<< hGetLine h + reader h + +withForkWait :: IO () -> (IO () -> IO a) -> IO a +withForkWait async body = do + waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) + mask $ \restore -> do + tid <- forkIO $ try (restore async) >>= putMVar waitVar + let wait = takeMVar waitVar >>= either throwIO return + restore (body wait) `onException` killThread tid diff --git a/core/GhcMod/PathsAndFiles.hs b/core/GhcMod/PathsAndFiles.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/PathsAndFiles.hs @@ -0,0 +1,242 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +module GhcMod.PathsAndFiles ( + module GhcMod.PathsAndFiles + , module GhcMod.Caching + ) where + +import Config (cProjectVersion) +import Control.Arrow (second) +import Control.Applicative +import Control.Exception as E +import Control.Monad +import Control.Monad.Trans.Maybe +import Data.List +import Data.Char +import Data.Maybe +import Data.Traversable hiding (mapM) +import Distribution.Helper (buildPlatform) +import System.Directory +import System.FilePath +import System.Process + +import GhcMod.Types +import GhcMod.Caching +import qualified GhcMod.Utils as U +import Utils (mightExist) +import Prelude + +-- | Guaranteed to be a path to a directory with no trailing slash. +type DirPath = FilePath + +-- | Guaranteed to be the name of a file only (no slashes). +type FileName = String + +-- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent +-- directories. The first parent directory containing more than one cabal file +-- is assumed to be the project directory. If only one cabal file exists in this +-- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile' +-- or 'GMETooManyCabalFiles' +findCabalFile :: FilePath -> IO (Maybe FilePath) +findCabalFile dir = findFileInParentsP isCabalFile pick dir + where + pick [] = Nothing + pick [cf] = Just cf + pick cfs = throw $ GMETooManyCabalFiles cfs + +findStackConfigFile :: FilePath -> IO (Maybe FilePath) +findStackConfigFile dir = + findFileInParentsP (=="stack.yaml") pick dir + where + pick [] = Nothing + pick (sf:_) = Just sf + +findCabalSandboxDir :: FilePath -> IO (Maybe FilePath) +findCabalSandboxDir dir = + fmap takeDirectory <$> findFileInParentsP isSandboxConfig pick dir + where + isSandboxConfig = (==sandboxConfigFileName) + pick [] = Nothing + pick (sc:_) = Just sc + +findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath) +findCustomPackageDbFile dir = + mightExist $ dir "ghc-mod.package-db-stack" + +-- | Get path to sandbox config file +getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb) +getSandboxDb crdl = do + mConf <- traverse readFile =<< mightExist (sandboxConfigFile crdl) + bp <- buildPlatform readProcess + return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf) + + where + fixPkgDbVer bp dir = + case takeFileName dir == ghcSandboxPkgDbDir bp of + True -> dir + False -> takeDirectory dir ghcSandboxPkgDbDir bp + +-- | Extract the sandbox package db directory from the cabal.sandbox.config +-- file. Exception is thrown if the sandbox config file is broken. +extractSandboxDbDir :: String -> Maybe FilePath +extractSandboxDbDir conf = extractValue <$> parse conf + where + key = "package-db:" + keyLen = length key + + parse = listToMaybe . filter (key `isPrefixOf`) . lines + extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen + + +-- | +-- >>> isCabalFile "/home/user/.cabal" +-- False +isCabalFile :: FilePath -> Bool +isCabalFile f = takeExtension' f == ".cabal" + +-- | +-- >>> takeExtension' "/some/dir/bla.cabal" +-- ".cabal" +-- +-- >>> takeExtension' "some/reldir/bla.cabal" +-- ".cabal" +-- +-- >>> takeExtension' "bla.cabal" +-- ".cabal" +-- +-- >>> takeExtension' ".cabal" +-- "" +takeExtension' :: FilePath -> String +takeExtension' p = + if takeFileName p == takeExtension p + then "" -- just ".cabal" is not a valid cabal file + else takeExtension p + +-- | @findFileInParentsP p r dir@ Look for files satisfying @p@ in @dir@ and all +-- it's parent directories. Files found to satisfy @p@ in a given directory are +-- passed to @r@ and if this yields a 'Just' value the search finishes early +-- without examinig any more directories and this value is returned. +findFileInParentsP :: (FilePath -> Bool) + -> ([FilePath] -> Maybe a) + -> FilePath + -> IO (Maybe a) +findFileInParentsP p r dir = runMaybeT $ + join $ msum <$> map (MaybeT . fmap r) <$> liftIO (findFilesInParentsP p dir) + +-- | @findFilesInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all +-- it's parent directories. +findFilesInParentsP :: (FilePath -> Bool) -> FilePath + -> IO [IO [FilePath]] +findFilesInParentsP p dir' = U.makeAbsolute' dir' >>= \dir -> return $ + map (\d -> (map (d )) <$> getFilesP p d) $ parents dir + +-- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@. +getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName] +getFilesP p dir = filterM p' =<< getDirectoryContentsSafe + where + p' fn = do + (p fn && ) <$> doesFileExist (dir fn) + getDirectoryContentsSafe = do + rdable <- readable <$> getPermissions dir + if rdable + then getDirectoryContents dir + else return [] + +-- | @parents dir@. Returns all parent directories of @dir@ including @dir@. +-- +-- Examples +-- +-- >>> parents "foo" +-- ["foo"] +-- +-- >>> parents "/foo" +-- ["/foo","/"] +-- +-- >>> parents "/foo/bar" +-- ["/foo/bar","/foo","/"] +-- +-- >>> parents "foo/bar" +-- ["foo/bar","foo"] +parents :: FilePath -> [FilePath] +parents "" = [] +parents dir' = + let (drive, dir) = splitDrive $ normalise $ dropTrailingPathSeparator dir' + in map (joinDrive drive) $ parents' $ filter (/=".") $ splitDirectories dir + where + parents' :: [String] -> [FilePath] + parents' [] | isAbsolute dir' = "":[] + parents' [] = [] + parents' dir = [joinPath dir] ++ parents' (init dir) + +---------------------------------------------------------------- + +setupConfigFile :: Cradle -> FilePath +setupConfigFile crdl = + cradleRootDir crdl setupConfigPath (cradleDistDir crdl) + +sandboxConfigFile :: Cradle -> FilePath +sandboxConfigFile crdl = cradleRootDir crdl sandboxConfigFileName + +sandboxConfigFileName :: String +sandboxConfigFileName = "cabal.sandbox.config" + +-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ +setupConfigPath :: FilePath -> FilePath +setupConfigPath dist = dist "setup-config" + -- localBuildInfoFile defaultDistPref + +macrosHeaderPath :: FilePath +macrosHeaderPath = autogenModulesDir "cabal_macros.h" + +autogenModulePath :: String -> String +autogenModulePath pkg_name = + autogenModulesDir ("Paths_" ++ map fixchar pkg_name) <.> ".hs" + where fixchar '-' = '_' + fixchar c = c + +autogenModulesDir :: FilePath +autogenModulesDir = "build" "autogen" + +ghcSandboxPkgDbDir :: String -> String +ghcSandboxPkgDbDir buildPlatf = do + buildPlatf ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d" + +packageCache :: String +packageCache = "package.cache" + +-- | Filename of the symbol table cache file. +symbolCache :: Cradle -> FilePath +symbolCache crdl = cradleRootDir crdl cradleDistDir crdl symbolCacheFile + +symbolCacheFile :: String +symbolCacheFile = "ghc-mod.symbol-cache" + +resolvedComponentsCacheFile :: FilePath -> FilePath +resolvedComponentsCacheFile dist = + setupConfigPath dist <.> "ghc-mod.resolved-components" + +cabalHelperCacheFile :: FilePath -> FilePath +cabalHelperCacheFile dist = + setupConfigPath dist <.> "ghc-mod.cabal-components" + +mergedPkgOptsCacheFile :: FilePath -> FilePath +mergedPkgOptsCacheFile dist = + setupConfigPath dist <.> "ghc-mod.package-options" + +pkgDbStackCacheFile :: FilePath -> FilePath +pkgDbStackCacheFile dist = + setupConfigPath dist <.> "ghc-mod.package-db-stack" diff --git a/core/GhcMod/Pretty.hs b/core/GhcMod/Pretty.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Pretty.hs @@ -0,0 +1,90 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +module GhcMod.Pretty + ( renderGm + , renderSDoc + , gmComponentNameDoc + , gmLogLevelDoc + , (<+>:) + , fnDoc + , showToDoc + , warnDoc + , strLnDoc + , strDoc + ) where + +import Control.Arrow hiding ((<+>)) +import Data.Char +import Data.List +import Distribution.Helper +import Pretty +import GHC +import Outputable (SDoc, withPprStyleDoc) + +import GhcMod.Types +import GhcMod.Doc +import GhcMod.Gap (renderGm) + +renderSDoc :: GhcMonad m => SDoc -> m Doc +renderSDoc sdoc = do + df <- getSessionDynFlags + ppsty <- getStyle + return $ withPprStyleDoc df ppsty sdoc + +gmComponentNameDoc :: ChComponentName -> Doc +gmComponentNameDoc ChSetupHsName = text $ "Setup.hs" +gmComponentNameDoc (ChLibName "") = text $ "library" +gmComponentNameDoc (ChLibName n) = text $ "library:" ++ n +gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n +gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n +gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n + +gmLogLevelDoc :: GmLogLevel -> Doc +gmLogLevelDoc GmSilent = error "GmSilent MUST not be used for log messages" +gmLogLevelDoc GmPanic = text "PANIC" +gmLogLevelDoc GmException = text "EXCEPTION" +gmLogLevelDoc GmError = text "ERROR" +gmLogLevelDoc GmWarning = text "Warning" +gmLogLevelDoc GmInfo = text "info" +gmLogLevelDoc GmDebug = text "DEBUG" +gmLogLevelDoc GmVomit = text "VOMIT" + +infixl 6 <+>: +(<+>:) :: Doc -> Doc -> Doc +a <+>: b = (a <> colon) <+> b + +fnDoc :: FilePath -> Doc +fnDoc = doubleQuotes . text + +showToDoc :: Show a => a -> Doc +showToDoc = strLnDoc . show + +warnDoc :: Doc -> Doc +warnDoc d = text "Warning" <+>: d + +strLnDoc :: String -> Doc +strLnDoc str = doc (dropWhileEnd isSpace str) + where + doc = lines >>> map text >>> foldr ($+$) empty + +strDoc :: String -> Doc +strDoc str = doc (dropWhileEnd isSpace str) + where + doc :: String -> Doc + doc = lines + >>> map (words >>> map text >>> fsep) + >>> \l -> case l of (x:xs) -> hang x 4 (vcat xs); [] -> empty diff --git a/core/GhcMod/Read.hs b/core/GhcMod/Read.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Read.hs @@ -0,0 +1,106 @@ +module GhcMod.Read where + +import Text.Read (readPrec_to_S, readPrec, minPrec) +import qualified Text.ParserCombinators.ReadP as P +import Text.ParserCombinators.ReadPrec (lift) + +-- This library (libraries/base) is derived from code from several +-- sources: + +-- * Code from the GHC project which is largely (c) The University of +-- Glasgow, and distributable under a BSD-style license (see below), + +-- * Code from the Haskell 98 Report which is (c) Simon Peyton Jones +-- and freely redistributable (but see the full license for +-- restrictions). + +-- * Code from the Haskell Foreign Function Interface specification, +-- which is (c) Manuel M. T. Chakravarty and freely redistributable +-- (but see the full license for restrictions). + +-- The full text of these licenses is reproduced below. All of the +-- licenses are BSD-style or compatible. + +-- ----------------------------------------------------------------------------- + +-- The Glasgow Haskell Compiler License + +-- Copyright 2004, The University Court of the University of Glasgow. +-- All rights reserved. + +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: + +-- - Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. + +-- - Redistributions in binary form must reproduce the above copyright notice, +-- this list of conditions and the following disclaimer in the documentation +-- and/or other materials provided with the distribution. + +-- - Neither name of the University nor the names of its contributors may be +-- used to endorse or promote products derived from this software without +-- specific prior written permission. + +-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +-- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +-- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +-- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +-- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +-- DAMAGE. + +-- ----------------------------------------------------------------------------- + +-- Code derived from the document "Report on the Programming Language +-- Haskell 98", is distributed under the following license: + +-- Copyright (c) 2002 Simon Peyton Jones + +-- The authors intend this Report to belong to the entire Haskell +-- community, and so we grant permission to copy and distribute it for +-- any purpose, provided that it is reproduced in its entirety, +-- including this Notice. Modified versions of this Report may also be +-- copied and distributed for any purpose, provided that the modified +-- version is clearly presented as such, and that it does not claim to +-- be a definition of the Haskell 98 Language. + +-- ----------------------------------------------------------------------------- + +-- Code derived from the document "The Haskell 98 Foreign Function +-- Interface, An Addendum to the Haskell 98 Report" is distributed under +-- the following license: + +-- Copyright (c) 2002 Manuel M. T. Chakravarty + +-- The authors intend this Report to belong to the entire Haskell +-- community, and so we grant permission to copy and distribute it for +-- any purpose, provided that it is reproduced in its entirety, +-- including this Notice. Modified versions of this Report may also be +-- copied and distributed for any purpose, provided that the modified +-- version is clearly presented as such, and that it does not claim to +-- be a definition of the Haskell 98 Foreign Function Interface. + +-- ----------------------------------------------------------------------------- + +readEither :: Read a => String -> Either String a +readEither s = + case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of + [x] -> Right x + [] -> Left "Prelude.read: no parse" + _ -> Left "Prelude.read: ambiguous parse" + where + read' = + do x <- readPrec + lift P.skipSpaces + return x + +readMaybe :: Read a => String -> Maybe a +readMaybe s = case readEither s of + Left _ -> Nothing + Right a -> Just a diff --git a/core/GhcMod/SrcUtils.hs b/core/GhcMod/SrcUtils.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/SrcUtils.hs @@ -0,0 +1,191 @@ +-- TODO: remove CPP once Gap(ed) +{-# LANGUAGE CPP, TupleSections, FlexibleInstances, Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GhcMod.SrcUtils where + +import Control.Applicative +import CoreUtils (exprType) +import Data.Generics +import Data.Maybe +import Data.Ord as O +import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L)) +import Var (Var) +import qualified GHC as G +import qualified Var as G +import qualified Type as G +import GHC.SYB.Utils +import GhcMonad +import qualified Language.Haskell.Exts as HE +import GhcMod.Doc +import GhcMod.Gap +import qualified GhcMod.Gap as Gap +import OccName (OccName) +import Outputable (PprStyle) +import TcHsSyn (hsPatType) +import Prelude +import Control.Monad +import Data.List (nub) +import Control.Arrow +import qualified Data.Map as M + +---------------------------------------------------------------- + +instance HasType (LHsExpr Id) where + getType tcm e = do + hs_env <- G.getSession + mbe <- liftIO $ Gap.deSugar tcm e hs_env + return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe + +instance HasType (LPat Id) where + getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat) + +---------------------------------------------------------------- + +-- | Stores mapping from monomorphic to polymorphic types +type CstGenQS = M.Map Var Type +-- | Generic type to simplify SYB definition +type CstGenQT a = forall m. GhcMonad m => a Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS) + +collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)] +collectSpansTypes withConstraints tcs lc = + -- This walks AST top-down, left-to-right, while carrying CstGenQS down the tree + -- (but not left-to-right) + everythingStagedWithContext TypeChecker M.empty (liftM2 (++)) + (return []) + ((return [],) + `mkQ` (hsBind :: CstGenQT G.LHsBind) -- matches on binds + `extQ` (genericCT :: CstGenQT G.LHsExpr) -- matches on expressions + `extQ` (genericCT :: CstGenQT G.LPat) -- matches on patterns + ) + (G.tm_typechecked_source tcs) + where + -- Helper function to insert mapping into CstGenQS + insExp x = M.insert (G.abe_mono x) (G.varType $ G.abe_poly x) + -- If there is AbsBinds here, insert mapping into CstGenQS if needed + hsBind (L _ G.AbsBinds{abs_exports = es'}) s + | withConstraints = (return [], foldr insExp s es') + | otherwise = (return [], s) +#if __GLASGOW_HASKELL__ >= 800 + -- TODO: move to Gap + -- Note: this deals with bindings with explicit type signature, e.g. + -- double :: Num a => a -> a + -- double x = 2*x + hsBind (L _ G.AbsBindsSig{abs_sig_export = poly, abs_sig_bind = bind}) s + | withConstraints = + let new_s = + case bind of + G.L _ G.FunBind{fun_id = i} -> M.insert (G.unLoc i) (G.varType poly) s + _ -> s + in (return [], new_s) + | otherwise = (return [], s) +#endif + -- Otherwise, it's the same as other cases + hsBind x s = genericCT x s + -- Generic SYB function to get type + genericCT x s + | withConstraints + = (maybe [] (uncurry $ constrainedType (collectBinders x) s) <$> getType' x, s) + | otherwise = (maybeToList <$> getType' x, s) + -- Collects everything with Id from LHsBind, LHsExpr, or LPat + collectBinders :: Data a => a -> [Id] + collectBinders = listifyStaged TypeChecker (const True) + -- Gets monomorphic type with location + getType' x@(L spn _) + | G.isGoodSrcSpan spn && spn `G.spans` lc + = getType tcs x + | otherwise = return Nothing + -- Gets constrained type + constrainedType :: [Var] -- ^ Binders in expression, i.e. anything with Id + -> CstGenQS -- ^ Map from Id to polymorphic type + -> SrcSpan -- ^ extent of expression, copied to result + -> Type -- ^ monomorphic type + -> [(SrcSpan, Type)] -- ^ result + constrainedType pids s spn genTyp = + let + -- runs build on every binder. + ctys = mapMaybe build (nub pids) + -- Computes constrained type for x. Returns (constraints, substitutions) + -- Substitutions are needed because type variables don't match + -- between polymorphic and monomorphic types. + -- E.g. poly type might be `Monad m => m ()`, while monomorphic might be `f ()` + build x | Just cti <- x `M.lookup` s + = let + (preds', ctt) = getPreds cti + -- list of type variables in monomorphic type + vts = listifyStaged TypeChecker G.isTyVar $ G.varType x + -- list of type variables in polymorphic type + tvm = listifyStaged TypeChecker G.isTyVarTy ctt + in Just (preds', zip vts tvm) + | otherwise = Nothing + -- list of constraints + preds = concatMap fst ctys + -- Type variable substitutions +#if __GLASGOW_HASKELL__ >= 800 + -- TODO: move to Gap + subs = G.mkTvSubstPrs $ concatMap snd ctys +#else + subs = G.mkTopTvSubst $ concatMap snd ctys +#endif + -- Constrained type + ty = G.substTy subs $ G.mkFunTys preds genTyp + in [(spn, ty)] + -- Splits a given type into list of constraints and simple type. Drops foralls. + getPreds :: Type -> ([Type], Type) + getPreds x | G.isForAllTy x = getPreds $ G.dropForAlls x + | Just (c, t) <- G.splitFunTy_maybe x + , G.isPredTy c = first (c:) $ getPreds t + | otherwise = ([], x) + +listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] +listifySpans tcs lc = listifyStaged TypeChecker p tcs + where + p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc + +listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a] +listifyParsedSpans pcs lc = listifyStaged Parser p pcs + where + p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc + +listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a] +listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs + where + p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc + +listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] +listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) + +cmp :: SrcSpan -> SrcSpan -> Ordering +cmp a b + | a `G.isSubspanOf` b = O.LT + | b `G.isSubspanOf` a = O.GT + | otherwise = O.EQ + +toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String) +toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ) + +fourInts :: SrcSpan -> (Int,Int,Int,Int) +fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan + +fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int) +fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc + , HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc) + +-- Check whether (line,col) is inside a given SrcSpanInfo +typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool +typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) = + HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) +typeSigInRangeHE lineNo colNo (HE.TypeFamDecl (HE.SrcSpanInfo s _) _ _ _) = + HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) +typeSigInRangeHE lineNo colNo (HE.DataFamDecl (HE.SrcSpanInfo s _) _ _ _) = + HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) +typeSigInRangeHE _ _ _= False + +pretty :: DynFlags -> PprStyle -> Type -> String +pretty dflag style = showOneLine dflag style . Gap.typeForUser + +showName :: DynFlags -> PprStyle -> G.Name -> String +showName dflag style name = showOneLine dflag style $ Gap.nameForUser name + +showOccName :: DynFlags -> PprStyle -> OccName -> String +showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name diff --git a/core/GhcMod/Stack.hs b/core/GhcMod/Stack.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Stack.hs @@ -0,0 +1,97 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +module GhcMod.Stack where + +import Safe +import Control.Applicative +import Control.Exception as E +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Class +import Data.List +import Data.List.Split +import Data.Maybe +import System.Directory +import System.FilePath +import System.Info.Extra +import Exception + +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.Output +import GhcMod.Logging +import GhcMod.Error +import qualified GhcMod.Utils as U +import Prelude + +patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs +patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do + Just ghc <- getStackGhcPath senv + Just ghcPkg <- getStackGhcPkgPath senv + return $ progs { + ghcProgram = ghc + , ghcPkgProgram = ghcPkg + } +patchStackPrograms _crdl progs = return progs + +getStackEnv :: (IOish m, GmOut m, GmLog m) + => FilePath -> FilePath -> m (Maybe StackEnv) +getStackEnv projdir stackProg = U.withDirectory_ projdir $ runMaybeT $ do + env <- map (liToTup . splitOn ": ") . lines <$> readStack stackProg ["path"] + let look k = fromJustNote "getStackEnv" $ lookup k env + return StackEnv { + seDistDir = look "dist-dir" + , seBinPath = splitSearchPath $ look "bin-path" + , seSnapshotPkgDb = look "snapshot-pkg-db" + , seLocalPkgDb = look "local-pkg-db" + } + where + liToTup [k,v] = (k,v) + liToTup [k] = (k, error "getStackEnv: missing key '"++k++"'") + liToTup _ = error "getStackEnv" + +getStackGhcPath :: IOish m => StackEnv -> m (Maybe FilePath) +getStackGhcPath = findExecutablesInStackBinPath "ghc" + +getStackGhcPkgPath :: IOish m => StackEnv -> m (Maybe FilePath) +getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg" + +findExecutablesInStackBinPath :: IOish m => String -> StackEnv -> m (Maybe FilePath) +findExecutablesInStackBinPath exe StackEnv {..} = + liftIO $ listToMaybe <$> findExecutablesInDirectories' seBinPath exe + +findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath] +findExecutablesInDirectories' path binary = + U.findFilesWith' isExecutable path (binary <.> exeExtension') + where isExecutable file = do + perms <- getPermissions file + return $ executable perms + + exeExtension' = if isWindows then "exe" else "" + +readStack :: (IOish m, GmOut m, GmLog m) + => FilePath -> [String] -> MaybeT m String +readStack exe args = do + stack <- MaybeT $ liftIO $ findExecutable exe + readProc <- lift gmReadProcess + flip gcatch handler $ do + liftIO $ evaluate =<< readProc stack args "" + where + handler (e :: IOError) = do + gmLog GmWarning "readStack" $ gmeDoc $ exToErr e + mzero + exToErr = GMEStackBootstrap . GMEString . show diff --git a/core/GhcMod/Target.hs b/core/GhcMod/Target.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Target.hs @@ -0,0 +1,515 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-} +module GhcMod.Target where + +import Control.Arrow +import Control.Applicative +import Control.Category ((.)) +import GHC +#if __GLASGOW_HASKELL__ >= 800 +import GHC.LanguageExtensions +#endif +import GHC.Paths (libdir) +import SysTools +import DynFlags +import HscTypes +import Pretty + +import GhcMod.DynFlags +import GhcMod.Monad.Types +import GhcMod.CabalHelper +import GhcMod.HomeModuleGraph +import GhcMod.PathsAndFiles +import GhcMod.GhcPkg +import GhcMod.Error +import GhcMod.Logging +import GhcMod.Types +import GhcMod.Utils as U +import GhcMod.FileMapping +import GhcMod.LightGhc +import GhcMod.CustomPackageDb +import GhcMod.Output + +import Safe +import Data.Maybe +import Data.Monoid as Monoid +import Data.Either +import Data.Foldable as Foldable (foldrM) +import qualified Data.Foldable as Foldable +import Data.Traversable hiding (mapM, forM) +import Data.IORef +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Function (on) +import Distribution.Helper +import Prelude hiding ((.)) + +import System.Directory +import System.FilePath + +runGmPkgGhc :: (IOish m, Gm m) => LightGhc a -> m a +runGmPkgGhc action = do + pkgOpts <- packageGhcOptions + withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action + +initSession :: IOish m + => [GHCOption] + -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) + -> GhcModT m () +initSession opts mdf = do + s <- gmsGet + case gmGhcSession s of + Nothing -> do + gmLog GmDebug "initSession" $ text "Session not initialized, creating new one" + putNewSession s + Just (GmGhcSession hsc_env_ref) -> do + crdl <- cradle + + df <- liftIO $ hsc_dflags <$> readIORef hsc_env_ref + changed <- + withLightHscEnv' (initDF crdl) $ \hsc_env -> + return $ not $ hsc_dflags hsc_env `eqDynFlags` df + + if changed + then do + gmLog GmDebug "initSession" $ text "Flags changed, creating new session" + teardownSession hsc_env_ref + putNewSession s + else + gmLog GmDebug "initSession" $ text "Session already initialized" + where + initDF Cradle { cradleTempDir } df = + setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df) + + teardownSession hsc_env_ref = do + hsc_env <- liftIO $ readIORef hsc_env_ref + teardownLightEnv hsc_env + + putNewSession :: IOish m => GhcModState -> GhcModT m () + putNewSession s = do + crdl <- cradle + nhsc_env_ref <- liftIO . newIORef =<< newLightEnv (initDF crdl) + runLightGhc' nhsc_env_ref $ setSessionDynFlags =<< getSessionDynFlags + gmsPut s { gmGhcSession = Just $ GmGhcSession nhsc_env_ref } + + +-- | Drop the currently active GHC session, the next that requires a GHC session +-- will initialize a new one. +dropSession :: IOish m => GhcModT m () +dropSession = do + s <- gmsGet + case gmGhcSession s of + Just (GmGhcSession ref) -> do + -- TODO: This is still not enough, there seem to still be references to + -- GHC's state around afterwards. + liftIO $ writeIORef ref (error "HscEnv: session was dropped") + -- Not available on ghc<7.8; didn't really help anyways + -- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped") + gmsPut s { gmGhcSession = Nothing } + + Nothing -> return () + +-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context +-- of certain files or modules +runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a +runGmlT fns action = runGmlT' fns return action + +-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context +-- of certain files or modules, with updated GHC flags +runGmlT' :: IOish m + => [Either FilePath ModuleName] + -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) + -> GmlT m a + -> GhcModT m a +runGmlT' fns mdf action = runGmlTWith fns mdf id action + +-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context +-- of certain files or modules, with updated GHC flags and a final +-- transformation +runGmlTWith :: IOish m + => [Either FilePath ModuleName] + -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) + -> (GmlT m a -> GmlT m b) + -> GmlT m a + -> GhcModT m b +runGmlTWith efnmns' mdf wrapper action = do + crdl <- cradle + Options { optGhcUserOptions } <- options + + let (fns, mns) = partitionEithers efnmns' + ccfns = map (cradleCurrentDir crdl ) fns + cfns <- mapM getCanonicalFileNameSafe ccfns + let serfnmn = Set.fromList $ map Right mns ++ map Left cfns + opts <- targetGhcOptions crdl serfnmn + let opts' = opts ++ ["-O0"] ++ optGhcUserOptions + + gmVomit + "session-ghc-options" + (text "Initializing GHC session with following options") + (intercalate " " $ map (("\""++) . (++"\"")) opts') + + GhcModLog { gmLogLevel = Just level } <- gmlHistory + putErr <- gmErrStrIO + let setLogger | level >= GmDebug = setDebugLogger putErr + | otherwise = setEmptyLogger + + initSession opts' $ + setHscNothing >>> setLogger >>> mdf + + mappedStrs <- getMMappedFilePaths + let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns + + unGmlT $ wrapper $ do + loadTargets opts targetStrs + action + +targetGhcOptions :: forall m. IOish m + => Cradle + -> Set (Either FilePath ModuleName) + -> GhcModT m [GHCOption] +targetGhcOptions crdl sefnmn = do + when (Set.null sefnmn) $ error "targetGhcOptions: no targets given" + + case cradleProject crdl of + proj + | isCabalHelperProject proj -> cabalOpts crdl + | otherwise -> sandboxOpts crdl + where + zipMap f l = l `zip` (f `map` l) + + cabalOpts :: Cradle -> GhcModT m [String] + cabalOpts Cradle{..} = do + mcs <- cabalResolvedComponents + + let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn + candidates = findCandidates $ map snd mdlcs + + let noCandidates = Set.null candidates + noModuleHasAnyAssignment = all (Set.null . snd) mdlcs + + if noCandidates && noModuleHasAnyAssignment + then do + -- First component should be ChLibName, if no lib will take lexically first exe. + let cns = filter (/= ChSetupHsName) $ Map.keys mcs + + gmLog GmDebug "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file." + return $ gmcGhcOpts $ fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup (head cns) mcs + else do + when noCandidates $ + throwError $ GMECabalCompAssignment mdlcs + + let cn = pickComponent candidates + return $ gmcGhcOpts $ fromJustNote "targetGhcOptions" $ Map.lookup cn mcs + +resolvedComponentsCache :: IOish m => FilePath -> + Cached (GhcModT m) GhcModState + [GmComponent 'GMCRaw (Set.Set ModulePath)] + (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) +resolvedComponentsCache distdir = Cached { + cacheLens = Just (lGmcResolvedComponents . lGmCaches), + cacheFile = resolvedComponentsCacheFile distdir, + cachedAction = \tcfs comps ma -> do + Cradle {..} <- cradle + let iifs = invalidatingInputFiles tcfs + + setupChanged = + (cradleRootDir setupConfigPath distdir) `elem` iifs + + mums :: Maybe [Either FilePath ModuleName] + mums = + let + filterOutSetupCfg = + filter (/= cradleRootDir setupConfigPath distdir) + changedFiles = filterOutSetupCfg iifs + in if null changedFiles || setupChanged + then Nothing + else Just $ map Left changedFiles + + let mdesc (Left f) = "file:" ++ f + mdesc (Right mn) = "module:" ++ moduleNameString mn + + changed = map (text . mdesc) $ Foldable.concat mums + changedDoc | [] <- changed = text "none" + | otherwise = sep changed + + gmLog GmDebug "resolvedComponentsCache" $ + text "files changed" <+>: changedDoc + + mcs <- resolveGmComponents ((,) <$> mums <*> ma) comps + + return (setupConfigPath distdir : flatten mcs , mcs) + } + + where + flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath)) + -> [FilePath] + flatten = Map.elems + >>> map (gmcHomeModuleGraph >>> gmgGraph + >>> (Map.keysSet &&& Map.elems) + >>> uncurry insert + >>> map (Set.map mpPath) + >>> Set.unions + ) + >>> Set.unions + >>> Set.toList + +moduleComponents :: Map ChComponentName (GmComponent t (Set ModulePath)) + -> Either FilePath ModuleName + -> Set ChComponentName +moduleComponents m efnmn = + foldr' Set.empty m $ \c s -> + let + memb = + case efnmn of + Left fn -> fn `Set.member` Set.map mpPath (smp c) + Right mn -> mn `Set.member` Set.map mpModule (smp c) + in if memb + then Set.insert (gmcName c) s + else s + where + smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c + + foldr' b as f = Map.foldr f b as + + +findCandidates :: [Set ChComponentName] -> Set ChComponentName +findCandidates [] = Set.empty +findCandidates scns = foldl1 Set.intersection scns + +pickComponent :: Set ChComponentName -> ChComponentName +pickComponent scn = Set.findMin scn + +packageGhcOptions :: (IOish m, Applicative m, Gm m) => m [GHCOption] +packageGhcOptions = do + crdl <- cradle + case cradleProject crdl of + proj + | isCabalHelperProject proj -> getGhcMergedPkgOptions + | otherwise -> sandboxOpts crdl + +-- also works for plain projects! +sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String] +sandboxOpts crdl = do + mCusPkgDb <- getCustomPkgDbStack + pkgDbStack <- liftIO $ getSandboxPackageDbStack + let pkgOpts = ghcDbStackOpts $ fromMaybe pkgDbStack mCusPkgDb + return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"] + where + (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl) + + getSandboxPackageDbStack :: IO [GhcPkgDb] + getSandboxPackageDbStack = + ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl + +resolveGmComponent :: (IOish m, Gm m) + => Maybe [CompilationUnit] -- ^ Updated modules + -> GmComponent 'GMCRaw (Set ModulePath) + -> m (GmComponent 'GMCResolved (Set ModulePath)) +resolveGmComponent mums c@GmComponent {..} = do + distDir <- cradleDistDir <$> cradle + gmLog GmDebug "resolveGmComponent" $ text $ show $ ghcOpts distDir + withLightHscEnv (ghcOpts distDir) $ \env -> do + let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs + let mg = gmcHomeModuleGraph + let simp = gmcEntrypoints + sump <- case mums of + Nothing -> return simp + Just ums -> + Set.fromList . catMaybes <$> + mapM (resolveModule env srcDirs) ums + + mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump + + return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' } + + where ghcOpts distDir = concat [ + gmcGhcSrcOpts, + gmcGhcLangOpts, + [ "-optP-include", "-optP" ++ distDir macrosHeaderPath ] + ] + +resolveEntrypoint :: (IOish m, Gm m) + => Cradle + -> GmComponent 'GMCRaw ChEntrypoint + -> m (GmComponent 'GMCRaw (Set ModulePath)) +resolveEntrypoint Cradle {..} c@GmComponent {..} = do + gmLog GmDebug "resolveEntrypoint" $ text $ show $ gmcGhcSrcOpts + withLightHscEnv gmcGhcSrcOpts $ \env -> do + let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs + eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints + rms <- resolveModule env srcDirs `mapM` eps + return c { gmcEntrypoints = Set.fromList $ catMaybes rms } + +-- TODO: remember that the file from `main-is:` is always module `Main` and let +-- ghc do the warning about it. Right now we run that module through +-- resolveModule like any other +resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit] +resolveChEntrypoints _ (ChLibEntrypoint em om) = + return $ map (Right . chModToMod) (em ++ om) + +resolveChEntrypoints _ (ChExeEntrypoint main om) = + return $ [Left main] ++ map (Right . chModToMod) om + +resolveChEntrypoints srcDir ChSetupEntrypoint = do + shs <- doesFileExist (srcDir "Setup.hs") + slhs <- doesFileExist (srcDir "Setup.lhs") + return $ case (shs, slhs) of + (True, _) -> [Left "Setup.hs"] + (_, True) -> [Left "Setup.lhs"] + (False, False) -> [] + +chModToMod :: ChModuleName -> ModuleName +chModToMod (ChModuleName mn) = mkModuleName mn + + +resolveModule :: (IOish m, Gm m) => + HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath) +resolveModule env _srcDirs (Right mn) = + liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn +resolveModule env srcDirs (Left fn') = do + mfn <- liftIO $ findFile' srcDirs fn' + case mfn of + Nothing -> return Nothing + Just fn'' -> do + fn <- liftIO $ canonicalizePath fn'' + emn <- fileModuleName env fn + case emn of + Left errs -> do + gmLog GmWarning ("resolveModule " ++ show fn) $ + Pretty.empty $+$ (vcat $ map text errs) + return Nothing -- TODO: should expose these errors otherwise + -- modules with preprocessor/parse errors are + -- going to be missing + Right mmn -> return $ Just $ + case mmn of + Nothing -> mkMainModulePath fn + Just mn -> ModulePath mn fn + where + -- needed for ghc 7.4 + findFile' dirs file = + getFirst . mconcat <$> mapM (fmap First . mightExist . (file)) dirs + + -- fileModuleName fn (dir:dirs) + -- | makeRelative dir fn /= fn + +type CompilationUnit = Either FilePath ModuleName +type Components = + [GmComponent 'GMCRaw (Set ModulePath)] +type ResolvedComponentsMap = + Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)) + +resolveGmComponents :: (IOish m, Gm m) + => Maybe ([CompilationUnit], ResolvedComponentsMap) + -- ^ Updated modules + -> Components -> m ResolvedComponentsMap +resolveGmComponents mcache cs = do + let rcm = fromMaybe Map.empty $ snd <$> mcache + + m' <- foldrM' rcm cs $ \c m -> do + case Map.lookup (gmcName c) m of + Nothing -> insertUpdated m c + Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c' + then return m + else insertUpdated m c + return m' + + where + foldrM' b fa f = foldrM f b fa + insertUpdated m c = do + rc <- resolveGmComponent (fst <$> mcache) c + return $ Map.insert (gmcName rc) rc m + + same :: Eq b + => (forall t a. GmComponent t a -> b) + -> GmComponent u c -> GmComponent v d -> Bool + same f a b = (f a) == (f b) + +-- | Set the files as targets and load them. +loadTargets :: IOish m => [GHCOption] -> [FilePath] -> GmlT m () +loadTargets opts targetStrs = do + targets' <- + withLightHscEnv opts $ \env -> + liftM (nubBy ((==) `on` targetId)) + (mapM ((`guessTarget` Nothing) >=> mapFile env) targetStrs) + >>= mapM relativize + + let targets = map (\t -> t { targetAllowObjCode = False }) targets' + + gmLog GmDebug "loadTargets" $ + text "Loading" <+>: fsep (map (text . showTargetId) targets) + + setTargets targets + + mg <- depanal [] False + + let interp = needsHscInterpreted mg + target <- hscTarget <$> getSessionDynFlags + when (interp && target /= HscInterpreted) $ do + _ <- setSessionDynFlags . setHscInterpreted =<< getSessionDynFlags + gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms." + + target' <- hscTarget <$> getSessionDynFlags + + case target' of + HscNothing -> do + void $ load LoadAllTargets + forM_ mg $ + handleSourceError (gmLog GmDebug "loadTargets" . text . show) + . void . (parseModule >=> typecheckModule >=> desugarModule) + HscInterpreted -> do + void $ load LoadAllTargets + _ -> error ("loadTargets: unsupported hscTarget") + + gmLog GmDebug "loadTargets" $ text "Loading done" + + where + relativize (Target (TargetFile filePath phase) taoc src) = do + crdl <- cradle + let tid = TargetFile relativeFilePath phase + relativeFilePath = makeRelative (cradleRootDir crdl) filePath + return $ Target tid taoc src + relativize tgt = return tgt + + showTargetId (Target (TargetModule s) _ _) = moduleNameString s + showTargetId (Target (TargetFile s _) _ _) = s + +needsHscInterpreted :: ModuleGraph -> Bool +needsHscInterpreted = any $ \ms -> + let df = ms_hspp_opts ms in +#if __GLASGOW_HASKELL__ >= 800 + TemplateHaskell `xopt` df + || QuasiQuotes `xopt` df + || PatternSynonyms `xopt` df +#else + Opt_TemplateHaskell `xopt` df + || Opt_QuasiQuotes `xopt` df +#if __GLASGOW_HASKELL__ >= 708 + || (Opt_PatternSynonyms `xopt` df) +#endif +#endif + +cabalResolvedComponents :: (IOish m) => + GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) +cabalResolvedComponents = do + crdl@(Cradle{..}) <- cradle + comps <- mapM (resolveEntrypoint crdl) =<< getComponents + withAutogen $ + cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps diff --git a/core/GhcMod/Types.hs b/core/GhcMod/Types.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Types.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes, + StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell, + GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} +module GhcMod.Types ( + module GhcMod.Types + , ModuleName + , mkModuleName + , moduleNameString + ) where + +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Error (Error(..)) +import qualified Control.Monad.IO.Class as MTL +import Control.Exception (Exception) +import Control.Applicative +import Control.Concurrent +import Control.Monad +import Control.DeepSeq +import Data.Binary +import Data.Binary.Generic +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Monoid +import Data.Maybe +import Data.Typeable (Typeable) +import Data.IORef +import Data.Label.Derive +import Distribution.Helper hiding (Programs(..)) +import qualified Distribution.Helper as CabalHelper +import Exception (ExceptionMonad) +#if __GLASGOW_HASKELL__ < 708 +import qualified MonadUtils as GHC (MonadIO(..)) +#endif +import GHC (ModuleName, moduleNameString, mkModuleName) +import HscTypes (HscEnv) +import GHC.Generics +import Pretty (Doc) +import Prelude + +import GhcMod.Caching.Types + +-- | A constraint alias (-XConstraintKinds) to make functions dealing with +-- 'GhcModT' somewhat cleaner. +-- +-- Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and +-- exception handling. Usually this will simply be 'IO' but we parametrise it in +-- the exported API so users have the option to use a custom inner monad. +type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m) + + +-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. +-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. +#if __GLASGOW_HASKELL__ < 708 +type MonadIOC m = (GHC.MonadIO m, MTL.MonadIO m) +#else +type MonadIOC m = (MTL.MonadIO m) +#endif + +class MonadIOC m => MonadIO m where + liftIO :: IO a -> m a + +-- | Output style. +data OutputStyle = LispStyle -- ^ S expression style. + | PlainStyle -- ^ Plain textstyle. + deriving (Show) + +-- | The type for line separator. Historically, a Null string is used. +newtype LineSeparator = LineSeparator String deriving (Show) + +data FileMapping = FileMapping {fmPath :: FilePath, fmTemp :: Bool} + deriving (Eq, Show) + +type FileMappingMap = Map FilePath FileMapping + +data ProgramSource = ProgramSourceUser | ProgramSourceStack + +data Programs = Programs { + -- | @ghc@ program name. + ghcProgram :: FilePath + -- | @ghc-pkg@ program name. + , ghcPkgProgram :: FilePath + -- | @cabal@ program name. + , cabalProgram :: FilePath + -- | @stack@ program name. + , stackProgram :: FilePath + } deriving (Show) + +data OutputOpts = OutputOpts { + -- | Verbosity + ooptLogLevel :: GmLogLevel + , ooptStyle :: OutputStyle + -- | Line separator string. + , ooptLineSeparator :: LineSeparator + -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout, + -- @snd@ is stderr prefix. + , ooptLinePrefix :: Maybe (String, String) + } deriving (Show) + +data Options = Options { + optOutput :: OutputOpts + , optPrograms :: Programs + -- | GHC command line options set on the @ghc-mod@ command line + , optGhcUserOptions :: [GHCOption] + , optFileMappings :: [(FilePath, Maybe FilePath)] + , optEncoding :: String + , optStackBuildDeps :: Bool + } deriving (Show) + +-- | A default 'Options'. +defaultOptions :: Options +defaultOptions = Options { + optOutput = OutputOpts { + ooptLogLevel = GmWarning + , ooptStyle = PlainStyle + , ooptLineSeparator = LineSeparator "\0" + , ooptLinePrefix = Nothing + } + , optPrograms = Programs { + ghcProgram = "ghc" + , ghcPkgProgram = "ghc-pkg" + , cabalProgram = "cabal" + , stackProgram = "stack" + } + , optGhcUserOptions = [] + , optFileMappings = [] + , optEncoding = "UTF-8" + , optStackBuildDeps = False + } + +---------------------------------------------------------------- + +data Project = CabalProject + | SandboxProject + | PlainProject + | StackProject StackEnv + deriving (Eq, Show, Ord) + +isCabalHelperProject :: Project -> Bool +isCabalHelperProject StackProject {} = True +isCabalHelperProject CabalProject {} = True +isCabalHelperProject _ = False + +data StackEnv = StackEnv { + seDistDir :: FilePath + , seBinPath :: [FilePath] + , seSnapshotPkgDb :: FilePath + , seLocalPkgDb :: FilePath + } deriving (Eq, Show, Ord) + +-- | The environment where this library is used. +data Cradle = Cradle { + cradleProject :: Project + -- | The directory where this library is executed. + , cradleCurrentDir :: FilePath + -- | The project root directory. + , cradleRootDir :: FilePath + -- | Per-Project temporary directory + , cradleTempDir :: FilePath + -- | The file name of the found cabal file. + , cradleCabalFile :: Maybe FilePath + -- | The build info directory. + , cradleDistDir :: FilePath + } deriving (Eq, Show, Ord) + +data GmStream = GmOutStream | GmErrStream + deriving (Show) + +data GhcModEnv = GhcModEnv { + gmOptions :: Options + , gmCradle :: Cradle + } + +data GhcModOut = GhcModOut { + gmoOptions :: OutputOpts + , gmoChan :: Chan (Either (MVar ()) (GmStream, String)) + } + +data GhcModLog = GhcModLog { + gmLogLevel :: Maybe GmLogLevel, + gmLogVomitDump :: Last Bool, + gmLogMessages :: [(GmLogLevel, String, Doc)] + } deriving (Show) + +instance Monoid GhcModLog where + mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty + GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' = + GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls') + +data GmGhcSession = GmGhcSession { + gmgsSession :: !(IORef HscEnv) + } + +data GhcModCaches = GhcModCaches { + gmcPackageDbStack :: CacheContents ChCacheData [GhcPkgDb] + , gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption] + , gmcComponents :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint] + , gmcResolvedComponents :: CacheContents + [GmComponent 'GMCRaw (Set.Set ModulePath)] + (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) + } + +data GhcModState = GhcModState { + gmGhcSession :: !(Maybe GmGhcSession) + , gmCaches :: !GhcModCaches + , gmMMappedFiles :: !FileMappingMap + } + +defaultGhcModState :: GhcModState +defaultGhcModState = + GhcModState n (GhcModCaches n n n n) Map.empty + where n = Nothing + +---------------------------------------------------------------- + +-- | GHC package database flags. +data GhcPkgDb = GlobalDb + | UserDb + | PackageDb String + deriving (Eq, Show, Generic) + +instance Binary GhcPkgDb where + put = ggput . from + get = to `fmap` ggget + +-- | A single GHC command line option. +type GHCOption = String + +-- | An include directory for modules. +type IncludeDir = FilePath + +-- | Haskell expression. +newtype Expression = Expression { getExpression :: String } + deriving (Show, Eq, Ord) + +-- | Module name. +newtype ModuleString = ModuleString { getModuleString :: String } + deriving (Show, Eq, Ord, Binary, NFData) + +data GmLogLevel = + GmSilent + | GmPanic + | GmException + | GmError + | GmWarning + | GmInfo + | GmDebug + | GmVomit + deriving (Eq, Ord, Enum, Bounded, Show, Read) + +data GmModuleGraph = GmModuleGraph { + gmgGraph :: Map ModulePath (Set ModulePath) + } deriving (Eq, Ord, Show, Read, Generic, Typeable) + +instance Binary GmModuleGraph where + put GmModuleGraph {..} = put (mpim, graph) + where + mpim :: Map ModulePath Integer + mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..] + graph :: Map Integer (Set Integer) + graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph + mpToInt :: ModulePath -> Integer + mpToInt mp = fromJust $ Map.lookup mp mpim + + get = do + (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get + let impm = swapMap mpim + intToMp i = fromJust $ Map.lookup i impm + mpGraph :: Map ModulePath (Set ModulePath) + mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph + return $ GmModuleGraph mpGraph + where + swapMap :: Ord v => Map k v -> Map v k + swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList + +instance Monoid GmModuleGraph where + mempty = GmModuleGraph mempty + mappend (GmModuleGraph a) (GmModuleGraph a') = + GmModuleGraph (Map.unionWith Set.union a a') + +data GmComponentType = GMCRaw + | GMCResolved +data GmComponent (t :: GmComponentType) eps = GmComponent { + gmcHomeModuleGraph :: GmModuleGraph + , gmcName :: ChComponentName + , gmcGhcOpts :: [GHCOption] + , gmcGhcPkgOpts :: [GHCOption] + , gmcGhcSrcOpts :: [GHCOption] + , gmcGhcLangOpts :: [GHCOption] + , gmcRawEntrypoints :: ChEntrypoint + , gmcEntrypoints :: eps + , gmcSourceDirs :: [FilePath] + } deriving (Eq, Ord, Show, Read, Generic, Functor) + +instance Binary eps => Binary (GmComponent t eps) where + put = ggput . from + get = to `fmap` ggget + +data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath } + deriving (Eq, Ord, Show, Read, Generic, Typeable) +instance Binary ModulePath where + put = ggput . from + get = to `fmap` ggget + +instance Binary ModuleName where + get = mkModuleName <$> get + put mn = put (moduleNameString mn) + +instance Show ModuleName where + show mn = "ModuleName " ++ show (moduleNameString mn) + +instance Read ModuleName where + readsPrec d = + readParen + (d > app_prec) + (\r' -> [ (mkModuleName m, t) + | ("ModuleName", s) <- lex r' + , (m, t) <- readsPrec (app_prec + 1) s + ]) + where + app_prec = 10 + +data GhcModError + = GMENoMsg + -- ^ Unknown error + + | GMEString String + -- ^ Some Error with a message. These are produced mostly by + -- 'fail' calls on GhcModT. + + | GMECabalConfigure GhcModError + -- ^ Configuring a cabal project failed. + + | GMEStackConfigure GhcModError + -- ^ Configuring a stack project failed. + + | GMEStackBootstrap GhcModError + -- ^ Bootstrapping @stack@ environment failed (process exited with failure) + + | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)] + -- ^ Could not find a consistent component assignment for modules + + | GMEProcess String String [String] (Either Int GhcModError) + -- ^ Launching an operating system process failed. Fields in + -- order: function, command, arguments, (stdout, stderr, exitcode) + + | GMENoCabalFile + -- ^ No cabal file found. + + | GMETooManyCabalFiles [FilePath] + -- ^ Too many cabal files found. + + deriving (Eq,Show,Typeable) + +instance Error GhcModError where + noMsg = GMENoMsg + strMsg = GMEString + +instance Exception GhcModError + +instance Binary CabalHelper.Programs where + put = ggput . from + get = to `fmap` ggget +instance Binary ChModuleName where + put = ggput . from + get = to `fmap` ggget +instance Binary ChComponentName where + put = ggput . from + get = to `fmap` ggget +instance Binary ChEntrypoint where + put = ggput . from + get = to `fmap` ggget + +-- | Options for "lintWith" function +data LintOpts = LintOpts { + optLintHlintOpts :: [String] + -- ^ options that will be passed to hlint executable + } deriving (Show) + +-- | Default "LintOpts" instance +defaultLintOpts :: LintOpts +defaultLintOpts = LintOpts [] + +-- | Options for "browseWith" function +data BrowseOpts = BrowseOpts { + optBrowseOperators :: Bool + -- ^ If 'True', "browseWith" also returns operators. + , optBrowseDetailed :: Bool + -- ^ If 'True', "browseWith" also returns types. + , optBrowseParents :: Bool + -- ^ If 'True', "browseWith" also returns parents. + , optBrowseQualified :: Bool + -- ^ If 'True', "browseWith" will return fully qualified name + } deriving (Show) + +-- | Default "BrowseOpts" instance +defaultBrowseOpts :: BrowseOpts +defaultBrowseOpts = BrowseOpts False False False False + +mkLabel ''GhcModCaches +mkLabel ''GhcModState +mkLabel ''Options +mkLabel ''OutputOpts +mkLabel ''Programs diff --git a/core/GhcMod/Utils.hs b/core/GhcMod/Utils.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/Utils.hs @@ -0,0 +1,165 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} + +module GhcMod.Utils ( + module GhcMod.Utils + , module Utils + , readProcess + ) where + +import Control.Applicative +import Data.Char +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Either (rights) +import Data.List (inits) +import Exception +import GhcMod.Error +import GhcMod.Types +import GhcMod.Monad.Types +import System.Directory +import System.Environment +import System.FilePath +import System.IO.Temp (createTempDirectory) +import System.Process (readProcess) +import Text.Printf + +import Paths_ghc_mod (getLibexecDir, getBinDir) +import Utils +import Prelude + +-- dropWhileEnd is not provided prior to base 4.5.0.0. +dropWhileEnd :: (a -> Bool) -> [a] -> [a] +dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] + +withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a +withDirectory_ dir action = + gbracket + (liftIO getCurrentDirectory) + (liftIO . setCurrentDirectory) + (\_ -> liftIO (setCurrentDirectory dir) >> action) + +uniqTempDirName :: FilePath -> FilePath +uniqTempDirName dir = + "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path + where + (drive, path) = splitDrive dir + escapeDriveChar :: Char -> Char + escapeDriveChar c + | isAlphaNum c = c + | otherwise = '-' + escapePathChar :: Char -> Char + escapePathChar c + | c `elem` pathSeparators = '-' + | otherwise = c + +newTempDir :: FilePath -> IO FilePath +newTempDir _dir = + flip createTempDirectory "ghc-mod" =<< getTemporaryDirectory + +whenM :: Monad m => m Bool -> m () -> m () +whenM mb ma = mb >>= flip when ma + +-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6 +-- this is a guess but >=7.6 uses 'getExecutablePath'. +ghcModExecutable :: IO FilePath +ghcModExecutable = do + exe <- getExecutablePath' + stack <- lookupEnv "STACK_EXE" + case takeBaseName exe of + "spec" | Just _ <- stack -> + ( "ghc-mod") <$> getBinDir + "spec" -> + ( "dist/build/ghc-mod/ghc-mod") <$> getCurrentDirectory + "ghc-mod" -> + return exe + _ -> + return $ takeDirectory exe "ghc-mod" + +getExecutablePath' :: IO FilePath +#if __GLASGOW_HASKELL__ >= 706 +getExecutablePath' = getExecutablePath +#else +getExecutablePath' = getProgName +#endif + +canonFilePath :: FilePath -> IO FilePath +canonFilePath f = do + p <- canonicalizePath f + e <- doesFileExist p + when (not e) $ error $ "canonFilePath: not a file: " ++ p + return p + +withMappedFile :: (IOish m, GmState m, GmEnv m) => + forall a. FilePath -> (FilePath -> m a) -> m a +withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile >>= runWithFile + where + runWithFile (Just to) = action $ fmPath to + runWithFile _ = action file + +getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath +getCanonicalFileNameSafe fn = do + let fn' = normalise fn + pl <- liftIO $ rights <$> (mapM ((try :: IO FilePath -> IO (Either SomeException FilePath)) . canonicalizePath . joinPath) $ reverse $ inits $ splitPath' fn') + return $ + if (length pl > 0) + then joinPath $ (head pl):(drop (length pl - 1) (splitPath fn')) + else error "Current dir doesn't seem to exist?" + where +#if __GLASGOW_HASKELL__ < 710 + splitPath' = (".":) . splitPath +#else + splitPath' = splitPath +#endif + +mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath) +mkRevRedirMapFunc = do + rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles + crdl <- cradle + return $ \key -> + fromMaybe key + $ makeRelative (cradleRootDir crdl) + <$> M.lookup key rm + where + mf :: FilePath -> FileMapping -> (FilePath, FilePath) + mf from to = (fmPath to, from) + +findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath] +findFilesWith' _ [] _ = return [] +findFilesWith' f (d:ds) fileName = do + let file = d fileName + exist <- doesFileExist file + b <- if exist then f file else return False + if b then do + files <- findFilesWith' f ds fileName + return $ file : files + else findFilesWith' f ds fileName + + +-- Copyright : (c) The University of Glasgow 2001 +-- | Make a path absolute by prepending the current directory (if it isn't +-- already absolute) and applying 'normalise' to the result. +-- +-- If the path is already absolute, the operation never fails. Otherwise, the +-- operation may fail with the same exceptions as 'getCurrentDirectory'. +makeAbsolute' :: FilePath -> IO FilePath +makeAbsolute' = (normalise <$>) . absolutize + where absolutize path -- avoid the call to `getCurrentDirectory` if we can + | isRelative path = ( path) <$> getCurrentDirectory + | otherwise = return path diff --git a/core/GhcMod/World.hs b/core/GhcMod/World.hs new file mode 100644 --- /dev/null +++ b/core/GhcMod/World.hs @@ -0,0 +1,55 @@ +module GhcMod.World where + +import GhcMod.GhcPkg +import GhcMod.PathsAndFiles +import GhcMod.Types +import GhcMod.Monad.Types +import GhcMod.Utils + +import Control.Applicative +import Data.Maybe +import Data.Traversable hiding (mapM) +import System.FilePath (()) + +import GHC.Paths (libdir) +import Prelude + +data World = World { + worldPackageCaches :: [TimedFile] + , worldCabalFile :: Maybe TimedFile + , worldCabalConfig :: Maybe TimedFile + , worldCabalSandboxConfig :: Maybe TimedFile + , worldMappedFiles :: FileMappingMap + } deriving (Eq) + +timedPackageCaches :: IOish m => GhcModT m [TimedFile] +timedPackageCaches = do + fs <- mapM (liftIO . mightExist) . map ( packageCache) + =<< getPackageCachePaths libdir + (liftIO . timeFile) `mapM` catMaybes fs + +getCurrentWorld :: IOish m => GhcModT m World +getCurrentWorld = do + crdl <- cradle + pkgCaches <- timedPackageCaches + mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl + mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) + mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl) + mFileMap <- getMMappedFiles + + return World { + worldPackageCaches = pkgCaches + , worldCabalFile = mCabalFile + , worldCabalConfig = mCabalConfig + , worldCabalSandboxConfig = mCabalSandboxConfig + , worldMappedFiles = mFileMap + } + +didWorldChange :: IOish m => World -> GhcModT m Bool +didWorldChange world = do + (world /=) <$> getCurrentWorld + +isYoungerThanSetupConfig :: FilePath -> World -> IO Bool +isYoungerThanSetupConfig file World {..} = do + tfile <- timeFile file + return $ worldCabalConfig < Just tfile diff --git a/elisp/Makefile b/elisp/Makefile --- a/elisp/Makefile +++ b/elisp/Makefile @@ -1,17 +1,17 @@ SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-check.el ghc-process.el \ ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el ghc-rewrite.el EMACS = emacs -DETECT = xemacs TEMPFILE = temp.el +TEMPFILE2 = temp2.el all: $(TEMPFILE) ghc.el $(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE) -f ghc-compile rm -f $(TEMPFILE) -detect: $(TEMPFILE) ghc.el - $(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE) -f ghc-compile - rm -f $(DETECT) +lint: $(TEMPFILE2) ghc.el + $(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE2) -f ghc-compile + rm -f $(TEMPFILE2) $(TEMPFILE): @echo '(setq load-path (cons "." load-path))' >> $(TEMPFILE) @@ -19,8 +19,15 @@ @echo $(SRCS)| sed -e 's/\(ghc[^ ]*\.el\)/"\1"/g' >> $(TEMPFILE) @echo ')))' >> $(TEMPFILE) +$(TEMPFILE2): + @echo '(setq load-path (cons "." load-path))' >> $(TEMPFILE2) + @echo '(setq hack-local-variables-hook (lambda () (setq lexical-binding t)))' >> $(TEMPFILE2) + @echo '(defun ghc-compile () (mapcar (lambda (x) (byte-compile-file x)) (list ' >> $(TEMPFILE2) + @echo $(SRCS)| sed -e 's/\(ghc[^ ]*\.el\)/"\1"/g' >> $(TEMPFILE2) + @echo ')))' >> $(TEMPFILE2) + clean: - rm -f *.elc $(TEMPFILE) + rm -f *.elc $(TEMPFILE) $(TEMPFILE2) VERSION = `grep version ghc.el | sed -e 's/[^0-9\.]//g'` diff --git a/elisp/ghc-check.el b/elisp/ghc-check.el --- a/elisp/ghc-check.el +++ b/elisp/ghc-check.el @@ -20,7 +20,7 @@ :underline (:style wave :color "orangered")) (t :inherit error)) - "Face used for marking error lines." + "Face used for error lines." :group 'ghc) (defface ghc-face-warn @@ -28,7 +28,7 @@ :underline (:style wave :color "gold")) (t :inherit warning)) - "Face used for marking warning lines." + "Face used for warning lines." :group 'ghc) (defface ghc-face-hole @@ -36,7 +36,7 @@ :underline (:style wave :color "purple")) (t :inherit warning)) - "Face used for marking hole lines." + "Face used for hole lines." :group 'ghc) (defvar ghc-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark))) @@ -46,27 +46,30 @@ (defvar ghc-check-hole-fringe (propertize "_" 'display '(left-fringe horizontal-bar))) (defvar ghc-display-error nil - "*An action to display errors/warnings for 'M-n' and 'M-p: + "*How to display errors/warnings when using 'M-n' and 'M-p': -nil does not display errors/warnings. -'minibuffer displays errors/warnings in the minibuffer. -'other-buffer displays errors/warnings in the other buffer. +nil do not display errors/warnings. +'minibuffer display errors/warnings in the minibuffer. +'other-buffer display errors/warnings in a new buffer. ") (defvar ghc-display-hole 'other-buffer - "*An action to display hole information for 'C-c C-j' and 'C-c C-h' + "*How to display hole information when using 'C-c C-j' and 'C-c C-h' -'minibuffer displays errors/warnings in the minibuffer. -'other-buffer displays errors/warnings in the other buffer" +'minibuffer display errors/warnings in the minibuffer. +'other-buffer display errors/warnings in the a new buffer" ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-check-syntax () (interactive) - (ghc-with-process (ghc-check-send) - 'ghc-check-callback - (lambda () (setq mode-line-process " -:-")))) + ;; Only check syntax of visible buffers + (when (and (buffer-file-name) + (file-exists-p (buffer-file-name))) + (ghc-with-process (ghc-check-send) + 'ghc-check-callback + (lambda () (setq mode-line-process " -:-"))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -129,10 +132,10 @@ (defun ghc-to-info (errs) ;; [^\t] to include \n. (let ((regex "^\\([^\n]*\\):\\([0-9]+\\):\\([0-9]+\\): *\\([^\t]+\\)") - info infos) + infos) (dolist (err errs (nreverse infos)) (when (string-match regex err) - (let* ((file (expand-file-name (match-string 1 err))) ;; for Windows + (let* ((file (expand-file-name (match-string 1 err) ghc-process-root)) ;; for Windows (line (string-to-number (match-string 2 err))) (coln (string-to-number (match-string 3 err))) (msg (match-string 4 err)) @@ -167,18 +170,21 @@ ;; If this is a bottleneck for a large code, let's fix. (goto-char (point-min)) (cond - ((and (string= ofile file) hole) - (forward-line (1- line)) - (forward-char (1- coln)) - (setq beg (point)) - (forward-char (length hole)) - (setq end (point))) - ((string= ofile file) - (forward-line (1- line)) - (while (eq (char-after) 32) (forward-char)) - (setq beg (point)) - (forward-line) - (setq end (1- (point)))) + ((file-equal-p ofile file) + (if hole + (progn + (forward-line (1- line)) + (forward-char (1- coln)) + (setq beg (point)) + (forward-char (length hole)) + (setq end (point))) + (progn + (forward-line (1- line)) + (forward-char (1- coln)) + (setq beg (point)) + (forward-sexp) + ;; (skip-chars-forward "^[:space:]" (line-end-position)) + (setq end (point))))) (t (setq beg (point)) (forward-line) @@ -285,14 +291,13 @@ (let ((file-msgs (ghc-get-only-holes))) (if (null file-msgs) (message "No holes") - (let ((file (ghc-file-msgs-get-file file-msgs)) - (msgs (ghc-file-msgs-get-msgs file-msgs))) + (let ((msgs (ghc-file-msgs-get-msgs file-msgs))) (ghc-display nil (lambda () (progn (mapc (lambda (x) (insert x "\n\n")) msgs) - (buttonize-buffer)) )))))) + (buttonize-buffer)))))))) (defun ghc-display-holes-to-minibuf () (let ((file-msgs (ghc-get-only-holes))) @@ -410,6 +415,10 @@ (let ((old (match-string 1 data)) (new (match-string 2 data))) (ghc-check-replace old new))) + ((string-match "Found hole .\\(_[_[:alnum:]]*\\). with type: \\([^\t\n]+\\)" data) + (let ((old (match-string 1 data)) + (new (match-string 2 data))) + (ghc-check-replace old new))) (t (setq ret nil))))))) @@ -465,7 +474,7 @@ (forward-line) (re-search-forward "^$" nil t) (insert fn) - (dotimes (i arity) + (dotimes (_i arity) (insert " _")) (insert " = error \"" fn "\"\n"))))) diff --git a/elisp/ghc-command.el b/elisp/ghc-command.el --- a/elisp/ghc-command.el +++ b/elisp/ghc-command.el @@ -53,7 +53,7 @@ (let ((inhibit-field-text-motion t)) (sort-subr nil 'forward-line 'end-of-line (lambda () - (re-search-forward "^import\\( *qualified\\)? *" nil t) + (re-search-forward "^import +\\(qualified\\)? *" nil t) nil) 'end-of-line)) (ghc-merge-lines)))) @@ -64,7 +64,7 @@ (while (not (eolp)) ;; qualified modlues are not merged at this moment. ;; fixme if it is improper. - (if (looking-at "^import *\\([A-Z][^ \n]+\\) *(\\(.*\\))$") + (if (looking-at "^import +\\([A-Z][^ \n]+\\) *(\\(.*\\))$") (let ((mod (match-string-no-properties 1)) (syms (match-string-no-properties 2)) (beg (point))) @@ -73,7 +73,7 @@ (forward-line))))) (defun ghc-merge-line (beg mod syms) - (let ((regex (concat "^import *" (regexp-quote mod) " *(\\(.*\\))$")) + (let ((regex (concat "^import +" (regexp-quote mod) " *(\\(.*\\))$")) duplicated) (while (looking-at regex) (setq duplicated t) diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el --- a/elisp/ghc-comp.el +++ b/elisp/ghc-comp.el @@ -127,7 +127,7 @@ (interactive) (if (ghc-should-scroll) (ghc-scroll-completion-buffer) - (ghc-try-complete))) + (ghc-try-complete))) (defun ghc-should-scroll () (let ((window (ghc-completion-window))) @@ -265,7 +265,7 @@ (let (ret) (save-excursion (goto-char (point-min)) - (while (re-search-forward "^import\\( *qualified\\)? +\\([^\n ]+\\)" nil t) + (while (re-search-forward "^import +\\(qualified\\)? *\\([^\n ]+\\)" nil t) (ghc-add ret (match-string-no-properties 2)) (forward-line))) ret)) diff --git a/elisp/ghc-doc.el b/elisp/ghc-doc.el --- a/elisp/ghc-doc.el +++ b/elisp/ghc-doc.el @@ -10,6 +10,17 @@ (require 'ghc-comp) (require 'ghc-info) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Customize Variables +;;; + +(defcustom ghc-doc-browser-function #'browse-url + "Function used to browse documentation." + :type '(radio (function-item browse-url) + (function-item ghc-browse-url-safari)) + :group 'ghc-mod) + ;;; Code: (defun ghc-browse-document (&optional haskell-org) @@ -22,40 +33,49 @@ (setq expr (ghc-read-expression expr0)) (setq info (ghc-get-info expr0)) (setq mod (ghc-extact-module-from-info info))) - (setq pkg-ver-path (ghc-resolve-document-path mod)) - (if (and pkg-ver-path mod) + (setq pkg-ver-path (and mod (ghc-resolve-document-path mod))) + (if pkg-ver-path (ghc-display-document pkg-ver-path mod haskell-org expr) - (message "No document found")))) + (message "No documentation found")))) (ghc-defstruct pkg-ver-path pkg ver path) (defun ghc-resolve-document-path (mod) - (with-temp-buffer - (ghc-call-process ghc-module-command nil t nil "doc" mod) - (goto-char (point-min)) - (when (looking-at "^\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\) \\(.*\\)$") - (ghc-make-pkg-ver-path - :pkg (match-string-no-properties 1) - :ver (match-string-no-properties 2) - :path (match-string-no-properties 4))))) + (let ((root ghc-process-root)) + (with-temp-buffer + (let ((default-directory root)) + (ghc-call-process ghc-module-command nil t nil "doc" mod)) + (goto-char (point-min)) + (when (looking-at "^\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\) \\(.*\\)$") + (ghc-make-pkg-ver-path + :pkg (match-string-no-properties 1) + :ver (match-string-no-properties 2) + :path (match-string-no-properties 4)))))) (defconst ghc-doc-local-format "file://%s/%s.html") (defconst ghc-doc-hackage-format "http://hackage.haskell.org/packages/archive/%s/%s/doc/html/%s.html") +(defun ghc-browse-url-safari (uri &rest _args) +"Open a URI in Safari using AppleScript. This preserves anchors." + (let ((script (format " +tell application \"Safari\" + open location \"%s\" + activate +end tell" uri))) + (do-applescript script))) + (defun ghc-display-document (pkg-ver-path mod haskell-org &optional symbol) - (let* ((mod- (ghc-replace-character mod ?. ?-)) - (pkg (ghc-pkg-ver-path-get-pkg pkg-ver-path)) + (let* ((pkg (ghc-pkg-ver-path-get-pkg pkg-ver-path)) + (mod- (ghc-replace-character mod ?. ?-)) (ver (ghc-pkg-ver-path-get-ver pkg-ver-path)) (path (ghc-pkg-ver-path-get-path pkg-ver-path)) - (pkg-with-ver (format "%s-%s" pkg ver)) (local (format ghc-doc-local-format path mod-)) (remote (format ghc-doc-hackage-format pkg ver mod-)) (file (format "%s/%s.html" path mod-)) (url0 (if (or haskell-org (not (file-exists-p file))) remote local)) (url (if symbol (ghc-add-anchor url0 symbol) url0))) - ;; Mac's "open" removes the anchor from "file://", sigh. - (browse-url url))) + (funcall ghc-doc-browser-function url))) (defun ghc-add-anchor (url symbol) (let ((case-fold-search nil)) @@ -75,7 +95,7 @@ (apply 'concat (nreverse acc)))) (defun ghc-extact-module-from-info (info) - (when (string-match "\`\\([^']+\\)'" info) + (when (string-match "[`\u2018]\\([^'\u2019]+\\)['\u2019]" info) (match-string 1 info))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -93,7 +113,7 @@ (read-from-minibuffer "Module name: " def ghc-input-map)) (defun ghc-read-expression (def) - (read-from-minibuffer "Expression: " def ghc-input-map)) + (read-from-minibuffer "Identifier: " def ghc-input-map)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/elisp/ghc-func.el b/elisp/ghc-func.el --- a/elisp/ghc-func.el +++ b/elisp/ghc-func.el @@ -18,9 +18,10 @@ (defun ghc-replace-character (string from to) "Replace characters equal to FROM to TO in STRING." (let ((ret (copy-sequence string))) - (dotimes (cnt (length ret) ret) + (dotimes (cnt (length ret)) (if (char-equal (aref ret cnt) from) - (aset ret cnt to))))) + (aset ret cnt to))) + ret)) (defun ghc-replace-character-buffer (from-c to-c) (let ((from (char-to-string from-c)) @@ -66,7 +67,7 @@ (dolist (lst lol) (dolist (key lst) (puthash key key hash))) - (maphash (lambda (key val) (ghc-add ret key)) hash) + (maphash (lambda (key _val) (ghc-add ret key)) hash) ret)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -90,8 +91,9 @@ (condition-case nil (let ((m (set-marker (make-marker) 1 (current-buffer))) ret) - (dotimes (i n (nreverse ret)) - (ghc-add ret (read m)))) + (dotimes (_i n) + (ghc-add ret (read m))) + (nreverse ret)) (error ())))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -108,10 +110,11 @@ (defun ghc-keyword-number-pair (spec) (let ((len (length spec)) key ret) - (dotimes (i len (nreverse ret)) + (dotimes (i len) (setq key (intern (concat ":" (symbol-name (car spec))))) (setq ret (cons (cons key i) ret)) - (setq spec (cdr spec))))) + (setq spec (cdr spec))) + (nreverse ret))) (defmacro ghc-defstruct (type &rest spec) `(progn @@ -182,9 +185,19 @@ (funcall ins-func) (goto-char (point-min)) (if (not fontify) - (turn-off-haskell-font-lock) + ;; turn-off-haskell-font-lock has been removed from haskell-mode + ;; test if the function is defined in our version + (if (fboundp 'turn-off-haskell-font-lock) + (turn-off-haskell-font-lock) + ;; it's not defined, fallback on font-lock-mode + (font-lock-mode -1)) (haskell-font-lock-defaults-create) - (turn-on-haskell-font-lock))) + ;; turn-on-haskell-font-lock has been removed from haskell-mode + ;; test if the function is defined in our version + (if (fboundp 'turn-on-haskell-font-lock) + (turn-on-haskell-font-lock) + ;; it's not defined, fallback on font-lock-mode + (turn-on-font-lock)))) (display-buffer buf '((display-buffer-reuse-window display-buffer-pop-up-window)))))) @@ -194,12 +207,13 @@ (defun ghc-run-ghc-mod (cmds &optional prog) (let ((target (or prog ghc-module-command))) (ghc-executable-find target - (let ((cdir default-directory)) + (let ((cdir (or ghc-process-root ;; ghc-mod version/debug + default-directory))) ;; ghc-mod root (with-temp-buffer - (cd cdir) - (apply 'ghc-call-process target nil t nil - (append (ghc-make-ghc-options) cmds)) - (buffer-substring (point-min) (1- (point-max)))))))) + (let ((default-directory cdir)) + (apply 'ghc-call-process target nil '(t nil) nil + (append (ghc-make-ghc-options) cmds)) + (buffer-substring (point-min) (1- (point-max))))))))) (defmacro ghc-executable-find (cmd &rest body) ;; (declare (indent 1)) diff --git a/elisp/ghc-indent.el b/elisp/ghc-indent.el --- a/elisp/ghc-indent.el +++ b/elisp/ghc-indent.el @@ -10,11 +10,11 @@ (defvar ghc-indent-offset 4) -(defun ghc-make-indent-shallower (beg end) +(defun ghc-make-indent-shallower (_beg _end) (interactive "r") (indent-rigidly (region-beginning) (region-end) (- ghc-indent-offset))) -(defun ghc-make-indent-deeper (beg end) +(defun ghc-make-indent-deeper (_beg _end) (interactive "r") (indent-rigidly (region-beginning) (region-end) ghc-indent-offset)) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -63,7 +63,7 @@ (cons 'ghc-type-clear-overlay after-change-functions)) (add-hook 'post-command-hook 'ghc-type-post-command-hook)) -(defun ghc-type-clear-overlay (&optional beg end len) +(defun ghc-type-clear-overlay (&optional _beg _end _len) (when (overlayp ghc-type-overlay) (ghc-type-set-ix 0) (ghc-type-set-point 0) @@ -82,7 +82,7 @@ (if (null tinfos) (progn (ghc-type-clear-overlay) - (message "Cannot guess type")) + (message "Cannot determine type")) (let* ((tinfo (nth (ghc-type-get-ix) tinfos)) (type (ghc-tinfo-get-info tinfo)) (beg-line (ghc-tinfo-get-beg-line tinfo)) @@ -111,13 +111,7 @@ (cn (int-to-string (1+ (current-column)))) (file (buffer-file-name)) (cmd (format "type %s %s %s\n" file ln cn))) - (ghc-sync-process cmd nil 'ghc-type-fix-string))) - -(defun ghc-type-fix-string () - (save-excursion - (goto-char (point-min)) - (while (search-forward "[Char]" nil t) - (replace-match "String")))) + (ghc-sync-process cmd nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -127,7 +121,7 @@ (defun ghc-expand-th () (interactive) (let* ((file (buffer-file-name)) - (cmds (list "expand" file "-b" "\n")) + (cmds (list "-b" "\n" "expand" file)) (source (ghc-run-ghc-mod cmds))) (when source (ghc-display diff --git a/elisp/ghc-ins-mod.el b/elisp/ghc-ins-mod.el --- a/elisp/ghc-ins-mod.el +++ b/elisp/ghc-ins-mod.el @@ -56,7 +56,7 @@ (defun ghc-goto-module-position () (goto-char (point-max)) - (if (re-search-backward "^import" nil t) + (if (re-search-backward "^import +" nil t) (ghc-goto-empty-line) (if (not (re-search-backward "^module" nil t)) (goto-char (point-min)) diff --git a/elisp/ghc-pkg.el b/elisp/ghc-pkg.el --- a/elisp/ghc-pkg.el +++ b/elisp/ghc-pkg.el @@ -2,4 +2,4 @@ "ghc" 2.0.0 "Sub mode for Haskell mode" - nil) + '((haskell-mode "13.0"))) diff --git a/elisp/ghc-process.el b/elisp/ghc-process.el --- a/elisp/ghc-process.el +++ b/elisp/ghc-process.el @@ -1,3 +1,4 @@ +;;; -*- lexical-binding: t -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-process.el @@ -10,94 +11,179 @@ (require 'ghc-func) +(defvar ghc-debug-options nil) +;; (setq ghc-debug-options '("-v9")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar ghc-process-running nil) +(defvar ghc-process-file-mapping nil) (defvar-local ghc-process-process-name nil) (defvar-local ghc-process-original-buffer nil) (defvar-local ghc-process-original-file nil) -(defvar-local ghc-process-callback nil) -(defvar-local ghc-process-hook nil) +(defvar-local ghc-process-root nil) -(defvar ghc-interactive-command "ghc-modi") +(defvar ghc-command "ghc-mod") +(defvar ghc-report-errors t "Report GHC errors to *GHC Error* buffer") +(defvar ghc-error-buffer "*GHC Error*") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-get-project-root () (ghc-run-ghc-mod '("root"))) -(defun ghc-with-process (cmd callback &optional hook1 hook2) +(defun ghc-with-process (cmd async-after-callback &optional sync-before-hook) (unless ghc-process-process-name (setq ghc-process-process-name (ghc-get-project-root))) (when (and ghc-process-process-name (not ghc-process-running)) (setq ghc-process-running t) - (if hook1 (funcall hook1)) + (if sync-before-hook (funcall sync-before-hook)) (let* ((cbuf (current-buffer)) (name ghc-process-process-name) - (buf (get-buffer-create (concat " ghc-modi:" name))) + (root (file-name-as-directory ghc-process-process-name)) + (buf (get-buffer-create (concat " ghc-mod:" name))) (file (buffer-file-name)) (cpro (get-process name))) + ;; setting root in the original buffer, sigh + (setq ghc-process-root root) (ghc-with-current-buffer buf (setq ghc-process-original-buffer cbuf) (setq ghc-process-original-file file) - (setq ghc-process-callback callback) - (setq ghc-process-hook hook2) - (erase-buffer) - (let ((pro (ghc-get-process cpro name buf))) - (process-send-string pro cmd) + (setq ghc-process-root root) + (let ((pro (ghc-get-process cpro name buf root)) + (map-cmd (format "map-file %s\n" file))) +; (unmap-cmd (format "unmap-file %s\n" file))) + (when (buffer-modified-p cbuf) + (setq ghc-process-file-mapping t) + (setq ghc-process-async-after-callback nil) + (erase-buffer) + (when ghc-debug + (ghc-with-debug-buffer + (insert (format "%% %s" map-cmd)) + (insert "CONTENTS + EOT\n"))) + (process-send-string pro map-cmd) + (with-current-buffer cbuf + (save-restriction + (widen) + (process-send-region pro (point-min) (point-max)))) + (process-send-string pro "\n\004\n") + (condition-case nil + (let ((inhibit-quit nil)) + (while ghc-process-file-mapping + (accept-process-output pro 0.1 nil t))) + (quit + (setq ghc-process-running nil) + (setq ghc-process-file-mapping nil)))) + ;; command + (setq ghc-process-async-after-callback async-after-callback) + (erase-buffer) (when ghc-debug (ghc-with-debug-buffer (insert (format "%% %s" cmd)))) + (process-send-string pro cmd) + + ;;; this needs to be done asyncrounously after the command actually + ;;; finished, gah + ;; (when do-map-file + ;; (when ghc-debug + ;; (ghc-with-debug-buffer + ;; (insert (format "%% %s" unmap-cmd)))) + ;; (process-send-string pro unmap-cmd)) + pro))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun ghc-get-process (cpro name buf) +(defun ghc-get-process (cpro name buf root) (cond ((not cpro) - (ghc-start-process name buf)) + (ghc-start-process name buf root)) ((not (eq (process-status cpro) 'run)) (delete-process cpro) - (ghc-start-process name buf)) + (ghc-start-process name buf root)) (t cpro))) -(defun ghc-start-process (name buf) - (let* ((opts (append '("-b" "\n" "-l") (ghc-make-ghc-options))) - (pro (apply 'start-file-process name buf ghc-interactive-command opts))) +(defun ghc-start-process (name buf root) + (let* ((default-directory root) + (process-connection-type nil) ;; using PIPE due to ^D + (opts (append ghc-debug-options + '("-b" "\n" "-l" "--line-prefix=O: ,E: ") + (ghc-make-ghc-options) + '("legacy-interactive"))) + (pro (apply 'start-process name buf ghc-command opts))) (set-process-filter pro 'ghc-process-filter) (set-process-sentinel pro 'ghc-process-sentinel) (set-process-query-on-exit-flag pro nil) pro)) (defun ghc-process-filter (process string) - (let ((pbuf (process-buffer process))) + (let* ((pbuf (process-buffer process)) + (tbufname (concat " tmp " (buffer-name pbuf))) + tbuf) (if (not (get-buffer pbuf)) (setq ghc-process-running nil) ;; just in case - (ghc-with-current-buffer (process-buffer process) - (goto-char (point-max)) - (insert string) + (ghc-with-current-buffer pbuf + (when ghc-debug + (ghc-with-debug-buffer + (insert string))) + (with-current-buffer (get-buffer-create tbufname) + (setq tbuf (current-buffer)) + (goto-char (point-max)) + (insert string) + (goto-char (point-min)) + (let ((cont t) end out) + (while (and cont (not (eobp)) ghc-process-running) + (cond + ((looking-at "^O: ") + (setq out t)) + ((looking-at "^E: ") + (setq out nil)) + (t + (setq cont nil))) + (when cont + (forward-line) + (unless (bolp) (setq cont nil))) + (when cont + (delete-region 1 4) + (setq end (point)) + (if out + (with-current-buffer pbuf + (goto-char (point-max)) + (insert-buffer-substring tbuf 1 end)) + (when ghc-report-errors + (with-current-buffer (get-buffer-create ghc-error-buffer) + (setq buffer-read-only t) + (let* ((buffer-read-only nil) + (inhibit-read-only t) + (cbuf (current-buffer)) + cwin) + (unless (get-buffer-window cbuf) (display-buffer cbuf)) + (setq cwin (get-buffer-window cbuf)) + (with-selected-window cwin + (goto-char (point-max)) + (insert-buffer-substring tbuf 1 end) + (set-buffer-modified-p nil)) + (redisplay))))) + (delete-region 1 end))))) + (goto-char (point-max)) (forward-line -1) (cond ((looking-at "^OK$") - (if ghc-process-hook (funcall ghc-process-hook)) - (goto-char (point-min)) - (funcall ghc-process-callback 'ok) - (when ghc-debug - (let ((cbuf (current-buffer))) - (ghc-with-debug-buffer - (insert-buffer-substring cbuf)))) - (setq ghc-process-running nil)) + (delete-region (point) (point-max)) + (setq ghc-process-file-mapping nil) + (when ghc-process-async-after-callback + (goto-char (point-min)) + (funcall ghc-process-async-after-callback 'ok) + (setq ghc-process-running nil))) ((looking-at "^NG ") - (funcall ghc-process-callback 'ng) - (when ghc-debug - (let ((cbuf (current-buffer))) - (ghc-with-debug-buffer - (insert-buffer-substring cbuf)))) + (funcall ghc-process-async-after-callback 'ng) (setq ghc-process-running nil))))))) -(defun ghc-process-sentinel (process event) - (setq ghc-process-running nil)) +(defun ghc-process-sentinel (_process _event) + (setq ghc-process-running nil) + (setq ghc-process-file-mapping nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -105,24 +191,23 @@ (defvar ghc-process-num-of-results nil) (defvar ghc-process-results nil) -(defun ghc-sync-process (cmd &optional n hook) +(defun ghc-sync-process (cmd &optional n) (unless ghc-process-running (setq ghc-process-rendezvous nil) (setq ghc-process-results nil) (setq ghc-process-num-of-results (or n 1)) - (let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook))) + (let ((pro (ghc-with-process cmd 'ghc-sync-process-callback nil))) + ;; ghc-process-running is now t. + ;; But if the process exits abnormally, it is set to nil. (condition-case nil - (while (null ghc-process-rendezvous) - ;; 0.01 is too fast for Emacs 24.4. - ;; (sit-for 0.1 t) may get stuck when tooltip is displayed. - (sit-for 0.1) - ;; (discard-input) avoids getting stuck. - (discard-input)) + (let ((inhibit-quit nil)) + (while (and (null ghc-process-rendezvous) ghc-process-running) + (accept-process-output pro 0.1 nil t))) (quit (setq ghc-process-running nil)))) ghc-process-results)) -(defun ghc-process-callback (status) +(defun ghc-sync-process-callback (status) (cond ((eq status 'ok) (let* ((n ghc-process-num-of-results) @@ -139,11 +224,12 @@ (defun ghc-kill-process () (interactive) - (let* ((name ghc-process-process-name) - (cpro (if name (get-process name)))) - (if (not cpro) - (message "No process") - (delete-process cpro) - (message "A process was killed")))) + (when (eq major-mode 'haskell-mode) + (let* ((name ghc-process-process-name) + (cpro (if name (get-process name)))) + (if (not cpro) + (message "No ghc-mod process") + (delete-process cpro) + (message "ghc-mod process was killed"))))) (provide 'ghc-process) diff --git a/elisp/ghc-rewrite.el b/elisp/ghc-rewrite.el --- a/elisp/ghc-rewrite.el +++ b/elisp/ghc-rewrite.el @@ -125,13 +125,10 @@ (ghc-display nil (lambda () (insert "Possible completions:\n") - (mapc - (lambda (x) - (let* (; (ins1 (insert "- ")) - (pos-begin (point)) - (ins (insert x)) - (pos-end (point)) - (ins3 (insert "\n"))) + (mapc + (lambda (_x) + (let ((pos-begin (point)) + (pos-end (point))) (make-button pos-begin pos-end :type 'auto-button))) (ghc-sinfo-get-info info)))) (select-window (ghc-auto-completion-window)))) diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -28,8 +28,10 @@ (< emacs-minor-version minor))) (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "5.1.0.2") +(defconst ghc-version "5.8.0.0") +(defgroup ghc-mod '() "ghc-mod customization") + ;; (eval-when-compile ;; (require 'haskell-mode)) @@ -115,6 +117,7 @@ (define-key haskell-mode-map ghc-next-hole-key 'ghc-goto-next-hole) (ghc-comp-init) (setq ghc-initialized t) + (add-hook 'kill-buffer-hook 'ghc-kill-process) (defadvice save-buffer (after ghc-check-syntax-on-save activate) "Check syntax with GHC when a haskell-mode buffer is saved." (when (eq 'haskell-mode major-mode) (ghc-check-syntax)))) @@ -130,26 +133,26 @@ (let ((el-path (locate-file "ghc.el" load-path)) (ghc-path (executable-find "ghc")) ;; FIXME (ghc-mod-path (executable-find ghc-module-command)) - (ghc-modi-path (executable-find ghc-interactive-command)) (el-ver ghc-version) (ghc-ver (ghc-run-ghc-mod '("--version") "ghc")) (ghc-mod-ver (ghc-run-ghc-mod '("version"))) - (ghc-modi-ver (ghc-run-ghc-mod '("version") ghc-interactive-command)) - (path (getenv "PATH"))) + (path (getenv "PATH")) + (debug (ghc-run-ghc-mod '("debug")))) ;; before switching buffers. (switch-to-buffer (get-buffer-create "**GHC Debug**")) (erase-buffer) (insert "Path: check if you are using intended programs.\n") (insert (format "\t ghc.el path: %s\n" el-path)) (insert (format "\t ghc-mod path: %s\n" ghc-mod-path)) - (insert (format "\tghc-modi path: %s\n" ghc-modi-path)) (insert (format "\t ghc path: %s\n" ghc-path)) - (insert "\nVersion: all versions must be the same.\n") + (insert "\nVersion: all GHC versions must be the same.\n") (insert (format "\t ghc.el version %s\n" el-ver)) (insert (format "\t %s\n" ghc-mod-ver)) - (insert (format "\t%s\n" ghc-modi-ver)) (insert (format "\t%s\n" ghc-ver)) (insert "\nEnvironment variables:\n") - (insert (format "\tPATH=%s\n" path)))) + (insert (format "\tPATH=%s\n" path)) + (insert "\nThe result of \"ghc-mod debug\":\n") + (insert debug) + (goto-char (point-min)))) (defun ghc-insert-template-or-signature (&optional flag) (interactive "P") diff --git a/ghc-mod.cabal b/ghc-mod.cabal --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,162 +1,272 @@ Name: ghc-mod -Version: 5.1.0.2 -Author: Kazu Yamamoto - Daniel Gröber - Alejandro Serrano -Maintainer: Kazu Yamamoto -License: BSD3 +Version: 5.8.0.0 +Author: Kazu Yamamoto , + Daniel Gröber , + Alejandro Serrano , + Nikolay Yakimov +Maintainer: Daniel Gröber +License: AGPL-3 License-File: LICENSE -Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ -Synopsis: Happy Haskell Programming -Description: The ghc-mod command is a backend command to enrich - Haskell programming on editors including - Emacs, Vim, and Sublime. - The ghc-mod command is based on ghc-mod library - which is a wrapper of GHC API. - This package includes the ghc-mod command, - the ghc-mod library, and Emacs front-end - (for historical reasons). - For more information, please see its home page. +License-Files: COPYING.BSD3 COPYING.AGPL3 +Homepage: https://github.com/DanielG/ghc-mod +Synopsis: Happy Haskell Hacking +Description: + ghc-mod is a backend program to enrich Haskell programming in editors. It + strives to offer most of the features one has come to expect from modern IDEs + in any editor. -Category: Development -Cabal-Version: >= 1.10 -Build-Type: Simple -Data-Dir: elisp -Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el - ghc-check.el ghc-process.el ghc-command.el ghc-info.el - ghc-ins-mod.el ghc-indent.el ghc-pkg.el ghc-rewrite.el + ghc-mod provides a library for other haskell programs to use as well as a + standalone program for easy editor integration. All of the fundamental + functionality of the frontend program can be accessed through the library + however many implementation details are hidden and if you want to + significantly extend ghc-mod you should submit these changes upstream instead + of implementing them on top of the library. + + +Category: GHC, Development +Cabal-Version: >= 1.18 +Build-Type: Custom +Data-Files: elisp/Makefile + elisp/*.el Extra-Source-Files: ChangeLog - test/data/*.cabal - test/data/*.hs - test/data/cabal.sandbox.config.in - test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf + README.md + core/GhcMod/Monad/Compat.hs_h + test/data/annotations/*.hs test/data/broken-cabal/*.cabal - test/data/broken-cabal/cabal.sandbox.config.in - test/data/broken-sandbox/*.cabal test/data/broken-sandbox/cabal.sandbox.config - test/data/cabal-flags/*.cabal + test/data/broken-sandbox/dummy.cabal + test/data/cabal-flags/cabal-flags.cabal + test/data/cabal-project/*.cabal + test/data/cabal-project/*.hs + test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf + test/data/cabal-project/subdir1/subdir2/dummy + test/data/case-split/*.hs + test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf test/data/check-test-subdir/*.cabal test/data/check-test-subdir/src/Check/Test/*.hs test/data/check-test-subdir/test/*.hs test/data/check-test-subdir/test/Bar/*.hs - test/data/check-packageid/cabal.sandbox.config.in - test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf - test/data/duplicate-pkgver/cabal.sandbox.config.in test/data/duplicate-pkgver/duplicate-pkgver.cabal test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-1.0-7c59d13f32294d1ef6dc6233c24df961.conf test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-14e543bdae2da4d2aeff5386892c9112.conf test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf - test/data/pattern-synonyms/*.cabal - test/data/pattern-synonyms/*.hs + test/data/foreign-export/*.hs test/data/ghc-mod-check/*.cabal test/data/ghc-mod-check/*.hs - test/data/ghc-mod-check/Data/*.hs - test/data/subdir1/subdir2/dummy - test/data/.cabal-sandbox/packages/00-index.tar + test/data/ghc-mod-check/lib/Data/*.hs + test/data/hlint/*.hs + test/data/home-module-graph/cpp/*.hs + test/data/home-module-graph/cycle/*.hs + test/data/home-module-graph/errors/*.hs + test/data/home-module-graph/indirect/*.hs + test/data/home-module-graph/indirect-update/*.hs + test/data/import-cycle/*.hs + test/data/non-exported/*.hs + test/data/pattern-synonyms/*.cabal + test/data/pattern-synonyms/*.hs + test/data/quasi-quotes/*.hs + test/data/template-haskell/*.hs + test/data/target/*.hs + test/data/check-missing-warnings/*.hs + test/data/custom-cradle/custom-cradle.cabal + test/data/custom-cradle/ghc-mod.package-db-stack + test/data/custom-cradle/package-db-a/.gitkeep + test/data/custom-cradle/package-db-b/.gitkeep + test/data/custom-cradle/package-db-c/.gitkeep + test/data/cabal-preprocessors/*.cabal + test/data/cabal-preprocessors/*.hs + test/data/cabal-preprocessors/*.hsc + test/data/file-mapping/*.hs + test/data/file-mapping/preprocessor/*.hs + test/data/file-mapping/lhs/*.lhs + test/data/nice-qualification/*.hs + test/data/stack-project/stack.yaml.in + test/data/stack-project/new-template.cabal + test/data/stack-project/*.hs + test/data/stack-project/app/*.hs + test/data/stack-project/src/*.hs + test/data/stack-project/test/*.hs + bench/data/simple-cabal/simple-cabal.cabal + bench/data/simple-cabal/*.hs + +Custom-Setup + Setup-Depends: base + , Cabal >= 1.18 && < 1.25 + , containers + , filepath + , directory + , process + , template-haskell + , transformers + + Library Default-Language: Haskell2010 - GHC-Options: -Wall - Default-Extensions: ConstraintKinds, FlexibleContexts - Exposed-Modules: Language.Haskell.GhcMod - Language.Haskell.GhcMod.Internal - Other-Modules: Language.Haskell.GhcMod.Boot - Language.Haskell.GhcMod.Browse - Language.Haskell.GhcMod.Cabal16 - Language.Haskell.GhcMod.Cabal18 - Language.Haskell.GhcMod.Cabal21 - Language.Haskell.GhcMod.CabalApi - Language.Haskell.GhcMod.CabalConfig - Language.Haskell.GhcMod.CaseSplit - Language.Haskell.GhcMod.Check - Language.Haskell.GhcMod.Convert - Language.Haskell.GhcMod.Cradle - Language.Haskell.GhcMod.Debug - Language.Haskell.GhcMod.Doc - Language.Haskell.GhcMod.DynFlags - Language.Haskell.GhcMod.Error - Language.Haskell.GhcMod.FillSig - Language.Haskell.GhcMod.Find - Language.Haskell.GhcMod.Flag - Language.Haskell.GhcMod.GHCApi - Language.Haskell.GhcMod.GHCChoice - Language.Haskell.GhcMod.Gap - Language.Haskell.GhcMod.GhcPkg - Language.Haskell.GhcMod.Info - Language.Haskell.GhcMod.Lang - Language.Haskell.GhcMod.Lint - Language.Haskell.GhcMod.Logger - Language.Haskell.GhcMod.Monad - Language.Haskell.GhcMod.Modules - Language.Haskell.GhcMod.PkgDoc - Language.Haskell.GhcMod.Read - Language.Haskell.GhcMod.SrcUtils - Language.Haskell.GhcMod.Target - Language.Haskell.GhcMod.Types - Language.Haskell.GhcMod.Utils - Build-Depends: base >= 4.0 && < 5 + GHC-Options: -Wall -fno-warn-deprecations + Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, + ConstraintKinds, FlexibleContexts, + DataKinds, KindSignatures, TypeOperators, ViewPatterns + HS-Source-Dirs: ., core, shared + Exposed-Modules: + GhcMod + GhcMod.Exe.Boot + GhcMod.Exe.Browse + GhcMod.Exe.CaseSplit + GhcMod.Exe.Check + GhcMod.Exe.Debug + GhcMod.Exe.FillSig + GhcMod.Exe.Find + GhcMod.Exe.Flag + GhcMod.Exe.Info + GhcMod.Exe.Internal + GhcMod.Exe.Lang + GhcMod.Exe.Lint + GhcMod.Exe.Modules + GhcMod.Exe.PkgDoc + GhcMod.Exe.Test + GhcMod.CabalHelper + GhcMod.Caching + GhcMod.Caching.Types + GhcMod.Convert + GhcMod.Cradle + GhcMod.CustomPackageDb + GhcMod.DebugLogger + GhcMod.Doc + GhcMod.DynFlags + GhcMod.DynFlagsTH + GhcMod.Error + GhcMod.FileMapping + GhcMod.Gap + GhcMod.GhcPkg + GhcMod.HomeModuleGraph + GhcMod.LightGhc + GhcMod.Logger + GhcMod.Logging + GhcMod.Monad + GhcMod.Monad.Env + GhcMod.Monad.Log + GhcMod.Monad.Newtypes + GhcMod.Monad.Orphans + GhcMod.Monad.Out + GhcMod.Monad.State + GhcMod.Monad.Types + GhcMod.Options.DocUtils + GhcMod.Options.Help + GhcMod.Options.Options + GhcMod.Output + GhcMod.PathsAndFiles + GhcMod.Pretty + GhcMod.Read + GhcMod.SrcUtils + GhcMod.Stack + GhcMod.Target + GhcMod.Types + GhcMod.Utils + GhcMod.World + Other-Modules: Paths_ghc_mod + Utils + Data.Binary.Generic + System.Directory.ModTime + Build-Depends: + -- See Note [GHC Boot libraries] + binary + , bytestring , containers , deepseq , directory , filepath - , ghc - , ghc-paths - , ghc-syb-utils - , hlint >= 1.8.61 - , io-choice - , monad-journal >= 0.4 + , mtl , old-time , process - , syb + , template-haskell , time , transformers - , transformers-base - , mtl >= 2.0 - , monad-control - , split - , haskell-src-exts - , text - , djinn-ghc >= 0.0.2.2 - if impl(ghc >= 7.8) - Build-Depends: Cabal >= 1.18 - else - Build-Depends: convertible - , Cabal >= 1.10 && < 1.17 - if impl(ghc <= 7.4.2) - -- Only used to constrain random to a version that still works with GHC 7.4 - Build-Depends: random <= 1.0.1.1 + , base < 4.10 && >= 4.6.0.1 + , djinn-ghc < 0.1 && >= 0.0.2.2 + , extra < 1.6 && >= 1.4 + , fclabels < 2.1 && >= 2.0 + , ghc-paths < 0.2 && >= 0.1.0.9 + , ghc-syb-utils < 0.3 && >= 0.2.3 + , haskell-src-exts < 1.20 && >= 1.18 + , hlint < 2.1 && >= 2.0.8 + , monad-control < 1.1 && >= 1 + , monad-journal < 0.8 && >= 0.4 + , optparse-applicative < 0.14 && >= 0.13.0.0 + , pipes < 4.4 && >= 4.1 + , safe < 0.4 && >= 0.3.9 + , semigroups < 0.19 && >= 0.10.0 + , split < 0.3 && >= 0.2.2 + , syb < 0.7 && >= 0.5.1 + , temporary < 1.3 && >= 1.2.0.3 + , text < 1.3 && >= 1.2.1.3 + , transformers-base < 0.5 && >= 0.4.4 + + , cabal-helper < 0.8 && >= 0.7.3.0 + , ghc < 8.2 && >= 7.6 + + if impl(ghc >= 8.0) + Build-Depends: ghc-boot + if impl(ghc < 7.8) + Build-Depends: convertible < 1.2 && >= 1.1.0.0 + Executable ghc-mod Default-Language: Haskell2010 - Main-Is: GHCMod.hs + Main-Is: GhcModMain.hs Other-Modules: Paths_ghc_mod - GHC-Options: -Wall + , GhcMod.Exe.Options + , GhcMod.Exe.Options.Commands + , GhcMod.Exe.Version + , GhcMod.Exe.Options.ShellParse + GHC-Options: -Wall -fno-warn-deprecations -threaded Default-Extensions: ConstraintKinds, FlexibleContexts - HS-Source-Dirs: src - Build-Depends: base >= 4.0 && < 5 - , directory + HS-Source-Dirs: src, shared + X-Internal: True + Build-Depends: + -- See Note [GHC Boot libraries] + directory , filepath - , mtl >= 2.0 - , ghc + , mtl + , process + + , base < 4.10 && >= 4.6.0.1 + , fclabels < 2.1 && >= 2.0 + , monad-control < 1.1 && >= 1 + , optparse-applicative < 0.14 && >= 0.13.0.0 + , semigroups < 0.19 && >= 0.10.0 + , split < 0.3 && >= 0.2.2 + + , ghc < 8.2 && >= 7.6 , ghc-mod + Executable ghc-modi Default-Language: Haskell2010 - Main-Is: GHCModi.hs + Main-Is: GhcModi.hs Other-Modules: Paths_ghc_mod Utils - GHC-Options: -Wall -threaded + System.Directory.ModTime + GHC-Options: -Wall -threaded -fno-warn-deprecations + if os(windows) + Cpp-Options: -DWINDOWS Default-Extensions: ConstraintKinds, FlexibleContexts - HS-Source-Dirs: src - Build-Depends: base >= 4.0 && < 5 - , async - , containers + HS-Source-Dirs: ., src, shared + Build-Depends: + -- See Note [GHC Boot libraries] + binary + , deepseq , directory , filepath - , split - , ghc + , old-time + , process + , time + + , base < 4.10 && >= 4.6.0.1 + , ghc-mod + Test-Suite doctest Type: exitcode-stdio-1.0 Default-Language: Haskell2010 @@ -164,62 +274,116 @@ Ghc-Options: -Wall Default-Extensions: ConstraintKinds, FlexibleContexts Main-Is: doctests.hs - Build-Depends: base - , doctest >= 0.9.3 + Build-Depends: base < 4.10 && >= 4.6.0.1 + , doctest < 0.12 && >= 0.9.3 + Test-Suite spec Default-Language: Haskell2010 - Default-Extensions: ConstraintKinds, FlexibleContexts + Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, + ConstraintKinds, FlexibleContexts, + DataKinds, KindSignatures, TypeOperators, ViewPatterns Main-Is: Main.hs - Hs-Source-Dirs: test, . - Ghc-Options: -Wall + Hs-Source-Dirs: test, src + Ghc-Options: -Wall -fno-warn-deprecations -threaded Type: exitcode-stdio-1.0 - Other-Modules: Dir - Spec + Other-Modules: Paths_ghc_mod + Dir + TestUtils + +-- $ ls test/*Spec.hs | sed 's_^.*/\(.*\)\.hs$_\1_' | sort BrowseSpec - CabalApiSpec + CabalHelperSpec + CaseSplitSpec CheckSpec + CradleSpec + CustomPackageDbSpec + FileMappingSpec + FindSpec FlagSpec + GhcPkgSpec + HomeModuleGraphSpec InfoSpec LangSpec LintSpec ListSpec MonadSpec - GhcPkgSpec - TestUtils - Build-Depends: base >= 4.0 && < 5 - , containers - , deepseq + PathsAndFilesSpec + ShellParseSpec + TargetSpec + + Build-Depends: + -- See Note [GHC Boot libraries] + containers , directory , filepath - , ghc - , ghc-paths - , ghc-syb-utils - , hlint >= 1.7.1 - , io-choice - , monad-journal >= 0.4 - , old-time + , mtl , process - , syb - , time , transformers - , transformers-base - , mtl >= 2.0 - , monad-control - , hspec >= 1.8.2 - , split - , haskell-src-exts - , text - , djinn-ghc >= 0.0.2.2 - if impl(ghc >= 7.8) - Build-Depends: Cabal >= 1.18 - else - Build-Depends: convertible - , Cabal >= 1.10 && < 1.17 - if impl(ghc < 7.6) - Build-Depends: executable-path - CPP-Options: -DSPEC=1 + , base < 4.10 && >= 4.6.0.1 + , fclabels < 2.1 && >= 2.0 + , hspec < 2.4 && >= 2.0.0 + , monad-journal < 0.8 && >= 0.4 + , split < 0.3 && >= 0.2.2 + , temporary < 1.3 && >= 1.2.0.3 + + + if impl(ghc < 7.8) + Build-Depends: convertible < 1.2 && >= 1.1.0.0 + if impl(ghc >= 8.0) + Build-Depends: ghc-boot + + Build-Depends: + cabal-helper < 0.8 && >= 0.7.1.0 + , ghc < 8.2 && >= 7.6 + , ghc-mod + + +Test-Suite shelltest + Default-Language: Haskell2010 + Main-Is: ShellTest.hs + Hs-Source-Dirs: shelltest + Type: exitcode-stdio-1.0 + Build-Tools: shelltest + Build-Depends: base < 4.10 && >= 4.6.0.1 + , process < 1.5 + -- , shelltestrunner >= 1.3.5 + if !flag(shelltest) + Buildable: False + + +Benchmark criterion + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, + ConstraintKinds, FlexibleContexts, + DataKinds, KindSignatures, TypeOperators, ViewPatterns + HS-Source-Dirs: bench, test + Main-Is: Bench.hs + Build-Depends: + -- See Note [GHC Boot libraries] + directory + , filepath + + , base < 4.10 && >= 4.6.0.1 + , criterion < 1.2 && >= 1.1.1.0 + , temporary < 1.3 && >= 1.2.0.3 + + , ghc-mod + + +Flag shelltest + Description: Enable/disable shelltest test-suite + Default: False + Manual: True + + Source-Repository head Type: git - Location: git://github.com/kazu-yamamoto/ghc-mod.git + Location: https://github.com/DanielG/ghc-mod.git + +-- Note [GHC Boot libraries] +-- +-- We don't give bounds to GHC boot libraries as our dependency on 'ghc' already +-- constrains these packages to the version that shipped with GHC. diff --git a/shared/System/Directory/ModTime.hs b/shared/System/Directory/ModTime.hs new file mode 100644 --- /dev/null +++ b/shared/System/Directory/ModTime.hs @@ -0,0 +1,63 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +module System.Directory.ModTime where + +import Control.Applicative +import Control.DeepSeq +import Data.Binary +#if MIN_VERSION_directory(1,2,0) +import Data.Time (UTCTime(..), Day(..), getCurrentTime) +#else +import System.Time (ClockTime(..), getClockTime) +#endif +import System.Directory +import Prelude + +#if MIN_VERSION_directory(1,2,0) + +newtype ModTime = ModTime UTCTime + deriving (Eq, Ord, NFData) +getCurrentModTime = ModTime <$> getCurrentTime + +instance Binary ModTime where + put (ModTime (UTCTime (ModifiedJulianDay day) difftime)) = + put day >> put (toRational difftime) + get = + ModTime <$> (UTCTime <$> (ModifiedJulianDay <$> get) <*> (fromRational <$> get)) + +#else + +newtype ModTime = ModTime ClockTime + deriving (Eq, Ord) +getCurrentModTime = ModTime <$> getClockTime + +instance Binary ModTime where + put (ModTime (TOD s ps)) = + put s >> put ps + get = + ModTime <$> (TOD <$> get <*> get) + +instance NFData ModTime where + rnf (ModTime (TOD s ps)) = + s `seq` ps `seq` (ModTime $! TOD s ps) `seq` () + +#endif + +getCurrentModTime :: IO ModTime + +getModTime :: FilePath -> IO ModTime +getModTime f = ModTime <$> getModificationTime f diff --git a/shared/Utils.hs b/shared/Utils.hs new file mode 100644 --- /dev/null +++ b/shared/Utils.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +module Utils where + +import Control.Applicative +import Data.Traversable +import System.Directory +import System.Directory.ModTime + +import Prelude + +data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime } + deriving (Eq) + +instance Ord TimedFile where + compare (TimedFile _ a) (TimedFile _ b) = compare a b + +timeFile :: FilePath -> IO TimedFile +timeFile f = TimedFile <$> pure f <*> getModTime f + +mightExist :: FilePath -> IO (Maybe FilePath) +mightExist f = do + exists <- doesFileExist f + return $ if exists then (Just f) else (Nothing) + +timeMaybe :: FilePath -> IO (Maybe TimedFile) +timeMaybe f = traverse timeFile =<< mightExist f diff --git a/shelltest/ShellTest.hs b/shelltest/ShellTest.hs new file mode 100644 --- /dev/null +++ b/shelltest/ShellTest.hs @@ -0,0 +1,23 @@ +#!/usr/bin/env runhaskell +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2017 Daniel Gröber +-- +-- 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 . + +module Main where + +import System.Exit +import System.Process + +main = exitWith =<< rawSystem "shelltest" [ "--execdir", "shelltest/" ] diff --git a/src/GHCMod.hs b/src/GHCMod.hs deleted file mode 100644 --- a/src/GHCMod.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Main where - -import Config (cProjectVersion) -import Control.Applicative ((<$>)) -import Control.Exception (Exception, Handler(..), ErrorCall(..)) -import CoreMonad (liftIO) -import qualified Control.Exception as E -import Data.Typeable (Typeable) -import Data.Version (showVersion) -import Language.Haskell.GhcMod -import Paths_ghc_mod -import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) -import qualified System.Console.GetOpt as O -import System.Directory (doesFileExist) -import System.Environment (getArgs) -import System.Exit (exitFailure) -import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8) - ----------------------------------------------------------------- - -progVersion :: String -progVersion = "ghc-mod version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n" - -ghcOptHelp :: String -ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] " - -usage :: String -usage = progVersion - ++ "Usage:\n" - ++ "\t ghc-mod list " ++ ghcOptHelp ++ "[-l] [-d]\n" - ++ "\t ghc-mod lang [-l]\n" - ++ "\t ghc-mod flag [-l]\n" - ++ "\t ghc-mod browse " ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [:] [[:] ...]\n" - ++ "\t ghc-mod check " ++ ghcOptHelp ++ "\n" - ++ "\t ghc-mod expand " ++ ghcOptHelp ++ "\n" - ++ "\t ghc-mod debug " ++ ghcOptHelp ++ "\n" - ++ "\t ghc-mod info " ++ ghcOptHelp ++ " \n" - ++ "\t ghc-mod type " ++ ghcOptHelp ++ " \n" - ++ "\t ghc-mod split " ++ ghcOptHelp ++ " \n" - ++ "\t ghc-mod sig " ++ ghcOptHelp ++ " \n" - ++ "\t ghc-mod refine " ++ ghcOptHelp ++ " \n" - ++ "\t ghc-mod auto " ++ ghcOptHelp ++ " \n" - ++ "\t ghc-mod find \n" - ++ "\t ghc-mod lint [-h opt] \n" - ++ "\t ghc-mod root\n" - ++ "\t ghc-mod doc \n" - ++ "\t ghc-mod boot\n" - ++ "\t ghc-mod version\n" - ++ "\t ghc-mod help\n" - ++ "\n" - ++ " for \"info\" and \"type\" is not used, anything is OK.\n" - ++ "It is necessary to maintain backward compatibility.\n" - ----------------------------------------------------------------- - -argspec :: [OptDescr (Options -> Options)] -argspec = - let option s l udsc dsc = Option s l dsc udsc - reqArg udsc dsc = ReqArg dsc udsc - in - [ option "l" ["tolisp"] "print as a list of Lisp" $ - NoArg $ \o -> o { outputStyle = LispStyle } - - , option "h" ["hlintOpt"] "hlint options" $ - reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o } - - , option "g" ["ghcOpt"] "GHC options" $ - reqArg "ghcOpt" $ \g o -> - o { ghcUserOptions = g : ghcUserOptions o } - - , option "v" ["verbose"] "verbose" $ - NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o } - - , option "o" ["operators"] "print operators, too" $ - NoArg $ \o -> o { operators = True } - - , option "d" ["detailed"] "print detailed info" $ - NoArg $ \o -> o { detailed = True } - - , option "q" ["qualified"] "show qualified names" $ - NoArg $ \o -> o { qualified = True } - - , option "b" ["boundary"] "specify line separator (default is Nul string)"$ - reqArg "sep" $ \s o -> o { lineSeparator = LineSeparator s } - ] - -parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) -parseArgs spec argv - = case O.getOpt Permute spec argv of - (o,n,[] ) -> (foldr id defaultOptions o, n) - (_,_,errs) -> E.throw (CmdArg errs) - ----------------------------------------------------------------- - -data GHCModError = SafeList - | ArgumentsMismatch String - | NoSuchCommand String - | CmdArg [String] - | FileNotExist String deriving (Show, Typeable) - -instance Exception GHCModError - ----------------------------------------------------------------- - -main :: IO () -main = flip E.catches handlers $ do - hSetEncoding stdout utf8 - args <- getArgs - let (opt,cmdArg) = parseArgs argspec args - let cmdArg0 = cmdArg !. 0 - cmdArg1 = cmdArg !. 1 - cmdArg3 = cmdArg !. 3 - cmdArg4 = cmdArg !. 4 - cmdArg5 = cmdArg !. 5 - remainingArgs = tail cmdArg - nArgs :: Int -> a -> a - nArgs n f = if length remainingArgs == n - then f - else E.throw (ArgumentsMismatch cmdArg0) - (res, _) <- runGhcModT opt $ case cmdArg0 of - "list" -> modules - "lang" -> languages - "flag" -> flags - "browse" -> concat <$> mapM browse remainingArgs - "check" -> checkSyntax remainingArgs - "expand" -> expandTemplate remainingArgs - "debug" -> debugInfo - "info" -> nArgs 3 info cmdArg1 cmdArg3 - "type" -> nArgs 4 $ types cmdArg1 (read cmdArg3) (read cmdArg4) - "split" -> nArgs 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4) - "sig" -> nArgs 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4) - "refine" -> nArgs 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5 - "auto" -> nArgs 4 $ auto cmdArg1 (read cmdArg3) (read cmdArg4) - "find" -> nArgs 1 $ findSymbol cmdArg1 - "lint" -> nArgs 1 $ withFile lint cmdArg1 - "root" -> rootInfo - "doc" -> nArgs 1 $ pkgDoc cmdArg1 - "dumpsym" -> dumpSymbol - "boot" -> boot - "version" -> return progVersion - "help" -> return $ O.usageInfo usage argspec - cmd -> E.throw (NoSuchCommand cmd) - - case res of - Right s -> putStr s - Left (GMENoMsg) -> - hPutStrLn stderr "Unknown error" - Left (GMEString msg) -> - hPutStrLn stderr msg - Left (GMECabalConfigure msg) -> - hPutStrLn stderr $ "cabal configure failed: " ++ show msg - Left (GMECabalFlags msg) -> - hPutStrLn stderr $ "retrieval of the cabal configuration flags failed: " ++ show msg - Left (GMEProcess cmd msg) -> - hPutStrLn stderr $ - "launching operating system process `"++c++"` failed: " ++ show msg - where c = unwords cmd - - where - handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)] - handleThenExit handler e = handler e >> exitFailure - handler1 :: ErrorCall -> IO () - handler1 = print -- for debug - handler2 :: GHCModError -> IO () - handler2 SafeList = printUsage - handler2 (ArgumentsMismatch cmd) = do - hPutStrLn stderr $ "\"" ++ cmd ++ "\": Arguments did not match" - printUsage - handler2 (NoSuchCommand cmd) = do - hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported" - printUsage - handler2 (CmdArg errs) = do - mapM_ (hPutStr stderr) errs - printUsage - handler2 (FileNotExist file) = do - hPutStrLn stderr $ "\"" ++ file ++ "\" not found" - printUsage - printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec - withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a - withFile cmd file = do - exist <- liftIO $ doesFileExist file - if exist - then cmd file - else E.throw (FileNotExist file) - xs !. idx - | length xs <= idx = E.throw SafeList - | otherwise = xs !! idx diff --git a/src/GHCModi.hs b/src/GHCModi.hs deleted file mode 100644 --- a/src/GHCModi.hs +++ /dev/null @@ -1,323 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} - --- Commands: --- check --- find --- info --- type --- lint [hlint options] --- the format of hlint options is [String] because they may contain --- spaces and also may contain spaces. --- boot --- browse [:] --- quit --- --- Session separators: --- OK -- success --- NG -- failure - -module Main where - -import Config (cProjectVersion) -import Control.Applicative ((<$>)) -import Control.Concurrent.Async (Async, async, wait) -import Control.Exception (SomeException(..), Exception) -import qualified Control.Exception as E -import Control.Monad (when) -import CoreMonad (liftIO) -import Data.List (find, intercalate) -import Data.List.Split (splitOn) -import Data.Maybe (fromMaybe) -import Data.Set (Set) -import qualified Data.Set as S -import Data.Typeable (Typeable) -import Data.Version (showVersion) -import qualified GHC as G -import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal -import Paths_ghc_mod -import System.Console.GetOpt -import System.Directory (setCurrentDirectory) -import System.Environment (getArgs) -import System.IO (hFlush,stdout) -import System.Exit (ExitCode, exitFailure) - -import Utils - ----------------------------------------------------------------- - -type Logger = IO String - ----------------------------------------------------------------- - -progVersion :: String -progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n" - -argspec :: [OptDescr (Options -> Options)] -argspec = [ Option "b" ["boundary"] - (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep") - "specify line separator (default is Nul string)" - , Option "l" ["tolisp"] - (NoArg (\opts -> opts { outputStyle = LispStyle })) - "print as a list of Lisp" - , Option "g" [] - (ReqArg (\s opts -> opts { ghcUserOptions = s : ghcUserOptions opts }) "flag") "specify a ghc flag" - ] - -usage :: String -usage = progVersion - ++ "Usage:\n" - ++ "\t ghc-modi [-l] [-b sep] [-g flag]\n" - ++ "\t ghc-modi version\n" - ++ "\t ghc-modi help\n" - -parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) -parseArgs spec argv - = case getOpt Permute spec argv of - (o,n,[] ) -> (foldr id defaultOptions o, n) - (_,_,errs) -> E.throw (CmdArg errs) - ----------------------------------------------------------------- - -data GHCModiError = CmdArg [String] - deriving (Show, Typeable) - -instance Exception GHCModiError - ----------------------------------------------------------------- - --- Running two GHC monad threads disables the handling of --- C-c since installSignalHandlers is called twice, sigh. - -main :: IO () -main = E.handle cmdHandler $ - go =<< parseArgs argspec <$> getArgs - where - cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec - go (_,"help":_) = putStr $ usageInfo usage argspec - go (_,"version":_) = putStr progVersion - go (opt,_) = flip E.catches handlers $ do - cradle0 <- findCradle - let rootdir = cradleRootDir cradle0 --- c = cradle0 { cradleCurrentDir = rootdir } TODO: ????? - setCurrentDirectory rootdir - symDb <- async $ runGhcModT opt loadSymbolDb - (res, _) <- runGhcModT opt $ loop S.empty symDb - - case res of - Right () -> return () - Left (GMECabalConfigure msg) -> do - putStrLn $ notGood $ "cabal configure failed: " ++ show msg - exitFailure - Left e -> bug $ show e - where - -- this is just in case. - -- If an error is caught here, it is a bug of GhcMod library. - handlers = [ E.Handler (\(_ :: ExitCode) -> return ()) - , E.Handler (\(SomeException e) -> bug $ show e) ] - -bug :: String -> IO () -bug msg = do - putStrLn $ notGood $ "BUG: " ++ msg - exitFailure - -notGood :: String -> String -notGood msg = "NG " ++ escapeNewlines msg - -escapeNewlines :: String -> String -escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n" - -replace :: String -> String -> String -> String -replace needle replacement = intercalate replacement . splitOn needle - ----------------------------------------------------------------- - -loop :: IOish m => Set FilePath -> SymDbReq -> GhcModT m () -loop set symDbReq = do - cmdArg <- liftIO getLine - let (cmd,arg') = break (== ' ') cmdArg - arg = dropWhile (== ' ') arg' - (ret,ok,set') <- case cmd of - "check" -> checkStx set arg - "find" -> findSym set arg symDbReq - "lint" -> lintStx set arg - "info" -> showInfo set arg - "type" -> showType set arg - "split" -> doSplit set arg - "sig" -> doSig set arg - "refine" -> doRefine set arg - "auto" -> doAuto set arg - "boot" -> bootIt set - "browse" -> browseIt set arg - "quit" -> return ("quit", False, set) - "" -> return ("quit", False, set) - _ -> return ([], True, set) - if ok then do - liftIO $ putStr ret - liftIO $ putStrLn "OK" - else do - liftIO $ putStrLn $ notGood ret - liftIO $ hFlush stdout - when ok $ loop set' symDbReq - ----------------------------------------------------------------- - -checkStx :: IOish m - => Set FilePath - -> FilePath - -> GhcModT m (String, Bool, Set FilePath) -checkStx set file = do - set' <- newFileSet set file - let files = S.toList set' - eret <- check files - case eret of - Right ret -> return (ret, True, set') - Left ret -> return (ret, True, set) -- fxime: set - -newFileSet :: IOish m => Set FilePath -> FilePath -> GhcModT m (Set FilePath) -newFileSet set file = do - let set1 - | S.member file set = set - | otherwise = S.insert file set - mx <- isSameMainFile file <$> getModSummaryForMain - return $ case mx of - Nothing -> set1 - Just mainfile -> S.delete mainfile set1 - -getModSummaryForMain :: IOish m => GhcModT m (Maybe G.ModSummary) -getModSummaryForMain = find isMain <$> G.getModuleGraph - where - isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main" - -isSameMainFile :: FilePath -> (Maybe G.ModSummary) -> Maybe FilePath -isSameMainFile _ Nothing = Nothing -isSameMainFile file (Just x) - | mainfile == file = Nothing - | otherwise = Just mainfile - where - mmainfile = G.ml_hs_file (G.ms_location x) - -- G.ms_hspp_file x is a temporary file with CPP. - -- this is a just fake. - mainfile = fromMaybe (G.ms_hspp_file x) mmainfile - ----------------------------------------------------------------- - -type SymDbReq = Async (Either GhcModError SymbolDb, GhcModLog) - -findSym :: IOish m => Set FilePath -> String -> SymDbReq - -> GhcModT m (String, Bool, Set FilePath) -findSym set sym dbReq = do - db <- hoistGhcModT =<< liftIO (wait dbReq) - ret <- lookupSymbol sym db - return (ret, True, set) - -lintStx :: IOish m => Set FilePath - -> FilePath - -> GhcModT m (String, Bool, Set FilePath) -lintStx set optFile = do - ret <- withOptions changeOpt $ lint file - return (ret, True, set) - where - (opts,file) = parseLintOptions optFile - hopts = if opts == "" then [] else read opts - changeOpt o = o { hlintOpts = hopts } - --- | --- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name" --- (["--ignore=Use camelCase", "--ignore=Eta reduce"], "file name") --- >>> parseLintOptions "file name" --- ([], "file name") -parseLintOptions :: String -> (String, String) -parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of - ("","") -> ([], optFile) - (opt',file') -> (opt', dropWhile (== ' ') file') - where - brk _ [] = ([],[]) - brk p (x:xs') - | p x = ([x],xs') - | otherwise = let (ys,zs) = brk p xs' in (x:ys,zs) - ----------------------------------------------------------------- - -showInfo :: IOish m - => Set FilePath - -> FilePath - -> GhcModT m (String, Bool, Set FilePath) -showInfo set fileArg = do - let [file, expr] = splitN 2 fileArg - set' <- newFileSet set file - ret <- info file expr - return (ret, True, set') - -showType :: IOish m - => Set FilePath - -> FilePath - -> GhcModT m (String, Bool, Set FilePath) -showType set fileArg = do - let [file, line, column] = splitN 3 fileArg - set' <- newFileSet set file - ret <- types file (read line) (read column) - return (ret, True, set') - -doSplit :: IOish m - => Set FilePath - -> FilePath - -> GhcModT m (String, Bool, Set FilePath) -doSplit set fileArg = do - let [file, line, column] = splitN 3 fileArg - set' <- newFileSet set file - ret <- splits file (read line) (read column) - return (ret, True, set') - -doSig :: IOish m - => Set FilePath - -> FilePath - -> GhcModT m (String, Bool, Set FilePath) -doSig set fileArg = do - let [file, line, column] = splitN 3 fileArg - set' <- newFileSet set file - ret <- sig file (read line) (read column) - return (ret, True, set') - -doRefine :: IOish m - => Set FilePath - -> FilePath - -> GhcModT m (String, Bool, Set FilePath) -doRefine set fileArg = do - let [file, line, column, expr] = splitN 4 fileArg - set' <- newFileSet set file - ret <- refine file (read line) (read column) expr - return (ret, True, set') - -doAuto :: IOish m - => Set FilePath - -> FilePath - -> GhcModT m (String, Bool, Set FilePath) -doAuto set fileArg = do - let [file, line, column] = splitN 3 fileArg - set' <- newFileSet set file - ret <- auto file (read line) (read column) - return (ret, True, set') - ----------------------------------------------------------------- - -bootIt :: IOish m - => Set FilePath - -> GhcModT m (String, Bool, Set FilePath) -bootIt set = do - ret <- boot - return (ret, True, set) - -browseIt :: IOish m - => Set FilePath - -> ModuleString - -> GhcModT m (String, Bool, Set FilePath) -browseIt set mdl = do - let (det,rest') = break (== ' ') mdl - rest = dropWhile (== ' ') rest' - ret <- if det == "-d" - then withOptions setDetailed (browse rest) - else browse mdl - return (ret, True, set) - where - setDetailed opt = opt { detailed = True } diff --git a/src/GhcMod/Exe/Options.hs b/src/GhcMod/Exe/Options.hs new file mode 100644 --- /dev/null +++ b/src/GhcMod/Exe/Options.hs @@ -0,0 +1,72 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- 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 . +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module GhcMod.Exe.Options ( + parseArgs, + parseArgsInteractive, + GhcModCommands(..) +) where + +import Options.Applicative +import Options.Applicative.Types + +import GhcMod.Exe.Options.Commands +import GhcMod.Exe.Options.ShellParse +import GhcMod.Exe.Version +import GhcMod.Options.DocUtils +import GhcMod.Options.Options +import GhcMod.Types + +parseArgs :: IO (Options, GhcModCommands) +parseArgs = + execParser opts + where + opts = info (argAndCmdSpec <**> helpVersion) + $$ fullDesc + <=> header "ghc-mod: Happy Haskell Hacking" + +parseArgsInteractive :: String -> Either String GhcModCommands +parseArgsInteractive args = + handle $ execParserPure (prefs idm) opts $ parseCmdLine args + where + opts = info interactiveCommandsSpec $$ fullDesc + handle (Success a) = Right a + handle (Failure failure) = + Left $ fst $ renderFailure failure "" + handle _ = Left "Completion invoked" + +helpVersion :: Parser (a -> a) +helpVersion = + helper + <*> abortOption (InfoMsg ghcModVersion) + $$ long "version" + <=> help "Print the version of the program." + <*> argument r + $$ value id + <=> metavar "" + where + r :: ReadM (a -> a) + r = do + v <- readerAsk + case v of + "help" -> readerAbort ShowHelpText + "version" -> readerAbort $ InfoMsg ghcModVersion + _ -> return id + +argAndCmdSpec :: Parser (Options, GhcModCommands) +argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec diff --git a/src/GhcMod/Exe/Options/Commands.hs b/src/GhcMod/Exe/Options/Commands.hs new file mode 100644 --- /dev/null +++ b/src/GhcMod/Exe/Options/Commands.hs @@ -0,0 +1,301 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- 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 . +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module GhcMod.Exe.Options.Commands where + +import Data.Semigroup +import Options.Applicative +import Options.Applicative.Types +import Options.Applicative.Builder.Internal +import GhcMod.Types +import GhcMod.Read +import GhcMod.Options.DocUtils +import GhcMod.Options.Help + +type Symbol = String +type Expr = String +type Module = String +type Line = Int +type Col = Int +type Point = (Line, Col) + +data GhcModCommands = + CmdLang + | CmdFlag + | CmdDebug + | CmdBoot + | CmdNukeCaches + | CmdRoot + | CmdLegacyInteractive + | CmdModules Bool + | CmdDumpSym + | CmdFind Symbol + | CmdDoc Module + | CmdLint LintOpts FilePath + | CmdBrowse BrowseOpts [Module] + | CmdDebugComponent [String] + | CmdCheck [FilePath] + | CmdExpand [FilePath] + | CmdInfo FilePath Symbol + | CmdType Bool FilePath Point + | CmdSplit FilePath Point + | CmdSig FilePath Point + | CmdAuto FilePath Point + | CmdRefine FilePath Point Expr + | CmdTest FilePath + -- interactive-only commands + | CmdMapFile FilePath + | CmdUnmapFile FilePath + | CmdQuit + deriving (Show) + +commandsSpec :: Parser GhcModCommands +commandsSpec = + hsubparser commands + +commands :: Mod CommandFields GhcModCommands +commands = + command "lang" + $$ info (pure CmdLang) + $$ progDesc "List all known GHC language extensions" + <> command "flag" + $$ info (pure CmdFlag) + $$ progDesc "List GHC -f flags" + <> command "debug" + $$ info (pure CmdDebug) + $$ progDesc' $$$ do + "Print debugging information. Please include" + \\ "the output in any bug reports you submit" + <> command "debug-component" + $$ info debugComponentArgSpec + $$ progDesc' $$$ do + "Debugging information related to cabal component" + \\ "resolution" + <> command "boot" + $$ info (pure CmdBoot) + $$ progDesc "Internal command used by the emacs frontend" + -- <> command "nuke-caches" + -- $$ info (pure CmdNukeCaches) idm + <> command "root" + $$ info (pure CmdRoot) + $$ progDesc' + "Try to find the project directory." + <=> desc $$$ do + "For Cabal projects this is the" + \\ "directory containing the cabal file, for projects" + \\ "that use a cabal sandbox but have no cabal file" + \\ "this is the directory containing the cabal.sandbox.config" + \\ "file and otherwise this is the current directory" + <> command "legacy-interactive" + $$ info legacyInteractiveArgSpec + $$ progDesc "ghc-modi compatibility mode" + <> command "list" + $$ info modulesArgSpec + $$ progDesc "List all visible modules" + <> command "modules" + $$ info modulesArgSpec + $$ progDesc "List all visible modules" + <> command "dumpsym" + $$ info (pure CmdDumpSym) idm + <> command "find" + $$ info findArgSpec + $$ progDesc "List all modules that define SYMBOL" + <> command "doc" + $$ info docArgSpec + $$ progDesc' $$$ do + "Try finding the html documentation directory" + \\ "for the given MODULE" + <> command "lint" + $$ info lintArgSpec + $$ progDesc "Check files using `hlint'" + <> command "browse" + $$ info browseArgSpec + $$ progDesc "List symbols in a module" + <> command "check" + $$ info checkArgSpec + $$ progDesc' $$$ do + "Load the given files using GHC and report errors/warnings," + \\ "but don't produce output files" + <> command "expand" + $$ info expandArgSpec + $$ progDesc "Like `check' but also pass `-ddump-splices' to GHC" + <> command "info" + $$ info infoArgSpec + $$ progDesc' $$$ do + "Look up an identifier in the context" + \\ "of FILE (like ghci's `:info')" + <> command "type" + $$ info typeArgSpec + $$ progDesc "Get the type of the expression under (LINE,COL)" + <> command "split" + $$ info splitArgSpec + $$ progDesc + "Split a function case by examining a type's constructors" + <=> desc $$$ do + "For example given the following code snippet:" + code $ do + "f :: [a] -> a" + "f x = _body" + "would be replaced by:" + code $ do + "f :: [a] -> a" + "f [] = _body" + "f (x:xs) = _body" + "(See https://github.com/DanielG/ghc-mod/pull/274)" + <> command "sig" + $$ info sigArgSpec + $$ progDesc "Generate initial code given a signature" + <=> desc $$$ do + "For example when (LINE,COL) is on the" + \\ "signature in the following code snippet:" + code "func :: [a] -> Maybe b -> (a -> b) -> (a,b)" + "ghc-mod would add the following on the next line:" + code "func x y z f = _func_body" + "(See: https://github.com/DanielG/ghc-mod/pull/274)" + <> command "auto" + $$ info autoArgSpec + $$ progDesc "Try to automatically fill the contents of a hole" + <> command "refine" + $$ info refineArgSpec + $$ progDesc "Refine the typed hole at (LINE,COL) given EXPR" + <=> desc $$$ do + "For example if EXPR is `filter', which has type" + \\ "`(a -> Bool) -> [a] -> [a]' and (LINE,COL) is on" + \\ " the hole `_body' in the following code snippet:" + code $ do + "filterNothing :: [Maybe a] -> [a]" + "filterNothing xs = _body" + "ghc-mod changes the code to get a value of type" + \\ " `[a]', which results in:" + code "filterNothing xs = filter _body_1 _body_2" + "(See also: https://github.com/DanielG/ghc-mod/issues/311)" + <> command "test" + $$ info (CmdTest <$> strArg "FILE") + $$ progDesc "" + + +interactiveCommandsSpec :: Parser GhcModCommands +interactiveCommandsSpec = + hsubparser' + $ commands + <> command "map-file" + $$ info mapArgSpec + $$ progDesc "tells ghc-modi to read `file.hs` source from stdin" + <=> desc $$$ do + "Works the same as second form of" + \\ "`--map-file` CLI option." + <> command "unmap-file" + $$ info unmapArgSpec + $$ progDesc' $$$ do + "unloads previously mapped file," + \\ "so that it's no longer mapped." + <=> desc $$$ do + "`file.hs` can be full path or relative" + \\ "to project root, either will work." + <> command "quit" + $$ info (pure CmdQuit) + $$ progDesc "Exit interactive mode" + <> command "" + $$ info (pure CmdQuit) idm + +strArg :: String -> Parser String +strArg = argument str . metavar + +filesArgsSpec :: Parser ([String] -> b) -> Parser b +filesArgsSpec x = x <*> some (strArg "FILES..") + +locArgSpec :: Parser (String -> (Int, Int) -> b) -> Parser b +locArgSpec x = x + <*> strArg "FILE" + <*> ( (,) + <$> argument int (metavar "LINE") + <*> argument int (metavar "COL") + ) + +modulesArgSpec, docArgSpec, findArgSpec, + lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec, + infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec, + sigArgSpec, refineArgSpec, debugComponentArgSpec, + mapArgSpec, unmapArgSpec, legacyInteractiveArgSpec :: Parser GhcModCommands + +modulesArgSpec = CmdModules + <$> switch + $$ long "detailed" + <=> short 'd' + <=> help "Print package modules belong to" +findArgSpec = CmdFind <$> strArg "SYMBOL" +docArgSpec = CmdDoc <$> strArg "MODULE" +lintArgSpec = CmdLint + <$> LintOpts <$$> many $$ strOption + $$ long "hlintOpt" + <=> short 'h' + <=> help "Option to be passed to hlint" + <*> strArg "FILE" +browseArgSpec = CmdBrowse + <$> (BrowseOpts + <$> switch + $$ long "operators" + <=> short 'o' + <=> help "Also print operators" + <*> switch + $$ long "detailed" + <=> short 'd' + <=> help "Print symbols with accompanying signature" + <*> switch + $$ long "parents" + <=> short 'p' + <=> help "Print symbols parents" + <*> switch + $$ long "qualified" + <=> short 'q' + <=> help "Qualify symbols" + ) + <*> some (strArg "MODULE") +debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent) +checkArgSpec = filesArgsSpec (pure CmdCheck) +expandArgSpec = filesArgsSpec (pure CmdExpand) +infoArgSpec = CmdInfo + <$> strArg "FILE" + <*> strArg "SYMBOL" +typeArgSpec = locArgSpec $ CmdType <$> + switch + $$ long "constraints" + <=> short 'c' + <=> help "Include constraints into type signature" +autoArgSpec = locArgSpec (pure CmdAuto) +splitArgSpec = locArgSpec (pure CmdSplit) +sigArgSpec = locArgSpec (pure CmdSig) +refineArgSpec = locArgSpec (pure CmdRefine) <*> strArg "SYMBOL" +mapArgSpec = CmdMapFile <$> strArg "FILE" +unmapArgSpec = CmdUnmapFile <$> strArg "FILE" +legacyInteractiveArgSpec = const CmdLegacyInteractive <$> + optional interactiveCommandsSpec + +hsubparser' :: Mod CommandFields a -> Parser a +hsubparser' m = mkParser d g rdr + where + Mod _ d g = m `mappend` metavar "" + (ms, cmds, subs) = mkCommand m + rdr = CmdReader ms cmds (fmap add_helper . subs) + add_helper pinfo = pinfo + { infoParser = infoParser pinfo <**> helper } + +int :: ReadM Int +int = do + v <- readerAsk + maybe (readerError $ "Not a number \"" ++ v ++ "\"") return $ readMaybe v diff --git a/src/GhcMod/Exe/Options/ShellParse.hs b/src/GhcMod/Exe/Options/ShellParse.hs new file mode 100644 --- /dev/null +++ b/src/GhcMod/Exe/Options/ShellParse.hs @@ -0,0 +1,44 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- 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 . +module GhcMod.Exe.Options.ShellParse (parseCmdLine) where + +import Data.Char +import Data.List + +go :: String -> String -> [String] -> Bool -> [String] +-- result +go [] curarg accargs _ = reverse $ reverse curarg : accargs +go (c:cl) curarg accargs quotes + -- open quotes + | c == '\STX', not quotes + = go cl curarg accargs True + -- close quotes + | c == '\ETX', quotes + = go cl curarg accargs False + -- space separates arguments outside quotes + | isSpace c, not quotes + = if null curarg + then go cl curarg accargs quotes + else go cl [] (reverse curarg : accargs) quotes + -- general character + | otherwise = go cl (c:curarg) accargs quotes + +parseCmdLine :: String -> [String] +parseCmdLine comline' + | Just comline <- stripPrefix "ascii-escape " $ dropWhile isSpace comline' + = go (dropWhile isSpace comline) [] [] False +parseCmdLine [] = [""] +parseCmdLine comline = words comline diff --git a/src/GhcMod/Exe/Version.hs b/src/GhcMod/Exe/Version.hs new file mode 100644 --- /dev/null +++ b/src/GhcMod/Exe/Version.hs @@ -0,0 +1,32 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Nikolay Yakimov +-- +-- 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 . + +module GhcMod.Exe.Version where + +import Paths_ghc_mod +import Data.Version (showVersion) +import Config (cProjectVersion) + +progVersion :: String -> String +progVersion pf = + "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC " + ++ cProjectVersion + +ghcModVersion :: String +ghcModVersion = progVersion "" + +ghcModiVersion :: String +ghcModiVersion = progVersion "i" diff --git a/src/GhcModMain.hs b/src/GhcModMain.hs new file mode 100644 --- /dev/null +++ b/src/GhcModMain.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} + +module Main where + +import Control.Applicative +import Control.Monad +import Data.Typeable (Typeable) +import Data.List +import Data.List.Split +import GhcMod.Pretty +import System.FilePath (()) +import System.Directory (setCurrentDirectory, getAppUserDataDirectory, + removeDirectoryRecursive) +import System.IO +import System.Exit +import Prelude + +import GhcMod +import GhcMod.Exe.Find +import GhcMod.Exe.Options +import GhcMod.Exe.Internal hiding (MonadIO,liftIO) +import GhcMod.Monad +import GhcMod.Types + +import Exception + +handler :: IOish m => GhcModT m a -> GhcModT m a +handler = flip gcatches + [ GHandler $ \(e :: ExitCode) -> throw e + , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e + ] + +main :: IO () +main = + parseArgs >>= \res@(globalOptions, _) -> do + enc <- mkTextEncoding $ optEncoding globalOptions + hSetEncoding stdout enc + hSetEncoding stderr enc + hSetEncoding stdin enc + catches (progMain res) [ + Handler $ \(e :: GhcModError) -> + runGmOutT globalOptions $ exitError $ renderGm (gmeDoc e) + ] + +progMain :: (Options, GhcModCommands) -> IO () +progMain (globalOptions, commands) = runGmOutT globalOptions $ + wrapGhcCommands globalOptions commands + +-- ghc-modi +legacyInteractive :: IOish m => GhcModT m () +legacyInteractive = do + prepareCabalHelper + asyncSymbolDb <- newAsyncSymbolDb + world <- getCurrentWorld + legacyInteractiveLoop asyncSymbolDb world + +legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m () +legacyInteractiveLoop asyncSymbolDb world = do + liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle + + -- blocking + cmdArg <- liftIO getLine + + -- after blocking, we need to see if the world has changed. + + changed <- didWorldChange world + + world' <- if changed + then getCurrentWorld -- TODO: gah, we're hitting the fs twice + else return world + + when changed dropSession + + res <- flip gcatches interactiveHandlers $ do + pargs <- either (throw . InvalidCommandLine . Right) return + $ parseArgsInteractive cmdArg + case pargs of + CmdFind symbol -> + lookupSymbol symbol =<< getAsyncSymbolDb asyncSymbolDb + -- other commands are handled here + x -> ghcCommands x + + gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout) + legacyInteractiveLoop asyncSymbolDb world' + where + interactiveHandlers = + [ GHandler $ \(e :: ExitCode) -> throw e + , GHandler $ \(InvalidCommandLine e) -> do + let err = notGood $ either ("Invalid command line: "++) Prelude.id e + liftIO $ do + putStr err + exitFailure + , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return "" + ] + notGood msg = "NG " ++ escapeNewlines msg + escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n" + replace needle replacement = intercalate replacement . splitOn needle + +getFileSourceFromStdin :: IO String +getFileSourceFromStdin = do + linesIn <- readStdin' + return (intercalate "\n" linesIn) + where + readStdin' = do + x <- getLine + if x/="\EOT" + then fmap (x:) readStdin' + else return [] + +wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m () +wrapGhcCommands opts cmd = + handleGmError $ runGhcModT opts $ handler $ do + forM_ (reverse $ optFileMappings opts) $ + uncurry loadMMappedFiles + + gmPutStr =<< ghcCommands cmd + where + handleGmError action = do + (e, _l) <- liftIO . evaluate =<< action + case e of + Right _ -> + return () + Left ed -> + exitError $ renderGm (gmeDoc ed) + + loadMMappedFiles from (Just to) = loadMappedFile from to + loadMMappedFiles from (Nothing) = do + src <- liftIO getFileSourceFromStdin + loadMappedFileSource from src + + +ghcCommands :: IOish m => GhcModCommands -> GhcModT m String +-- ghcCommands cmd = action args +ghcCommands (CmdLang) = languages +ghcCommands (CmdFlag) = flags +ghcCommands (CmdDebug) = debugInfo +ghcCommands (CmdDebugComponent ts) = componentInfo ts +ghcCommands (CmdBoot) = boot +-- ghcCommands (CmdNukeCaches) = nukeCaches >> return "" +ghcCommands (CmdRoot) = rootInfo +ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return "" +ghcCommands (CmdModules detail) = modules detail +ghcCommands (CmdDumpSym) = dumpSymbol >> return "" +ghcCommands (CmdFind symb) = findSymbol symb +ghcCommands (CmdDoc m) = pkgDoc m +ghcCommands (CmdLint opts file) = lint opts file +ghcCommands (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms +ghcCommands (CmdCheck files) = checkSyntax files +ghcCommands (CmdExpand files) = expandTemplate files +ghcCommands (CmdInfo file symb) = info file $ Expression symb +ghcCommands (CmdType wCon file (line, col)) = types wCon file line col +ghcCommands (CmdSplit file (line, col)) = splits file line col +ghcCommands (CmdSig file (line, col)) = sig file line col +ghcCommands (CmdAuto file (line, col)) = auto file line col +ghcCommands (CmdRefine file (line, col) expr) = refine file line col $ Expression expr +-- interactive-only commands +ghcCommands (CmdMapFile f) = + liftIO getFileSourceFromStdin + >>= loadMappedFileSource f + >> return "" +ghcCommands (CmdUnmapFile f) = unloadMappedFile f >> return "" +ghcCommands (CmdQuit) = liftIO exitSuccess +ghcCommands (CmdTest file) = test file +ghcCommands cmd = throw $ InvalidCommandLine $ Left $ show cmd + +newtype InvalidCommandLine = InvalidCommandLine (Either String String) + deriving (Show, Typeable) +instance Exception InvalidCommandLine + +exitError :: (MonadIO m, GmOut m) => String -> m a +exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure + +nukeCaches :: IOish m => GhcModT m () +nukeCaches = do + chdir <- liftIO $ ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" + c <- cradle + + when (isCabalHelperProject $ cradleProject c) $ do + let root = cradleRootDir c + let dist = cradleDistDir c + liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root dist] + +trySome :: IO a -> IO (Either SomeException a) +trySome = try diff --git a/src/GhcModi.hs b/src/GhcModi.hs new file mode 100644 --- /dev/null +++ b/src/GhcModi.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | WARNING +-- This program is deprecated, use `ghc-mod legacy-interactive` instead. + +module Main where + +import Control.Applicative +import Control.Monad +import Control.Exception +import Data.Version +import Data.Maybe +import System.IO +import System.Exit +import System.Process +import System.FilePath +import System.Environment +import Paths_ghc_mod +import Utils +import Prelude + +main :: IO () +main = do + hPutStrLn stderr $ + "Warning: ghc-modi is deprecated please use 'ghc-mod legacy-interactive' instead" + + args <- getArgs + bindir <- getBinDir + let installedExe = bindir "ghc-mod" + mexe <- mplus <$> mightExist installedExe <*> pathExe + case mexe of + Nothing -> do + hPutStrLn stderr $ + "ghc-modi: Could not find '"++installedExe++"', check your installation!" + exitWith $ ExitFailure 1 + + Just exe -> do + (_, _, _, h) <- + createProcess $ proc exe $ ["legacy-interactive"] ++ args + exitWith =<< waitForProcess h + +pathExe :: IO (Maybe String) +pathExe = do + ev <- try $ words <$> readProcess "ghc-mod" ["--version"] "" + let mexe = case ev of + Left (SomeException _) -> Nothing + Right ["ghc-mod", "version", ver + , "compiled", "by", "GHC", _] + | showVersion version == ver -> do + Just "ghc-mod" + Right _ -> Nothing + + when (isNothing mexe) $ + hPutStrLn stderr "ghc-modi: ghc-mod executable on PATH has different version, check your installation!" + return mexe diff --git a/src/Utils.hs b/src/Utils.hs deleted file mode 100644 --- a/src/Utils.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Utils where - --- | --- --- >>> split "foo bar baz" --- ["foo","bar baz"] --- >>> split "foo bar baz" --- ["foo","bar baz"] -split :: String -> [String] -split xs = [ys, dropWhile isSpace zs] - where - isSpace = (== ' ') - (ys,zs) = break isSpace xs - --- | --- --- >>> splitN 0 "foo bar baz" --- ["foo","bar baz"] --- >>> splitN 2 "foo bar baz" --- ["foo","bar baz"] --- >>> splitN 3 "foo bar baz" --- ["foo","bar","baz"] -splitN :: Int -> String -> [String] -splitN n xs - | n <= 2 = split xs - | otherwise = let [ys,zs] = split xs - in ys : splitN (n - 1) zs diff --git a/test/BrowseSpec.hs b/test/BrowseSpec.hs --- a/test/BrowseSpec.hs +++ b/test/BrowseSpec.hs @@ -1,8 +1,9 @@ module BrowseSpec where import Control.Applicative -import Language.Haskell.GhcMod +import GhcMod import Test.Hspec +import Prelude import TestUtils import Dir @@ -11,22 +12,23 @@ spec = do describe "browse Data.Map" $ do it "contains at least `differenceWithKey'" $ do - syms <- runD $ lines <$> browse "Data.Map" + syms <- runD $ lines <$> browse defaultBrowseOpts "Data.Map" syms `shouldContain` ["differenceWithKey"] describe "browse -d Data.Either" $ do it "contains functions (e.g. `either') including their type signature" $ do - syms <- run defaultOptions { detailed = True } - $ lines <$> browse "Data.Either" + syms <- runD + $ lines <$> browse defaultBrowseOpts{ optBrowseDetailed = True } "Data.Either" syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"] it "contains type constructors (e.g. `Left') including their type signature" $ do - syms <- run defaultOptions { detailed = True} - $ lines <$> browse "Data.Either" + syms <- runD + $ lines <$> browse defaultBrowseOpts{ optBrowseDetailed = True } "Data.Either" syms `shouldContain` ["Left :: a -> Either a b"] describe "`browse' in a project directory" $ do - it "lists symbols defined in a a local module (e.g. `Baz.baz)" $ do - withDirectory_ "test/data" $ do - syms <- runID $ lines <$> browse "Baz" - syms `shouldContain` ["baz"] + it "can list symbols defined in a a local module" $ do + withDirectory_ "test/data/ghc-mod-check/" $ do + syms <- runD $ lines <$> browse defaultBrowseOpts "Data.Foo" + syms `shouldContain` ["foo"] + syms `shouldContain` ["fibonacci"] diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs deleted file mode 100644 --- a/test/CabalApiSpec.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module CabalApiSpec where - -import Control.Applicative -import Data.Maybe -import Language.Haskell.GhcMod.CabalApi -import Language.Haskell.GhcMod.Cradle -import Language.Haskell.GhcMod.Types -import Test.Hspec -import System.Directory -import System.FilePath -import System.Process (readProcess) - -import Dir -import TestUtils - -import Config (cProjectVersionInt) -- ghc version - -ghcVersion :: Int -ghcVersion = read cProjectVersionInt - -spec :: Spec -spec = do - describe "parseCabalFile" $ do - it "throws an exception if the cabal file is broken" $ do - shouldReturnError $ do - withDirectory_ "test/data/broken-cabal" $ do - crdl <- findCradle - runD' $ parseCabalFile crdl "broken.cabal" - - - describe "getCompilerOptions" $ do - it "gets necessary CompilerOptions" $ do - cwd <- getCurrentDirectory - withDirectory "test/data/subdir1/subdir2" $ \dir -> do - crdl <- findCradle - pkgDesc <- runD $ parseCabalFile crdl $ fromJust $ cradleCabalFile crdl - res <- runD $ getCompilerOptions [] crdl pkgDesc - let res' = res { - ghcOptions = ghcOptions res - , includeDirs = map (toRelativeDir dir) (includeDirs res) - } - if ghcVersion < 706 - then ghcOptions res' `shouldContain` ["-global-package-conf", "-no-user-package-conf","-package-conf",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"] - else ghcOptions res' `shouldContain` ["-global-package-db", "-no-user-package-db","-package-db",cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"] - includeDirs res' `shouldBe` ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"] - (pkgName `map` depPackages res') `shouldContain` ["Cabal"] - - - describe "cabalDependPackages" $ do - it "extracts dependent packages" $ do - crdl <- findCradle' "test/data/" - pkgs <- cabalDependPackages . cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal") - pkgs `shouldBe` ["Cabal","base","template-haskell"] - it "uses non default flags" $ do - withDirectory_ "test/data/cabal-flags" $ do - crdl <- findCradle - _ <- readProcess "cabal" ["configure", "-ftest-flag"] "" - pkgs <- cabalDependPackages . cabalAllBuildInfo <$> runD (parseCabalFile crdl "cabal-flags.cabal") - pkgs `shouldBe` ["Cabal","base"] - - describe "cabalSourceDirs" $ do - it "extracts all hs-source-dirs" $ do - crdl <- findCradle' "test/data/check-test-subdir" - dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/check-test-subdir/check-test-subdir.cabal") - dirs `shouldBe` ["src", "test"] - it "extracts all hs-source-dirs including \".\"" $ do - crdl <- findCradle' "test/data/" - dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal") - dirs `shouldBe` [".", "test"] - - describe "cabalAllBuildInfo" $ do - it "extracts build info" $ do - crdl <- findCradle' "test/data/" - info <- cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal") - show info `shouldBe` "[BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\".\"], otherModules = [ModuleName [\"Browse\"],ModuleName [\"CabalApi\"],ModuleName [\"Cabal\"],ModuleName [\"CabalDev\"],ModuleName [\"Check\"],ModuleName [\"ErrMsg\"],ModuleName [\"Flag\"],ModuleName [\"GHCApi\"],ModuleName [\"GHCChoice\"],ModuleName [\"Gap\"],ModuleName [\"Info\"],ModuleName [\"Lang\"],ModuleName [\"Lint\"],ModuleName [\"List\"],ModuleName [\"Paths_ghc_mod\"],ModuleName [\"Types\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [(GHC,[\"-Wall\"])], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))),Dependency (PackageName \"template-haskell\") AnyVersion]},BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\"test\",\".\"], otherModules = [ModuleName [\"Expectation\"],ModuleName [\"BrowseSpec\"],ModuleName [\"CabalApiSpec\"],ModuleName [\"FlagSpec\"],ModuleName [\"LangSpec\"],ModuleName [\"LintSpec\"],ModuleName [\"ListSpec\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []})))]}]" diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs new file mode 100644 --- /dev/null +++ b/test/CabalHelperSpec.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE CPP #-} +module CabalHelperSpec where + +import Control.Arrow +import Control.Applicative +import Distribution.Helper +import GhcMod.CabalHelper +import GhcMod.PathsAndFiles +import GhcMod.Error +import Test.Hspec +import System.Directory +import System.FilePath +import System.Process +import Prelude + +import Dir +import TestUtils +import Data.List + +import Config (cProjectVersionInt) + +ghcVersion :: Int +ghcVersion = read cProjectVersionInt + +gmeProcessException :: GhcModError -> Bool +gmeProcessException GMEProcess {} = True +gmeProcessException _ = False + +pkgOptions :: [String] -> [String] +pkgOptions [] = [] +pkgOptions (_:[]) = [] +pkgOptions (x:y:xs) | x == "-package-id" = [name y] ++ pkgOptions xs + | otherwise = pkgOptions (y:xs) + where + stripDash s = maybe s id $ (flip drop s . (+1) <$> findIndex (=='-') s) +#if __GLASGOW_HASKELL__ >= 800 + name s = reverse $ stripDash $ reverse s +#else + name s = reverse $ stripDash $ stripDash $ reverse s +#endif + +idirOpts :: [(c, [String])] -> [(c, [String])] +idirOpts = map (second $ map (drop 2) . filter ("-i"`isPrefixOf`)) + +spec :: Spec +spec = do + describe "getComponents" $ do + it "throws an exception if the cabal file is broken" $ do + let tdir = "test/data/broken-cabal" + runD' tdir getComponents `shouldThrow` anyIOException + + it "handles sandboxes correctly" $ do + let tdir = "test/data/cabal-project" + cwd <- getCurrentDirectory + + -- TODO: ChSetupHsName should also have sandbox stuff, see related + -- comment in cabal-helper + opts <- map gmcGhcOpts . filter ((/= ChSetupHsName) . gmcName) <$> runD' tdir getComponents + + bp <- buildPlatform readProcess + if ghcVersion < 706 + then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp]) + else forM_ opts (\o -> o `shouldContain` ["-no-user-package-db","-package-db",cwd "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp]) + +#if !MIN_VERSION_ghc(7,8,0) + it "handles stack project" $ do + let tdir = "test/data/stack-project" + [ghcOpts] <- map gmcGhcOpts . filter ((==ChExeName "new-template-exe") . gmcName) <$> runD' tdir getComponents + let pkgs = pkgOptions ghcOpts + sort pkgs `shouldBe` ["base", "bytestring"] +#endif + + it "extracts build dependencies" $ do + let tdir = "test/data/cabal-project" + opts <- map gmcGhcOpts <$> runD' tdir getComponents + let ghcOpts:_ = opts + pkgs = pkgOptions ghcOpts + pkgs `shouldBe` ["Cabal","base","template-haskell"] + + it "uses non default flags and preserves them across reconfigures" $ do + let tdir = "test/data/cabal-flags" + _ <- withDirectory_ tdir $ + readProcess "cabal" ["configure", "-ftest-flag"] "" + + let test = do + opts <- map gmcGhcOpts <$> runD' tdir getComponents + let ghcOpts = head opts + pkgs = pkgOptions ghcOpts + pkgs `shouldBe` ["Cabal","base"] + + test + + touch $ tdir "cabal-flags.cabal" + + test + +touch :: FilePath -> IO () +touch fn = do + f <- readFile fn + writeFile (fn <.> "tmp") f + renameFile (fn <.> "tmp") fn diff --git a/test/CaseSplitSpec.hs b/test/CaseSplitSpec.hs new file mode 100644 --- /dev/null +++ b/test/CaseSplitSpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP #-} +module CaseSplitSpec where + +import GhcMod +import Test.Hspec +import TestUtils +import Dir + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + describe "case split" $ do +#if __GLASGOW_HASKELL__ >= 708 + it "does not blow up on HsWithBndrs panic" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect.hs" 24 10 + res `shouldBe` "24 1 24 30"++ + " \"mlAppend Nil y = _mlAppend_body\NUL"++ + "mlAppend (Cons x1 x2) y = _mlAppend_body\"\n" + + it "works with case expressions" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect.hs" 28 20 + res `shouldBe` "28 19 28 39"++ + " \"Nil -> _mlAppend_body\NUL"++ + " (Cons x'1 x'2) -> _mlAppend_body\"\n" + + it "works with where clauses" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect.hs" 34 17 + res `shouldBe` "34 5 34 43"++ + " \"mlReverse' Nil accum = _mlReverse_body\NUL"++ + " mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n" + + it "works with let bindings" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect.hs" 38 33 + res `shouldBe` "38 21 38 59"++ + " \"mlReverse' Nil accum = _mlReverse_body\NUL"++ + " mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n" +#else + it "does not blow up on HsWithBndrs panic" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect706.hs" 24 10 + res `shouldBe` "24 1 24 25"++ + " \"mlAppend Nil y = undefined\NUL"++ + "mlAppend (Cons x1 x2) y = undefined\"\n" + + it "works with case expressions" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect706.hs" 28 20 + res `shouldBe` "28 19 28 34"++ + " \"Nil -> undefined\NUL"++ + " (Cons x'1 x'2) -> undefined\"\n" + + it "works with where clauses" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect706.hs" 34 17 + res `shouldBe` "34 5 34 37"++ + " \"mlReverse' Nil accum = undefined\NUL"++ + " mlReverse' (Cons xs'1 xs'2) accum = undefined\"\n" + + it "works with let bindings" $ do + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Vect706.hs" 38 33 + res `shouldBe` "38 21 38 53"++ + " \"mlReverse' Nil accum = undefined\NUL"++ + " mlReverse' (Cons xs'1 xs'2) accum = undefined\"\n" + +#endif + it "doesn't crash when source doesn't make sense" $ + withDirectory_ "test/data/case-split" $ do + res <- runD $ splits "Crash.hs" 4 6 +#if __GLASGOW_HASKELL__ < 710 + res `shouldBe` "4 1 4 19 \"test x = undefined\"\n" +#else + res `shouldBe` "" +#endif diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} module CheckSpec where -import Data.List (isSuffixOf, isInfixOf, isPrefixOf) -import Language.Haskell.GhcMod -import System.FilePath +import GhcMod + +import Data.List +import System.Process import Test.Hspec import TestUtils @@ -14,38 +15,66 @@ describe "checkSyntax" $ do it "works even if an executable depends on the library defined in the same cabal file" $ do withDirectory_ "test/data/ghc-mod-check" $ do - res <- runID $ checkSyntax ["main.hs"] + res <- runD $ checkSyntax ["main.hs"] res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n" + it "works even if a module imports another module from a different directory" $ do withDirectory_ "test/data/check-test-subdir" $ do - res <- runID $ checkSyntax ["test/Bar/Baz.hs"] + _ <- system "cabal configure --enable-tests" + res <- runD $ checkSyntax ["test/Bar/Baz.hs"] res `shouldSatisfy` (("test" "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`) it "detects cyclic imports" $ do - withDirectory_ "test/data" $ do - res <- runID $ checkSyntax ["Mutual1.hs"] + withDirectory_ "test/data/import-cycle" $ do + res <- runD $ checkSyntax ["Mutual1.hs"] res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`) it "works with modules using QuasiQuotes" $ do - withDirectory_ "test/data" $ do - res <- runID $ checkSyntax ["Baz.hs"] - res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`) + withDirectory_ "test/data/quasi-quotes" $ do + res <- runD $ checkSyntax ["QuasiQuotes.hs"] + res `shouldSatisfy` ("QuasiQuotes.hs:6:1:Warning:" `isInfixOf`) #if __GLASGOW_HASKELL__ >= 708 it "works with modules using PatternSynonyms" $ do withDirectory_ "test/data/pattern-synonyms" $ do - res <- runID $ checkSyntax ["B.hs"] + res <- runD $ checkSyntax ["B.hs"] res `shouldSatisfy` ("B.hs:6:9:Warning:" `isPrefixOf`) #endif it "works with foreign exports" $ do - withDirectory_ "test/data" $ do - res <- runID $ checkSyntax ["ForeignExport.hs"] + withDirectory_ "test/data/foreign-export" $ do + res <- runD $ checkSyntax ["ForeignExport.hs"] res `shouldBe` "" context "when no errors are found" $ do it "doesn't output an empty line" $ do - withDirectory_ "test/data/ghc-mod-check/Data" $ do - res <- runID $ checkSyntax ["Foo.hs"] + withDirectory_ "test/data/ghc-mod-check/lib/Data" $ do + res <- runD $ checkSyntax ["Foo.hs"] res `shouldBe` "" + +#if __GLASGOW_HASKELL__ >= 708 +-- See https://github.com/kazu-yamamoto/ghc-mod/issues/507 + it "emits warnings generated in GHC's desugar stage" $ do + withDirectory_ "test/data/check-missing-warnings" $ do + res <- runD $ checkSyntax ["DesugarWarnings.hs"] + res `shouldSatisfy` ("DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched:" `isPrefixOf`) +#endif + + it "works with cabal builtin preprocessors" $ do + withDirectory_ "test/data/cabal-preprocessors" $ do + _ <- system "cabal clean" + _ <- system "cabal build" + res <- runD $ checkSyntax ["Main.hs"] + res `shouldBe` "Preprocessed.hsc:3:1:Warning: Top-level binding with no type signature: warning :: ()\n" + + it "Uses the right qualification style" $ do + withDirectory_ "test/data/nice-qualification" $ do + res <- runD $ checkSyntax ["NiceQualification.hs"] +#if __GLASGOW_HASKELL__ >= 800 + res `shouldBe` "NiceQualification.hs:4:8:\8226 Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NUL\8226 In the expression: \"wrong type\"\NUL In an equation for \8216main\8217: main = \"wrong type\"\n" +#elif __GLASGOW_HASKELL__ >= 708 + res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NULIn the expression: \"wrong type\"\NULIn an equation for \8216main\8217: main = \"wrong type\"\n" +#else + res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type `IO ()' with actual type `[Char]'\NULIn the expression: \"wrong type\"\NULIn an equation for `main': main = \"wrong type\"\n" +#endif diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs new file mode 100644 --- /dev/null +++ b/test/CradleSpec.hs @@ -0,0 +1,67 @@ +module CradleSpec where + +import Control.Applicative +import Data.List (isSuffixOf) +import GhcMod.Cradle +import GhcMod.Types +import System.Directory (canonicalizePath) +import System.FilePath (pathSeparator) +import Test.Hspec +import TestUtils +import Prelude + +import Dir + +clean_ :: IO Cradle -> IO Cradle +clean_ f = do + crdl <- f + cleanupCradle crdl + return crdl + +relativeCradle :: FilePath -> Cradle -> Cradle +relativeCradle dir crdl = crdl { + cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir crdl + , cradleRootDir = toRelativeDir dir $ cradleRootDir crdl + , cradleCabalFile = toRelativeDir dir <$> cradleCabalFile crdl + } + +-- Work around GHC 7.2.2 where `canonicalizePath "/"` returns "/.". +stripLastDot :: FilePath -> FilePath +stripLastDot path + | (pathSeparator:'.':"") `isSuffixOf` path = init path + | otherwise = path + +spec :: Spec +spec = do + describe "findCradle" $ do + it "returns the current directory" $ do + withDirectory_ "/" $ do + curDir <- stripLastDot <$> canonicalizePath "/" + res <- clean_ $ runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions + cradleCurrentDir res `shouldBe` curDir + cradleRootDir res `shouldBe` curDir + cradleCabalFile res `shouldBe` Nothing + + it "finds a cabal file and a sandbox" $ do + withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do + res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions) + + cradleCurrentDir res `shouldBe` + "test/data/cabal-project/subdir1/subdir2" + + cradleRootDir res `shouldBe` "test/data/cabal-project" + + cradleCabalFile res `shouldBe` + Just ("test/data/cabal-project/cabalapi.cabal") + + it "works even if a sandbox config file is broken" $ do + withDirectory "test/data/broken-sandbox" $ \dir -> do + res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions) + cradleCurrentDir res `shouldBe` + "test" "data" "broken-sandbox" + + cradleRootDir res `shouldBe` + "test" "data" "broken-sandbox" + + cradleCabalFile res `shouldBe` + Just ("test" "data" "broken-sandbox" "dummy.cabal") diff --git a/test/CustomPackageDbSpec.hs b/test/CustomPackageDbSpec.hs new file mode 100644 --- /dev/null +++ b/test/CustomPackageDbSpec.hs @@ -0,0 +1,35 @@ +module CustomPackageDbSpec where + +import GhcMod.CabalHelper +import GhcMod.CustomPackageDb +import GhcMod.Error +import System.Process +import Test.Hspec +import Prelude + +import Dir +import TestUtils + +spec :: Spec +spec = do + describe "getCustomPkgDbStack" $ do + it "works" $ do + let tdir = "test/data/custom-cradle" + Just stack <- runD' tdir $ getCustomPkgDbStack + stack `shouldBe` [ GlobalDb + , UserDb + , PackageDb "package-db-a" + , PackageDb "package-db-b" + , PackageDb "package-db-c" + ] + + describe "getPackageDbStack'" $ do + it "fixes out of sync custom pkg-db stack" $ do + withDirectory_ "test/data/custom-cradle" $ do + _ <- system "cabal configure" + (s, s') <- runD $ do + Just stack <- getCustomPkgDbStack + withCabal $ do + stack' <- getCabalPackageDbStack + return (stack, stack') + s' `shouldBe` s diff --git a/test/Dir.hs b/test/Dir.hs --- a/test/Dir.hs +++ b/test/Dir.hs @@ -1,9 +1,15 @@ -module Dir where +module Dir ( + module Dir + , getCurrentDirectory + , () + ) where import Control.Exception as E import Data.List (isPrefixOf) import System.Directory -import System.FilePath (addTrailingPathSeparator) +import System.FilePath (addTrailingPathSeparator,()) + + withDirectory_ :: FilePath -> IO a -> IO a withDirectory_ dir action = bracket getCurrentDirectory diff --git a/test/FileMappingSpec.hs b/test/FileMappingSpec.hs new file mode 100644 --- /dev/null +++ b/test/FileMappingSpec.hs @@ -0,0 +1,259 @@ +module FileMappingSpec where + +import GhcMod.FileMapping +import GhcMod.Utils (withMappedFile) +import Test.Hspec +import TestUtils +import qualified Data.Map as M +import Dir +import System.IO.Temp +import System.Directory + +import GhcMod + +spec :: Spec +spec = do + describe "loadMappedFile" $ do + it "inserts a given FilePath FileMapping into state with canonicalized path" $ do + withDirectory_ "test/data/file-mapping" $ do + mappedFiles <- runD $ do + loadMappedFile "File.hs" "File.hs" + getMMappedFiles + dir <- getCurrentDirectory + show mappedFiles `shouldBe` show (M.fromList [(dir "File.hs", FileMapping "File.hs" False)]) + it "should try to guess a canonical name if file doesn't exist" $ do + withDirectory_ "test/data/file-mapping" $ do + mappedFiles <- runD $ do + loadMappedFile "NonExistantFile.hs" "File.hs" + getMMappedFiles + dir <- getCurrentDirectory + show mappedFiles `shouldBe` show (M.fromList [(dir "NonExistantFile.hs", FileMapping "File.hs" False)]) + + describe "loadMappedFileSource" $ do + it "inserts a given FilePath FileMapping into state with canonicalized path" $ do + withDirectory_ "test/data/file-mapping" $ do + mappedFiles <- runD $ do + loadMappedFileSource "File.hs" "main :: IO ()" + getMMappedFiles + dir <- getCurrentDirectory + -- TODO + M.toList mappedFiles `shouldSatisfy` \[(fn, FileMapping _to True)] -> + fn == dir "File.hs" + it "should try to guess a canonical name if file doesn't exist" $ do + withDirectory_ "test/data/file-mapping" $ do + mappedFiles <- runD $ do + loadMappedFileSource "NonExistantFile.hs" "main :: IO ()" + getMMappedFiles + dir <- getCurrentDirectory + -- TODO + M.toList mappedFiles `shouldSatisfy` \[(fn, FileMapping _to True)] -> + fn == dir "NonExistantFile.hs" + + describe "unloadMappedFile" $ do + it "removes a given FilePath from state" $ do + withDirectory_ "test/data/file-mapping" $ do + mappedFiles <- runD $ do + loadMappedFile "File.hs" "File2.hs" + unloadMappedFile "File.hs" + getMMappedFiles + show mappedFiles `shouldBe` show (M.fromList ([] :: [(FilePath, FileMapping)])) + it "should work even if file does not exist" $ do + withDirectory_ "test/data/file-mapping" $ do + mappedFiles <- runD $ do + loadMappedFile "NonExistantFile.hs" "File2.hs" + unloadMappedFile "NonExistantFile.hs" + getMMappedFiles + show mappedFiles `shouldBe` show (M.fromList ([] :: [(FilePath, FileMapping)])) + it "should remove created temporary files" $ do + withDirectory_ "test/data/file-mapping" $ do + dir <- getCurrentDirectory + fileExists <- runD $ do + loadMappedFileSource "NonExistantFile.hs" "main :: IO ()" + fp <- maybe undefined fmPath `fmap` lookupMMappedFile (dir "NonExistantFile.hs") + unloadMappedFile "NonExistantFile.hs" + liftIO $ doesFileExist fp + not fileExists `shouldBe` True + + describe "withMappedFile" $ do + it "checks if there is a redirected file and calls and action with its FilePath" $ do + withDirectory_ "test/data/file-mapping" $ do + res <- runD $ do + loadMappedFile "File.hs" "File_Redir.hs" + withMappedFile "File.hs" return + res `shouldBe` "File_Redir.hs" + it "checks if there is an in-memory file and calls and action with temporary file" $ do + withDirectory_ "test/data/file-mapping" $ do + (fn, src) <- runD $ do + loadMappedFileSource "File.hs" "main = test" + withMappedFile "File.hs" $ \fn -> do + src <- liftIO $ readFile fn + return (fn, src) + fn `shouldSatisfy` (/="File.hs") + src `shouldBe` "main = test" + it "runs action with original filename if there is no mapping" $ do + withDirectory_ "test/data/file-mapping" $ do + fn <- runD $ do + withMappedFile "File.hs" return + fn `shouldBe` "File.hs" + + describe "integration tests" $ do + it "checks redirected file if one is specified and outputs original filename" $ do + withDirectory_ "test/data/file-mapping" $ do + let fm = [("File.hs", "File_Redir.hs")] + res <- run defaultOptions $ do + mapM_ (uncurry loadMappedFile) fm + checkSyntax ["File.hs"] + res `shouldBe` "File.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n" + it "checks in-memory file if one is specified and outputs original filename" $ do + withDirectory_ "test/data/file-mapping" $ do + let fm = [("File.hs", "main = putStrLn \"Hello World!\"\n")] + res <- run defaultOptions $ do + mapM_ (uncurry loadMappedFileSource) fm + checkSyntax ["File.hs"] + res `shouldBe` "File.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n" + it "should work even if file doesn't exist" $ do + withDirectory_ "test/data/file-mapping" $ do + let fm = [("Nonexistent.hs", "main = putStrLn \"Hello World!\"\n")] + res <- run defaultOptions $ do + mapM_ (uncurry loadMappedFileSource) fm + checkSyntax ["Nonexistent.hs"] + res `shouldBe` "Nonexistent.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n" + it "lints redirected file if one is specified and outputs original filename" $ do + withDirectory_ "test/data/file-mapping" $ do + res <- runD $ do + loadMappedFile "File.hs" "File_Redir_Lint.hs" + lint lintOpts "File.hs" + res `shouldBe` "File.hs:4:1: Warning: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" + it "lints in-memory file if one is specified and outputs original filename" $ do + withDirectory_ "test/data/file-mapping" $ do + res <- runD $ do + loadMappedFileSource "File.hs" "func a b = (++) a b\n" + lint lintOpts "File.hs" + res `shouldBe` "File.hs:1:1: Warning: Eta reduce\NULFound:\NUL func a b = (++) a b\NULWhy not:\NUL func = (++)\n" + it "shows types of the expression for redirected files" $ do + let tdir = "test/data/file-mapping" + res <- runD' tdir $ do + loadMappedFile "File.hs" "File_Redir_Lint.hs" + types False "File.hs" 4 12 + res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"a -> a -> a\"\n" + it "shows types of the expression with constraints for redirected files" $ do -- + let tdir = "test/data/file-mapping" + res <- runD' tdir $ do + loadMappedFile "File.hs" "File_Redir_Lint.hs" + types True "File.hs" 4 12 + res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"Num a => a -> a -> a\"\n" + it "shows types of the expression for in-memory files" $ do + let tdir = "test/data/file-mapping" + res <- runD' tdir $ do + loadMappedFileSource "File.hs" "main = putStrLn \"Hello!\"" + types False "File.hs" 1 14 + res `shouldBe` "1 8 1 16 \"String -> IO ()\"\n1 8 1 25 \"IO ()\"\n1 1 1 25 \"IO ()\"\n" + it "shows info for the expression for redirected files" $ do + let tdir = "test/data/file-mapping" + res <- runD' tdir $ do + loadMappedFile "File.hs" "File_Redir_Lint.hs" + info "File.hs" $ Expression "func" + res `shouldBe` "func :: Num a => a -> a -> a \t-- Defined at File.hs:4:1\n" + it "shows info for the expression for in-memory files" $ do + let tdir = "test/data/file-mapping" + res <- runD' tdir $ do + loadMappedFileSource "File.hs" "module File where\n\ntestfun = putStrLn \"Hello!\"" + info "File.hs" $ Expression "testfun" + res `shouldBe` "testfun :: IO () \t-- Defined at File.hs:3:1\n" + + describe "preprocessor tests" $ do + it "checks redirected file if one is specified and outputs original filename" $ do + withDirectory_ "test/data/file-mapping/preprocessor" $ do + let fm = [("File.hs", "File_Redir.hs")] + res <- run defaultOptions $ do + mapM_ (uncurry loadMappedFile) fm + checkSyntax ["File.hs"] + res `shouldBe` "File.hs:3:1:Warning: Top-level binding with no type signature: main :: IO ()\n" + it "works with full path as well" $ do + withDirectory_ "test/data/file-mapping/preprocessor" $ do + cwd <- getCurrentDirectory + let fm = [("File.hs", cwd "File_Redir.hs")] + res <- run defaultOptions $ do + mapM_ (uncurry loadMappedFile) fm + checkSyntax ["File.hs"] + res `shouldBe` "File.hs:3:1:Warning: Top-level binding with no type signature: main :: IO ()\n" + it "checks in-memory file" $ do + withDirectory_ "test/data/file-mapping/preprocessor" $ do + src <- readFile "File_Redir.hs" + let fm = [("File.hs", src)] + res <- run defaultOptions $ do + mapM_ (uncurry loadMappedFileSource) fm + checkSyntax ["File.hs"] + res `shouldBe` "File.hs:3:1:Warning: Top-level binding with no type signature: main :: IO ()\n" + it "lints redirected file if one is specified and outputs original filename" $ do + withDirectory_ "test/data/file-mapping/preprocessor" $ do + res <- runD $ do + loadMappedFile "File.hs" "File_Redir_Lint.hs" + lint lintOpts "File.hs" + res `shouldBe` "File.hs:6:1: Warning: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" + it "lints in-memory file if one is specified and outputs original filename" $ do + withDirectory_ "test/data/file-mapping/preprocessor" $ do + src <- readFile "File_Redir_Lint.hs" + res <- runD $ do + loadMappedFileSource "File.hs" src + lint lintOpts "File.hs" + res `shouldBe` "File.hs:6:1: Warning: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" + describe "literate haskell tests" $ do + it "checks redirected file if one is specified and outputs original filename" $ do + withDirectory_ "test/data/file-mapping/lhs" $ do + let fm = [("File.lhs", "File_Redir.lhs")] + res <- run defaultOptions $ do + mapM_ (uncurry loadMappedFile) fm + checkSyntax ["File.lhs"] + res `shouldBe` "File.lhs:1:3:Warning: Top-level binding with no type signature: main :: IO ()\n" + it "checks in-memory file if one is specified and outputs original filename" $ do + withDirectory_ "test/data/file-mapping/lhs" $ do + src <- readFile "File_Redir.lhs" + let fm = [("File.lhs", src)] + res <- run defaultOptions $ do + mapM_ (uncurry loadMappedFileSource) fm + checkSyntax ["File.lhs"] + res `shouldBe` "File.lhs:1:3:Warning: Top-level binding with no type signature: main :: IO ()\n" + -- NOTE: There is a bug in hlint that prevents it from linting lhs files. + -- it "lints redirected file if one is specified and outputs original filename" $ do + -- withDirectory_ "test/data/file-mapping/lhs" $ do + -- res <- runD $ do + -- loadMappedFile "File.lhs" (RedirectedMapping "File_Redir_Lint.lhs") + -- lint "File.lhs" + -- res `shouldBe` "File.lhs:6:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" + -- it "lints in-memory file if one is specified and outputs original filename" $ do + -- withDirectory_ "test/data/file-mapping/lhs" $ do + -- src <- readFile "File_Redir_Lint.lhs" + -- res <- runD $ do + -- loadMappedFile "File.lhs" (MemoryMapping $ Just src) + -- lint "File.lhs" + -- res `shouldBe` "File.lhs:6:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n" + describe "template haskell" $ do + it "works with a redirected module using TemplateHaskell" $ do + withSystemTempDirectory "ghc-mod-test" $ \tmpdir -> do + srcFoo <- readFile "test/data/template-haskell/Foo.hs" + srcBar <- readFile "test/data/template-haskell/Bar.hs" + withDirectory_ "test/data/file-mapping" $ do + writeFile (tmpdir "Foo_Redir.hs") srcFoo + writeFile (tmpdir "Bar_Redir.hs") srcBar + let fm = [("Foo.hs", tmpdir "Foo_Redir.hs") + ,("Bar.hs", tmpdir "Bar_Redir.hs")] + res <- run defaultOptions $ do + mapM_ (uncurry loadMappedFile) fm + types False "Bar.hs" 5 1 + res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] + it "works with a memory module using TemplateHaskell" $ do + srcFoo <- readFile "test/data/template-haskell/Foo.hs" + srcBar <- readFile "test/data/template-haskell/Bar.hs" + withDirectory_ "test/data/file-mapping" $ do + let fm = [("Foo.hs", srcFoo) + ,("Bar.hs", srcBar)] + res <- run defaultOptions $ do + mapM_ (uncurry loadMappedFileSource) fm + types False "Bar.hs" 5 1 + res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] + + +lintOpts :: LintOpts +lintOpts = + defaultLintOpts { optLintHlintOpts = ["--ignore=Use module export list"] } diff --git a/test/FindSpec.hs b/test/FindSpec.hs new file mode 100644 --- /dev/null +++ b/test/FindSpec.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} +module FindSpec where + +import GhcMod.Exe.Find +import Test.Hspec +import TestUtils + +spec :: Spec +spec = do + describe "db <- loadSymbolDb" $ do + it "lookupSymbol' db \"head\" contains at least `Data.List'" $ do + db <- runD $ loadSymbolDb + lookupSym "head" db `shouldContain` [ModuleString "Data.List"] diff --git a/test/FlagSpec.hs b/test/FlagSpec.hs --- a/test/FlagSpec.hs +++ b/test/FlagSpec.hs @@ -1,13 +1,14 @@ module FlagSpec where import Control.Applicative -import Language.Haskell.GhcMod +import GhcMod import Test.Hspec import TestUtils +import Prelude spec :: Spec spec = do describe "flags" $ do - it "contains at least `-fno-warn-orphans'" $ do + it "contains at least `-fprint-explicit-foralls" $ do f <- runD $ lines <$> flags - f `shouldContain` ["-fno-warn-orphans"] + f `shouldContain` ["-fprint-explicit-foralls"] diff --git a/test/GhcPkgSpec.hs b/test/GhcPkgSpec.hs --- a/test/GhcPkgSpec.hs +++ b/test/GhcPkgSpec.hs @@ -1,29 +1,23 @@ -{-# LANGUAGE CPP #-} module GhcPkgSpec where -import Language.Haskell.GhcMod.GhcPkg -#if __GLASGOW_HASKELL__ <= 706 -import Language.Haskell.GhcMod.Types -#endif - -import System.Directory -import System.FilePath (()) +import GhcMod.GhcPkg +import GhcMod.CabalHelper +import GhcMod.CustomPackageDb import Test.Hspec +import System.Process (system) +import Dir +import TestUtils + spec :: Spec spec = do - describe "getSandboxDb" $ do --- ghc < 7.8 -#if __GLASGOW_HASKELL__ <= 706 - it "does include a sandbox with ghc < 7.8" $ do - cwd <- getCurrentDirectory - getPackageDbStack "test/data/" `shouldReturn` [GlobalDb, PackageDb $ cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"] -#endif - - it "can parse a config file and extract the sandbox package-db" $ do - cwd <- getCurrentDirectory - pkgDb <- getSandboxDb "test/data/" - pkgDb `shouldBe` (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") - - it "throws an error if the sandbox config file is broken" $ do - getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException + describe "getPackageDbStack'" $ do + it "fixes out of sync custom pkg-db stack" $ do + withDirectory_ "test/data/custom-cradle" $ do + _ <- system "cabal configure" + (s, s') <- runD $ do + Just stack <- getCustomPkgDbStack + withCabal $ do + stack' <- getPackageDbStack + return (stack, stack') + s' `shouldBe` s diff --git a/test/HomeModuleGraphSpec.hs b/test/HomeModuleGraphSpec.hs new file mode 100644 --- /dev/null +++ b/test/HomeModuleGraphSpec.hs @@ -0,0 +1,178 @@ +-- ghc-mod: Happy Haskell Hacking +-- Copyright (C) 2015 Daniel Gröber +-- +-- 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 . + +{-# LANGUAGE OverloadedStrings #-} + +module HomeModuleGraphSpec where + +import GhcMod.HomeModuleGraph +import GhcMod.LightGhc +import TestUtils + +import GHC +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Maybe + +import Test.Hspec + +runAGhc :: [GHCOption] -> (HscEnv -> LightGhc a) -> IO a +runAGhc opts action = withLightHscEnv opts $ \env -> do + runLightGhc env $ getSession >>= action + +hmGraph :: FilePath -> [String] -> String -> IO GmModuleGraph +hmGraph dir opts mn = runAGhc opts $ \env -> liftIO $ do + runD' dir $ do + smp <- liftIO $ findModulePathSet env [mkModuleName mn] + homeModuleGraph env smp + +uhmGraph :: FilePath -> [String] -> String -> String -> GmModuleGraph -> IO GmModuleGraph +uhmGraph dir opts mn umn g = runAGhc opts $ \env -> liftIO $ do + runD' dir $ do + smp <- liftIO $ findModulePathSet env [mkModuleName mn] + usmp <- liftIO $ findModulePathSet env [mkModuleName umn] + updateHomeModuleGraph env g smp usmp + +mapMap :: (Ord k, Ord k') + => (k -> k') -> (a -> a') -> Map.Map k a -> Map.Map k' a' +mapMap fk fa = Map.mapKeys fk . Map.map fa + +mapMpFn :: (FilePath -> FilePath) -> ModulePath -> ModulePath +mapMpFn f (ModulePath mn fn) = ModulePath mn (f fn) + +mp :: ModuleName -> ModulePath +mp mn = ModulePath mn $ moduleNameString mn ++ ".hs" + +spec :: Spec +spec = do + describe "reachable" $ do + let + smp = + Set.fromList + [ mp "A" + , mp "B" + , mp "C" + , mp "D" + , mp "E" + , mp "F" + , mp "G" + , mp "H" + , mp "I" + ] + + moduleMap = mkModuleMap smp + + completeGraph = + Map.map (Set.map lookupMM) . Map.mapKeys lookupMM + + lookupMM = fromJust . flip Map.lookup moduleMap + + graph = completeGraph $ + Map.fromList + [ ("A", Set.fromList ["B"]) + , ("B", Set.fromList ["C", "D"]) + , ("C", Set.fromList ["F"]) + , ("D", Set.fromList ["E"]) + , ("E", Set.fromList []) + , ("F", Set.fromList []) + , ("G", Set.fromList []) + , ("H", Set.fromList []) + , ("I", Set.fromList []) + ] + + really_reachable = + Set.fromList + [ mp "A" + , mp "B" + , mp "C" + , mp "D" + , mp "E" + , mp "F" + ] + + g = GmModuleGraph { + gmgGraph = graph + } + + it "reachable Set.empty g == Set.empty" $ do + reachable Set.empty g `shouldBe` Set.empty + + it "lists only reachable nodes" $ do + reachable (Set.fromList [mp "A"]) g `shouldBe` really_reachable + + + describe "homeModuleGraph" $ do + it "cycles don't break it" $ do + let tdir = "test/data/home-module-graph/cycle" + g <- hmGraph tdir [] "A" + gmgGraph g `shouldBe` + Map.fromList + [ (mp "A", Set.fromList [mp "B"]) + , (mp "B", Set.fromList [mp "A"]) + ] + + it "follows imports" $ do + let tdir = "test/data/home-module-graph/indirect" + g <- hmGraph tdir [] "A" + gmgGraph g `shouldBe` + Map.fromList + [ (mp "A", Set.fromList [mp "A1", mp "A2", mp "A3"]) + , (mp "A1", Set.fromList [mp "B"]) + , (mp "A2", Set.fromList [mp "C"]) + , (mp "A3", Set.fromList [mp "B"]) + , (mp "B", Set.fromList []) + , (mp "C", Set.fromList []) + ] + + it "returns partial results on parse errors" $ do + let tdir = "test/data/home-module-graph/errors" + g <- hmGraph tdir [] "A" + gmgGraph g `shouldBe` + Map.fromList + [ (mp "A", Set.fromList [mp "A1", mp "A2", mp "A3"]) + , (mp "A1", Set.fromList []) -- parse error here + , (mp "A2", Set.fromList []) + , (mp "A3", Set.fromList [mp "B"]) + , (mp "B", Set.fromList []) + ] + + it "returns partial results on CPP errors" $ do + let tdir = "test/data/home-module-graph/cpp" + g <- hmGraph tdir [] "A" + gmgGraph g `shouldBe` + Map.fromList + [ (mp "A", Set.fromList [mp "A1", mp "A2", mp "A3"]) + , (mp "A1", Set.fromList []) -- CPP error here + , (mp "A2", Set.fromList []) + , (mp "A3", Set.fromList [mp "B"]) + , (mp "B", Set.fromList []) + ] + + describe "updateHomeModuleGraph" $ do + it "removes unreachable nodes" $ do + let tdir = "test/data/home-module-graph/indirect" + let tdir' = "test/data/home-module-graph/indirect-update" + ig <- hmGraph tdir [] "A" + g <- uhmGraph tdir' [] "A" "A2" ig + gmgGraph g `shouldBe` + Map.fromList + [ (mp "A", Set.fromList [mp "A1", mp "A2", mp "A3"]) + , (mp "A1", Set.fromList [mp "B"]) + , (mp "A2", Set.fromList []) + , (mp "A3", Set.fromList [mp "B"]) + , (mp "B", Set.fromList []) + -- C was removed + ] diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -1,59 +1,66 @@ {-# LANGUAGE CPP #-} module InfoSpec where -import Control.Applicative ((<$>)) +import Control.Applicative import Data.List (isPrefixOf) -import Language.Haskell.GhcMod +import GhcMod #if __GLASGOW_HASKELL__ < 706 import System.Environment.Executable (getExecutablePath) #else import System.Environment (getExecutablePath) #endif -import System.Exit import System.FilePath -import System.Process import Test.Hspec import TestUtils -import Dir +import Prelude spec :: Spec spec = do describe "types" $ do it "shows types of the expression and its outers" $ do - withDirectory_ "test/data/ghc-mod-check" $ do - res <- runD $ types "Data/Foo.hs" 9 5 - res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" + let tdir = "test/data/ghc-mod-check" + res <- runD' tdir $ types False "lib/Data/Foo.hs" 9 5 +#if __GLASGOW_HASKELL__ >= 800 + res `shouldBe` "9 5 11 40 \"Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n" +#else + res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" +#endif + + it "shows types of the expression with constraints and its outers" $ do + let tdir = "test/data/ghc-mod-check" + res <- runD' tdir $ types True "lib/Data/Foo.hs" 9 5 +#if __GLASGOW_HASKELL__ >= 800 + res `shouldBe` "9 5 11 40 \"Num t => Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n" +#else + res `shouldBe` "9 5 11 40 \"Num a => Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" +#endif + it "works with a module using TemplateHaskell" $ do - withDirectory_ "test/data" $ do - res <- runD $ types "Bar.hs" 5 1 - res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] + let tdir = "test/data/template-haskell" + res <- runD' tdir $ types False "Bar.hs" 5 1 + res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] it "works with a module that imports another module using TemplateHaskell" $ do - withDirectory_ "test/data" $ do - res <- runD $ types "Main.hs" 3 8 - res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""] + let tdir = "test/data/template-haskell" + res <- runD' tdir $ types False "ImportsTH.hs" 3 8 + res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""] describe "info" $ do - it "works for non-export functions" $ do - withDirectory_ "test/data" $ do - res <- runD $ info "Info.hs" "fib" - res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`) + it "works for non exported functions" $ do + let tdir = "test/data/non-exported" + res <- runD' tdir $ info "Fib.hs" $ Expression "fib" + res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`) it "works with a module using TemplateHaskell" $ do - withDirectory_ "test/data" $ do - res <- runD $ info "Bar.hs" "foo" - res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`) + let tdir = "test/data/template-haskell" + res <- runD' tdir $ info "Bar.hs" $ Expression "foo" + res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`) it "works with a module that imports another module using TemplateHaskell" $ do - withDirectory_ "test/data" $ do - res <- runD $ info "Main.hs" "bar" - res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`) - - it "doesn't fail on unicode output" $ do - dir <- getDistDir - code <- rawSystem (dir "build/ghc-mod/ghc-mod") ["info", "test/data/Unicode.hs", "Unicode", "unicode"] - code `shouldSatisfy` (== ExitSuccess) + let tdir = "test/data/template-haskell" + res <- runD' tdir $ info "ImportsTH.hs" $ Expression "bar" + res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`) getDistDir :: IO FilePath getDistDir = takeDirectory . takeDirectory . takeDirectory <$> getExecutablePath diff --git a/test/LangSpec.hs b/test/LangSpec.hs --- a/test/LangSpec.hs +++ b/test/LangSpec.hs @@ -1,9 +1,10 @@ module LangSpec where import Control.Applicative -import Language.Haskell.GhcMod +import GhcMod import Test.Hspec import TestUtils +import Prelude spec :: Spec spec = do diff --git a/test/LintSpec.hs b/test/LintSpec.hs --- a/test/LintSpec.hs +++ b/test/LintSpec.hs @@ -1,6 +1,6 @@ module LintSpec where -import Language.Haskell.GhcMod +import GhcMod import Test.Hspec import TestUtils @@ -8,10 +8,14 @@ spec = do describe "lint" $ do it "can detect a redundant import" $ do - res <- runD $ lint "test/data/hlint.hs" - res `shouldBe` "test/data/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n" + res <- runD $ lint lintOpts "test/data/hlint/hlint.hs" + res `shouldBe` "test/data/hlint/hlint.hs:4:8: Warning: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n" context "when no suggestions are given" $ do it "doesn't output an empty line" $ do - res <- runD $ lint "test/data/ghc-mod-check/Data/Foo.hs" + res <- runD $ lint lintOpts "test/data/ghc-mod-check/lib/Data/Foo.hs" res `shouldBe` "" + +lintOpts :: LintOpts +lintOpts = + defaultLintOpts { optLintHlintOpts = ["--ignore=Use module export list"] } diff --git a/test/ListSpec.hs b/test/ListSpec.hs --- a/test/ListSpec.hs +++ b/test/ListSpec.hs @@ -1,13 +1,14 @@ module ListSpec where import Control.Applicative -import Language.Haskell.GhcMod +import GhcMod import Test.Hspec import TestUtils +import Prelude spec :: Spec spec = do describe "modules" $ do it "contains at least `Data.Map'" $ do - mdls <- runD $ lines <$> modules + mdls <- runD $ lines <$> modules False mdls `shouldContain` ["Data.Map"] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,33 +1,94 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-} -import Spec import Dir import Control.Exception as E import Control.Monad (void) -import Language.Haskell.GhcMod (debugInfo) +import GhcMod (debugInfo) import System.Process +import System.Environment import Test.Hspec import TestUtils +import qualified BrowseSpec +import qualified CabalHelperSpec +import qualified CaseSplitSpec +import qualified CheckSpec +import qualified CradleSpec +import qualified CustomPackageDbSpec +import qualified FileMappingSpec +import qualified FindSpec +import qualified FlagSpec +import qualified GhcPkgSpec +import qualified HomeModuleGraphSpec +import qualified InfoSpec +import qualified LangSpec +import qualified LintSpec +import qualified ListSpec +import qualified MonadSpec +import qualified PathsAndFilesSpec +import qualified ShellParseSpec +import qualified TargetSpec + +spec :: Spec +spec = do + describe "Browse" BrowseSpec.spec + describe "CabalHelper" CabalHelperSpec.spec + describe "CaseSplit" CaseSplitSpec.spec + describe "Check" CheckSpec.spec + describe "Cradle" CradleSpec.spec + describe "CustomPackageDb" CustomPackageDbSpec.spec + describe "FileMapping" FileMappingSpec.spec + describe "Find" FindSpec.spec + describe "Flag" FlagSpec.spec + describe "GhcPkg" GhcPkgSpec.spec + describe "HomeModuleGraph" HomeModuleGraphSpec.spec + describe "Info" InfoSpec.spec + describe "Lang" LangSpec.spec + describe "Lint" LintSpec.spec + describe "List" ListSpec.spec + describe "Monad" MonadSpec.spec + describe "PathsAndFiles" PathsAndFilesSpec.spec + describe "ShellParse" ShellParseSpec.spec + describe "Target" TargetSpec.spec + main :: IO () main = do - let sandboxes = [ "test/data", "test/data/check-packageid" +#if __GLASGOW_HASKELL__ >= 708 + unsetEnv "GHC_PACKAGE_PATH" +#endif + let sandboxes = [ "test/data/cabal-project" + , "test/data/check-packageid" , "test/data/duplicate-pkgver/" , "test/data/broken-cabal/" ] genSandboxCfg dir = withDirectory dir $ \cwdir -> do - system ("sed 's|@CWD@|" ++ cwdir ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config") + system ("rm cabal.sandbox.config; cabal sandbox init") pkgDirs = - [ "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" + [ "test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" , "test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" , "test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"] genGhcPkgCache dir = system $ "ghc-pkg recache --force -f" ++ dir - genSandboxCfg `mapM_` sandboxes - genGhcPkgCache `mapM_` pkgDirs - void $ system "find test -name setup-config -name ghc-mod.cache -exec rm {} \\;" + + let cleanCmd = "git clean -dXf test/data/" + putStrLn $ "$ " ++ cleanCmd + void $ system cleanCmd void $ system "cabal --version" - putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal void $ system "ghc --version" + + genSandboxCfg `mapM_` sandboxes + genGhcPkgCache `mapM_` pkgDirs + + let stackDir = "test/data/stack-project" + void $ withDirectory_ stackDir $ do + let ghcver = let gvn = show (__GLASGOW_HASKELL__ :: Int) + (major, minor') = splitAt (length gvn - 2) gvn + minor = case dropWhile (=='0') minor' of + "" -> "0" + x -> x + in major ++ "." ++ minor + void $ system $ "sed '$ a resolver: ghc-" ++ ghcver ++ "' stack.yaml.in > stack.yaml" + void $ system "stack setup" + void $ system "stack build" (putStrLn =<< runD debugInfo) `E.catch` (\(_ :: E.SomeException) -> return () ) diff --git a/test/MonadSpec.hs b/test/MonadSpec.hs --- a/test/MonadSpec.hs +++ b/test/MonadSpec.hs @@ -1,19 +1,17 @@ -{-# LANGUAGE ScopedTypeVariables #-} module MonadSpec where import Test.Hspec -import Dir import TestUtils -import Control.Applicative -import Control.Exception import Control.Monad.Error.Class +import Control.Concurrent +import Control.Exception spec :: Spec spec = do describe "When using GhcModT in a do block" $ it "a pattern match failure causes a call to `fail` on ErrorT in the monad stack" $ do - (a, _) - <- runGhcModT defaultOptions $ + (a, _h) + <- runGmOutDef $ runGhcModT defaultOptions $ do Just _ <- return Nothing return "hello" @@ -21,19 +19,30 @@ a `shouldBe` (Left $ GMEString "oh noes") describe "runGhcModT" $ - it "complains if the cabal file fails to parse while a sandbox is present" $ withDirectory_ "test/data/broken-cabal" $ do - shouldReturnError $ runD' (gmCradle <$> ask) + it "throws an exception when run in multiple threads" $ do - describe "gmsGet/Put" $ - it "work" $ do - (runD $ gmsPut (GhcModState Intelligent) >> gmsGet) - `shouldReturn` (GhcModState Intelligent) + mv_ex :: MVar (Either SomeException ()) + <- newEmptyMVar + mv_startup_barrier :: MVar () + <- newEmptyMVar - describe "liftIO" $ do - it "converts user errors to GhcModError" $ do - shouldReturnError $ - runD' $ liftIO $ throw (userError "hello") >> return "" + _t1 <- forkOS $ do + -- wait (inside GhcModT) for t2 to receive the exception + _ <- runD $ liftIO $ do + putMVar mv_startup_barrier () + readMVar mv_ex + return () - it "converts a file not found exception to GhcModError" $ do - shouldReturnError $ - runD' $ liftIO $ readFile "/DOES_NOT_EXIST" >> return "" + _t2 <- forkOS $ do + readMVar mv_startup_barrier -- wait for t1 to be in GhcModT + res <- try $ runD $ return () + res' <- evaluate res + putMVar mv_ex res' + + ex <- takeMVar mv_ex + + isLeft ex `shouldBe` True + +isLeft :: Either a b -> Bool +isLeft (Right _) = False +isLeft (Left _) = True diff --git a/test/PathsAndFilesSpec.hs b/test/PathsAndFilesSpec.hs new file mode 100644 --- /dev/null +++ b/test/PathsAndFilesSpec.hs @@ -0,0 +1,48 @@ +module PathsAndFilesSpec where + + +import GhcMod.PathsAndFiles +import GhcMod.Cradle +import qualified GhcMod.Utils as U + +import Control.Monad.Trans.Maybe +import System.Directory +import System.FilePath +import Test.Hspec +import TestUtils + +spec :: Spec +spec = do + describe "getSandboxDb" $ do + it "can parse a config file and extract the sandbox package-db" $ do + cwd <- getCurrentDirectory + Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/cabal-project" + Just db <- getSandboxDb crdl + db `shouldSatisfy` isPkgDbAt (cwd "test/data/cabal-project/.cabal-sandbox") + + it "returns Nothing if the sandbox config file is broken" $ do + Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/broken-sandbox" + getSandboxDb crdl `shouldReturn` Nothing + + describe "findCabalFile" $ do + it "works" $ do + p <- U.makeAbsolute' "test/data/cabal-project/cabalapi.cabal" + findCabalFile "test/data/cabal-project" `shouldReturn` Just p + + it "finds cabal files in parent directories" $ do + p <- U.makeAbsolute' "test/data/cabal-project/cabalapi.cabal" + findCabalFile "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just p + + describe "findStackConfigFile" $ do + it "works" $ do + p <- U.makeAbsolute' "test/data/stack-project/stack.yaml" + findStackConfigFile "test/data/stack-project" `shouldReturn` Just p + + describe "findCabalSandboxDir" $ do + it "works" $ do + p <- U.makeAbsolute' "test/data/cabal-project" + findCabalSandboxDir "test/data/cabal-project" `shouldReturn` Just p + + it "finds sandboxes in parent directories" $ do + p <- U.makeAbsolute' "test/data/cabal-project" + findCabalSandboxDir "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just p diff --git a/test/ShellParseSpec.hs b/test/ShellParseSpec.hs new file mode 100644 --- /dev/null +++ b/test/ShellParseSpec.hs @@ -0,0 +1,34 @@ +module ShellParseSpec where + + +import GhcMod.Exe.Options.ShellParse + +import Test.Hspec + +spec :: Spec +spec = + describe "parseCmdLine" $ do + it "splits arguments" $ do + parseCmdLine "test command line" `shouldBe` ["test", "command", "line"] + parseCmdLine "ascii-escape test command line" `shouldBe` ["test", "command", "line"] + it "honors quoted segments if turned on" $ + parseCmdLine "ascii-escape test command line \STXwith quoted segment\ETX" + `shouldBe` ["test", "command", "line", "with quoted segment"] + it "doesn't honor quoted segments if turned off" $ + parseCmdLine "test command line \STXwith quoted segment\ETX" + `shouldBe` words "test command line \STXwith quoted segment\ETX" + it "squashes multiple spaces" $ do + parseCmdLine "test command" + `shouldBe` ["test", "command"] + parseCmdLine "ascii-escape test command" + `shouldBe` ["test", "command"] + it "ingores leading spaces" $ do + parseCmdLine " test command" + `shouldBe` ["test", "command"] + parseCmdLine " ascii-escape test command" + `shouldBe` ["test", "command"] + it "parses empty string as no argument" $ do + parseCmdLine "" + `shouldBe` [""] + parseCmdLine "ascii-escape " + `shouldBe` [""] diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/test/TargetSpec.hs b/test/TargetSpec.hs new file mode 100644 --- /dev/null +++ b/test/TargetSpec.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +module TargetSpec where + +import GhcMod.Target +import GhcMod.LightGhc +import GhcMod.Gap +import Test.Hspec + +import TestUtils + +import GHC +import Data.List +import Data.Maybe +import System.Directory +import System.FilePath + +spec :: Spec +spec = do + describe "runLightGhc" $ do + it "works at all" $ do + withLightHscEnv [] $ \env -> + runLightGhc env (return ()) `shouldReturn` () + + it "has modules in scope" $ do + (withLightHscEnv [] $ \env -> + runLightGhc env $ do + dflags <- getSessionDynFlags + let i = intersect (listVisibleModuleNames dflags) + ["Control.Applicative", "Control.Arrow" + ,"Control.Exception", "GHC.Exts", "GHC.Float"] + liftIO $ i `shouldSatisfy` not . null) :: IO () + + it "can get module info" $ do + (withLightHscEnv [] $ \env -> + runLightGhc env $ do + mdl <- findModule "Data.List" Nothing + mmi <- getModuleInfo mdl + liftIO $ isJust mmi `shouldBe` True) :: IO () + + + describe "resolveModule" $ do + it "Works when a module given as path uses CPP" $ do + dir <- getCurrentDirectory + let srcDirs = [dir "test/data/target/src"] + x <- withLightHscEnv [] $ \env -> runD $ do + resolveModule env srcDirs (Left $ dir "test/data/target/Cpp.hs") + liftIO $ x `shouldBe` Just (ModulePath "Cpp" $ dir "test/data/target/Cpp.hs") diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -1,27 +1,42 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module TestUtils ( run , runD , runD' - , runI - , runID - , runIsolatedGhcMod - , isolateCradle + , runE + , runNullLog + , runGmOutDef + , runLogDef , shouldReturnError - , module Language.Haskell.GhcMod.Monad - , module Language.Haskell.GhcMod.Types + , isPkgDbAt + , isPkgConfDAt + , module GhcMod.Monad + , module GhcMod.Types ) where -import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Types +import GhcMod.Logging +import GhcMod.Monad +import GhcMod.Cradle +import GhcMod.Types +import Control.Arrow +import Control.Category +import Control.Applicative +import Control.Monad.Error (ErrorT, runErrorT) +import Control.Monad.Trans.Journal +import Data.List.Split +import Data.Label +import Data.String +import System.FilePath +import System.Directory import Test.Hspec +import Prelude hiding ((.)) -isolateCradle :: IOish m => GhcModT m a -> GhcModT m a -isolateCradle action = - local modifyEnv $ action - where - modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } } +import Exception +testLogLevel :: GmLogLevel +testLogLevel = GmDebug + extract :: Show e => IO (Either e a, w) -> IO a extract action = do (r,_) <- action @@ -29,29 +44,57 @@ Right a -> return a Left e -> error $ show e -runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a -runIsolatedGhcMod opt action = do - extract $ runGhcModT opt $ isolateCradle action +runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog) +runGhcModTSpec opt action = do + dir <- getCurrentDirectory + runGhcModTSpec' dir opt action --- | Run GhcMod in isolated cradle with default options -runID :: GhcModT IO a -> IO a -runID = runIsolatedGhcMod defaultOptions +runGhcModTSpec' :: IOish m + => FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog) +runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do + runGmOutT opt $ + withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do + first (fst <$>) <$> runGhcModT' env defaultGhcModState + (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action) + where + withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a + withSpecCradle cradledir f = + gbracket + (runJournalT $ findSpecCradle (optPrograms opt) cradledir) + (liftIO . cleanupCradle . fst) f --- | Run GhcMod in isolated cradle -runI :: Options -> GhcModT IO a -> IO a -runI = runIsolatedGhcMod -- | Run GhcMod run :: Options -> GhcModT IO a -> IO a -run opt a = extract $ runGhcModT opt a +run opt a = extract $ runGhcModTSpec opt a -- | Run GhcMod with default options runD :: GhcModT IO a -> IO a -runD = extract . runGhcModT defaultOptions +runD = + extract . runGhcModTSpec (setLogLevel testLogLevel defaultOptions) -runD' :: GhcModT IO a -> IO (Either GhcModError a, GhcModLog) -runD' = runGhcModT defaultOptions +runD' :: FilePath -> GhcModT IO a -> IO a +runD' dir = + extract . runGhcModTSpec' dir (setLogLevel testLogLevel defaultOptions) +setLogLevel :: GmLogLevel -> Options -> Options +setLogLevel = set (lOoptLogLevel . lOptOutput) + +runE :: ErrorT e IO a -> IO (Either e a) +runE = runErrorT + +runNullLog :: MonadIO m => JournalT GhcModLog m a -> m a +runNullLog action = do + (a,w) <- runJournalT action + liftIO $ print w + return a + +runGmOutDef :: IOish m => GmOutT m a -> m a +runGmOutDef = runGmOutT defaultOptions + +runLogDef :: IOish m => GmOutT (JournalT GhcModLog m) a -> m a +runLogDef = fmap fst . runJournalT . runGmOutDef + shouldReturnError :: Show a => IO (Either GhcModError a, GhcModLog) -> Expectation @@ -61,3 +104,21 @@ where isLeft (Left _) = True isLeft _ = False + +isPkgConfD :: FilePath -> Bool +isPkgConfD d = let + (_dir, pkgconfd) = splitFileName d + in case splitOn "-" pkgconfd of + [_arch, _platform, _compiler, _compver, "packages.conf.d"] -> True + _ -> False + +isPkgConfDAt :: FilePath -> FilePath -> Bool +isPkgConfDAt d d' | d == takeDirectory d' && isPkgConfD d' = True +isPkgConfDAt _ _ = False + +isPkgDbAt :: FilePath -> GhcPkgDb -> Bool +isPkgDbAt d (PackageDb dir) = isPkgConfDAt d dir +isPkgDbAt _ _ = False + +instance IsString ModuleName where + fromString = mkModuleName diff --git a/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf b/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf deleted file mode 100644 --- a/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf +++ /dev/null @@ -1,4 +0,0 @@ -name: Cabal -version: 1.18.1.3 -id: Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b -exposed: True diff --git a/test/data/.cabal-sandbox/packages/00-index.tar b/test/data/.cabal-sandbox/packages/00-index.tar deleted file mode 100644 Binary files a/test/data/.cabal-sandbox/packages/00-index.tar and /dev/null differ diff --git a/test/data/Bar.hs b/test/data/Bar.hs deleted file mode 100644 --- a/test/data/Bar.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Bar (bar) where -import Foo (foo) - -bar = $foo ++ "bar" diff --git a/test/data/Baz.hs b/test/data/Baz.hs deleted file mode 100644 --- a/test/data/Baz.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Baz (baz) where -import Foo (fooQ) - -baz = [fooQ| foo bar baz |] diff --git a/test/data/Foo.hs b/test/data/Foo.hs deleted file mode 100644 --- a/test/data/Foo.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Foo (foo, fooQ) where -import Language.Haskell.TH -import Language.Haskell.TH.Quote (QuasiQuoter(..)) - -foo :: ExpQ -foo = stringE "foo" - -fooQ :: QuasiQuoter -fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined diff --git a/test/data/ForeignExport.hs b/test/data/ForeignExport.hs deleted file mode 100644 --- a/test/data/ForeignExport.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -module ForeignExport where - -import Foreign.C.Types - -foreign export ccall foo :: CUInt - -foo :: CUInt -foo = 123 diff --git a/test/data/Info.hs b/test/data/Info.hs deleted file mode 100644 --- a/test/data/Info.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted - -module Info () where - -fib :: Int -> Int -fib 0 = 0 -fib 1 = 1 -fib n = fib (n - 1) + fib (n - 2) diff --git a/test/data/Main.hs b/test/data/Main.hs deleted file mode 100644 --- a/test/data/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Bar (bar) - -main = putStrLn bar diff --git a/test/data/Mutual1.hs b/test/data/Mutual1.hs deleted file mode 100644 --- a/test/data/Mutual1.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted - -module Mutual1 where - -import Mutual2 diff --git a/test/data/Mutual2.hs b/test/data/Mutual2.hs deleted file mode 100644 --- a/test/data/Mutual2.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Mutual2 where - -import Mutual1 diff --git a/test/data/Unicode.hs b/test/data/Unicode.hs deleted file mode 100644 --- a/test/data/Unicode.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Unicode where - -unicode :: α -> α -unicode = id diff --git a/test/data/annotations/With.hs b/test/data/annotations/With.hs new file mode 100644 --- /dev/null +++ b/test/data/annotations/With.hs @@ -0,0 +1,6 @@ +module Main where + +{-# ANN module ["this", "can", "be", "anything"] #-} + +main :: IO () +main = putStrLn "Hello world!" diff --git a/test/data/broken-cabal/cabal.sandbox.config.in b/test/data/broken-cabal/cabal.sandbox.config.in deleted file mode 100644 --- a/test/data/broken-cabal/cabal.sandbox.config.in +++ /dev/null @@ -1,25 +0,0 @@ --- This is a Cabal package environment file. --- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. --- Please create a 'cabal.config' file in the same directory --- if you want to change the default settings for this sandbox. - - -local-repo: @CWD@/test/data/broken-cabal/.cabal-sandbox/packages -logs-dir: @CWD@/test/data/broken-cabal/.cabal-sandbox/logs -world-file: @CWD@/test/data/broken-cabal/.cabal-sandbox/world -user-install: False -package-db: @CWD@/test/data/broken-cabal/.cabal-sandbox/x86_64-linux-ghc-7.8.3-packages.conf.d -build-summary: @CWD@/test/data/broken-cabal/.cabal-sandbox/logs/build.log - -install-dirs - prefix: @CWD@/test/data/broken-cabal/.cabal-sandbox - bindir: $prefix/bin - libdir: $prefix/lib - libsubdir: $arch-$os-$compiler/$pkgid - libexecdir: $prefix/libexec - datadir: $prefix/share - datasubdir: $arch-$os-$compiler/$pkgid - docdir: $datadir/doc/$arch-$os-$compiler/$pkgid - htmldir: $docdir/html - haddockdir: $htmldir - sysconfdir: $prefix/etc diff --git a/test/data/cabal-flags/cabal-flags.cabal b/test/data/cabal-flags/cabal-flags.cabal --- a/test/data/cabal-flags/cabal-flags.cabal +++ b/test/data/cabal-flags/cabal-flags.cabal @@ -7,8 +7,7 @@ default: False library - build-depends: base == 4.* + build-depends: base if flag(test-flag) build-depends: Cabal >= 1.10 - diff --git a/test/data/cabal-preprocessors/Main.hs b/test/data/cabal-preprocessors/Main.hs new file mode 100644 --- /dev/null +++ b/test/data/cabal-preprocessors/Main.hs @@ -0,0 +1,4 @@ +import Preprocessed + +main :: IO () +main = return warning diff --git a/test/data/cabal-preprocessors/Preprocessed.hsc b/test/data/cabal-preprocessors/Preprocessed.hsc new file mode 100644 --- /dev/null +++ b/test/data/cabal-preprocessors/Preprocessed.hsc @@ -0,0 +1,3 @@ +module Preprocessed where + +warning = () diff --git a/test/data/cabal-preprocessors/cabal-preprocessors.cabal b/test/data/cabal-preprocessors/cabal-preprocessors.cabal new file mode 100644 --- /dev/null +++ b/test/data/cabal-preprocessors/cabal-preprocessors.cabal @@ -0,0 +1,14 @@ +name: cabal-preprocessors +version: 0.1.0.0 +license-file: LICENSE +author: asd +maintainer: asd +build-type: Simple +cabal-version: >=1.10 + +executable cabal-preprocessors + main-is: Main.hs + build-depends: base + default-language: Haskell2010 + other-modules: Preprocessed + ghc-options: -Wall diff --git a/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf b/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf new file mode 100644 --- /dev/null +++ b/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf @@ -0,0 +1,4 @@ +name: Cabal +version: 1.18.1.3 +id: Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b +exposed: True diff --git a/test/data/cabal-project/Baz.hs b/test/data/cabal-project/Baz.hs new file mode 100644 --- /dev/null +++ b/test/data/cabal-project/Baz.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} +module Baz (baz) where +import Foo (fooQ) + +baz = [fooQ| foo bar baz |] diff --git a/test/data/cabal-project/Foo.hs b/test/data/cabal-project/Foo.hs new file mode 100644 --- /dev/null +++ b/test/data/cabal-project/Foo.hs @@ -0,0 +1,9 @@ +module Foo (foo, fooQ) where +import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter(..)) + +foo :: ExpQ +foo = stringE "foo" + +fooQ :: QuasiQuoter +fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined diff --git a/test/data/cabal-project/Info.hs b/test/data/cabal-project/Info.hs new file mode 100644 --- /dev/null +++ b/test/data/cabal-project/Info.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted + +module Info () where + +fib :: Int -> Int +fib 0 = 0 +fib 1 = 1 +fib n = fib (n - 1) + fib (n - 2) diff --git a/test/data/cabal-project/Main.hs b/test/data/cabal-project/Main.hs new file mode 100644 --- /dev/null +++ b/test/data/cabal-project/Main.hs @@ -0,0 +1,3 @@ +import Bar (bar) + +main = putStrLn bar diff --git a/test/data/cabal-project/cabalapi.cabal b/test/data/cabal-project/cabalapi.cabal new file mode 100644 --- /dev/null +++ b/test/data/cabal-project/cabalapi.cabal @@ -0,0 +1,67 @@ +Name: ghc-mod +Version: 1.11.3 +Author: Kazu Yamamoto +Maintainer: Kazu Yamamoto +License: BSD3 +License-File: LICENSE +Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ +Synopsis: Happy Haskell programming on Emacs/Vim +Description: This packages includes Elisp files + and a Haskell command, "ghc-mod". + "ghc*.el" enable completion of + Haskell symbols on Emacs. + Flymake is also integrated. + "ghc-mod" is a backend of "ghc*.el". + It lists up all installed modules + or extracts names of functions, classes, + and data declarations. + To use "ghc-mod" on Vim, + see or + +Category: Development +Cabal-Version: >= 1.6 +Build-Type: Simple +Data-Dir: elisp +Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el + ghc-flymake.el ghc-command.el ghc-info.el + ghc-ins-mod.el ghc-indent.el +Executable ghc-mod + Main-Is: GHCMod.hs + Other-Modules: Browse + CabalApi + Cabal + CabalDev + Check + ErrMsg + Flag + GHCApi + GHCChoice + Gap + Info + Lang + Lint + List + Paths_ghc_mod + Types + GHC-Options: -Wall + Build-Depends: base + , Cabal >= 1.10 + , template-haskell + +Test-Suite spec + Main-Is: Spec.hs + Hs-Source-Dirs: test, . + Type: exitcode-stdio-1.0 + Other-Modules: Expectation + BrowseSpec + CabalApiSpec + FlagSpec + LangSpec + LintSpec + ListSpec + Build-Depends: base + , Cabal >= 1.10 + +Source-Repository head + Type: git + Location: git://github.com/kazu-yamamoto/ghc-mod.git diff --git a/test/data/cabal-project/subdir1/subdir2/dummy b/test/data/cabal-project/subdir1/subdir2/dummy new file mode 100644 --- /dev/null +++ b/test/data/cabal-project/subdir1/subdir2/dummy @@ -0,0 +1,1 @@ +dummy diff --git a/test/data/cabal.sandbox.config.in b/test/data/cabal.sandbox.config.in deleted file mode 100644 --- a/test/data/cabal.sandbox.config.in +++ /dev/null @@ -1,25 +0,0 @@ --- This is a Cabal package environment file. --- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. --- Please create a 'cabal.config' file in the same directory --- if you want to change the default settings for this sandbox. - - -local-repo: @CWD@/test/data/.cabal-sandbox/packages -logs-dir: @CWD@/test/data/.cabal-sandbox/logs -world-file: @CWD@/test/data/.cabal-sandbox/world -user-install: False -package-db: @CWD@/test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d -build-summary: @CWD@/test/data/.cabal-sandbox/logs/build.log - -install-dirs - prefix: @CWD@/test/data/.cabal-sandbox - bindir: $prefix/bin - libdir: $prefix/lib - libsubdir: $arch-$os-$compiler/$pkgid - libexecdir: $prefix/libexec - datadir: $prefix/share - datasubdir: $arch-$os-$compiler/$pkgid - docdir: $datadir/doc/$arch-$os-$compiler/$pkgid - htmldir: $docdir/html - haddockdir: $htmldir - sysconfdir: $prefix/etc diff --git a/test/data/cabalapi.cabal b/test/data/cabalapi.cabal deleted file mode 100644 --- a/test/data/cabalapi.cabal +++ /dev/null @@ -1,67 +0,0 @@ -Name: ghc-mod -Version: 1.11.3 -Author: Kazu Yamamoto -Maintainer: Kazu Yamamoto -License: BSD3 -License-File: LICENSE -Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ -Synopsis: Happy Haskell programming on Emacs/Vim -Description: This packages includes Elisp files - and a Haskell command, "ghc-mod". - "ghc*.el" enable completion of - Haskell symbols on Emacs. - Flymake is also integrated. - "ghc-mod" is a backend of "ghc*.el". - It lists up all installed modules - or extracts names of functions, classes, - and data declarations. - To use "ghc-mod" on Vim, - see or - -Category: Development -Cabal-Version: >= 1.6 -Build-Type: Simple -Data-Dir: elisp -Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el - ghc-flymake.el ghc-command.el ghc-info.el - ghc-ins-mod.el ghc-indent.el -Executable ghc-mod - Main-Is: GHCMod.hs - Other-Modules: Browse - CabalApi - Cabal - CabalDev - Check - ErrMsg - Flag - GHCApi - GHCChoice - Gap - Info - Lang - Lint - List - Paths_ghc_mod - Types - GHC-Options: -Wall - Build-Depends: base >= 4.0 && < 5 - , Cabal >= 1.10 - , template-haskell - -Test-Suite spec - Main-Is: Spec.hs - Hs-Source-Dirs: test, . - Type: exitcode-stdio-1.0 - Other-Modules: Expectation - BrowseSpec - CabalApiSpec - FlagSpec - LangSpec - LintSpec - ListSpec - Build-Depends: base >= 4.0 && < 5 - , Cabal >= 1.10 - -Source-Repository head - Type: git - Location: git://github.com/kazu-yamamoto/ghc-mod.git diff --git a/test/data/case-split/Crash.hs b/test/data/case-split/Crash.hs new file mode 100644 --- /dev/null +++ b/test/data/case-split/Crash.hs @@ -0,0 +1,4 @@ +module Crash where + +test :: Maybe a +test x = undefined diff --git a/test/data/case-split/Vect.hs b/test/data/case-split/Vect.hs new file mode 100644 --- /dev/null +++ b/test/data/case-split/Vect.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, GADTs, KindSignatures #-} + +module Vect where + +data Nat = Z | S Nat + +type family (n :: Nat) :+ (m :: Nat) :: Nat +type instance Z :+ m = m +type instance S n :+ m = S (n :+ m) + +data Vect :: Nat -> * -> * where + VNil :: Vect Z a + (:::) :: a -> Vect n a -> Vect (S n) a + +vAppend :: Vect n a -> Vect m a -> Vect (n :+ m) a +vAppend x y = _vAppend_body + +lAppend :: [a] -> [a] -> [a] +lAppend x y = _lAppend_body + +data MyList a = Nil | Cons a (MyList a) + +mlAppend :: MyList a -> MyList a -> MyList a +mlAppend x y = _mlAppend_body + +mlAppend2 :: MyList a -> MyList a -> MyList a +mlAppend2 x y = case x of + x' -> _mlAppend_body + +mlReverse :: MyList a -> MyList a +mlReverse xs = mlReverse' xs Nil + where + mlReverse' :: MyList a -> MyList a -> MyList a + mlReverse' xs' accum = _mlReverse_body + +mlReverse2 :: MyList a -> MyList a +mlReverse2 xs = let mlReverse' :: MyList a -> MyList a -> MyList a + mlReverse' xs' accum = _mlReverse_body + in mlReverse' xs Nil diff --git a/test/data/case-split/Vect706.hs b/test/data/case-split/Vect706.hs new file mode 100644 --- /dev/null +++ b/test/data/case-split/Vect706.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, GADTs, KindSignatures #-} + +module Vect706 where + +data Nat = Z | S Nat + +type family (n :: Nat) :+ (m :: Nat) :: Nat +type instance Z :+ m = m +type instance S n :+ m = S (n :+ m) + +data Vect :: Nat -> * -> * where + VNil :: Vect Z a + (:::) :: a -> Vect n a -> Vect (S n) a + +vAppend :: Vect n a -> Vect m a -> Vect (n :+ m) a +vAppend x y = undefined + +lAppend :: [a] -> [a] -> [a] +lAppend x y = undefined + +data MyList a = Nil | Cons a (MyList a) + +mlAppend :: MyList a -> MyList a -> MyList a +mlAppend x y = undefined + +mlAppend2 :: MyList a -> MyList a -> MyList a +mlAppend2 x y = case x of + x' -> undefined + +mlReverse :: MyList a -> MyList a +mlReverse xs = mlReverse' xs Nil + where + mlReverse' :: MyList a -> MyList a -> MyList a + mlReverse' xs' accum = undefined + +mlReverse2 :: MyList a -> MyList a +mlReverse2 xs = let mlReverse' :: MyList a -> MyList a -> MyList a + mlReverse' xs' accum = undefined + in mlReverse' xs Nil diff --git a/test/data/check-missing-warnings/DesugarWarnings.hs b/test/data/check-missing-warnings/DesugarWarnings.hs new file mode 100644 --- /dev/null +++ b/test/data/check-missing-warnings/DesugarWarnings.hs @@ -0,0 +1,5 @@ +module Warnings (zoo) where + +zoo :: [a] -> () +zoo x = case x of + [] -> undefined diff --git a/test/data/check-packageid/cabal.sandbox.config.in b/test/data/check-packageid/cabal.sandbox.config.in deleted file mode 100644 --- a/test/data/check-packageid/cabal.sandbox.config.in +++ /dev/null @@ -1,25 +0,0 @@ --- This is a Cabal package environment file. --- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. --- Please create a 'cabal.config' file in the same directory --- if you want to change the default settings for this sandbox. - - -local-repo: @CWD@/test/data/check-packageid/.cabal-sandbox/packages -logs-dir: @CWD@/test/data/check-packageid/.cabal-sandbox/logs -world-file: @CWD@/test/data/check-packageid/.cabal-sandbox/world -user-install: False -package-db: @CWD@/test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d -build-summary: @CWD@/test/data/check-packageid/.cabal-sandbox/logs/build.log - -install-dirs - prefix: @CWD@/test/data/check-packageid/.cabal-sandbox - bindir: $prefix/bin - libdir: $prefix/lib - libsubdir: $arch-$os-$compiler/$pkgid - libexecdir: $prefix/libexec - datadir: $prefix/share - datasubdir: $arch-$os-$compiler/$pkgid - docdir: $datadir/doc/$arch-$os-$compiler/$pkgid - htmldir: $docdir/html - haddockdir: $htmldir - sysconfdir: $prefix/etc diff --git a/test/data/check-test-subdir/check-test-subdir.cabal b/test/data/check-test-subdir/check-test-subdir.cabal --- a/test/data/check-test-subdir/check-test-subdir.cabal +++ b/test/data/check-test-subdir/check-test-subdir.cabal @@ -13,3 +13,4 @@ build-depends: base == 4.* hs-source-dirs: test main-is: Main.hs + ghc-options: -Wall diff --git a/test/data/custom-cradle/custom-cradle.cabal b/test/data/custom-cradle/custom-cradle.cabal new file mode 100644 --- /dev/null +++ b/test/data/custom-cradle/custom-cradle.cabal @@ -0,0 +1,12 @@ +name: custom-cradle +version: 0.1.0.0 +homepage: asd +license-file: LICENSE +author: asd +maintainer: asd +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base + default-language: Haskell2010 diff --git a/test/data/custom-cradle/ghc-mod.package-db-stack b/test/data/custom-cradle/ghc-mod.package-db-stack new file mode 100644 --- /dev/null +++ b/test/data/custom-cradle/ghc-mod.package-db-stack @@ -0,0 +1,5 @@ +global +user +package-db-a +package-db-b +package-db-c diff --git a/test/data/custom-cradle/package-db-a/.gitkeep b/test/data/custom-cradle/package-db-a/.gitkeep new file mode 100644 --- /dev/null +++ b/test/data/custom-cradle/package-db-a/.gitkeep diff --git a/test/data/custom-cradle/package-db-b/.gitkeep b/test/data/custom-cradle/package-db-b/.gitkeep new file mode 100644 --- /dev/null +++ b/test/data/custom-cradle/package-db-b/.gitkeep diff --git a/test/data/custom-cradle/package-db-c/.gitkeep b/test/data/custom-cradle/package-db-c/.gitkeep new file mode 100644 --- /dev/null +++ b/test/data/custom-cradle/package-db-c/.gitkeep diff --git a/test/data/duplicate-pkgver/cabal.sandbox.config.in b/test/data/duplicate-pkgver/cabal.sandbox.config.in deleted file mode 100644 --- a/test/data/duplicate-pkgver/cabal.sandbox.config.in +++ /dev/null @@ -1,25 +0,0 @@ --- This is a Cabal package environment file. --- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. --- Please create a 'cabal.config' file in the same directory --- if you want to change the default settings for this sandbox. - - -local-repo: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/packages -logs-dir: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/logs -world-file: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/world -user-install: False -package-db: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d -build-summary: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/logs/build.log - -install-dirs - prefix: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox - bindir: $prefix/bin - libdir: $prefix/lib - libsubdir: $arch-$os-$compiler/$pkgid - libexecdir: $prefix/libexec - datadir: $prefix/share - datasubdir: $arch-$os-$compiler/$pkgid - docdir: $datadir/doc/$arch-$os-$compiler/$pkgid - htmldir: $docdir/html - haddockdir: $htmldir - sysconfdir: $prefix/etc diff --git a/test/data/file-mapping/File.hs b/test/data/file-mapping/File.hs new file mode 100644 --- /dev/null +++ b/test/data/file-mapping/File.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Hello World!" diff --git a/test/data/file-mapping/File_Redir.hs b/test/data/file-mapping/File_Redir.hs new file mode 100644 --- /dev/null +++ b/test/data/file-mapping/File_Redir.hs @@ -0,0 +1,1 @@ +main = putStrLn "Hello World!" diff --git a/test/data/file-mapping/File_Redir_Lint.hs b/test/data/file-mapping/File_Redir_Lint.hs new file mode 100644 --- /dev/null +++ b/test/data/file-mapping/File_Redir_Lint.hs @@ -0,0 +1,4 @@ +module File where + +func :: Num a => a -> a -> a +func a b = (*) a b diff --git a/test/data/file-mapping/lhs/File.lhs b/test/data/file-mapping/lhs/File.lhs new file mode 100644 --- /dev/null +++ b/test/data/file-mapping/lhs/File.lhs @@ -0,0 +1,2 @@ +> main :: IO () +> main = putStrLn "Hello World!" diff --git a/test/data/file-mapping/lhs/File_Redir.lhs b/test/data/file-mapping/lhs/File_Redir.lhs new file mode 100644 --- /dev/null +++ b/test/data/file-mapping/lhs/File_Redir.lhs @@ -0,0 +1,1 @@ +> main = putStrLn "Hello World!" diff --git a/test/data/file-mapping/lhs/File_Redir_Lint.lhs b/test/data/file-mapping/lhs/File_Redir_Lint.lhs new file mode 100644 --- /dev/null +++ b/test/data/file-mapping/lhs/File_Redir_Lint.lhs @@ -0,0 +1,4 @@ +> module File where + +> func :: Num a => a -> a -> a +> func a b = (*) a b diff --git a/test/data/file-mapping/preprocessor/File.hs b/test/data/file-mapping/preprocessor/File.hs new file mode 100644 --- /dev/null +++ b/test/data/file-mapping/preprocessor/File.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +#ifndef NOTHING +main :: IO () +main = putStrLn "Hello World!" +#else +INVALID +#endif diff --git a/test/data/file-mapping/preprocessor/File_Redir.hs b/test/data/file-mapping/preprocessor/File_Redir.hs new file mode 100644 --- /dev/null +++ b/test/data/file-mapping/preprocessor/File_Redir.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE CPP #-} +#ifndef NOTHING +main = putStrLn "Hello World!" +#else +INVALID +#endif diff --git a/test/data/file-mapping/preprocessor/File_Redir_Lint.hs b/test/data/file-mapping/preprocessor/File_Redir_Lint.hs new file mode 100644 --- /dev/null +++ b/test/data/file-mapping/preprocessor/File_Redir_Lint.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} +#ifndef NOTHING +module File where + +func :: Num a => a -> a -> a +func a b = (*) a b +#else +INVALID +#endif diff --git a/test/data/foreign-export/ForeignExport.hs b/test/data/foreign-export/ForeignExport.hs new file mode 100644 --- /dev/null +++ b/test/data/foreign-export/ForeignExport.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module ForeignExport where + +import Foreign.C.Types + +foreign export ccall foo :: CUInt + +foo :: CUInt +foo = 123 diff --git a/test/data/ghc-mod-check/Data/Foo.hs b/test/data/ghc-mod-check/Data/Foo.hs deleted file mode 100644 --- a/test/data/ghc-mod-check/Data/Foo.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Data.Foo where - -foo :: Int -foo = undefined - -fibonacci :: Int -> Integer -fibonacci n = fib 1 0 1 - where - fib m x y - | n == m = y - | otherwise = fib (m+1) y (x + y) diff --git a/test/data/ghc-mod-check/ghc-mod-check.cabal b/test/data/ghc-mod-check/ghc-mod-check.cabal --- a/test/data/ghc-mod-check/ghc-mod-check.cabal +++ b/test/data/ghc-mod-check/ghc-mod-check.cabal @@ -15,13 +15,12 @@ cabal-version: >=1.8 library - -- exposed-modules: - -- other-modules: + HS-Source-Dirs: lib build-depends: base exposed-modules: Data.Foo executable foo Main-Is: main.hs GHC-Options: -Wall - Build-Depends: base >= 4 && < 5 + Build-Depends: base , ghc-mod-check diff --git a/test/data/ghc-mod-check/lib/Data/Foo.hs b/test/data/ghc-mod-check/lib/Data/Foo.hs new file mode 100644 --- /dev/null +++ b/test/data/ghc-mod-check/lib/Data/Foo.hs @@ -0,0 +1,11 @@ +module Data.Foo where + +foo :: Int +foo = undefined + +fibonacci :: Int -> Integer +fibonacci n = fib 1 0 1 + where + fib m x y + | n == m = y + | otherwise = fib (m+1) y (x + y) diff --git a/test/data/hlint.hs b/test/data/hlint.hs deleted file mode 100644 --- a/test/data/hlint.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Hlist where - -main :: IO () -main = do - putStrLn "Hello, world!" diff --git a/test/data/hlint/hlint.hs b/test/data/hlint/hlint.hs new file mode 100644 --- /dev/null +++ b/test/data/hlint/hlint.hs @@ -0,0 +1,5 @@ +module Hlist where + +main :: IO () +main = do + putStrLn "Hello, world!" diff --git a/test/data/home-module-graph/cpp/A.hs b/test/data/home-module-graph/cpp/A.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/cpp/A.hs @@ -0,0 +1,4 @@ +module A where +import A1 +import A2 +import A3 diff --git a/test/data/home-module-graph/cpp/A1.hs b/test/data/home-module-graph/cpp/A1.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/cpp/A1.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE CPP #-} +module A1 where +#elif +import B diff --git a/test/data/home-module-graph/cpp/A2.hs b/test/data/home-module-graph/cpp/A2.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/cpp/A2.hs @@ -0,0 +1,1 @@ +module A2 where diff --git a/test/data/home-module-graph/cpp/A3.hs b/test/data/home-module-graph/cpp/A3.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/cpp/A3.hs @@ -0,0 +1,2 @@ +module A3 where +import B diff --git a/test/data/home-module-graph/cpp/B.hs b/test/data/home-module-graph/cpp/B.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/cpp/B.hs @@ -0,0 +1,1 @@ +module B where diff --git a/test/data/home-module-graph/cycle/A.hs b/test/data/home-module-graph/cycle/A.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/cycle/A.hs @@ -0,0 +1,2 @@ +module A where +import B diff --git a/test/data/home-module-graph/cycle/B.hs b/test/data/home-module-graph/cycle/B.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/cycle/B.hs @@ -0,0 +1,2 @@ +module B where +import A diff --git a/test/data/home-module-graph/errors/A.hs b/test/data/home-module-graph/errors/A.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/errors/A.hs @@ -0,0 +1,4 @@ +module A where +import A1 +import A2 +import A3 diff --git a/test/data/home-module-graph/errors/A1.hs b/test/data/home-module-graph/errors/A1.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/errors/A1.hs @@ -0,0 +1,4 @@ +module A1 where +psogduapzs9 +import B +lx,vLMCks diff --git a/test/data/home-module-graph/errors/A2.hs b/test/data/home-module-graph/errors/A2.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/errors/A2.hs @@ -0,0 +1,1 @@ +module A2 where diff --git a/test/data/home-module-graph/errors/A3.hs b/test/data/home-module-graph/errors/A3.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/errors/A3.hs @@ -0,0 +1,2 @@ +module A3 where +import B diff --git a/test/data/home-module-graph/errors/B.hs b/test/data/home-module-graph/errors/B.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/errors/B.hs @@ -0,0 +1,1 @@ +module B where diff --git a/test/data/home-module-graph/indirect-update/A.hs b/test/data/home-module-graph/indirect-update/A.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/indirect-update/A.hs @@ -0,0 +1,4 @@ +module A where +import A1 +import A2 +import A3 diff --git a/test/data/home-module-graph/indirect-update/A1.hs b/test/data/home-module-graph/indirect-update/A1.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/indirect-update/A1.hs @@ -0,0 +1,2 @@ +module A1 where +import B diff --git a/test/data/home-module-graph/indirect-update/A2.hs b/test/data/home-module-graph/indirect-update/A2.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/indirect-update/A2.hs @@ -0,0 +1,1 @@ +module A2 where diff --git a/test/data/home-module-graph/indirect-update/A3.hs b/test/data/home-module-graph/indirect-update/A3.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/indirect-update/A3.hs @@ -0,0 +1,2 @@ +module A3 where +import B diff --git a/test/data/home-module-graph/indirect-update/B.hs b/test/data/home-module-graph/indirect-update/B.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/indirect-update/B.hs @@ -0,0 +1,1 @@ +module B where diff --git a/test/data/home-module-graph/indirect-update/C.hs b/test/data/home-module-graph/indirect-update/C.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/indirect-update/C.hs @@ -0,0 +1,1 @@ +module C where diff --git a/test/data/home-module-graph/indirect/A.hs b/test/data/home-module-graph/indirect/A.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/indirect/A.hs @@ -0,0 +1,4 @@ +module A where +import A1 +import A2 +import A3 diff --git a/test/data/home-module-graph/indirect/A1.hs b/test/data/home-module-graph/indirect/A1.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/indirect/A1.hs @@ -0,0 +1,2 @@ +module A1 where +import B diff --git a/test/data/home-module-graph/indirect/A2.hs b/test/data/home-module-graph/indirect/A2.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/indirect/A2.hs @@ -0,0 +1,2 @@ +module A2 where +import C diff --git a/test/data/home-module-graph/indirect/A3.hs b/test/data/home-module-graph/indirect/A3.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/indirect/A3.hs @@ -0,0 +1,2 @@ +module A3 where +import B diff --git a/test/data/home-module-graph/indirect/B.hs b/test/data/home-module-graph/indirect/B.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/indirect/B.hs @@ -0,0 +1,1 @@ +module B where diff --git a/test/data/home-module-graph/indirect/C.hs b/test/data/home-module-graph/indirect/C.hs new file mode 100644 --- /dev/null +++ b/test/data/home-module-graph/indirect/C.hs @@ -0,0 +1,1 @@ +module C where diff --git a/test/data/import-cycle/Mutual1.hs b/test/data/import-cycle/Mutual1.hs new file mode 100644 --- /dev/null +++ b/test/data/import-cycle/Mutual1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted + +module Mutual1 where + +import Mutual2 diff --git a/test/data/import-cycle/Mutual2.hs b/test/data/import-cycle/Mutual2.hs new file mode 100644 --- /dev/null +++ b/test/data/import-cycle/Mutual2.hs @@ -0,0 +1,3 @@ +module Mutual2 where + +import Mutual1 diff --git a/test/data/nice-qualification/NiceQualification.hs b/test/data/nice-qualification/NiceQualification.hs new file mode 100644 --- /dev/null +++ b/test/data/nice-qualification/NiceQualification.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = "wrong type" diff --git a/test/data/non-exported/Fib.hs b/test/data/non-exported/Fib.hs new file mode 100644 --- /dev/null +++ b/test/data/non-exported/Fib.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted + +module Fib () where + +fib :: Int -> Int +fib 0 = 0 +fib 1 = 1 +fib n = fib (n - 1) + fib (n - 2) diff --git a/test/data/pattern-synonyms/A.hs b/test/data/pattern-synonyms/A.hs --- a/test/data/pattern-synonyms/A.hs +++ b/test/data/pattern-synonyms/A.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms #-} + module A where data SomeType a b = SomeType (a,b) diff --git a/test/data/pattern-synonyms/pattern-synonyms.cabal b/test/data/pattern-synonyms/pattern-synonyms.cabal --- a/test/data/pattern-synonyms/pattern-synonyms.cabal +++ b/test/data/pattern-synonyms/pattern-synonyms.cabal @@ -1,24 +1,27 @@ --- Initial pattern-synonyms.cabal generated by cabal init. For further +-- Initial pattern-synonyms.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: pattern-synonyms version: 0.1.0.0 --- synopsis: --- description: --- license: +-- synopsis: +-- description: +-- license: license-file: LICENSE author: Daniel Gröber maintainer: dxld@darkboxed.org --- copyright: --- category: +-- copyright: +-- category: build-type: Simple --- extra-source-files: +-- extra-source-files: cabal-version: >=1.10 library exposed-modules: A, B - -- other-modules: + -- other-modules: other-extensions: PatternSynonyms - build-depends: base >=4.7 && <4.8 - -- hs-source-dirs: + build-depends: base + -- hs-source-dirs: default-language: Haskell2010 + ghc-options: -Wall + if impl(ghc >= 8.0.1) + ghc-options: -Wno-missing-pattern-synonym-signatures diff --git a/test/data/quasi-quotes/FooQ.hs b/test/data/quasi-quotes/FooQ.hs new file mode 100644 --- /dev/null +++ b/test/data/quasi-quotes/FooQ.hs @@ -0,0 +1,6 @@ +module FooQ (fooQ) where +import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter(..)) + +fooQ :: QuasiQuoter +fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined diff --git a/test/data/quasi-quotes/QuasiQuotes.hs b/test/data/quasi-quotes/QuasiQuotes.hs new file mode 100644 --- /dev/null +++ b/test/data/quasi-quotes/QuasiQuotes.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} +module QuasiQuotes where + +import FooQ + +bar = [fooQ| foo bar baz |] diff --git a/test/data/stack-project/Setup.hs b/test/data/stack-project/Setup.hs new file mode 100644 --- /dev/null +++ b/test/data/stack-project/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/data/stack-project/app/Main.hs b/test/data/stack-project/app/Main.hs new file mode 100644 --- /dev/null +++ b/test/data/stack-project/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib + +main :: IO () +main = someFunc diff --git a/test/data/stack-project/new-template.cabal b/test/data/stack-project/new-template.cabal new file mode 100644 --- /dev/null +++ b/test/data/stack-project/new-template.cabal @@ -0,0 +1,42 @@ +name: new-template +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: http://github.com/name/project +-- license: BSD3 +-- license-file: LICENSE +author: Your name here +maintainer: your.address@example.com +-- copyright: +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Lib + build-depends: base + default-language: Haskell2010 + +executable new-template-exe + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , new-template + , bytestring + default-language: Haskell2010 + +test-suite new-template-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , new-template + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/name/project diff --git a/test/data/stack-project/src/Lib.hs b/test/data/stack-project/src/Lib.hs new file mode 100644 --- /dev/null +++ b/test/data/stack-project/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/test/data/stack-project/stack.yaml.in b/test/data/stack-project/stack.yaml.in new file mode 100644 --- /dev/null +++ b/test/data/stack-project/stack.yaml.in @@ -0,0 +1,4 @@ +flags: {} +packages: +- '.' +extra-deps: [] diff --git a/test/data/stack-project/test/Spec.hs b/test/data/stack-project/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/data/stack-project/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/test/data/subdir1/subdir2/dummy b/test/data/subdir1/subdir2/dummy deleted file mode 100644 --- a/test/data/subdir1/subdir2/dummy +++ /dev/null @@ -1,1 +0,0 @@ -dummy diff --git a/test/data/target/Cpp.hs b/test/data/target/Cpp.hs new file mode 100644 --- /dev/null +++ b/test/data/target/Cpp.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +#undef NOTHING +#ifdef NOTHING +module WRONG_MODULE where +#else +module Cpp where +#endif diff --git a/test/data/template-haskell/Bar.hs b/test/data/template-haskell/Bar.hs new file mode 100644 --- /dev/null +++ b/test/data/template-haskell/Bar.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module Bar (bar) where +import Foo (foo) + +bar = $foo ++ "bar" diff --git a/test/data/template-haskell/Foo.hs b/test/data/template-haskell/Foo.hs new file mode 100644 --- /dev/null +++ b/test/data/template-haskell/Foo.hs @@ -0,0 +1,9 @@ +module Foo (foo, fooQ) where +import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter(..)) + +foo :: ExpQ +foo = stringE "foo" + +fooQ :: QuasiQuoter +fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined diff --git a/test/data/template-haskell/ImportsTH.hs b/test/data/template-haskell/ImportsTH.hs new file mode 100644 --- /dev/null +++ b/test/data/template-haskell/ImportsTH.hs @@ -0,0 +1,3 @@ +import Bar (bar) + +main = putStrLn bar diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -1,14 +1,23 @@ +{-# LANGUAGE CPP #-} module Main where import Test.DocTest +import System.Environment +import Data.Maybe main :: IO () -main = doctest [ - "-package" - , "ghc" - , "-XConstraintKinds", "-XFlexibleContexts" - , "-idist/build/autogen/" - , "-optP-include" - , "-optPdist/build/autogen/cabal_macros.h" - , "Language/Haskell/GhcMod.hs" - ] +main = do + distdir <- (fromMaybe "dist" . lookup "DOCTEST_DIST_DIR") `fmap` getEnvironment + doctest + [ "-package", "ghc-" ++ VERSION_ghc + , "-package", "transformers-" ++ VERSION_transformers + , "-package", "mtl-" ++ VERSION_mtl + , "-package", "directory-" ++ VERSION_directory + , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators", "-XViewPatterns" + , "-i" ++ distdir ++ "/build/autogen/" + , "-icore/" + , "-ishared" +-- , "-optP-include" +-- , "-optP" ++ distdir ++ "/build/autogen/cabal_macros.h" + , "GhcMod.hs" + ]