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,3 +1,12 @@ +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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,29 +1,6 @@ -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. +ghc-mod was originally licensed under the BSD3 but the primary license has been +changed to the AGPL3, files originally contributed under the BSD3 license remain +under this license and can generally be identified by the lack of a GPL header. -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. +See the files COPYING.BSD3 and COPYING.AGPL3 in the source distribution for +copies of the two licenses. diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -3,15 +3,22 @@ module Language.Haskell.GhcMod ( -- * Cradle Cradle(..) + , ProjectType(..) , findCradle -- * Options , Options(..) , LineSeparator(..) , OutputStyle(..) , defaultOptions + -- * Logging + , GmLogLevel + , increaseLogLevel + , decreaseLogLevel + , gmSetLogLevel + , gmLog -- * Types , ModuleString - , Expression + , Expression(..) , GhcPkgDb , Symbol , SymbolDb @@ -22,12 +29,14 @@ -- * Monad utilities , runGhcModT , withOptions + , dropSession -- * 'GhcMod' utilities , boot , browse , check , checkSyntax , debugInfo + , componentInfo , expandTemplate , info , lint @@ -47,6 +56,13 @@ -- * SymbolDb , loadSymbolDb , isOutdated + -- * Output + , gmPutStr + , gmErrStr + , gmPutStrLn + , gmErrStrLn + , gmUnsafePutStrLn + , gmUnsafeErrStrLn ) where import Language.Haskell.GhcMod.Boot @@ -61,7 +77,10 @@ import Language.Haskell.GhcMod.Info import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lint -import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Modules +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Target +import Language.Haskell.GhcMod.Output diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs --- a/Language/Haskell/GhcMod/Boot.hs +++ b/Language/Haskell/GhcMod/Boot.hs @@ -1,6 +1,7 @@ module Language.Haskell.GhcMod.Boot where import Control.Applicative +import Prelude import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.Flag import Language.Haskell.GhcMod.Lang @@ -9,8 +10,9 @@ -- | Printing necessary information for front-end booting. boot :: IOish m => GhcModT m String -boot = concat <$> sequence [modules, languages, flags, - concat <$> mapM browse preBrowsedModules] +boot = concat <$> sequence ms + where + ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules] preBrowsedModules :: [String] preBrowsedModules = [ diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -2,54 +2,57 @@ browse ) where -import Control.Applicative ((<$>)) +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 Data.Char +import Data.List +import Data.Maybe +import FastString +import GHC 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.Gap as Gap +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Name (getOccString) -import Outputable (ppr, Outputable) +import Outputable import TyCon (isAlgTyCon) import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) +import Exception (ExceptionMonad, ghandle) +import Prelude ---------------------------------------------------------------- -- | 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\") +browse :: forall m. IOish m + => String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude") -> GhcModT m String -browse pkgmdl = convert' . sort =<< (listExports =<< getModule) +browse pkgmdl = do + convert' . sort =<< go where - (mpkg,mdl) = splitPkgMdl pkgmdl + -- 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 (\(SomeException _) -> return []) $ do + goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule) + + goPkgModule = do + opt <- options + runGmPkgGhc $ + processExports opt =<< tryModuleInfo =<< G.findModule mdlname mpkgid + + goHomeModule = runGmlT [Right mdlname] $ do + opt <- options + processExports opt =<< tryModuleInfo =<< G.findModule mdlname Nothing + + tryModuleInfo m = fromJust <$> G.getModuleInfo m + + (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" @@ -57,9 +60,10 @@ -- >>> splitPkgMdl "Prelude" -- (Nothing,"Prelude") splitPkgMdl :: String -> (Maybe String,String) -splitPkgMdl pkgmdl = case break (==':') pkgmdl of - (mdl,"") -> (Nothing,mdl) - (pkg,_:mdl) -> (Just pkg,mdl) +splitPkgMdl pkgmdl = + case break (==':') pkgmdl of + (mdl, "") -> (Nothing, mdl) + (pkg, _:mdl) -> (Just pkg, mdl) -- Haskell 2010: -- small -> ascSmall | uniSmall | _ @@ -71,22 +75,23 @@ isNotOp (h:_) = isAlpha h || (h == '_') isNotOp _ = error "isNotOp" -processExports :: IOish m => ModuleInfo -> GhcModT m [String] -processExports minfo = do - opt <- options +processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m) + => Options -> ModuleInfo -> m [String] +processExports opt minfo = do let removeOps | operators opt = id | otherwise = filter (isNotOp . getOccString) mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo -showExport :: IOish m => Options -> ModuleInfo -> Name -> GhcModT m String +showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m) + => Options -> 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` qualified opt - mtype :: IOish m => GhcModT m (Maybe String) + mtype :: m (Maybe String) mtype | detailed opt = do tyInfo <- G.modInfoLookupName minfo e @@ -101,8 +106,9 @@ | null nm = error "formatOp" | isNotOp nm = nm | otherwise = "(" ++ nm ++ ")" - inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing) - inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName 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 @@ -127,7 +133,7 @@ && not (G.isClassTyCon typ) = Just "data" | G.isNewTyCon typ = Just "newtype" | G.isClassTyCon typ = Just "class" - | G.isSynTyCon typ = Just "type" + | Gap.isSynTyCon typ = Just "type" | otherwise = Nothing removeForAlls :: Type -> Type 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 as C (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 C.ghcProgram silent (programName C.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,171 +0,0 @@ -{-# LANGUAGE RecordWildCards, 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.PathsAndFiles -import Language.Haskell.GhcMod.Read -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.World - -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 (void, mplus, when) -#if MIN_VERSION_mtl(2,2,1) -import Control.Monad.Except () -#else -import Control.Monad.Error () -#endif -import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) -import Distribution.Package (InstalledPackageId(..) - , PackageIdentifier(..) - , PackageName(..)) -import Distribution.PackageDescription (FlagAssignment) -import Distribution.Simple.LocalBuildInfo (ComponentName) -import MonadUtils (liftIO) - ----------------------------------------------------------------- - --- | '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 = do - outOfDate <- liftIO $ isSetupConfigOutOfDate cradle - when outOfDate configure - liftIO (readFile file) `tryFix` \_ -> - configure `modifyError'` GMECabalConfigure - where - file = setupConfigFile cradle - prjDir = cradleRootDir cradle - - configure :: (IOish m, MonadError GhcModError m) => m () - configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] - --- | 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/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -0,0 +1,228 @@ +-- ghc-mod: Making Haskell development *more* fun +-- 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 Language.Haskell.GhcMod.CabalHelper +#ifndef SPEC + ( getComponents + , getGhcMergedPkgOptions + , getCabalPackageDbStack + , getCustomPkgDbStack + , prepareCabalHelper + ) +#endif + where + +import Control.Applicative +import Control.Monad +import Control.Category ((.)) +import Data.Maybe +import Data.Monoid +import Data.Serialize (Serialize) +import Data.Traversable +import Distribution.Helper +import qualified Language.Haskell.GhcMod.Types as T +import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram, + cabalProgram) +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Utils +import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.Logging +import Language.Haskell.GhcMod.Output +import System.FilePath +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, GmEnv m, GmState m, GmLog m) + => m [GHCOption] +getGhcMergedPkgOptions = chCached Cached { + cacheLens = Just (lGmcMergedPkgOptions . lGmCaches), + cacheFile = mergedPkgOptsCacheFile, + cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do + readProc <- gmReadProcess + opts <- withCabal $ runQuery'' readProc progs rootdir distdir $ + ghcMergedPkgOptions + return ([setupConfigPath], opts) + } + +getCabalPackageDbStack :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb] +getCabalPackageDbStack = chCached Cached { + cacheLens = Just (lGmcPackageDbStack . lGmCaches), + cacheFile = pkgDbStackCacheFile, + cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do + readProc <- gmReadProcess + dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery'' readProc progs rootdir distdir packageDbStack + return ([setupConfigPath, sandboxConfigFile], 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, GmEnv m, GmState m, GmLog m) + => m [GmComponent 'GMCRaw ChEntrypoint] +getComponents = chCached Cached { + cacheLens = Just (lGmcComponents . lGmCaches), + cacheFile = cabalHelperCacheFile, + cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma -> do + readProc <- gmReadProcess + runQuery'' readProc progs rootdir distdir $ do + q <- join7 + <$> ghcOptions + <*> ghcPkgOptions + <*> ghcSrcOptions + <*> ghcLangOptions + <*> entrypoints + <*> entrypoints + <*> sourceDirs + let cs = flip map q $ curry8 (GmComponent mempty) + return ([setupConfigPath], 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' + ] + +prepareCabalHelper :: (IOish m, GmEnv m, GmLog m) => m () +prepareCabalHelper = do + crdl <- cradle + let projdir = cradleRootDir crdl + distdir = projdir "dist" + readProc <- gmReadProcess + when (cradleProjectType crdl == CabalProject) $ + withCabal $ liftIO $ prepare readProc projdir distdir + +parseCustomPackageDb :: String -> [GhcPkgDb] +parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src + where + parsePkgDb "global" = GlobalDb + parsePkgDb "user" = UserDb + parsePkgDb s = PackageDb s + +getCustomPkgDbStack :: (IOish m, GmEnv m) => m (Maybe [GhcPkgDb]) +getCustomPkgDbStack = do + mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle + return $ parseCustomPackageDb <$> mCusPkgDbFile + +withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a +withCabal action = do + crdl <- cradle + opts <- options + readProc <- gmReadProcess + + let projdir = cradleRootDir crdl + distdir = projdir "dist" + + mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl + mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) + + mCusPkgDbStack <- getCustomPkgDbStack + + pkgDbStackOutOfSync <- + case mCusPkgDbStack of + Just cusPkgDbStack -> do + pkgDb <- runQuery'' readProc (helperProgs opts) projdir distdir $ + map chPkgToGhcPkg <$> packageDbStack + return $ pkgDb /= cusPkgDbStack + + Nothing -> return False + + cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack + + --TODO: also invalidate when sandboxConfig file changed + + when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $ + gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project." + when pkgDbStackOutOfSync $ + gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack, reconfiguring Cabal project." + + when (isSetupConfigOutOfDate mCabalFile mCabalConfig || pkgDbStackOutOfSync) $ + withDirectory_ (cradleRootDir crdl) $ do + let progOpts = + [ "--with-ghc=" ++ T.ghcProgram opts ] + -- Only pass ghc-pkg if it was actually set otherwise we + -- might break cabal's guessing logic + ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions + then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ] + else [] + ++ map pkgDbArg cusPkgStack + liftIO $ void $ readProc (T.cabalProgram opts) ("configure":progOpts) "" + gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" + liftIO $ writeAutogenFiles readProc projdir distdir + action + +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 (unlikely case) -> should return False +-- @Just cc < Nothing = False@ +-- TODO: should we delete dist/setup-config? +-- +-- * 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 :: Options -> Programs +helperProgs opts = Programs { + cabalProgram = T.cabalProgram opts, + ghcProgram = T.ghcProgram opts, + ghcPkgProgram = T.ghcPkgProgram opts + } + +chCached :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m, Serialize a) + => Cached m GhcModState ChCacheData a -> m a +chCached c = do + root <- cradleRootDir <$> cradle + d <- cacheInputData root + withCabal $ cached root c d + where + cacheInputData root = do + opt <- options + return $ ( helperProgs opt + , root + , root "dist" + , (gmVer, chVer) + ) + + gmVer = GhcMod.version + chVer = VERSION_cabal_helper diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/GhcMod/Caching.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.Haskell.GhcMod.Caching ( + module Language.Haskell.GhcMod.Caching + , module Language.Haskell.GhcMod.Caching.Types + ) where + +import Control.Arrow (first) +import Control.Monad +import Control.Monad.Trans.Maybe +import Data.Maybe +import Data.Serialize (Serialize, encode, decode) +import Data.Version +import Data.Label +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import System.FilePath +import Utils (TimedFile(..), timeMaybe, mightExist) +import Paths_ghc_mod (version) + +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Caching.Types +import Language.Haskell.GhcMod.Logging + +-- | Cache a MonadIO action with proper invalidation. +cached :: forall m a d. (Gm m, MonadIO m, Serialize a, Eq d, Serialize 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 + tcfile <- liftIO $ timeMaybe (cacheFile cd) + case mcc of + Nothing -> + writeCache (TimedCacheFiles tcfile []) Nothing "cache missing or unreadable" + Just (ifs, d', a) | d /= d' -> do + tcf <- timeCacheInput dir (cacheFile cd) ifs + writeCache tcf (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d' + Just (ifs, _, a) -> do + tcf <- timeCacheInput dir (cacheFile cd) ifs + case invalidatingInputFiles tcf of + Just [] -> return a + Just _ -> writeCache tcf (Just a) "input files changed" + Nothing -> writeCache tcf (Just a) "cache missing, existed a sec ago WTF?" + + where + cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n" + + writeCache tcf ma cause = do + (ifs', a) <- (cachedAction cd) tcf d ma + 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 (ifs', d, a) + + liftIO $ BS.writeFile (dir cacheFile cd) $ + BS.append cacheHeader $ encode (ifs', d, a) + return a + + setLabel l x = do + s <- gmsGet + gmsPut $ set l x s + + readCache :: m (Maybe ([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 = do + f <- MaybeT $ liftIO $ mightExist $ cacheFile cd + readCacheFromFile' f + + 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 -> + return $ either (const Nothing) Just $ decode $ BS.drop 1 rest + _ -> return Nothing + +timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles +timeCacheInput dir cfile ifs = liftIO $ do + -- TODO: is checking the times this way around race free? + ins <- (timeMaybe . (dir )) `mapM` ifs + mtcfile <- timeMaybe cfile + return $ TimedCacheFiles mtcfile (catMaybes ins) + +invalidatingInputFiles :: TimedCacheFiles -> Maybe [FilePath] +invalidatingInputFiles tcf = + case tcCacheFile tcf of + Nothing -> Nothing + Just tcfile -> Just $ map tfPath $ + -- get input files older than tcfile + filter (tcfile<) $ tcFiles tcf diff --git a/Language/Haskell/GhcMod/Caching/Types.hs b/Language/Haskell/GhcMod/Caching/Types.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/GhcMod/Caching/Types.hs @@ -0,0 +1,52 @@ +module Language.Haskell.GhcMod.Caching.Types where + +import Utils +import Data.Label +import Data.Version +import Distribution.Helper + +type CacheContents d a = Maybe ([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 { + tcCacheFile :: Maybe TimedFile, + -- ^ 'cacheFile' timestamp + tcFiles :: [TimedFile] + -- ^ Timestamped files returned by the cached action + } + +type ChCacheData = (Programs, FilePath, FilePath, (Version, [Char])) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -8,17 +8,24 @@ import Data.Maybe (isJust) import qualified Data.Text as T import qualified Data.Text.IO as T (readFile) +import System.FilePath + 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 Outputable (PprStyle) +import qualified TyCon as Ty +import qualified Type as Ty +import Exception + import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.DynFlags 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 +import Language.Haskell.GhcMod.Doc +import Language.Haskell.GhcMod.Logging +import Language.Haskell.GhcMod.Types ---------------------------------------------------------------- -- CASE SPLITTING @@ -38,23 +45,29 @@ -> 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 +splits file lineNo colNo = + ghandle handler $ runGmlT' [Left file] deferErrors $ do + opt <- options + crdl <- cradle + style <- getStyle + dflag <- G.getSessionDynFlags + modSum <- Gap.fileModSummary (cradleCurrentDir crdl 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 + t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ + getTyCons dflag style varName varT) + return (fourInts bndLoc, t) + (TySplitInfo varName bndLoc (varLoc,varT)) -> do + let varName' = showName dflag style varName -- Convert name to string + t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ + getTyCons dflag style varName varT) + return (fourInts bndLoc, t) + where + handler (SomeException ex) = do + gmLog GmDebug "splits" $ + text "" $$ nest 4 (showDoc ex) + emptyResult =<< options ---------------------------------------------------------------- -- a. Code for getting the information of the variable @@ -79,7 +92,11 @@ 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 @@ -178,15 +195,16 @@ ---------------------------------------------------------------- -- c. Code for performing the case splitting -genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String +genCaseSplitTextFile :: (MonadIO m, GhcMonad m) => + FilePath -> SplitToTextInfo -> m String genCaseSplitTextFile file info = liftIO $ do - text <- T.readFile file - return $ getCaseSplitText (T.lines text) info + t <- T.readFile file + return $ getCaseSplitText (T.lines t) info getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String -getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS +getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS , sVarSpan = sVS, sTycons = sT }) = - let bindingText = getBindingText text sBS + 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 @@ -195,9 +213,9 @@ in T.unpack $ T.intercalate (T.pack "\n") (concat replaced') getBindingText :: [T.Text] -> SrcSpan -> [T.Text] -getBindingText text srcSpan = +getBindingText t srcSpan = let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan - lines_ = drop (sl - 1) $ take el text + lines_ = drop (sl - 1) $ take el t in if sl == el then -- only one line [T.drop (sc - 1) $ T.take ec $ head lines_] @@ -212,7 +230,7 @@ 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 = +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' @@ -222,7 +240,7 @@ 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 + [0 ..] t indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text] indentBindingTo bndLoc binds = diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -5,12 +5,12 @@ , expand ) where -import Control.Applicative ((<$>)) +import Control.Applicative +import Prelude import Language.Haskell.GhcMod.DynFlags import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Logger -import Language.Haskell.GhcMod.Monad (IOish, GhcModT) -import Language.Haskell.GhcMod.Target (setTargetFiles) +import Language.Haskell.GhcMod.Monad ---------------------------------------------------------------- @@ -29,15 +29,12 @@ 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 --} -check fileNames = - withLogger (setAllWarningFlags . setNoMaxRelevantBindings) $ - setTargetFiles fileNames +check files = + runGmlTWith + (map Left files) + return + ((fmap fst <$>) . withLogger setNoMaxRelevantBindings) + (return ()) ---------------------------------------------------------------- @@ -51,8 +48,10 @@ ---------------------------------------------------------------- -- | Expanding Haskell Template. -expand :: IOish m - => [FilePath] -- ^ The target files. - -> GhcModT m (Either String String) -expand fileNames = withLogger (Gap.setDumpSplices . setNoWarningFlags) $ - setTargetFiles fileNames +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/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-} +{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-} module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where -import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types -import Control.Applicative ((<$>)) +import Control.Applicative +import Prelude type Builder = String -> String @@ -23,11 +24,11 @@ inter _ [] = id inter c bs = foldr1 (\x y -> x . (c:) . y) bs -convert' :: (ToString a, IOish m) => a -> GhcModT m String +convert' :: (ToString a, IOish m, GmEnv m) => a -> 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 = LispStyle } x = toLisp opt x "\n" convert opt@Options { outputStyle = PlainStyle } x | str == "\n" = "" | otherwise = str @@ -35,8 +36,8 @@ str = toPlain opt x "\n" class ToString a where - toLisp :: Options -> a -> Builder - toPlain :: Options -> a -> Builder + toLisp :: Options -> a -> Builder + toPlain :: Options -> a -> Builder lineSep :: Options -> String lineSep opt = interpret lsep @@ -51,8 +52,8 @@ -- >>> toPlain defaultOptions "foo" "" -- "foo" instance ToString String where - toLisp opt = quote opt - toPlain opt = replace '\n' (lineSep opt) + toLisp opt = quote opt + toPlain opt = replace '\n' (lineSep opt) -- | -- @@ -61,9 +62,13 @@ -- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" -- "foo\nbar\nbaz" instance ToString [String] where - toLisp opt = toSexp1 opt - toPlain opt = inter '\n' . map (toPlain opt) + toLisp opt = toSexp1 opt + toPlain opt = inter '\n' . map (toPlain opt) +instance ToString [ModuleString] where + toLisp opt = toLisp opt . map getModuleString + toPlain opt = toPlain opt . map getModuleString + -- | -- -- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)] @@ -72,23 +77,23 @@ -- >>> 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) + 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 + 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 + 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] + 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) . (')' :) diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -1,19 +1,22 @@ module Language.Haskell.GhcMod.Cradle ( findCradle , findCradle' - , findCradleWithoutSandbox + , findSpecCradle , cleanupCradle ) where -import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils -import Control.Exception.IOChoice ((||>)) -import System.Directory (getCurrentDirectory, removeDirectoryRecursive) -import System.FilePath (takeDirectory) - +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Maybe +import Data.Maybe +import System.Directory +import System.FilePath +import Prelude ---------------------------------------------------------------- @@ -25,51 +28,62 @@ findCradle = findCradle' =<< getCurrentDirectory findCradle' :: FilePath -> IO Cradle -findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir +findCradle' dir = run $ do + (cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir) + where run a = fillTempDir =<< (fromJust <$> runMaybeT a) +findSpecCradle :: FilePath -> IO Cradle +findSpecCradle dir = do + let cfs = [cabalCradle, sandboxCradle] + cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs + gcs <- filterM isNotGmCradle cs + fillTempDir =<< case gcs of + [] -> fromJust <$> runMaybeT (plainCradle dir) + c:_ -> return c + where + isNotGmCradle :: Cradle -> IO Bool + isNotGmCradle crdl = do + not <$> doesFileExist (cradleRootDir crdl "ghc-mod.cabal") + cleanupCradle :: Cradle -> IO () cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl -cabalCradle :: FilePath -> IO Cradle +fillTempDir :: MonadIO m => Cradle -> m Cradle +fillTempDir crdl = do + tmpDir <- liftIO $ newTempDir (cradleRootDir crdl) + return crdl { cradleTempDir = tmpDir } + +cabalCradle :: FilePath -> MaybeT IO Cradle cabalCradle wdir = do - Just cabalFile <- findCabalFile wdir + cabalFile <- MaybeT $ findCabalFile wdir + let cabalDir = takeDirectory cabalFile - pkgDbStack <- getPackageDbStack cabalDir - tmpDir <- newTempDir cabalDir + return Cradle { - cradleCurrentDir = wdir + cradleProjectType = CabalProject + , cradleCurrentDir = wdir , cradleRootDir = cabalDir - , cradleTempDir = tmpDir + , cradleTempDir = error "tmpDir" , cradleCabalFile = Just cabalFile - , cradlePkgDbStack = pkgDbStack } -sandboxCradle :: FilePath -> IO Cradle +sandboxCradle :: FilePath -> MaybeT IO Cradle sandboxCradle wdir = do - Just sbDir <- getSandboxDb wdir - pkgDbStack <- getPackageDbStack sbDir - tmpDir <- newTempDir sbDir + sbDir <- MaybeT $ findCabalSandboxDir wdir return Cradle { - cradleCurrentDir = wdir + cradleProjectType = SandboxProject + , cradleCurrentDir = wdir , cradleRootDir = sbDir - , cradleTempDir = tmpDir + , cradleTempDir = error "tmpDir" , cradleCabalFile = Nothing - , cradlePkgDbStack = pkgDbStack } -plainCradle :: FilePath -> IO Cradle +plainCradle :: FilePath -> MaybeT IO Cradle plainCradle wdir = do - tmpDir <- newTempDir wdir - return Cradle { - cradleCurrentDir = wdir + return $ Cradle { + cradleProjectType = PlainProject + , cradleCurrentDir = wdir , cradleRootDir = wdir - , cradleTempDir = tmpDir + , cradleTempDir = error "tmpDir" , cradleCabalFile = Nothing - , cradlePkgDbStack = [GlobalDb, UserDb] } - --- Just for testing -findCradleWithoutSandbox :: IO Cradle -findCradleWithoutSandbox = do - cradle <- findCradle - return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -1,39 +1,127 @@ -module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where +module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where -import Control.Applicative ((<$>)) -import Data.List (intercalate) -import Data.Maybe (isJust, fromJust) +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.List.Split +import Text.PrettyPrint import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Internal +import Language.Haskell.GhcMod.Target +import Language.Haskell.GhcMod.Pretty +import Language.Haskell.GhcMod.Utils ---------------------------------------------------------------- -- | 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 +debugInfo = do + Options {..} <- options + Cradle {..} <- cradle + cabal <- + case cradleProjectType of + CabalProject -> cabalDebug + _ -> return [] + + pkgOpts <- packageGhcOptions + + return $ unlines $ + [ "Root directory: " ++ cradleRootDir + , "Current directory: " ++ cradleCurrentDir + , "GHC Package flags:\n" ++ render (nest 4 $ + fsep $ map text pkgOpts) + , "GHC System libraries: " ++ ghcLibDir + , "GHC user options:\n" ++ render (nest 4 $ + fsep $ map text ghcUserOptions) + ] ++ cabal + +cabalDebug :: IOish m => GhcModT m [String] +cabalDebug = 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 + + return $ + [ "Cabal file: " ++ show cradleCabalFile + , "Cabal entrypoints:\n" ++ render (nest 4 $ + mapDoc gmComponentNameDoc smpDoc entrypoints) + , "Cabal components:\n" ++ render (nest 4 $ + mapDoc gmComponentNameDoc graphDoc graphs) + , "GHC Cabal options:\n" ++ render (nest 4 $ + mapDoc gmComponentNameDoc (fsep . map text) opts) + , "GHC search path options:\n" ++ render (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" ++ render (nest 4 $ + alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs) + , "Picked Component:\n" ++ render (nest 4 $ + gmComponentNameDoc cn) + , "GHC Cabal options:\n" ++ render (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. diff --git a/Language/Haskell/GhcMod/Doc.hs b/Language/Haskell/GhcMod/Doc.hs --- a/Language/Haskell/GhcMod/Doc.hs +++ b/Language/Haskell/GhcMod/Doc.hs @@ -1,9 +1,8 @@ module Language.Haskell.GhcMod.Doc where -import GHC (DynFlags, GhcMonad) -import qualified GHC as G +import GHC import Language.Haskell.GhcMod.Gap (withStyle, showDocWith) -import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify) +import Outputable import Pretty (Mode(..)) showPage :: DynFlags -> PprStyle -> SDoc -> String @@ -12,9 +11,14 @@ showOneLine :: DynFlags -> PprStyle -> SDoc -> String showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style +-- showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String +-- showForUser dflags unqual sdoc = +-- showDocWith dflags PageMode $ +-- runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay + getStyle :: GhcMonad m => m PprStyle getStyle = do - unqual <- G.getPrintUnqual + unqual <- getPrintUnqual return $ mkUserStyle unqual AllTheWay styleUnqualified :: PprStyle diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs --- a/Language/Haskell/GhcMod/DynFlags.hs +++ b/Language/Haskell/GhcMod/DynFlags.hs @@ -2,7 +2,7 @@ module Language.Haskell.GhcMod.DynFlags where -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Monad (void) import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..)) import qualified GHC as G @@ -11,8 +11,7 @@ import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types import System.IO.Unsafe (unsafePerformIO) - -data Build = CabalPkg | SingleFile deriving Eq +import Prelude setEmptyLogger :: DynFlags -> DynFlags setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return () @@ -41,37 +40,15 @@ , 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) + fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts) where - tfst (a,_,_) = a + fst3 (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 @@ -119,3 +96,7 @@ #else setNoMaxRelevantBindings = id #endif + +deferErrors :: DynFlags -> Ghc DynFlags +deferErrors df = return $ + Gap.setWarnTypedHoles $ Gap.setDeferTypeErrors $ setNoWarningFlags df diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -1,67 +1,173 @@ -{-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-} +-- ghc-mod: Making Haskell development *more* fun +-- 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 Language.Haskell.GhcMod.Error ( GhcModError(..) + , GMConfigStateFileError(..) + , GmError , gmeDoc + , ghcExceptionDoc + , liftMaybe + , overrideError , modifyError , modifyError' + , modifyGmError , tryFix + , GHandler(..) + , gcatches , module Control.Monad.Error - , module Exception + , module Control.Exception ) where -import Control.Monad.Error (MonadError(..), Error(..)) +import Control.Arrow +import Control.Exception +import Control.Monad.Error hiding (MonadIO, liftIO) +import qualified Data.Set as Set import Data.List -import Data.Typeable -import Exception +import Data.Version +import System.Process (showCommandForUser) import Text.PrettyPrint +import Text.Printf -data GhcModError = GMENoMsg - -- ^ Unknown error - | GMEString String - -- ^ Some Error with a message. These are produced mostly by - -- 'fail' calls on GhcModT. - | GMEIOException IOException - -- ^ IOExceptions captured by GhcModT's MonadIO instance - | 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. - | GMENoCabalFile - -- ^ No cabal file found. - | GMETooManyCabalFiles [FilePath] - -- ^ Too many cabal files found. - deriving (Eq,Show,Typeable) +import Exception +import Panic +import Config (cProjectVersion, cHostPlatformString) +import Paths_ghc_mod (version) -instance Exception GhcModError +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Pretty -instance Error GhcModError where - noMsg = GMENoMsg - strMsg = GMEString +type GmError m = MonadError GhcModError m +gmCsfeDoc :: GMConfigStateFileError -> Doc +gmCsfeDoc GMConfigStateFileNoHeader = text $ + "Saved package config file header is missing. " + ++ "Try re-running the 'configure' command." + +gmCsfeDoc GMConfigStateFileBadHeader = text $ + "Saved package config file header is corrupt. " + ++ "Try re-running the 'configure' command." + +gmCsfeDoc GMConfigStateFileNoParse = text $ + "Saved package config file body is corrupt. " + ++ "Try re-running the 'configure' command." + +gmCsfeDoc GMConfigStateFileMissing = text $ + "Run the 'configure' command first." + +-- gmCsfeDoc (ConfigStateFileBadVersion oldCabal oldCompiler _) = text $ +-- "You need to re-run the 'configure' command. " +-- ++ "The version of Cabal being used has changed (was " +-- ++ display oldCabal ++ ", now " +-- ++ display currentCabalId ++ ")." +-- ++ badCompiler +-- where +-- badCompiler +-- | oldCompiler == currentCompilerId = "" +-- | otherwise = +-- " Additionally the compiler is different (was " +-- ++ display oldCompiler ++ ", now " +-- ++ display currentCompilerId +-- ++ ") which is probably the cause of the problem." + gmeDoc :: GhcModError -> Doc gmeDoc e = case e of GMENoMsg -> text "Unknown error" GMEString msg -> text msg - GMEIOException ioe -> - text $ show ioe GMECabalConfigure msg -> - text "cabal configure failed: " <> gmeDoc msg + text "Configuring cabal project failed: " <> gmeDoc msg GMECabalFlags msg -> - text "retrieval of the cabal configuration flags failed: " <> gmeDoc msg - GMEProcess cmd msg -> - text ("launching operating system process `"++unwords cmd++"` failed: ") - <> gmeDoc msg + text "Retrieval of the cabal configuration flags failed: " <> gmeDoc msg + GMECabalComponent cn -> + text "Cabal component " <> quotes (gmComponentNameDoc cn) + <> text " could not be found." + 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 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 (_out, _err, 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 ++"\"." + GMECabalStateFile csfe -> + gmCsfeDoc csfe +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 @@ -69,6 +175,24 @@ 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 fix = do - action `catchError` \e -> fix e >> action +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/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -11,7 +11,8 @@ import Data.Function (on) import Data.List (find, nub, sortBy) import qualified Data.Map as M -import Data.Maybe (isJust, catMaybes) +import Data.Maybe (catMaybes) +import Text.PrettyPrint (($$), text, nest) import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) @@ -19,8 +20,12 @@ import qualified Name as G import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils +import Language.Haskell.GhcMod.Logging (gmLog) +import Language.Haskell.GhcMod.Pretty (showDoc) +import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.Types import Outputable (PprStyle) import qualified Type as Ty @@ -31,6 +36,10 @@ import qualified Language.Haskell.Exts.Annotated as HE import Djinn.GHC +#if __GLASGOW_HASKELL__ >= 710 +import GHC (unLoc) +#endif + ---------------------------------------------------------------- -- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE ---------------------------------------------------------------- @@ -62,22 +71,27 @@ -> 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 +sig file lineNo colNo = + runGmlT' [Left file] deferErrors $ ghandle fallback $ do + opt <- options + style <- getStyle + dflag <- G.getSessionDynFlags + 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) + ("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)) + 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 - in (rTy, fourInts loc, [initial ++ initialFamBody dflag style name vars]) - - handler (SomeException _) = do + body = initialFamBody dflag style name vars + in (rTy, fourInts loc, [initial ++ body]) + where + fallback (SomeException _) = do opt <- options -- Code cannot be parsed by ghc module -- Fallback: try to get information via haskell-src-exts @@ -97,7 +111,11 @@ 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__ >= 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 @@ -125,9 +143,14 @@ G.TypeFamily -> Open G.DataFamily -> Data #endif -#if __GLASGOW_HASKELL__ >= 706 + +#if __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 @@ -144,7 +167,8 @@ return $ InstanceDecl loc cls -- Get signature from haskell-src-exts -getSignatureFromHE :: GhcMonad m => FilePath -> Int -> Int -> m (Maybe HESigInfo) +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 @@ -220,9 +244,11 @@ 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 + arglist + | isSymbolName fname -> + head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) + | otherwise -> + fname ++ " " ++ unwords arglist initialBodyArgs1 :: [FnArg] -> [String] -> [String] initialBodyArgs1 args elts = take (length args) elts @@ -238,12 +264,24 @@ 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 +#if __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 - (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy +#if __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 @@ -301,48 +339,61 @@ -> Int -- ^ Column number. -> Expression -- ^ A Haskell expression. -> GhcModT m String -refine file lineNo colNo expr = ghandle handler body +refine file lineNo colNo (Expression expr) = + ghandle handler $ + runGmlT' [Left file] deferErrors $ do + opt <- options + style <- getStyle + dflag <- G.getSessionDynFlags + 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 + txt = initialHead1 expr iArgs (infinitePrefixSupply name) + in (fourInts loc, doParen paren txt) 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 + handler (SomeException ex) = do + gmLog GmDebug "refining" $ + text "" $$ nest 4 (showDoc ex) + 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 + :: 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 + case lst of + e@(L _ (G.HsVar i)):others -> do + 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" @@ -366,10 +417,11 @@ -> Int -- ^ Line number. -> Int -- ^ Column number. -> GhcModT m String -auto file lineNo colNo = ghandle handler body - where - body = inModuleContext file $ \dflag style -> do +auto file lineNo colNo = + ghandle handler $ runGmlT' [Left file] deferErrors $ do opt <- options + style <- getStyle + dflag <- G.getSessionDynFlags modSum <- Gap.fileModSummary file p <- G.parseModule modSum tcm@TypecheckedModule { @@ -395,8 +447,11 @@ djinns <- djinn True (Just minfo) env rty (Max 10) 100000 return ( fourInts loc , map (doParen paren) $ nub (djinnsEmpty ++ djinns)) - - handler (SomeException _) = emptyResult =<< options + where + handler (SomeException ex) = do + gmLog GmDebug "auto-refining" $ + text "" $$ nest 4 (showDoc ex) + emptyResult =<< options -- Functions we do not want in completions notWantedFuns :: [String] @@ -443,7 +498,11 @@ #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", []) @@ -478,7 +537,13 @@ 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) + 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/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP, BangPatterns #-} +{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-} module Language.Haskell.GhcMod.Find #ifndef SPEC - ( - Symbol + ( Symbol , SymbolDb , loadSymbolDb , lookupSymbol @@ -15,65 +14,51 @@ #endif where -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Monad (when, void) import Data.Function (on) import Data.List (groupBy, sort) -import Data.Maybe (fromMaybe) import qualified GHC as G import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.Gap (listVisibleModules) import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils -import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.World (timedPackageCaches) +import Language.Haskell.GhcMod.Output import Name (getOccString) +import Module (moduleName) import System.Directory (doesFileExist, getModificationTime) -import System.FilePath ((), takeDirectory) +import System.FilePath (()) import System.IO - -#ifndef MIN_VERSION_containers -#define MIN_VERSION_containers(x,y,z) 1 -#endif +import Prelude -#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'\]. -data SymbolDb = SymbolDb { - table :: Map Symbol [ModuleString] - , packageCachePath :: FilePath +data SymbolDb = SymbolDb + { table :: Map Symbol [ModuleString] , symbolDbCachePath :: FilePath } deriving (Show) -isOutdated :: SymbolDb -> IO Bool -isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db - ----------------------------------------------------------------- - --- | 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" +isOutdated :: IOish m => SymbolDb -> GhcModT m Bool +isOutdated db = + (liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches ---------------------------------------------------------------- -- | 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 +findSymbol sym = do + tmpdir <- cradleTempDir <$> cradle + loadSymbolDb tmpdir >>= lookupSymbol sym -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] -- which will be concatenated. @@ -81,25 +66,25 @@ lookupSymbol sym db = convert' $ lookupSym sym db lookupSym :: Symbol -> SymbolDb -> [ModuleString] -lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db +lookupSym sym db = M.findWithDefault [] sym $ table db --------------------------------------------------------------- -- | Loading a file and creates 'SymbolDb'. -loadSymbolDb :: IOish m => GhcModT m SymbolDb -loadSymbolDb = do - ghcMod <- liftIO ghcModExecutable - tmpdir <- cradleTempDir <$> cradle - file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir] - !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) - return $ SymbolDb { - table = db - , packageCachePath = takeDirectory file packageCache - , symbolDbCachePath = file - } +loadSymbolDb :: IOish m => FilePath -> GhcModT m SymbolDb +loadSymbolDb dir = do + ghcMod <- liftIO ghcModExecutable + readProc <- gmReadProcess + file <- liftIO $ chop <$> readProc ghcMod ["dumpsym", dir] "" + !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) + return $ SymbolDb + { table = db + , symbolDbCachePath = file + } where - conv :: String -> (Symbol,[ModuleString]) + conv :: String -> (Symbol, [ModuleString]) conv = read + chop :: String -> String chop "" = "" chop xs = init xs @@ -112,54 +97,52 @@ dumpSymbol :: IOish m => FilePath -> GhcModT m String dumpSymbol dir = do - let cache = dir symbolCache - pkgdb = dir packageCache - - create <- liftIO $ cache `isOlderThan` pkgdb - when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable + create <- (liftIO . isOlderThan cache) =<< timedPackageCaches + runGmPkgGhc $ do + when create $ + liftIO . writeSymbolCache cache =<< getGlobalSymbolTable return $ unlines [cache] + where + cache = dir symbolCacheFile writeSymbolCache :: FilePath - -> [(Symbol,[ModuleString])] + -> [(Symbol, [ModuleString])] -> IO () writeSymbolCache cache sm = void . withFile cache WriteMode $ \hdl -> - mapM (hPrint hdl) sm - -isOlderThan :: FilePath -> FilePath -> IO Bool -isOlderThan cache file = do - exist <- doesFileExist cache - if not exist then - return True - else do - tCache <- getModificationTime cache - tFile <- getModificationTime file - return $ tCache <= tFile -- including equal just in case + mapM (hPrint hdl) sm --- | 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 +-- | Check whether given file is older than any file from the given set. +-- Returns True if given file does not exist. +isOlderThan :: FilePath -> [TimedFile] -> IO Bool +isOlderThan cache files = do + exist <- doesFileExist cache + if not exist + then return True + else do + tCache <- getModificationTime cache + return $ any (tCache <=) $ map tfTime files -- including equal just in case - return $ collectModules - $ extractBindings `concatMap` (moduleInfos `zip` modules) +-- | Browsing all functions in all system modules. +getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])] +getGlobalSymbolTable = do + df <- G.getSessionDynFlags + let mods = listVisibleModules df + moduleInfos <- mapM G.getModuleInfo mods + return $ collectModules + $ extractBindings `concatMap` (moduleInfos `zip` mods) -extractBindings :: (Maybe G.ModuleInfo, ModuleString) +extractBindings :: (Maybe G.ModuleInfo, G.Module) -> [(Symbol, ModuleString)] -extractBindings (Nothing,_) = [] -extractBindings (Just inf,mdlname) = - map (\name -> (getOccString name, mdlname)) names +extractBindings (Nothing, _) = [] +extractBindings (Just inf, mdl) = + map (\name -> (getOccString name, modStr)) names where - names = G.modInfoExports inf + names = G.modInfoExports inf + modStr = ModuleString $ moduleNameString $ moduleName mdl -collectModules :: [(Symbol,ModuleString)] - -> [(Symbol,[ModuleString])] +collectModules :: [(Symbol, ModuleString)] + -> [(Symbol, [ModuleString])] collectModules = map tieup . groupBy ((==) `on` fst) . sort where tieup x = (head (map fst x), map snd x) 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 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -13,7 +13,6 @@ , showSeverityCaption , setCabalPkg , setHideAllPackages - , addPackageFlags , setDeferTypeErrors , setWarnTypedHoles , setDumpSplices @@ -33,14 +32,15 @@ , fileModSummary , WarnFlags , emptyWarnFlags - , benchmarkBuildInfo - , benchmarkTargets - , toModuleString , GLMatch , GLMatchI , getClass , occName - , setFlags + , listVisibleModuleNames + , listVisibleModules + , lookupModulePackageInAllPackages + , Language.Haskell.GhcMod.Gap.isSynTyCon + , parseModuleHeader ) where import Control.Applicative hiding (empty) @@ -49,15 +49,15 @@ import Data.List (intersperse) import Data.Maybe (catMaybes) import Data.Time.Clock (UTCTime) +import Data.Traversable hiding (mapM) import DataCon (dataConRepType) import Desugar (deSugarExpr) import DynFlags import ErrUtils +import Exception import FastString import GhcMonad import HscTypes -import Language.Haskell.GhcMod.GHCChoice -import Language.Haskell.GhcMod.Types import NameSet import OccName import Outputable @@ -65,8 +65,8 @@ import StringBuffer import TcType import Var (varType) +import System.Directory -import qualified Distribution.PackageDescription as P import qualified InstEnv import qualified Pretty import qualified StringBuffer as SB @@ -88,11 +88,24 @@ 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) -import qualified Distribution.ModuleName as M (ModuleName,toFilePath) #endif +import Bag +import Lexer as L +import Parser +import SrcLoc +import Packages + +import Language.Haskell.GhcMod.Types (Expression(..)) +import Prelude + ---------------------------------------------------------------- ---------------------------------------------------------------- -- @@ -173,7 +186,11 @@ ---------------------------------------------------------------- fOptions :: [String] -#if __GLASGOW_HASKELL__ >= 704 +#if __GLASGOW_HASKELL__ >= 710 +fOptions = [option | (FlagSpec option _ _ _) <- fFlags] + ++ [option | (FlagSpec option _ _ _) <- fWarningFlags] + ++ [option | (FlagSpec option _ _ _) <- fLangFlags] +#elif __GLASGOW_HASKELL__ >= 704 fOptions = [option | (option,_,_) <- fFlags] ++ [option | (option,_,_) <- fWarningFlags] ++ [option | (option,_,_) <- fLangFlags] @@ -187,9 +204,11 @@ ---------------------------------------------------------------- fileModSummary :: GhcMonad m => FilePath -> m ModSummary -fileModSummary file = do +fileModSummary file' = do mss <- getModuleGraph - let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss + file <- liftIO $ canonicalizePath file' + [ms] <- liftIO $ flip filterM mss $ \m -> + (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m) return ms withContext :: GhcMonad m => m a -> m a @@ -202,26 +221,31 @@ action topImports = do mss <- getModuleGraph - ms <- map modName <$> filterM isTop mss + mns <- map modName <$> filterM isTop mss + let ii = map IIModule mns #if __GLASGOW_HASKELL__ >= 704 - return ms + return ii #else - return (ms,[]) + return (ii,[]) #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 + modName = moduleName . ms_mod setCtx = setContext #elif __GLASGOW_HASKELL__ >= 704 - modName = IIModule . ms_mod + modName = ms_mod setCtx = setContext #else modName = ms_mod setCtx = uncurry setContext #endif +-- | Try the left action, if an IOException occurs try the right action. +(||>) :: ExceptionMonad m => m a -> m a -> m a +x ||> y = x `gcatch` (\(_ :: IOException) -> y) + showSeverityCaption :: Severity -> String #if __GLASGOW_HASKELL__ >= 706 showSeverityCaption SevWarning = "Warning: " @@ -249,12 +273,6 @@ 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 @@ -310,8 +328,8 @@ where implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] -infoThing :: GhcMonad m => String -> m SDoc -infoThing str = do +infoThing :: GhcMonad m => Expression -> m SDoc +infoThing (Expression str) = do names <- parseName str #if __GLASGOW_HASKELL__ >= 708 mb_stuffs <- mapM (getInfo False) names @@ -413,29 +431,6 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -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) @@ -445,8 +440,13 @@ #endif getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) -#if __GLASGOW_HASKELL__ >= 708 +#if __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) @@ -465,11 +465,73 @@ #endif ---------------------------------------------------------------- ----------------------------------------------------------------- -setFlags :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setFlags df = df `gopt_unset` Opt_SpecConstr -- consume memory if -O2 +#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 -setFlags = id + 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) diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -4,55 +4,29 @@ , ghcPkgDbStackOpts , ghcDbStackOpts , ghcDbOpt - , fromInstalledPackageId - , fromInstalledPackageId' , getPackageDbStack , getPackageCachePaths ) where import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) -import Control.Applicative ((<$>)) -import Data.List (intercalate) +import Control.Applicative import Data.List.Split (splitOn) import Data.Maybe -import Distribution.Package (InstalledPackageId(..)) import Exception (handleIO) -import Language.Haskell.GhcMod.PathsAndFiles -import Language.Haskell.GhcMod.Types import System.Directory (doesDirectoryExist, getAppUserDataDirectory) import System.FilePath (()) +import Prelude +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.CabalHelper +import Language.Haskell.GhcMod.PathsAndFiles + ghcVersion :: Int ghcVersion = read cProjectVersionInt -getPackageDbStack :: FilePath -- ^ Project Directory (where the - -- cabal.sandbox.config file would be if it - -- exists) - -> IO [GhcPkgDb] -getPackageDbStack cdir = do - mSDir <- getSandboxDb cdir - return $ [GlobalDb] ++ case mSDir of - Nothing -> [UserDb] - Just db -> [PackageDb db] - ---------------------------------------------------------------- -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] @@ -85,11 +59,24 @@ ---------------------------------------------------------------- - -getPackageCachePaths :: FilePath -> Cradle -> IO [FilePath] -getPackageCachePaths sysPkgCfg crdl = - catMaybes <$> resolvePackageConfig sysPkgCfg `mapM` cradlePkgDbStack crdl +getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb] +getPackageDbStack = do + crdl <- cradle + mCusPkgStack <- getCustomPkgDbStack + stack <- case cradleProjectType crdl of + PlainProject -> + return [GlobalDb, UserDb] + SandboxProject -> do + Just db <- liftIO $ getSandboxDb $ cradleRootDir crdl + return $ [GlobalDb, db] + CabalProject -> + getCabalPackageDbStack + 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 :/ diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -0,0 +1,263 @@ +-- ghc-mod: Making Haskell development *more* fun +-- 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 Language.Haskell.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 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 Prelude + +import Language.Haskell.GhcMod.Logging +import Language.Haskell.GhcMod.Logger +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Types +import Language.Haskell.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, GmLog m, GmEnv 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, GmLog m, GmEnv 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, GmLog m, GmEnv 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) $ Monoid.mempty $+$ (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 + liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns + +preprocessFile :: MonadIO m => + HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath))) +preprocessFile env file = + liftIO $ withLogger' env $ \setDf -> do + let env' = env { hsc_dflags = setDf (hsc_dflags env) } + preprocess env' (file, Nothing) + +fileModuleName :: + HscEnv -> FilePath -> IO (Either [String] (Maybe ModuleName)) +fileModuleName env fn = handle (\(_ :: SomeException) -> return $ Right Nothing) $ do + ep <- preprocessFile env fn + case ep of + Left errs -> do + return $ Left errs + Right (_warns, (dflags, procdFile)) -> do + src <- readFile procdFile + case parseModuleHeader src dflags procdFile of + Left errs -> do + return $ Left $ errBagToStrList env errs + Right (_, lmdl) -> do + let HsModule {..} = unLoc lmdl + return $ Right $ unLoc <$> hsmodName diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -3,20 +3,25 @@ , types ) where -import Control.Applicative ((<$>)) +import Control.Applicative import Data.Function (on) import Data.List (sortBy) import Data.Maybe (catMaybes) +import System.FilePath import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) +import Prelude 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.Convert +import Language.Haskell.GhcMod.Doc +import Language.Haskell.GhcMod.DynFlags +import Language.Haskell.GhcMod.Gap +import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Convert ---------------------------------------------------------------- @@ -25,15 +30,23 @@ => FilePath -- ^ A target file. -> Expression -- ^ A Haskell expression. -> GhcModT m String -info file expr = do - opt <- options - convert opt <$> ghandle handler body +info file expr = + ghandle handler $ + runGmlT' [Left file] deferErrors $ + withContext $ + convert <$> options <*> body where - body = inModuleContext file $ \dflag style -> do - sdoc <- Gap.infoThing expr - return $ showPage dflag style sdoc - handler (SomeException _) = return "Cannot show info" + handler (SomeException ex) = do + gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex) + convert' "Cannot show info" + body :: GhcMonad m => m String + body = do + sdoc <- Gap.infoThing expr + st <- getStyle + dflag <- G.getSessionDynFlags + return $ showPage dflag st sdoc + ---------------------------------------------------------------- -- | Obtaining type of a target expression. (GHCi's type:) @@ -42,24 +55,29 @@ -> 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 +types file lineNo colNo = + ghandle handler $ + runGmlT' [Left file] deferErrors $ + withContext $ do + crdl <- cradle + modSum <- Gap.fileModSummary (cradleCurrentDir crdl file) srcSpanTypes <- getSrcSpanType modSum lineNo colNo - return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes - handler (SomeException _) = return [] + dflag <- G.getSessionDynFlags + st <- getStyle + convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes + where + handler (SomeException ex) = do + gmLog GmException "types" $ showDoc ex + 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] + 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 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -8,35 +8,33 @@ , PackageVersion , PackageId , IncludeDir - , CompilerOptions(..) - -- * Cabal API - , parseCabalFile - , getCompilerOptions - , cabalAllBuildInfo - , cabalDependPackages - , cabalSourceDirs - , cabalAllTargets + , GmlT(..) + , MonadIO(..) + , GmEnv(..) -- * Various Paths , ghcLibDir , ghcModExecutable - -- * IO - , getDynamicFlags - -- * Targets - , setTargetFiles -- * Logging , withLogger , setNoWarningFlags , setAllWarningFlags -- * Environment, state and logging , GhcModEnv(..) - , newGhcModEnv , GhcModState - , defaultState , CompilerMode(..) , GhcModLog + , GmLog(..) + , GmLogLevel(..) + , gmSetLogLevel -- * Monad utilities , runGhcModT' , hoistGhcModT + , runGmlT + , runGmlT' + , gmlGetSession + , gmlSetSession + , loadTargets + , cabalResolvedComponents -- ** Accessing 'GhcModEnv' and 'GhcModState' , options , cradle @@ -45,28 +43,33 @@ , withOptions -- * 'GhcModError' , gmeDoc - -- * 'GhcMonad' Choice - , (||>) - , goNext - , runAnyOne -- * World , World , getCurrentWorld , didWorldChange + -- * Cabal Helper + , ModulePath(..) + , GmComponent(..) + , GmComponentType(..) + , GmModuleGraph(..) + , prepareCabalHelper + -- * Misc stuff + , GHandler(..) + , gcatches ) where import GHC.Paths (libdir) -import Language.Haskell.GhcMod.CabalApi +import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Error -import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.Logger +import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World +import Language.Haskell.GhcMod.CabalHelper -- | Obtaining the directory for ghc system libraries. ghcLibDir :: FilePath diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -1,31 +1,33 @@ -{-# LANGUAGE CPP #-} - module Language.Haskell.GhcMod.Logger ( withLogger - , withLoggerTwice + , withLogger' , checkErrorPrefix + , errsToStr + , errBagToStrList ) where -import Bag (Bag, bagToList, emptyBag, consBag, filterBag, unionBags) -import Control.Applicative ((<$>)) +import Control.Arrow +import Control.Applicative +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) 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 System.FilePath (normalise) +import Text.PrettyPrint + +import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo) import GHC (DynFlags, SrcSpan, Severity(SevError)) +import HscTypes +import Outputable 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) +import Bag ----------------------------------------------------------------- +import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.Doc (showPage) +import Language.Haskell.GhcMod.DynFlags (withDynFlags) +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Error +import qualified Language.Haskell.GhcMod.Gap as Gap +import Prelude type Builder = [String] -> [String] @@ -39,178 +41,94 @@ newLogRef :: IO LogRef newLogRef = LogRef <$> newIORef emptyLog -readAndClearLogRef :: IOish m => LogRef -> GhcModT m String +readAndClearLogRef :: LogRef -> IO [String] readAndClearLogRef (LogRef ref) = do - Log _ b <- liftIO $ readIORef ref - liftIO $ writeIORef ref emptyLog - convert' (b []) + Log _ b <- readIORef ref + writeIORef ref emptyLog + return $ b [] appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () -appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update +appendLogRef df (LogRef ref) _ sev src st msg = modifyIORef ref update where - l = ppMsg src sev df style msg + l = ppMsg src sev df st 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 +withLogger :: (GmGhc m, GmEnv 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 + -> m a + -> m (Either String (String, a)) +withLogger f action = do + env <- G.getSession + opts <- options + let conv = convert opts + eres <- withLogger' env $ \setDf -> + withDynFlags (f . setDf) action + return $ either (Left . conv) (Right . first conv) eres ----------------------------------------------------------------- +withLogger' :: IOish m + => HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a)) +withLogger' env action = do + logref <- liftIO $ newLogRef --- | Converting 'SourceError' to 'String'. -sourceError :: IOish m => SourceError -> GhcModT m (Either String String) -sourceError err = errBagToStr (srcErrorMessages err) + let dflags = hsc_dflags env + pu = icPrintUnqual dflags (hsc_IC env) + st = mkUserStyle pu AllTheWay -errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String) -errBagToStr = errBagToStr' Left + fn df = setLogger logref df -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 + a <- gcatches (Right <$> action fn) (handlers dflags st) + ls <- liftIO $ readAndClearLogRef logref -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 + return $ ((,) ls <$> a) -errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] -errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList + where + setLogger logref df = Gap.setLogAction df $ appendLogRef df logref + handlers df st = [ + GHandler $ \ex -> return $ Left $ sourceError df st ex, + GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex] + ] -warnBagToStrList :: DynFlags -> PprStyle -> Bag WarnMsg -> [String] -warnBagToStrList dflag style = map (ppWarnMsg dflag style) . reverse . bagToList +errBagToStrList :: HscEnv -> Bag ErrMsg -> [String] +errBagToStrList env errs = let + dflags = hsc_dflags env + pu = icPrintUnqual dflags (hsc_IC env) + st = mkUserStyle pu AllTheWay + in errsToStr dflags st $ bagToList errs -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) +-- | Converting 'SourceError' to 'String'. +sourceError :: DynFlags -> PprStyle -> SourceError -> [String] +sourceError df st src_err = errsToStr df st $ reverse $ bagToList $ srcErrorMessages src_err -isHoleMsg :: String -> Bool -isHoleMsg = isInfixOf "Found hole" +errsToStr :: DynFlags -> PprStyle -> [ErrMsg] -> [String] +errsToStr df st = map (ppErrMsg df st) ---------------------------------------------------------------- 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) +ppErrMsg dflag st err = + ppMsg spn SevError dflag st msg ++ (if null ext then "" else "\n" ++ ext) where spn = Gap.errorMsgSpan err msg = errMsgShortDoc err - ext = showPage dflag style (errMsgExtraInfo err) + ext = showPage dflag st (errMsgExtraInfo err) ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String -ppMsg spn sev dflag style msg = prefix ++ cts +ppMsg spn sev dflag st msg = prefix ++ cts where - cts = showPage dflag style msg - prefix = ppMsgPrefix spn sev dflag style cts + cts = showPage dflag st msg + prefix = ppMsgPrefix spn sev dflag st cts ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String -ppMsgPrefix spn sev dflag _style cts = +ppMsgPrefix spn sev dflag _st cts = let defaultPrefix | Gap.isDumpSplices dflag = "" | otherwise = checkErrorPrefix diff --git a/Language/Haskell/GhcMod/Logging.hs b/Language/Haskell/GhcMod/Logging.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/GhcMod/Logging.hs @@ -0,0 +1,102 @@ +-- ghc-mod: Making Haskell development *more* fun +-- 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 Language.Haskell.GhcMod.Logging ( + module Language.Haskell.GhcMod.Logging + , module Language.Haskell.GhcMod.Pretty + , GmLogLevel(..) + , module Text.PrettyPrint + , module Data.Monoid + ) 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 Text.PrettyPrint hiding (style, (<>)) +import Prelude + +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Pretty +import Language.Haskell.GhcMod.Output + +gmSetLogLevel :: GmLog m => GmLogLevel -> m () +gmSetLogLevel level = + gmlJournal $ GhcModLog (Just level) (Last Nothing) [] + +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, GmEnv m) => GmLogLevel -> String -> Doc -> m () +gmLog level loc' doc = do + GhcModLog { gmLogLevel = Just level' } <- gmlHistory + + let loc | loc' == "" = empty + | otherwise = text loc' <+>: empty + msgDoc = gmLogLevelDoc level <+>: sep [loc, doc] + msg = dropWhileEnd isSpace $ gmRenderDoc msgDoc + + when (level <= level') $ gmErrStrLn msg + + gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)]) + +gmVomit :: (MonadIO m, GmLog 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/Language/Haskell/GhcMod/Modules.hs b/Language/Haskell/GhcMod/Modules.hs --- a/Language/Haskell/GhcMod/Modules.hs +++ b/Language/Haskell/GhcMod/Modules.hs @@ -1,32 +1,26 @@ 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 Control.Arrow +import Data.List import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types -import Packages (pkgIdMap, exposedModules, sourcePackageId, display) -import UniqFM (eltsUFM) +import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Gap ( listVisibleModuleNames + , lookupModulePackageInAllPackages + ) +import qualified GHC as G + ---------------------------------------------------------------- -- | Listing installed modules. -modules :: IOish m => GhcModT m String +modules :: (IOish m, GmEnv m, GmState m, GmLog m) => 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 [] + Options { detailed } <- options + 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/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -1,289 +1,100 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} -{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +-- ghc-mod: Making Haskell development *more* fun +-- 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 Language.Haskell.GhcMod.Monad ( - -- * Monad Types - GhcModT - , IOish - -- ** Environment, state and logging - , GhcModEnv(..) - , newGhcModEnv - , GhcModState(..) - , defaultState - , CompilerMode(..) - , GhcModLog - , GhcModError(..) - -- * Monad utilities - , runGhcModT + runGhcModT , 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 + , runGmlT + , runGmlT' + , runGmlTWith + , runGmPkgGhc + , withGhcModEnv + , withGhcModEnv' + , module Language.Haskell.GhcMod.Monad.Types ) 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.Monad.Types import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.Logging 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 Language.Haskell.GhcMod.Target +import Language.Haskell.GhcMod.Output -import Control.Applicative (Alternative) import Control.Arrow (first) -import Control.Monad (MonadPlus, void) -#if !MIN_VERSION_monad_control(1,0,0) -import Control.Monad (liftM) -#endif -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 (isJust) -import Data.IORef (IORef, readIORef, writeIORef, newIORef) -import System.Directory (getCurrentDirectory) - ----------------------------------------------------------------- - -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 $ try action - case res of - Right a -> return a - - Left e | isIOError e -> - throwError $ GMEIOException (fromEx e :: IOError) - Left e | isGhcModError e -> - throwError $ (fromEx e :: GhcModError) - Left e -> throw e - - where - fromEx :: Exception e => SomeException -> e - fromEx se = let Just e = fromException se in e - isIOError se = - case fromException se of - Just (_ :: IOError) -> True - Nothing -> False - - isGhcModError se = - case fromException se of - Just (_ :: GhcModError) -> True - Nothing -> False - - -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 +import Control.Applicative -instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where - liftIO = lift . liftIO +import Control.Concurrent -instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where - liftIO = lift . liftIO +import Control.Monad.Reader (runReaderT) +import Control.Monad.State.Strict (runStateT) +import Control.Monad.Trans.Journal (runJournalT) -instance MonadIO m => MonadIO (MaybeT m) where - liftIO = lift . liftIO -#endif +import Exception (ExceptionMonad(..)) ----------------------------------------------------------------- +import System.Directory +import Prelude --- | 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 - mCabalFile = cradleCabalFile c - cabal = isJust mCabalFile - ghcopts = ghcUserOptions opt - withCabal = do - let Just cabalFile = mCabalFile - pkgDesc <- parseCabalFile c cabalFile - 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 +withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a +withCradle cradledir f = + gbracket (liftIO $ findCradle' cradledir) (liftIO . cleanupCradle) f -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) +withGhcModEnv :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a +withGhcModEnv dir opt f = withCradle dir (withGhcModEnv' opt f) ----------------------------------------------------------------- +withGhcModEnv' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a +withGhcModEnv' opt f crdl = do + olddir <- liftIO getCurrentDirectory + c <- liftIO newChan + let outp = case linePrefix opt of + Just _ -> GmOutputChan c + Nothing -> GmOutputStdio + gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opt crdl outp) + where + setup c = liftIO $ do + setCurrentDirectory $ cradleRootDir crdl + forkIO $ stdoutGateway c -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 - } + teardown olddir tid = liftIO $ do + setCurrentDirectory olddir + killThread tid -cleanupGhcModEnv :: GhcModEnv -> IO () -cleanupGhcModEnv env = cleanupCradle $ gmCradle env + gbracket_ ma mb mc = gbracket ma mb (const mc) -- | Run a @GhcModT m@ computation. runGhcModT :: IOish m => Options -> GhcModT m a -> m (Either GhcModError a, GhcModLog) -runGhcModT opt action = gbracket newEnv delEnv $ \env -> do - r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do - dflags <- getSessionDynFlags - defaultCleanupHandler dflags $ do - initializeFlagsWithCradle opt (gmCradle env) - action) - return r +runGhcModT opt action = do + dir <- liftIO getCurrentDirectory + runGhcModT' dir opt action - where - newEnv = liftBase $ newGhcModEnv opt =<< getCurrentDirectory - delEnv = liftBase . cleanupGhcModEnv +runGhcModT' :: IOish m + => FilePath + -> Options + -> GhcModT m a + -> m (Either GhcModError a, GhcModLog) +runGhcModT' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> + withGhcModEnv dir' opt $ \env -> + first (fst <$>) <$> runGhcModT'' env defaultGhcModState + (gmSetLogLevel (logLevel opt) >> action) -- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT -- computation. Note that if the computation that returned @result@ modified the @@ -292,7 +103,7 @@ => (Either GhcModError a, GhcModLog) -> GhcModT m a hoistGhcModT (r,l) = do - GhcModT (lift $ lift $ journal l) >> case r of + gmlJournal l >> case r of Left e -> throwError e Right a -> return a @@ -301,179 +112,10 @@ -- 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 - -#if MIN_VERSION_monad_control(1,0,0) - -instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where - type StM (GhcModT m) a = - StM (StateT GhcModState - (ErrorT GhcModError - (JournalT GhcModLog - (ReaderT GhcModEnv m) ) ) ) a - liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> - f $ runInBase . unGhcModT - - restoreM = GhcModT . restoreM - {-# INLINE liftBaseWith #-} - {-# INLINE restoreM #-} - -#else - -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 #-} - -#endif - --- 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 +runGhcModT'' :: IOish m + => GhcModEnv + -> GhcModState + -> GhcModT m a + -> m (Either GhcModError (a, GhcModState), GhcModLog) +runGhcModT'' r s a = do + flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGhcModT a) s diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -0,0 +1,442 @@ +-- ghc-mod: Making Haskell development *more* fun +-- 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 Language.Haskell.GhcMod.Monad.Types ( + -- * Monad Types + GhcModT(..) + , GmlT(..) + , LightGhc(..) + , GmGhc + , IOish + -- * Environment, state and logging + , GhcModEnv(..) + , GhcModState(..) + , GhcModCaches(..) + , defaultGhcModState + , GmGhcSession(..) + , GmComponent(..) + , CompilerMode(..) + -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog' + , GmLogLevel(..) + , GhcModLog(..) + , GhcModError(..) + , Gm + , GmEnv(..) + , GmState(..) + , GmLog(..) + , cradle + , options + , withOptions + , getCompilerMode + , setCompilerMode + -- * Re-exporting convenient stuff + , MonadIO + , liftIO + , gmlGetSession + , gmlSetSession + ) where + +-- 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 + +import Language.Haskell.GhcMod.Types + +import GHC +import DynFlags +import Exception +import HscTypes + +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.Trans.Maybe (MaybeT(..)) + +import Control.Monad.Base (MonadBase(..), liftBase) +import Control.Monad.Trans.Control + +import Control.Monad.Reader.Class +import Control.Monad.Writer.Class +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Journal.Class (MonadJournal(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Error (Error(..)) +import qualified Control.Monad.IO.Class as MTL + +#if DIFFERENT_MONADIO +import Data.Monoid (Monoid) +#endif + +import Data.Maybe +import Data.Monoid +import Data.IORef +import Prelude + +import qualified MonadUtils as GHC (MonadIO(..)) + +-- | 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 + , MTL.MonadIO +#if DIFFERENT_MONADIO + , GHC.MonadIO +#endif + , MonadError GhcModError + ) + +newtype GmlT m a = GmlT { unGmlT :: GhcModT m a } + deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadTrans + , MTL.MonadIO +#if DIFFERENT_MONADIO + , GHC.MonadIO +#endif + , MonadError GhcModError + , GmEnv + , GmState + , GmLog + ) + +newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a } + deriving ( Functor + , Applicative + , Monad + , MTL.MonadIO +#if DIFFERENT_MONADIO + , GHC.MonadIO +#endif + ) + +#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 +#endif + +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 (GhcModT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GmlT m) where + liftIO = MTL.liftIO +instance MonadIO LightGhc where + liftIO = MTL.liftIO + +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 #-} + +type Gm m = (GmEnv m, GmState m, GmLog m) + +instance Monad m => GmEnv (GhcModT m) where + gmeAsk = GhcModT ask + gmeReader = GhcModT . reader + gmeLocal f a = GhcModT $ local f (unGhcModT a) + +instance GmEnv m => GmEnv (StateT s m) where + gmeAsk = lift gmeAsk + gmeReader = lift . gmeReader + gmeLocal f (StateT a) = StateT $ \s -> gmeLocal f (a s) + +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 Monad m => GmState (StateT GhcModState m) where + gmsGet = get + gmsPut = put + gmsState = state + +instance Monad m => GmState (GhcModT m) where + gmsGet = GhcModT get + gmsPut = GhcModT . put + gmsState = GhcModT . state + +instance GmState m => GmState (MaybeT m) where + gmsGet = MaybeT $ Just `liftM` gmsGet + gmsPut = MaybeT . (Just `liftM`) . gmsPut + gmsState = MaybeT . (Just `liftM`) . gmsState + +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 (GhcModT m) where + gmlJournal = GhcModT . lift . lift . journal + gmlHistory = GhcModT $ lift $ lift history + gmlClear = GhcModT $ 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 => MonadJournal GhcModLog (GhcModT m) where + journal !w = GhcModT $ lift $ lift $ (journal w) + history = GhcModT $ lift $ lift $ history + clear = GhcModT $ lift $ lift $ clear + +instance MonadTrans GhcModT where + lift = GhcModT . lift . lift . lift . lift + +instance forall r m. MonadReader r m => MonadReader r (GhcModT m) where + local f ma = gmLiftWithInner (\run -> local f (run ma)) + ask = gmLiftInner ask + +instance (Monoid w, MonadWriter w m) => MonadWriter w (GhcModT m) where + tell = gmLiftInner . tell + listen ma = + liftWith (\run -> listen (run ma)) >>= \(sta, w) -> + flip (,) w `liftM` restoreT (return sta) + + pass maww = maww >>= gmLiftInner . pass . return + +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 + +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 (GhcModT m) a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadTransControl GmlT where + type StT GmlT a = StT GhcModT a + liftWith = defaultLiftWith GmlT unGmlT + restoreT = defaultRestoreT GmlT + +instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where + liftBase = GhcModT . liftBase + +instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where + type StM (GhcModT m) a = + StM (StateT GhcModState + (ErrorT GhcModError + (JournalT GhcModLog + (ReaderT GhcModEnv m) ) ) ) a + + liftBaseWith f = GhcModT (liftBaseWith $ \runInBase -> + f $ runInBase . unGhcModT) + + restoreM = GhcModT . restoreM + {-# INLINE liftBaseWith #-} + {-# INLINE restoreM #-} + +instance MonadTransControl GhcModT where + type StT GhcModT a = (Either GhcModError (a, GhcModState), GhcModLog) + + liftWith f = GhcModT $ + liftWith $ \runS -> + liftWith $ \runE -> + liftWith $ \runJ -> + liftWith $ \runR -> + f $ \ma -> runR $ runJ $ runE $ runS $ unGhcModT ma + restoreT = GhcModT . restoreT . restoreT . restoreT . restoreT + {-# INLINE liftWith #-} + {-# INLINE restoreT #-} + +gmLiftInner :: Monad m => m a -> GhcModT m a +gmLiftInner = GhcModT . 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 + +-- 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 + +-- --------------------------------------------------------------------- + +gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv +gmlGetSession = do + ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet + GHC.liftIO $ readIORef ref + +gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m () +gmlSetSession a = do + ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet + GHC.liftIO $ flip writeIORef a ref + +-- --------------------------------------------------------------------- +instance GhcMonad LightGhc where + getSession = (GHC.liftIO . readIORef) =<< LightGhc ask + setSession a = (GHC.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 (GhcModT 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 + +---------------------------------------------------------------- + +options :: GmEnv m => m Options +options = gmOptions `liftM` gmeAsk + +cradle :: GmEnv m => m Cradle +cradle = gmCradle `liftM` gmeAsk + +getCompilerMode :: GmState m => m CompilerMode +getCompilerMode = gmCompilerMode `liftM` gmsGet + +setCompilerMode :: GmState m => CompilerMode -> m () +setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet + +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/Language/Haskell/GhcMod/Output.hs b/Language/Haskell/GhcMod/Output.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/GhcMod/Output.hs @@ -0,0 +1,199 @@ +-- ghc-mod: Making Haskell development *more* fun +-- 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 + +module Language.Haskell.GhcMod.Output ( + gmPutStr + , gmErrStr + , gmPutStrLn + , gmErrStrLn + , gmUnsafePutStrLn + , gmUnsafeErrStrLn + , gmReadProcess + , stdoutGateway + ) where + +import Data.List +import System.IO +import System.Exit +import System.Process +import Control.Monad +import Control.DeepSeq +import Control.Exception +import Control.Concurrent + +import Language.Haskell.GhcMod.Types hiding (LineSeparator) +import Language.Haskell.GhcMod.Monad.Types + +withLines :: (String -> String) -> String -> String +withLines f s = let + res = unlines $ map f $ lines s + in + case s of + [] -> res + _ | not $ isTerminated s -> + reverse $ drop 1 $ reverse res + _ -> res + +isTerminated :: String -> Bool +isTerminated "" = False +isTerminated s = isNewline (last s) + +isNewline :: Char -> Bool +isNewline c = c == '\n' + +toGmLines :: String -> (GmLines String) +toGmLines "" = GmLines GmPartial "" +toGmLines s | isNewline (last s) = GmLines GmTerminated s +toGmLines s = GmLines GmPartial s + +outputFns :: (GmEnv m, MonadIO m') + => m (GmLines String -> m' (), GmLines String -> m' ()) +outputFns = do + opts <- options + env <- gmeAsk + return $ outputFns' opts (gmOutput env) + +outputFns' :: MonadIO m' + => Options + -> GmOutput + -> (GmLines String -> m' (), GmLines String -> m' ()) +outputFns' opts output = let + Options {..} = opts + + pfx f = withLines f + + outPfx, errPfx :: GmLines String -> GmLines String + (outPfx, errPfx) = + case linePrefix of + Nothing -> ( id, id ) + Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) ) + in + case output of + GmOutputStdio -> + ( liftIO . putStr . unGmLine . outPfx + , liftIO . hPutStr stderr . unGmLine . errPfx) + GmOutputChan c -> + ( liftIO . writeChan c . (,) GmOut . outPfx + , liftIO . writeChan c . (,) GmErr .errPfx) + +gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn + :: (MonadIO m, GmEnv m) => String -> m () + +gmPutStr str = do + putOut <- fst `liftM` outputFns + putOut $ toGmLines str + +gmPutStrLn = gmPutStr . (++"\n") +gmErrStrLn = gmErrStr . (++"\n") + +gmErrStr str = do + putErr <- snd `liftM` outputFns + putErr $ toGmLines str + +-- | Only use these when you're sure there are no other writers on stdout +gmUnsafePutStrLn, gmUnsafeErrStrLn + :: MonadIO m => Options -> String -> m () +gmUnsafePutStrLn opts = (fst $ outputFns' opts GmOutputStdio) . toGmLines +gmUnsafeErrStrLn opts = (snd $ outputFns' opts GmOutputStdio) . toGmLines + +gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String) +gmReadProcess = do + GhcModEnv {..} <- gmeAsk + case gmOutput of + GmOutputChan _ -> + readProcessStderrChan + GmOutputStdio -> + return $ readProcess + +stdoutGateway :: Chan (GmStream, GmLines String) -> IO () +stdoutGateway chan = go ("", "") + where + go buf@(obuf, ebuf) = do + (stream, GmLines ty l) <- readChan chan + case ty of + GmTerminated -> + case stream of + GmOut -> putStr (obuf++l) >> go ("", ebuf) + GmErr -> putStr (ebuf++l) >> go (obuf, "") + GmPartial -> case reverse $ lines l of + [] -> go buf + [x] -> go (appendBuf stream buf x) + x:xs -> do + putStr $ unlines $ reverse xs + go (appendBuf stream buf x) + + appendBuf GmOut (obuf, ebuf) s = (obuf++s, ebuf) + appendBuf GmErr (obuf, ebuf) s = (obuf, ebuf++s) + + +readProcessStderrChan :: + GmEnv m => m (FilePath -> [String] -> String -> IO String) +readProcessStderrChan = do + (_, e) <- outputFns + return $ go e + where + go :: (GmLines String -> IO ()) -> FilePath -> [String] -> String -> IO String + go 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 -> + processFailedException "readProcessStderrChan" exe args rv + ExitSuccess -> + return output + where + ignoreSEx = handle (\(SomeException _) -> return ()) + reader h = ignoreSEx $ do + putErr . toGmLines . (++"\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 + +processFailedException :: String -> String -> [String] -> Int -> IO a +processFailedException fn exe args rv = + error $ concat [ fn, ": ", exe, " " + , intercalate " " (map show args) + , " (exit " ++ show rv ++ ")"] diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -1,21 +1,42 @@ -{-# LANGUAGE BangPatterns, TupleSections #-} -module Language.Haskell.GhcMod.PathsAndFiles where +-- ghc-mod: Making Haskell development *more* fun +-- 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 Language.Haskell.GhcMod.PathsAndFiles ( + module Language.Haskell.GhcMod.PathsAndFiles + , module Language.Haskell.GhcMod.Caching + ) where + +import Config (cProjectVersion) import Control.Applicative import Control.Monad import Data.List import Data.Char import Data.Maybe -import Data.Traversable (traverse) -import Language.Haskell.GhcMod.Types +import Data.Traversable hiding (mapM) +import Distribution.Helper (buildPlatform) import System.Directory import System.FilePath +import System.Process +import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.Caching import qualified Language.Haskell.GhcMod.Utils as U - -import Distribution.Simple.BuildPaths (defaultDistPref) -import Distribution.Simple.Configure (localBuildInfoFile) +import Utils (mightExist) +import Prelude -- | Guaranteed to be a path to a directory with no trailing slash. type DirPath = FilePath @@ -23,40 +44,111 @@ -- | Guaranteed to be the name of a file only (no slashes). type FileName = String +newtype UnString = UnString { unString :: String } + +instance Show UnString where + show = unString + +instance Read UnString where + readsPrec _ = \str -> [(UnString str, "")] + -- | @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 directory = do - -- Look for cabal files in @dir@ and all it's parent directories - dcs <- getCabalFiles `zipMapM` parents directory - -- Extract first non-empty list, which represents a directory with cabal - -- files. - case find (not . null) $ uncurry appendDir `map` dcs of - Just [] -> throw $ GMENoCabalFile +findCabalFile dir = do + -- List of directories and all cabal file candidates + dcs <- findFileInParentsP isCabalFile dir :: IO ([(DirPath, [FileName])]) + let css = uncurry appendDir `map` dcs :: [[FilePath]] + case find (not . null) css of + Nothing -> return Nothing Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs - a -> return $ head <$> a + Just (a:_) -> return (Just a) + Just [] -> error "findCabalFile" where appendDir :: DirPath -> [FileName] -> [FilePath] - appendDir dir fs = (dir ) `map` fs + appendDir d fs = (d ) `map` fs --- | @getCabalFiles dir@. Find all files ending in @.cabal@ in @dir@. -getCabalFiles :: DirPath -> IO [FileName] -getCabalFiles dir = - filterM isCabalFile =<< getDirectoryContents dir +-- | Get path to sandbox config file +getSandboxDb :: FilePath + -- ^ Path to the cabal package root directory (containing the + -- @cabal.sandbox.config@ file) + -> IO (Maybe GhcPkgDb) +getSandboxDb d = do + mConf <- traverse readFile =<< mightExist (d "cabal.sandbox.config") + bp <- buildPlatform readProcess + return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf) + where - isCabalFile f = do - exists <- doesFileExist $ dir f - return (exists && takeExtension' f == ".cabal") + fixPkgDbVer bp dir = + case takeFileName dir == ghcSandboxPkgDbDir bp of + True -> dir + False -> takeDirectory dir ghcSandboxPkgDbDir bp - takeExtension' p = if takeFileName p == takeExtension p - then "" - else takeExtension p +-- | 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 dir@ Look for files satisfying @p@ in @dir@ and all +-- it's parent directories. +findFileInParentsP :: (FilePath -> Bool) -> FilePath + -> IO [(DirPath, [FileName])] +findFileInParentsP p dir = + getFilesP p `zipMapM` 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' =<< getDirectoryContents dir + where + p' fn = do + (p fn && ) <$> doesFileExist (dir fn) + +findCabalSandboxDir :: FilePath -> IO (Maybe FilePath) +findCabalSandboxDir dir = do + dss <- findFileInParentsP isSandboxConfig dir + return $ case find (not . null . snd) $ dss of + Just (sbDir, _:_) -> Just sbDir + _ -> Nothing + + where + isSandboxConfig = (==sandboxConfigFile) + zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)] -zipMapM f as = mapM (\a -> liftM (a,) $ f a) as +zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as -- | @parents dir@. Returns all parent directories of @dir@ including @dir@. -- @@ -86,31 +178,48 @@ ---------------------------------------------------------------- --- | Get path to sandbox config file -getSandboxDb :: FilePath -- ^ Path to the cabal package root directory - -- (containing the @cabal.sandbox.config@ file) - -> IO (Maybe FilePath) -getSandboxDb d = do - mConf <- traverse readFile =<< U.mightExist (d "cabal.sandbox.config") - return $ extractSandboxDbDir =<< mConf - --- | 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 - setupConfigFile :: Cradle -> FilePath setupConfigFile crdl = cradleRootDir crdl setupConfigPath +sandboxConfigFile :: FilePath +sandboxConfigFile = "cabal.sandbox.config" + -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ setupConfigPath :: FilePath -setupConfigPath = localBuildInfoFile defaultDistPref +setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref +macrosHeaderPath :: FilePath +macrosHeaderPath = "dist/build/autogen/cabal_macros.h" + +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 = cradleTempDir crdl symbolCacheFile + +symbolCacheFile :: String +symbolCacheFile = "ghc-mod.symbol-cache" + +resolvedComponentsCacheFile :: String +resolvedComponentsCacheFile = setupConfigPath <.> "ghc-mod.resolved-components" + +cabalHelperCacheFile :: String +cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-components" + +mergedPkgOptsCacheFile :: String +mergedPkgOptsCacheFile = setupConfigPath <.> "ghc-mod.package-options" + +pkgDbStackCacheFile :: String +pkgDbStackCacheFile = setupConfigPath <.> "ghc-mod.package-db-stack" + +-- | @findCustomPackageDbFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@. +-- If it exists in the given directory it is returned otherwise @findCradleFile@ returns @Nothing@ +findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath) +findCustomPackageDbFile directory = do + let path = directory "ghc-mod.package-db-stack" + mightExist path diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ b/Language/Haskell/GhcMod/PkgDoc.hs @@ -5,22 +5,23 @@ import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Utils -import Control.Applicative ((<$>)) +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 - c <- cradle - pkg <- trim <$> readProcess' "ghc-pkg" (toModuleOpts c) + pkgDbStack <- getPackageDbStack + pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts pkgDbStack) "" if pkg == "" then return "\n" else do - htmlpath <- readProcess' "ghc-pkg" (toDocDirOpts pkg c) + htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg pkgDbStack) "" 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) + 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/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/GhcMod/Pretty.hs @@ -0,0 +1,69 @@ +-- ghc-mod: Making Haskell development *more* fun +-- 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 Language.Haskell.GhcMod.Pretty where + +import Control.Arrow hiding ((<+>)) +import Data.Char +import Data.List +import Distribution.Helper +import Text.PrettyPrint + +import Language.Haskell.GhcMod.Types + +docStyle :: Style +docStyle = style { ribbonsPerLine = 1.2 } + +gmRenderDoc :: Doc -> String +gmRenderDoc = renderStyle docStyle + +gmComponentNameDoc :: ChComponentName -> Doc +gmComponentNameDoc ChSetupHsName = text $ "Setup.hs" +gmComponentNameDoc ChLibName = text $ "library" +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 + +showDoc :: Show a => a -> Doc +showDoc = text . show + +warnDoc :: Doc -> Doc +warnDoc d = text "Warning" <+>: d + +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/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -3,7 +3,7 @@ module Language.Haskell.GhcMod.SrcUtils where -import Control.Applicative ((<$>)) +import Control.Applicative import CoreUtils (exprType) import Data.Generics import Data.Maybe (fromMaybe) @@ -13,15 +13,13 @@ 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 Language.Haskell.GhcMod.Doc +import Language.Haskell.GhcMod.Gap 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) +import Prelude ---------------------------------------------------------------- @@ -82,22 +80,6 @@ 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 diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -1,60 +1,486 @@ -{-# LANGUAGE CPP #-} -module Language.Haskell.GhcMod.Target ( - setTargetFiles - ) where +-- ghc-mod: Making Haskell development *more* fun +-- 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 . -import Control.Applicative ((<$>)) -import Control.Monad (forM, void, (>=>)) -import DynFlags (ExtensionFlag(..), xopt) -import GHC (LoadHowMuch(..)) -import qualified GHC as G +{-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-} +module Language.Haskell.GhcMod.Target where + +import Control.Arrow +import Control.Applicative +import Control.Category ((.)) +import Control.Monad.Reader (runReaderT) +import GHC +import GHC.Paths (libdir) +import StaticFlags +import SysTools +import DynFlags +import HscMain +import HscTypes + import Language.Haskell.GhcMod.DynFlags -import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Monad.Types +import Language.Haskell.GhcMod.CabalHelper +import Language.Haskell.GhcMod.HomeModuleGraph +import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.Error +import Language.Haskell.GhcMod.Logging +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Utils as U + +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 Distribution.Helper +import Prelude hiding ((.)) + +import System.Directory +import System.FilePath + +withLightHscEnv :: forall m a. IOish m + => [GHCOption] -> (HscEnv -> m a) -> m a +withLightHscEnv opts action = gbracket initEnv teardownEnv action + where + teardownEnv :: HscEnv -> m () + teardownEnv env = liftIO $ do + let dflags = hsc_dflags env + cleanTempFiles dflags + cleanTempDirs dflags + + initEnv :: m HscEnv + initEnv = liftIO $ do + initStaticOpts + settings <- initSysTools (Just libdir) + dflags <- initDynFlags (defaultDynFlags settings) + env <- newHscEnv dflags + dflags' <- 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 + newHscEnv dflags' + +runLightGhc :: HscEnv -> LightGhc a -> IO a +runLightGhc env action = do + renv <- newIORef env + flip runReaderT renv $ unLightGhc action + +runGmPkgGhc :: (IOish m, GmEnv m, GmState m, GmLog m) => LightGhc a -> m a +runGmPkgGhc action = do + pkgOpts <- packageGhcOptions + withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action + +initSession :: IOish m + => [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m () +initSession opts mdf = do + s <- gmsGet + case gmGhcSession s of + Just GmGhcSession {..} -> when (gmgsOptions /= opts) $ putNewSession s + Nothing -> putNewSession s + + where + putNewSession s = do + rghc <- (liftIO . newIORef =<< newSession =<< cradle) + gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc } + + newSession Cradle { cradleTempDir } = liftIO $ do + runGhc (Just libdir) $ do + let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df) + _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags + getSession + +-- | 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 _opts 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 () + + +runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a +runGmlT fns action = runGmlT' fns return action + +runGmlT' :: IOish m + => [Either FilePath ModuleName] + -> (DynFlags -> Ghc DynFlags) + -> GmlT m a + -> GhcModT m a +runGmlT' fns mdf action = runGmlTWith fns mdf id action + +runGmlTWith :: IOish m + => [Either FilePath ModuleName] + -> (DynFlags -> Ghc DynFlags) + -> (GmlT m a -> GmlT m b) + -> GmlT m a + -> GhcModT m b +runGmlTWith efnmns' mdf wrapper action = do + crdl <- cradle + Options { ghcUserOptions } <- options + + let (fns, mns) = partitionEithers efnmns' + ccfns = map (cradleCurrentDir crdl ) fns + cfns <- liftIO $ mapM canonicalizePath ccfns + let serfnmn = Set.fromList $ map Right mns ++ map Left cfns + opts <- targetGhcOptions crdl serfnmn + let opts' = opts ++ ["-O0"] ++ ghcUserOptions + + gmVomit + "session-ghc-options" + (text "Initializing GHC session with following options") + (intercalate " " $ map (("\""++) . (++"\"")) opts') + + initSession opts' $ + setModeSimple >>> setEmptyLogger >>> mdf + + let rfns = map (makeRelative $ cradleRootDir crdl) cfns + + unGmlT $ wrapper $ do + loadTargets (map moduleNameString mns ++ rfns) + 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 cradleProjectType crdl of + CabalProject -> cabalOpts crdl + _ -> 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 GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file." + return $ gmcGhcOpts $ fromJust $ Map.lookup (head cns) mcs + else do + when noCandidates $ + throwError $ GMECabalCompAssignment mdlcs + + let cn = pickComponent candidates + return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs + +resolvedComponentsCache :: IOish m => Cached (GhcModT m) GhcModState + [GmComponent 'GMCRaw (Set.Set ModulePath)] + (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) +resolvedComponentsCache = Cached { + cacheLens = Just (lGmcResolvedComponents . lGmCaches), + cacheFile = resolvedComponentsCacheFile, + cachedAction = \tcfs comps ma -> do + Cradle {..} <- cradle + let iifsM = invalidatingInputFiles tcfs + mums :: Maybe [Either FilePath ModuleName] + mums = + case iifsM of + Nothing -> Nothing + Just iifs -> + let + filterOutSetupCfg = + filter (/= cradleRootDir setupConfigPath) + changedFiles = filterOutSetupCfg iifs + in if null changedFiles + then Nothing + else Just $ map Left changedFiles + setupChanged = maybe False + (elem $ cradleRootDir setupConfigPath) + iifsM + case (setupChanged, ma) of + (False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs } + _ -> return () + + 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 comps + return (setupConfigPath:flatten mcs , mcs) + } + + where + flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath)) + -> [FilePath] + flatten = Map.elems + >>> map (gmcHomeModuleGraph >>> gmgGraph + >>> Map.elems + >>> 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 :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m) + => m [GHCOption] +packageGhcOptions = do + crdl <- cradle + case cradleProjectType crdl of + CabalProject -> getGhcMergedPkgOptions + _ -> sandboxOpts crdl + +-- also works for plain projects! +sandboxOpts :: MonadIO m => Cradle -> m [String] +sandboxOpts crdl = do + pkgDbStack <- liftIO $ getSandboxPackageDbStack $ cradleRootDir crdl + let pkgOpts = ghcDbStackOpts pkgDbStack + return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"] + where + (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl) + + getSandboxPackageDbStack :: FilePath + -- ^ Project Directory (where the cabal.sandbox.config + -- file would be if it exists) + -> IO [GhcPkgDb] + getSandboxPackageDbStack cdir = + ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir + +resolveGmComponent :: (IOish m, GmLog m, GmEnv m) + => Maybe [CompilationUnit] -- ^ Updated modules + -> GmComponent 'GMCRaw (Set ModulePath) + -> m (GmComponent 'GMCResolved (Set ModulePath)) +resolveGmComponent mums c@GmComponent {..} = do + withLightHscEnv ghcOpts $ \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 = concat [ + gmcGhcSrcOpts, + gmcGhcLangOpts, + [ "-optP-include", "-optP" ++ macrosHeaderPath ] + ] + +resolveEntrypoint :: (IOish m, GmEnv m, GmLog m) + => Cradle + -> GmComponent 'GMCRaw ChEntrypoint + -> m (GmComponent 'GMCRaw (Set ModulePath)) +resolveEntrypoint Cradle {..} c@GmComponent {..} = do + 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 he 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 :: (MonadIO m, GmEnv m, GmLog 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 <- liftIO $ fileModuleName env fn + case emn of + Left errs -> do + gmLog GmWarning ("resolveModule " ++ show fn) $ + Monoid.mempty $+$ (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 + +resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m) + => Maybe [CompilationUnit] + -- ^ Updated modules + -> [GmComponent 'GMCRaw (Set ModulePath)] + -> m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) +resolveGmComponents mumns cs = do + s <- gmsGet + m' <- foldrM' (gmComponents s) 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 + gmsPut s { gmComponents = m' } + return m' + + where + foldrM' b fa f = foldrM f b fa + insertUpdated m c = do + rc <- resolveGmComponent mumns 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. -setTargetFiles :: IOish m => [FilePath] -> GhcModT m () -setTargetFiles files = do - targets <- forM files $ \file -> G.guessTarget file Nothing - G.setTargets targets +loadTargets :: IOish m => [String] -> GmlT m () +loadTargets filesOrModules = do + gmLog GmDebug "loadTargets" $ + text "Loading" <+>: fsep (map text filesOrModules) + + targets <- forM filesOrModules (flip guessTarget Nothing) + setTargets targets + mode <- getCompilerMode - if mode == Intelligent then - loadTargets Intelligent + if mode == Intelligent + then loadTargets' Intelligent else do - mdls <- G.depanal [] False + mdls <- depanal [] False let fallback = needsFallback mdls if fallback then do resetTargets targets setIntelligent - loadTargets Intelligent + gmLog GmInfo "loadTargets" $ + text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms." + loadTargets' Intelligent else - loadTargets Simple + 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 + loadTargets' Simple = do + void $ load LoadAllTargets + mapM_ (parseModule >=> typecheckModule >=> desugarModule) =<< getModuleGraph + + loadTargets' Intelligent = do + df <- getSessionDynFlags + void $ setSessionDynFlags (setModeIntelligent df) + void $ load LoadAllTargets + resetTargets targets = do - G.setTargets [] - void $ G.load LoadAllTargets - G.setTargets targets + setTargets [] + void $ load LoadAllTargets + setTargets targets + setIntelligent = do - newdf <- setModeIntelligent <$> G.getSessionDynFlags - void $ G.setSessionDynFlags newdf + newdf <- setModeIntelligent <$> getSessionDynFlags + void $ setSessionDynFlags newdf setCompilerMode Intelligent -needsFallback :: G.ModuleGraph -> Bool +needsFallback :: ModuleGraph -> Bool needsFallback = any $ \ms -> - let df = G.ms_hspp_opts ms in + let df = ms_hspp_opts ms in Opt_TemplateHaskell `xopt` df || Opt_QuasiQuotes `xopt` df #if __GLASGOW_HASKELL__ >= 708 || (Opt_PatternSynonyms `xopt` df) #endif + +cabalResolvedComponents :: (IOish m) => + GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) +cabalResolvedComponents = do + crdl@(Cradle{..}) <- cradle + comps <- mapM (resolveEntrypoint crdl) =<< getComponents + cached cradleRootDir resolvedComponentsCache comps diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -1,13 +1,46 @@ -module Language.Haskell.GhcMod.Types where +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, + StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} +module Language.Haskell.GhcMod.Types ( + module Language.Haskell.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 Data.Serialize +import Data.Version import Data.List (intercalate) -import qualified Data.Map as M +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 import Exception (ExceptionMonad) -import MonadUtils (MonadIO) - +#if __GLASGOW_HASKELL__ < 708 +import qualified MonadUtils as GHC (MonadIO(..)) +#endif +import GHC (ModuleName, moduleNameString, mkModuleName) +import HscTypes (HscEnv) import PackageConfig (PackageConfig) +import GHC.Generics +import Text.PrettyPrint (Doc) +import Prelude +import Language.Haskell.GhcMod.Caching.Types + -- | A constraint alias (-XConstraintKinds) to make functions dealing with -- 'GhcModT' somewhat cleaner. -- @@ -16,6 +49,18 @@ -- 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. @@ -28,8 +73,15 @@ outputStyle :: OutputStyle -- | Line separator string. , lineSeparator :: LineSeparator + -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout, + -- @snd@ is stderr prefix. + , linePrefix :: Maybe (String, String) + -- | Verbosity + , logLevel :: GmLogLevel -- | @ghc@ program name. , ghcProgram :: FilePath + -- | @ghc-pkg@ program name. + , ghcPkgProgram :: FilePath -- | @cabal@ program name. , cabalProgram :: FilePath -- | GHC command line options set on the @ghc-mod@ command line @@ -43,44 +95,114 @@ , hlintOpts :: [String] } deriving (Show) - -- | A default 'Options'. defaultOptions :: Options defaultOptions = Options { - outputStyle = PlainStyle - , hlintOpts = [] - , ghcProgram = "ghc" - , cabalProgram = "cabal" - , ghcUserOptions= [] - , operators = False - , detailed = False - , qualified = False - , lineSeparator = LineSeparator "\0" + outputStyle = PlainStyle + , lineSeparator = LineSeparator "\0" + , linePrefix = Nothing + , logLevel = GmWarning + , ghcProgram = "ghc" + , ghcPkgProgram = "ghc-pkg" + , cabalProgram = "cabal" + , ghcUserOptions = [] + , operators = False + , detailed = False + , qualified = False + , hlintOpts = [] } ---------------------------------------------------------------- +data ProjectType = CabalProject | SandboxProject | PlainProject + deriving (Eq, Show) + -- | The environment where this library is used. data Cradle = Cradle { + cradleProjectType:: ProjectType -- | The directory where this library is executed. - cradleCurrentDir :: FilePath + , 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 - -- | Package database stack - , cradlePkgDbStack :: [GhcPkgDb] } deriving (Eq, Show) + +data GmStream = GmOut | GmErr + deriving (Show) + +data GmLineType = GmTerminated | GmPartial + deriving (Show) + +data GmLines a = GmLines GmLineType a + deriving (Show, Functor) + +unGmLine :: GmLines a -> a +unGmLine (GmLines _ s) = s + +data GmOutput = GmOutputStdio + | GmOutputChan (Chan (GmStream, GmLines String)) + +data GhcModEnv = GhcModEnv { + gmOptions :: Options + , gmCradle :: Cradle + , gmOutput :: GmOutput + } + +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 { + gmgsOptions :: ![GHCOption], + 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) + , gmComponents :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) + , gmCompilerMode :: !CompilerMode + , gmCaches :: !GhcModCaches + } + +data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read) + +defaultGhcModState :: GhcModState +defaultGhcModState = + GhcModState n Map.empty Simple (GhcModCaches n n n n) + where n = Nothing + ---------------------------------------------------------------- -- | GHC package database flags. -data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show) +data GhcPkgDb = GlobalDb + | UserDb + | PackageDb String + deriving (Eq, Show, Generic) +instance Serialize GhcPkgDb + -- | A single GHC command line option. -type GHCOption = String +type GHCOption = String -- | An include directory for modules. type IncludeDir = FilePath @@ -89,44 +211,175 @@ type PackageBaseName = String -- | A package version. -type PackageVersion = String +type PackageVersion = String -- | A package id. -type PackageId = String +type PackageId = String -- | A package's name, verson and id. -type Package = (PackageBaseName, PackageVersion, PackageId) +type Package = (PackageBaseName, PackageVersion, PackageId) pkgName :: Package -> PackageBaseName -pkgName (n,_,_) = n +pkgName (n, _, _) = n pkgVer :: Package -> PackageVersion -pkgVer (_,v,_) = v +pkgVer (_, v, _) = v pkgId :: Package -> PackageId -pkgId (_,_,i) = i +pkgId (_, _, i) = i showPkg :: Package -> String -showPkg (n,v,_) = intercalate "-" [n,v] +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) +showPkgId (n, v, i) = intercalate "-" [n, v, i] -- | Haskell expression. -type Expression = String +newtype Expression = Expression { getExpression :: String } + deriving (Show, Eq, Ord) -- | Module name. -type ModuleString = String +newtype ModuleString = ModuleString { getModuleString :: String } + deriving (Show, Read, Eq, Ord) --- | A Module -type Module = [String] +data GmLogLevel = + GmSilent + | GmPanic + | GmException + | GmError + | GmWarning + | GmInfo + | GmDebug + | GmVomit + deriving (Eq, Ord, Enum, Bounded, Show, Read) --- | 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) +-- | Collection of packages +type PkgDb = (Map Package PackageConfig) + +data GmModuleGraph = GmModuleGraph { + gmgGraph :: Map ModulePath (Set ModulePath) + } deriving (Eq, Ord, Show, Read, Generic, Typeable) + +instance Serialize 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 k, 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 Serialize eps => Serialize (GmComponent t eps) + +data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath } + deriving (Eq, Ord, Show, Read, Generic, Typeable) +instance Serialize ModulePath + +instance Serialize 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. + + | GMECabalFlags GhcModError + -- ^ Retrieval of the cabal configuration flags failed. + + | GMECabalComponent ChComponentName + -- ^ Cabal component could not be found + + | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)] + -- ^ Could not find a consistent component assignment for modules + + | GMEProcess String [String] (Either (String, String, Int) GhcModError) + -- ^ Launching an operating system process failed. Fields in + -- order: command, arguments, (stdout, stderr, exitcode) + + | GMENoCabalFile + -- ^ No cabal file found. + + | GMETooManyCabalFiles [FilePath] + -- ^ Too many cabal files found. + + | GMECabalStateFile GMConfigStateFileError + -- ^ Reading Cabal's state configuration file falied somehow. + deriving (Eq,Show,Typeable) + +instance Error GhcModError where + noMsg = GMENoMsg + strMsg = GMEString + +instance Exception GhcModError + +data GMConfigStateFileError + = GMConfigStateFileNoHeader + | GMConfigStateFileBadHeader + | GMConfigStateFileNoParse + | GMConfigStateFileMissing +-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo) + deriving (Eq, Show, Read, Typeable) + + +deriving instance Generic Version +instance Serialize Version + +instance Serialize Programs +instance Serialize ChModuleName +instance Serialize ChComponentName +instance Serialize ChEntrypoint + +mkLabel ''GhcModCaches +mkLabel ''GhcModState diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -1,94 +1,159 @@ +-- ghc-mod: Making Haskell development *more* fun +-- 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 Language.Haskell.GhcMod.Utils where +{-# LANGUAGE DoAndIfThenElse #-} -import Control.Arrow +module Language.Haskell.GhcMod.Utils ( + module Language.Haskell.GhcMod.Utils + , module Utils + , readProcess + ) where + +import Control.Applicative import Data.Char +import Exception import Language.Haskell.GhcMod.Error -import MonadUtils (MonadIO, liftIO) -import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist) -import System.Exit (ExitCode(..)) -import System.Process (readProcessWithExitCode) -import System.Directory (getTemporaryDirectory) -import System.FilePath (splitDrive, pathSeparators) -import System.IO.Temp (createTempDirectory) -#ifndef SPEC -import Control.Applicative ((<$>)) +import Language.Haskell.GhcMod.Monad.Types +import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist, + getTemporaryDirectory, canonicalizePath) import System.Environment -import System.FilePath ((),takeDirectory) -#endif +import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators, + ()) +import System.IO.Temp (createTempDirectory) +import System.Process (readProcess) +import Text.Printf +import Paths_ghc_mod (getLibexecDir) +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) [] -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) + gbracket + (liftIO getCurrentDirectory) + (liftIO . setCurrentDirectory) + (\_ -> liftIO (setCurrentDirectory dir) >> action) uniqTempDirName :: FilePath -> FilePath -uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++) - $ map escapeDriveChar *** map escapePathChar - $ splitDrive dir - where +uniqTempDirName dir = + "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path + where + (drive, path) = splitDrive dir + escapeDriveChar :: Char -> Char escapeDriveChar c - | isAlphaNum c = c - | otherwise = '-' - + | isAlphaNum c = c + | otherwise = '-' + escapePathChar :: Char -> Char escapePathChar c - | c `elem` pathSeparators = '-' - | otherwise = c + | c `elem` pathSeparators = '-' + | otherwise = c newTempDir :: FilePath -> IO FilePath newTempDir dir = - flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory + flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory -mightExist :: FilePath -> IO (Maybe FilePath) -mightExist f = do - exists <- doesFileExist f - return $ if exists then (Just f) else (Nothing) +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 #ifndef SPEC ghcModExecutable = do - dir <- getExecutablePath' - return $ dir "ghc-mod" - where - getExecutablePath' :: IO FilePath -# if __GLASGOW_HASKELL__ >= 706 - getExecutablePath' = takeDirectory <$> getExecutablePath -# else - getExecutablePath' = return "" -# endif + dir <- takeDirectory <$> getExecutablePath' + return $ (if dir == "." then "" else dir) "ghc-mod" #else -ghcModExecutable = return "dist/build/ghc-mod/ghc-mod" +ghcModExecutable = fmap ( "dist/build/ghc-mod/ghc-mod") getCurrentDirectory #endif + +findLibexecExe :: String -> IO FilePath +findLibexecExe "cabal-helper-wrapper" = do + libexecdir <- getLibexecDir + let exeName = "cabal-helper-wrapper" + exe = libexecdir exeName + + exists <- doesFileExist exe + + if exists + then return exe + else do + mdir <- tryFindGhcModTreeDataDir + case mdir of + Nothing -> + error $ libexecNotExitsError exeName libexecdir + Just dir -> + return $ dir "dist" "build" exeName exeName +findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe + +libexecNotExitsError :: String -> FilePath -> String +libexecNotExitsError exe dir = printf + ( "Could not find $libexecdir/%s\n" + ++"\n" + ++"If you are a developer set the environment variable `ghc_mod_libexecdir'\n" + ++"to override $libexecdir[1] the following will work in the ghc-mod tree:\n" + ++"\n" + ++" $ export ghc_mod_libexecdir=$PWD/dist/build/%s\n" + ++"\n" + ++"[1]: %s\n" + ++"\n" + ++"If you don't know what I'm talking about something went wrong with your\n" + ++"installation. Please report this problem here:\n" + ++"\n" + ++" https://github.com/kazu-yamamoto/ghc-mod/issues") exe exe dir + +tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath) +tryFindGhcModTreeLibexecDir = do + exe <- getExecutablePath' + dir <- case takeFileName exe of + "ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD + _ -> return $ (!!4) $ iterate takeDirectory exe + exists <- doesFileExist $ dir "ghc-mod.cabal" + return $ if exists + then Just dir + else Nothing + +tryFindGhcModTreeDataDir :: IO (Maybe FilePath) +tryFindGhcModTreeDataDir = do + dir <- (!!4) . iterate takeDirectory <$> getExecutablePath' + exists <- doesFileExist $ dir "ghc-mod.cabal" + return $ if exists + then Just dir + else Nothing + +readLibExecProcess' :: (MonadIO m, ExceptionMonad m) + => String -> [String] -> m String +readLibExecProcess' cmd args = do + exe <- liftIO $ findLibexecExe cmd + liftIO $ readProcess exe args "" + +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 diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs --- a/Language/Haskell/GhcMod/World.hs +++ b/Language/Haskell/GhcMod/World.hs @@ -1,89 +1,52 @@ -{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.World where -{-( - , World - , getCurrentWorld - , isWorldChanged - ) where --} import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Utils -import Control.Applicative (pure,(<$>),(<*>)) +import Control.Applicative import Data.Maybe -import Data.Traversable (traverse) -import System.Directory (getModificationTime) +import Data.Traversable hiding (mapM) import System.FilePath (()) import GHC.Paths (libdir) - -#if __GLASGOW_HASKELL__ <= 704 -import System.Time (ClockTime) -#else -import Data.Time (UTCTime) -#endif - - -#if __GLASGOW_HASKELL__ <= 704 -type ModTime = ClockTime -#else -type ModTime = UTCTime -#endif - -data TimedFile = TimedFile FilePath ModTime deriving (Eq, Show) - -instance Ord TimedFile where - compare (TimedFile _ a) (TimedFile _ b) = compare a b - -timeFile :: FilePath -> IO TimedFile -timeFile f = TimedFile <$> pure f <*> getModificationTime f +import Prelude data World = World { worldPackageCaches :: [TimedFile] , worldCabalFile :: Maybe TimedFile , worldCabalConfig :: Maybe TimedFile + , worldSymbolCache :: Maybe TimedFile } deriving (Eq, Show) -timedPackageCache :: Cradle -> IO [TimedFile] -timedPackageCache crdl = do - fs <- mapM mightExist . map ( packageCache) - =<< getPackageCachePaths libdir crdl - timeFile `mapM` catMaybes fs +timedPackageCaches :: IOish m => GhcModT m [TimedFile] +timedPackageCaches = do + fs <- mapM (liftIO . mightExist) . map ( packageCache) + =<< getPackageCachePaths libdir + (liftIO . timeFile) `mapM` catMaybes fs -getCurrentWorld :: Cradle -> IO World -getCurrentWorld crdl = do - pkgCaches <- timedPackageCache crdl - mCabalFile <- timeFile `traverse` cradleCabalFile crdl - mSetupConfig <- mightExist (setupConfigFile crdl) - mCabalConfig <- timeFile `traverse` mSetupConfig +getCurrentWorld :: IOish m => GhcModT m World +getCurrentWorld = do + crdl <- cradle + pkgCaches <- timedPackageCaches + mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl + mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) + mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl) return World { worldPackageCaches = pkgCaches , worldCabalFile = mCabalFile , worldCabalConfig = mCabalConfig + , worldSymbolCache = mSymbolCache } -didWorldChange :: World -> Cradle -> IO Bool -didWorldChange world crdl = do - (world /=) <$> getCurrentWorld crdl +didWorldChange :: IOish m => World -> GhcModT m Bool +didWorldChange world = do + (world /=) <$> getCurrentWorld --- * 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 (unlikely case) -> should return False --- @Just cc < Nothing = False@ --- TODO: should we delete dist/setup-config? --- --- * 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 :: Cradle -> IO Bool -isSetupConfigOutOfDate crdl = do - world <- getCurrentWorld crdl - return $ worldCabalConfig world < worldCabalFile world +isYoungerThanSetupConfig :: FilePath -> World -> IO Bool +isYoungerThanSetupConfig file World {..} = do + tfile <- timeFile file + return $ worldCabalConfig < Just tfile diff --git a/NotCPP/Declarations.hs b/NotCPP/Declarations.hs new file mode 100644 --- /dev/null +++ b/NotCPP/Declarations.hs @@ -0,0 +1,164 @@ +-- ghc-mod: Making Haskell development *more* fun +-- 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 . + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE CPP #-} +-- Using CPP so you don't have to :) +module NotCPP.Declarations where + +import Control.Arrow +import Control.Applicative +import Data.Maybe +import Language.Haskell.TH.Syntax + +import NotCPP.LookupValueName + +nT :: Monad m => String -> m Type +cT :: Monad m => String -> m Type +nE :: Monad m => String -> m Exp +nP :: Monad m => String -> m Pat + +nT str = return $ VarT (mkName str) +cT str = return $ ConT (mkName str) +nE str = return $ VarE (mkName str) +nP str = return $ VarP (mkName str) +recUpdE' :: Q Exp -> Name -> Exp -> Q Exp +recUpdE' ex name assign = do + RecUpdE <$> ex <*> pure [(name, assign)] + +lookupName' :: (NameSpace, String) -> Q (Maybe Name) +lookupName' (VarName, n) = lookupValueName n +lookupName' (DataName, n) = lookupValueName n +lookupName' (TcClsName, n) = lookupTypeName n + +-- Does this even make sense? +ifelseD :: Q [Dec] -> Q [Dec] -> Q [Dec] +ifelseD if_decls' else_decls = do + if_decls <- if_decls' + alreadyDefined <- definedNames (boundNames `concatMap` if_decls) + case alreadyDefined of + [] -> if_decls' + _ -> else_decls + +ifdefelseD, ifelsedefD :: String -> Q [Dec] -> Q [Dec] -> Q [Dec] +ifelsedefD = ifdefelseD +ifdefelseD ident if_decls else_decls = do + exists <- isJust <$> lookupValueName ident + if exists + then if_decls + else else_decls + +ifdefD :: String -> Q [Dec] -> Q [Dec] +ifdefD ident decls = ifdefelseD ident decls (return []) + +ifndefD :: String -> Q [Dec] -> Q [Dec] +ifndefD ident decls = ifdefelseD ident (return []) decls + +-- | Each of the given declarations is only spliced if the identifier it defines +-- is not defined yet. +-- +-- For example: +-- +-- @$(ifD [[d| someFunctionThatShouldExist x = x+1 |]]@ +-- +-- If @someFunctionThatShouldExist@ doesn't actually exist the definition given +-- in the splice will be the result of the splice otherwise nothing will be +-- spliced. +-- +-- Currently this only works for function declarations but it can be easily +-- extended to other kinds of declarations. +ifD :: Q [Dec] -> Q [Dec] +ifD decls' = do + decls <- decls' + concat <$> flip mapM decls (\decl -> do + alreadyDefined <- definedNames (boundNames decl) + case alreadyDefined of + [] -> return [decl] + _ -> return []) + +definedNames :: [(NameSpace, Name)] -> Q [Name] +definedNames ns = catMaybes <$> (lookupName' . second nameBase) `mapM` ns + +boundNames :: Dec -> [(NameSpace, Name)] +boundNames decl = + case decl of + SigD n _ -> [(VarName, n)] + FunD n _cls -> [(VarName, n)] +#if __GLASGOW_HASKELL__ >= 706 + InfixD _ n -> [(VarName, n)] +#endif + ValD p _ _ -> map ((,) VarName) $ patNames p + + TySynD n _ _ -> [(TcClsName, n)] + ClassD _ n _ _ _ -> [(TcClsName, n)] + FamilyD _ n _ _ -> [(TcClsName, n)] + + DataD _ n _ ctors _ -> + [(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors) + + NewtypeD _ n _ ctor _ -> + [(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor) + + DataInstD _ _n _ ctors _ -> + map ((,) TcClsName) (conNames `concatMap` ctors) + + NewtypeInstD _ _n _ ctor _ -> + map ((,) TcClsName) (conNames ctor) + + InstanceD _ _ty _ -> + error "notcpp: Instance declarations are not supported yet" + ForeignD _ -> + error "notcpp: Foreign declarations are not supported yet" + PragmaD _pragma -> error "notcpp: pragmas are not supported yet" + +#if __GLASGOW_HASKELL__ >= 708 + TySynInstD _n _ -> error "notcpp: TySynInstD not supported yet" +#else + TySynInstD _n _ _ -> error "notcpp: TySynInstD not supported yet" +#endif + +#if __GLASGOW_HASKELL__ >= 708 + ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)] + RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet" +#endif + +conNames :: Con -> [Name] +conNames con = + case con of + NormalC n _ -> [n] + RecC n _ -> [n] + InfixC _ n _ -> [n] + ForallC _ _ c -> conNames c + +patNames :: Pat -> [Name] +patNames p'' = + case p'' of + LitP _ -> [] + VarP n -> [n] + TupP ps -> patNames `concatMap` ps + UnboxedTupP ps -> patNames `concatMap` ps + ConP _ ps -> patNames `concatMap` ps + InfixP p _ p' -> patNames `concatMap` [p,p'] + UInfixP p _ p' -> patNames `concatMap` [p,p'] + ParensP p -> patNames p + TildeP p -> patNames p + BangP p -> patNames p + AsP n p -> n:(patNames p) + WildP -> [] + RecP _ fps -> patNames `concatMap` map snd fps + ListP ps -> patNames `concatMap` ps + SigP p _ -> patNames p + ViewP _ p -> patNames p diff --git a/NotCPP/LookupValueName.hs b/NotCPP/LookupValueName.hs new file mode 100644 --- /dev/null +++ b/NotCPP/LookupValueName.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | This module uses scope lookup techniques to either export +-- 'lookupValueName' from @Language.Haskell.TH@, or define +-- its own 'lookupValueName', which attempts to do the +-- same job with just 'reify'. This will sometimes fail, but if it +-- succeeds it will give the answer that the real function would have +-- given. +-- +-- The idea is that if you use lookupValueName from this module, +-- your client code will automatically use the best available name +-- lookup mechanism. This means that e.g. 'scopeLookup' can work +-- very well on recent GHCs and less well but still somewhat +-- usefully on older GHCs. +module NotCPP.LookupValueName ( + lookupValueName + ) where + +import Language.Haskell.TH + +import NotCPP.Utils + +bestValueGuess :: String -> Q (Maybe Name) +bestValueGuess s = do + mi <- maybeReify (mkName s) + case mi of + Nothing -> no + Just i -> case i of + VarI n _ _ _ -> yes n + DataConI n _ _ _ -> yes n + _ -> err ["unexpected info:", show i] + where + no = return Nothing + yes = return . Just + err = fail . showString "NotCPP.bestValueGuess: " . unwords + +$(recover [d| lookupValueName = bestValueGuess |] $ do + VarI _ _ _ _ <- reify (mkName "lookupValueName") + return []) diff --git a/NotCPP/OrphanEvasion.hs b/NotCPP/OrphanEvasion.hs new file mode 100644 --- /dev/null +++ b/NotCPP/OrphanEvasion.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-} +-- | +-- The orphan instance problem is well-known in Haskell. This module +-- by no means purports to solve the problem, but provides a workaround +-- that may be significantly less awful than the status quo in some +-- cases. +-- +-- Say I think that the 'Name' type should have an 'IsString' instance. +-- But I don't control either the class or the type, so if I define the +-- instance, and then the template-haskell package defines one, my code +-- is going to break. +-- +-- 'safeInstance' can help me to solve this problem: +-- +-- > safeInstance ''IsString [t| Name |] [d| +-- > fromString = mkName |] +-- +-- This will declare an instance only if one doesn't already exist. +-- Now anyone importing your module is guaranteed to get an instance +-- one way or the other. +-- +-- This module is still highly experimental. The example given above +-- does work, but anything involving type variables or complex method +-- bodies may be less fortunate. The names of the methods are mangled +-- a bit, so using recursion to define them may not work. Define the +-- method outside the code and then use a simple binding as above. +-- +-- If you use this code (successfully or unsuccessfully!), go fetch +-- the maintainer address from the cabal file and let me know! +module NotCPP.OrphanEvasion ( + MultiParams, + safeInstance, + safeInstance', + ) where + +import Control.Applicative + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import NotCPP.ScopeLookup + +-- | An empty type used only to signify a multiparameter typeclass in +-- 'safeInstance'. +data MultiParams a + +-- | Given @(forall ts. Cxt => t)@, return @(Cxt, [t])@. +-- Given @(forall ts. Cxt => 'MultiParams' (t1, t2, t3))@, return +-- @(Cxt, [t1, t2, t3])@. +-- +-- This is used in 'safeInstance' to allow types to be specified more +-- easily with TH typequotes. +fromTuple :: Type -> (Cxt, [Type]) +fromTuple ty = unTuple <$> case ty of + ForallT _ cxt ty' -> (cxt, ty') + _ -> ([], ty) + where + unTuple :: Type -> [Type] + unTuple (AppT (ConT n) ta) + | n == ''MultiParams = case unrollAppT ta of + (TupleT{}, ts) -> ts + _ -> [ty] + unTuple t = [t] + +-- | A helper function to unwind type application. +-- Given @TyCon t1 t2 t3@, returns @(TyCon, [t1,t2,t3])@ +unrollAppT :: Type -> (Type, [Type]) +unrollAppT = go [] + where + go acc (AppT tc ta) = go (ta : acc) tc + go acc ty = (ty, reverse acc) + +-- | Left inverse to unrollAppT, equal to @'foldl' 'AppT'@ +rollAppT :: Type -> [Type] -> Type +rollAppT = foldl AppT + +-- | @'safeInstance'' className cxt types methods@ produces an instance +-- of the given class if and only if one doesn't already exist. +-- +-- See 'safeInstance' for a simple way to construct the 'Cxt' and +-- @['Type']@ parameters. +safeInstance' :: Name -> Cxt -> [Type] -> Q [Dec] -> Q [Dec] +safeInstance' cl cxt tys inst = do + b <- $(scopeLookups ["isInstance", "isClassInstance"]) cl tys + if b + then return [] + else do + ds <- map fixInst <$> inst + return [InstanceD cxt (rollAppT (ConT cl) tys) ds] + where + fixInst (FunD n cls) = FunD (fixName n) cls + fixInst (ValD (VarP n) rhs wh) = ValD (VarP (fixName n)) rhs wh + fixInst d = d + fixName (Name n _) = Name n NameS + +-- | 'safeInstance' is a more convenient version of 'safeInstance'' +-- that takes the context and type from a @'Q' 'Type'@ with the intention +-- that it be supplied using a type-quote. +-- +-- To define an instance @Show a => Show (Wrapper a)@, you'd use: +-- +-- > safeInstance ''Show [t| Show a => Wrapper a |] +-- > [d| show _ = "stuff" |] +-- +-- To define an instance of a multi-param type class, use the +-- 'MultiParams' type constructor with a tuple: +-- +-- > safeInstance ''MonadState +-- > [t| MonadState s m => MultiParams (s, MaybeT m) |] +-- > [d| put = ... |] +safeInstance :: Name -> Q Type -> Q [Dec] -> Q [Dec] +safeInstance n qty inst = do + (cxt, tys) <- fromTuple <$> qty + safeInstance' n cxt tys inst diff --git a/NotCPP/ScopeLookup.hs b/NotCPP/ScopeLookup.hs new file mode 100644 --- /dev/null +++ b/NotCPP/ScopeLookup.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | +-- This module exports 'scopeLookup', which will find a variable or +-- value constructor for you and present it for your use. E.g. at some +-- point in the history of the acid-state package, 'openAcidState' was +-- renamed 'openLocalState'; for compatibility with both, you could +-- use: +-- +-- > openState :: IO (AcidState st) +-- > openState = case $(scopeLookup "openLocalState") of +-- > Just open -> open defaultState +-- > Nothing -> case $(scopeLookup "openAcidState") of +-- > Just open -> open defaultState +-- > Nothing -> error +-- > "openState: runtime name resolution has its drawbacks :/" +-- +-- Or, for this specific case, you can use 'scopeLookups': +-- +-- > openState :: IO (AcidState st) +-- > openState = open defaultState +-- > where +-- > open = $(scopeLookups ["openLocalState","openAcidState"]) +-- +-- Now if neither of the names are found then TH will throw a +-- compile-time error. +module NotCPP.ScopeLookup ( + scopeLookup, + scopeLookups, + scopeLookup', + liftMaybe, + recoverMaybe, + maybeReify, + infoToExp, + ) where + +import Control.Applicative ((<$>)) + +import Language.Haskell.TH (Q, Exp, recover, reify) + +import NotCPP.LookupValueName +import NotCPP.Utils + +-- | Produces a spliceable expression which expands to @'Just' val@ if +-- the given string refers to a value @val@ in scope, or 'Nothing' +-- otherwise. +-- +-- @scopeLookup = 'fmap' 'liftMaybe' . 'scopeLookup''@ +scopeLookup :: String -> Q Exp +scopeLookup = fmap liftMaybe . scopeLookup' + +-- | Finds the first string in the list that names a value, and produces +-- a spliceable expression of that value, or reports a compile error if +-- it fails. +scopeLookups :: [String] -> Q Exp +scopeLookups xs = foldr + (\s r -> maybe r return =<< scopeLookup' s) + (fail ("scopeLookups: none found: " ++ show xs)) + xs + +-- | Produces @'Just' x@ if the given string names the value @x@, +-- or 'Nothing' otherwise. +scopeLookup' :: String -> Q (Maybe Exp) +scopeLookup' s = recover (return Nothing) $ do + Just n <- lookupValueName s + infoToExp <$> reify n diff --git a/NotCPP/Utils.hs b/NotCPP/Utils.hs new file mode 100644 --- /dev/null +++ b/NotCPP/Utils.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} +module NotCPP.Utils where + +import Control.Applicative ((<$>)) +import Language.Haskell.TH + +-- | Turns 'Nothing' into an expression representing 'Nothing', and +-- @'Just' x@ into an expression representing 'Just' applied to the +-- expression in @x@. +liftMaybe :: Maybe Exp -> Exp +liftMaybe = maybe (ConE 'Nothing) (AppE (ConE 'Just)) + +-- | A useful variant of 'reify' that returns 'Nothing' instead of +-- halting compilation when an error occurs (e.g. because the given +-- name was not in scope). +maybeReify :: Name -> Q (Maybe Info) +maybeReify = recoverMaybe . reify + +-- | Turns a possibly-failing 'Q' action into one returning a 'Maybe' +-- value. +recoverMaybe :: Q a -> Q (Maybe a) +recoverMaybe q = recover (return Nothing) (Just <$> q) + +-- | Returns @'Just' ('VarE' n)@ if the info relates to a value called +-- @n@, or 'Nothing' if it relates to a different sort of thing. +infoToExp :: Info -> Maybe Exp +infoToExp (VarI n _ _ _) = Just (VarE n) +infoToExp (DataConI n _ _ _) = Just (ConE n) +infoToExp _ = Nothing diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,198 @@ +#!/usr/bin/env runhaskell +{-# LANGUAGE RecordWildCards #-} import Distribution.Simple -main = defaultMain +import Distribution.Simple.Setup +import Distribution.Simple.Install +import Distribution.Simple.Register +import Distribution.Simple.InstallDirs as ID +import Distribution.Simple.LocalBuildInfo +import Distribution.PackageDescription + +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 Text.ParserCombinators.ReadP + +import SetupCompat + +main :: IO () +main = defaultMainWithHooks $ simpleUserHooks { + confHook = \(gpd, hbi) cf -> + xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf + + , instHook = inst + , copyHook = copy + +-- , postConf = sanityCheckCabalVersions + } + +xBuildDependsLike :: LocalBuildInfo -> LocalBuildInfo +xBuildDependsLike lbi = + let + cc = componentsConfigs lbi + pd = localPkgDescr lbi + deps = dependsMap lbi + in setComponentsConfigs lbi + [ (cn, updateClbi deps comp clbi, cdeps) + | (cn, clbi, cdeps) <- cc + , let comp = getComponent pd cn + ] + + where + updateClbi deps comp clbi = setUnionDeps (otherDeps deps comp) clbi + + dependsMap :: + LocalBuildInfo -> [(ComponentName, Deps)] + dependsMap lbi = + second getDeps <$> allComponentsInBuildOrder lbi + + otherDeps :: [(ComponentName, Deps)] -> Component -> Deps + otherDeps deps comp = fromMaybe noDeps $ + flip lookup deps =<< read <$> lookup "x-build-depends-like" fields + where + fields = customFieldsBI (componentBuildInfo comp) + +-- 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 (\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 (\pd' lbi' -> install pd' lbi' cf) + +xInstallTarget :: PackageDescription + -> LocalBuildInfo + -> (PackageDescription -> LocalBuildInfo -> IO ()) + -> IO () +xInstallTarget pd lbi fn = do + let (extended, regular) = partition (isJust . installTarget) (executables pd) + + let pd_regular = pd { executables = regular } + + _ <- flip mapM extended $ \exe -> do + putStrLn $ "extended " ++ show (exeName exe) + + let + idirtpl = installDirTemplates lbi + env = installDirsTemplateEnv idirtpl + libexecdir' = fromPathTemplate (libexecdir idirtpl) + + pd_extended = onlyExePackageDesc [exe] pd + install_target = fromJust $ installTarget exe + install_target' = ID.substPathTemplate env install_target + -- $libexec isn't a real thing :/ so we have to simulate it + install_target'' = substLibExec' libexecdir' install_target' + + let lbi' = lbi { + installDirTemplates = + (installDirTemplates lbi) { + bindir = install_target'' + } + } + fn pd_extended lbi' + + fn pd_regular lbi + + where + installTarget :: Executable -> Maybe PathTemplate + installTarget exe = + toPathTemplate <$> lookup "x-install-target" (customFieldsBI $ buildInfo exe) + + substLibExec libexecdir "$libexecdir" = libexecdir + substLibExec _ comp = comp + + substLibExec' dir = + withPT $ + withSP $ map (substLibExec dir . dropTrailingPathSeparator) + + + withPT f pt = toPathTemplate $ f (fromPathTemplate pt) + withSP f p = joinPath $ f (splitPath p) + +onlyExePackageDesc :: [Executable] -> PackageDescription -> PackageDescription +onlyExePackageDesc exes pd = emptyPackageDescription { + package = package pd + , executables = exes + } + +parseVer str = + case filter ((=="") . snd) $ readP_to_S parseVersion str of + [(ver, _)] -> ver + _ -> error $ "No parse (Ver) :(\n" ++ str ++ "\n" + +-- sanityCheckCabalVersions args cf desc lbi = do +-- (cabalInstallVer, cabalVer) <- getCabalExecVer + +-- let +-- ghcVer = compilerVersion (compiler lbi) +-- -- ghc >= 7.10? +-- minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10") + +-- when minGhc710 $ do +-- let cabalHelperCabalVer = compCabalVer (CExeName "cabal-helper") + +-- when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $ +-- failCabalVersionDifferent cabalVer cabalHelperCabalVer + +-- -- carry on as usual +-- (postConf simpleUserHooks) args cf desc lbi + +-- where +-- earlierVersionThan ver ver' = +-- ver `withinRange` earlierVersion ver' +-- sameMajorVersionAs ver ver' = +-- ver `withinRange` withinVersion (Version (take 2 $ versionBranch ver') []) + +-- compCabalVer comp = let +-- clbi = getComponentLocalBuildInfo lbi comp + +-- [cabalVer] = +-- [ ver | (_, PackageIdentifier pkg ver) <- componentPackageDeps clbi +-- , pkg == PackageName "Cabal" ] +-- in cabalVer + +-- getCabalExecVer = do +-- ["cabal-install", "version", cabalInstallVer, "using", "version", cabalVer, "of", "the", "Cabal", "library"] <- words <$> readProcess "cabal" ["--version"] "" +-- return (parseVer cabalInstallVer, parseVer cabalVer) + +-- failCabalVersionDifferent cabalVer libCabalVer = +-- putStrLn rerr >> exitFailure +-- where +-- replace :: String -> String -> String -> String +-- replace _ _ [] = [] +-- replace n r h@(h':hs) +-- | map snd (n `zip` h ) == n = r ++ replace n r (drop (length n) h) +-- | otherwise = h':replace n r hs + +-- rerr = replace "X.XX.X.X" (showVersion libCabalVer) $ +-- replace "Y.YY.Y.Y" (showVersion cabalVer) err +-- err = "\ +-- \Error: Cabal seems to have decided ghc-mod should be built using Cabal\n\ +-- \X.XX.X.X while the `cabal' executable in your PATH was built with Cabal\n\ +-- \Y.YY.Y.Y. This will lead to conflicts when running ghc-mod in any project\n\ +-- \where you use this `cabal' executable. Please compile ghc-mod using the same\n\ +-- \Cabal version as your `cabal' executable or recompile cabal-install using\n\ +-- \this version of the Cabal library.\n\ +-- \\n\ +-- \See: https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions\n" diff --git a/SetupCompat.hs b/SetupCompat.hs new file mode 100644 --- /dev/null +++ b/SetupCompat.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE TemplateHaskell, RecordWildCards, StandaloneDeriving #-} +module SetupCompat where + +import Control.Arrow +import Control.Monad.Trans.State +import Data.List +import Data.Maybe +import Data.Functor +import Data.Function +import Distribution.Simple.LocalBuildInfo +import Distribution.PackageDescription + +import Distribution.Simple +import Distribution.Simple.Setup +import Distribution.Simple.Install + +import qualified Data.Map as M +import Data.Map (Map) + + +import NotCPP.Declarations +import Language.Haskell.TH + +-- $(ifdefD "componentsConfigs" [d| deriving instance (Ord ComponentName) |] ) + +$(ifD [d| + + showComponentName :: ComponentName -> String + showComponentName CLibName = "library" + showComponentName (CExeName name) = "executable '" ++ name ++ "'" + showComponentName (CTestName name) = "test suite '" ++ name ++ "'" + showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'" + + |]) + +$(ifelsedefD "componentsConfigs" [d| + + setComponentsConfigs + :: LocalBuildInfo + -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] + -> LocalBuildInfo + setComponentsConfigs lbi cs = $(recUpdE' (nE "lbi") (mkName "componentsConfigs") (VarE $ mkName "cs")) + + |] [d| + + setComponentsConfigs + :: LocalBuildInfo + -> [(ComponentName, ComponentLocalBuildInfo, a)] + -> LocalBuildInfo + setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs + where + gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` showComponentName . fst3) cs + + fst3 (x,_,_) = x + + sameKind CLibName CLibName = True + sameKind CLibName _ = False + sameKind (CExeName _) (CExeName _) = True + sameKind (CExeName _) _ = False + sameKind (CTestName _) (CTestName _) = True + sameKind (CTestName _) _ = False + sameKind (CBenchName _) (CBenchName _) = True + sameKind (CBenchName _) _ = False + + setClbis [(CLibName, clbi, _)] = + get >>= \lbi -> + put $ $(recUpdE' (nE "lbi") (mkName "libraryConfig") (AppE (ConE (mkName "Just")) (VarE (mkName "clbi")))) + + setClbis cs@((CExeName _, _, _):_) = + let cfg = (\((CExeName n), clbi, _) -> (n, clbi)) <$> cs in + get >>= \lbi -> + put $ $(recUpdE' (nE "lbi") (mkName "executableConfigs") (VarE $ mkName "cfg")) + + setClbis cs@((CTestName _, _, _):_) = + let cfg = (\((CTestName n), clbi, _) -> (n, clbi)) <$> cs in + get >>= \lbi -> + put $ $(recUpdE' (nE "lbi") (mkName "testSuiteConfigs") (VarE $ mkName "cfg")) + + setClbis cs@((CBenchName _, _, _):_) = + let cfg = (\((CBenchName n), clbi, _) -> (n, clbi)) <$> cs in + get >>= \lbi -> + put $ $(recUpdE' (nE "lbi") (mkName "benchmarkConfigs") (VarE $ mkName "cfg")) + + |]) + + +$(ifD [d| + + componentsConfigs :: + LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] + componentsConfigs LocalBuildInfo {..} = + (maybe [] (\c -> [(CLibName, c, [])]) $(nE "libraryConfig")) + ++ ((\(n, clbi) -> (CExeName n, clbi, [])) <$> $(nE "executableConfigs")) + ++ ((\(n, clbi) -> (CTestName n, clbi, [])) <$> $(nE "testSuiteConfigs")) + ++ ((\(n, clbi) -> (CBenchName n, clbi, [])) <$> $(nE "benchmarkConfigs")) + + getComponent :: PackageDescription -> ComponentName -> Component + getComponent pkg cname = + case lookupComponent pkg cname of + Just cpnt -> cpnt + Nothing -> missingComponent + where + missingComponent = + error $ "internal error: the package description contains no " + ++ "component corresponding to " ++ show cname + + lookupComponent :: PackageDescription -> ComponentName -> Maybe Component + lookupComponent pkg CLibName = + fmap CLib $ library pkg + lookupComponent pkg (CExeName name) = + fmap CExe $ find ((name ==) . exeName) (executables pkg) + lookupComponent pkg (CTestName name) = + fmap CTest $ find ((name ==) . testName) (testSuites pkg) + lookupComponent pkg (CBenchName name) = + fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) + +-- We're lying here can't be bothered to order these + allComponentsInBuildOrder :: LocalBuildInfo + -> [(ComponentName, ComponentLocalBuildInfo)] + allComponentsInBuildOrder lbi = + [ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ] + + getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo + getComponentLocalBuildInfo lbi cname = + case [ clbi + | (cname', clbi, _) <- componentsConfigs lbi + , cname == cname' ] of + [clbi] -> clbi + _ -> missingComponent + where + missingComponent = + error $ "internal error: there is no configuration data " + ++ "for component " ++ show cname + + componentBuildInfo :: Component -> BuildInfo + componentBuildInfo = + foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo + + |]) + + +$(ifelsedefD "componentPackageRenaming" [d| + -- M.Map PackageName + newtype Deps = Deps { unDeps :: ([(InstalledPackageId, PackageId)], Map PackageName $(cT "ModuleRenaming")) } +-- $(return $ TySynD $(mkName "Deps") [] [t| |] ) + + noDeps = Deps ([], M.empty) + + getDeps :: ComponentLocalBuildInfo -> Deps + getDeps = componentPackageDeps &&& $(nE "componentPackageRenaming") >>> Deps + + setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo + setUnionDeps (Deps (deps, rns)) clbi = let + clbi' = setComponentPackageRenaming clbi rns + cpdeps = componentPackageDeps clbi + in + clbi' { + componentPackageDeps = cpdeps `union` deps + } + + setComponentPackageRenaming clbi cprn = + -- [| clbi { componentPackageRenaming = componentPackageRenaming clbi `M.union` cprn } |] + $(recUpdE' + (nE "clbi") + (mkName "componentPackageRenaming") + (InfixE + (Just + (AppE + (VarE + (mkName "componentPackageRenaming")) + (VarE (mkName "clbi")) + )) + (VarE (mkName "M.union")) + (Just (VarE (mkName "cprn"))) + ) + ) + + |] [d| + + newtype Deps = Deps { unDeps :: [(InstalledPackageId, PackageId)] } + + noDeps = Deps [] + + getDeps :: ComponentLocalBuildInfo -> Deps + getDeps lbi = Deps $ componentPackageDeps lbi + + setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo + setUnionDeps (Deps deps) clbi = let + cpdeps = componentPackageDeps clbi + in + clbi { + componentPackageDeps = cpdeps `union` deps + } + + +-- setComponentPackageRenaming clbi _cprn = clbi + + |]) diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +module Utils where + +import Control.Applicative +import Data.Traversable +import System.Directory + +#if MIN_VERSION_directory(1,2,0) +import Data.Time (UTCTime) +#else +import System.Time (ClockTime) +#endif +import Prelude + + +#if MIN_VERSION_directory(1,2,0) +type ModTime = UTCTime +#else +type ModTime = ClockTime +#endif + +data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime } + deriving (Eq, Show) + +instance Ord TimedFile where + compare (TimedFile _ a) (TimedFile _ b) = compare a b + +timeFile :: FilePath -> IO TimedFile +timeFile f = TimedFile <$> pure f <*> getModificationTime 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/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,34 @@ (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)) + (get-buffer-window (current-buffer) t)) + (with-timeout + (10 (error "ghc process may have hung or exited with an error")) + (while ghc-process-running (sleep-for 0.1))) + (ghc-with-process (ghc-check-send) + 'ghc-check-callback + (lambda () (setq mode-line-process " -:-"))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -132,7 +139,7 @@ info 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 +174,20 @@ ;; 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)))) + ((string= (file-truename ofile) (file-truename 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)) + (skip-chars-forward "^[:space:]" (line-end-position)) + (setq end (point))))) (t (setq beg (point)) (forward-line) 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))) diff --git a/elisp/ghc-doc.el b/elisp/ghc-doc.el --- a/elisp/ghc-doc.el +++ b/elisp/ghc-doc.el @@ -25,7 +25,7 @@ (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) @@ -93,7 +93,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 @@ -182,9 +182,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)))))) diff --git a/elisp/ghc-info.el b/elisp/ghc-info.el --- a/elisp/ghc-info.el +++ b/elisp/ghc-info.el @@ -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)) @@ -127,7 +127,7 @@ (defun ghc-expand-th () (interactive) (let* ((file (buffer-file-name)) - (cmds (list "expand" file)) + (cmds (list "-b" "\n" "expand" file)) (source (ghc-run-ghc-mod cmds))) (when source (ghc-display 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 @@ -10,6 +10,9 @@ (require 'ghc-func) +(defvar ghc-debug-options nil) +;; (setq ghc-debug-options '("-v9")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar ghc-process-running nil) @@ -19,37 +22,42 @@ (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-error-buffer "*GHC Error*") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-get-project-root () (ghc-run-ghc-mod '("root"))) (defun ghc-with-process (cmd callback &optional hook1 hook2) - (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)) - (let* ((cbuf (current-buffer)) - (name ghc-process-process-name) - (buf (get-buffer-create (concat " ghc-modi:" name))) - (file (buffer-file-name)) - (cpro (get-process name))) - (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) - (when ghc-debug - (ghc-with-debug-buffer - (insert (format "%% %s" cmd)))) - pro))))) + (let ((root (ghc-get-project-root))) + (unless ghc-process-process-name + (setq ghc-process-process-name root)) + (when (and ghc-process-process-name (not ghc-process-running)) + (setq ghc-process-running t) + (if hook1 (funcall hook1)) + (let* ((cbuf (current-buffer)) + (name ghc-process-process-name) + (buf (get-buffer-create (concat " ghc-mod:" name))) + (file (buffer-file-name)) + (cpro (get-process name))) + (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) + (setq ghc-process-root root) + (erase-buffer) + (let ((pro (ghc-get-process cpro name buf))) + (process-send-string pro cmd) + (when ghc-debug + (ghc-with-debug-buffer + (insert (format "%% %s" cmd)))) + pro)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -63,37 +71,74 @@ (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))) + (let* ((opts (append ghc-debug-options + '("-b" "\n" "-l" "--line-prefix=O: ,E: ") + (ghc-make-ghc-options) + '("legacy-interactive"))) + (pro (apply 'start-file-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))) + (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)) + (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)) ((looking-at "^NG ") (funcall ghc-process-callback 'ng) - (when ghc-debug - (let ((cbuf (current-buffer))) - (ghc-with-debug-buffer - (insert-buffer-substring cbuf)))) (setq ghc-process-running nil))))))) (defun ghc-process-sentinel (process event) diff --git a/elisp/ghc.el b/elisp/ghc.el --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -28,7 +28,7 @@ (< emacs-minor-version minor))) (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "5.2.1.2") +(defconst ghc-version "5.3.0.0") ;; (eval-when-compile ;; (require 'haskell-mode)) @@ -117,6 +117,9 @@ (setq ghc-initialized t) (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))) + (defadvice switch-to-buffer (after ghc-check-syntax-on-switch-to-buffer activate) + "Check syntax with GHC when switching to a haskell-mode buffer." (when (eq 'haskell-mode major-mode) (ghc-check-syntax)))) (ghc-import-module) (ghc-check-syntax)) @@ -130,23 +133,19 @@ (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"))) (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)))) diff --git a/ghc-mod.cabal b/ghc-mod.cabal --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,73 +1,102 @@ Name: ghc-mod -Version: 5.2.1.2 -Author: Kazu Yamamoto - Daniel Gröber +Version: 5.3.0.0 +Author: Kazu Yamamoto , + Daniel Gröber , Alejandro Serrano -Maintainer: Kazu Yamamoto -License: BSD3 +Maintainer: Daniel Gröber +License: AGPL-3 License-File: LICENSE +License-Files: COPYING.BSD3 COPYING.AGPL3 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. +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. + + For more information, please see its home page. + +Category: GHC, Development +Cabal-Version: >= 1.14 +Build-Type: Custom +Data-Files: elisp/Makefile + elisp/*.el +Data-Files: LICENSE COPYING.BSD3 COPYING.AGPL3 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 + SetupCompat.hs + NotCPP/*.hs + 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/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/cabal.sandbox.config.in + test/data/cabal-project/subdir1/subdir2/dummy test/data/case-split/*.hs - test/data/cabal-flags/*.cabal + 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/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 Library Default-Language: Haskell2010 - GHC-Options: -Wall - Default-Extensions: ConstraintKinds, FlexibleContexts + GHC-Options: -Wall -fno-warn-deprecations + Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, + ConstraintKinds, FlexibleContexts, + DataKinds, KindSignatures, TypeOperators Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Internal - Other-Modules: Language.Haskell.GhcMod.Boot + Other-Modules: Paths_ghc_mod + Utils + 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.CabalHelper + Language.Haskell.GhcMod.Caching + Language.Haskell.GhcMod.Caching.Types Language.Haskell.GhcMod.CaseSplit Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Convert @@ -79,18 +108,21 @@ 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.HomeModuleGraph Language.Haskell.GhcMod.Info Language.Haskell.GhcMod.Lang Language.Haskell.GhcMod.Lint Language.Haskell.GhcMod.Logger + Language.Haskell.GhcMod.Logging Language.Haskell.GhcMod.Modules Language.Haskell.GhcMod.Monad + Language.Haskell.GhcMod.Monad.Types + Language.Haskell.GhcMod.Output Language.Haskell.GhcMod.PathsAndFiles Language.Haskell.GhcMod.PkgDoc + Language.Haskell.GhcMod.Pretty Language.Haskell.GhcMod.Read Language.Haskell.GhcMod.SrcUtils Language.Haskell.GhcMod.Target @@ -98,7 +130,10 @@ Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.World Build-Depends: base >= 4.0 && < 5 + , bytestring + , cereal >= 0.4 , containers + , cabal-helper == 0.5.* && >= 0.5.1.0 , deepseq , directory , filepath @@ -106,7 +141,6 @@ , ghc-paths , ghc-syb-utils , hlint >= 1.8.61 - , io-choice , monad-journal >= 0.4 , old-time , pretty @@ -117,30 +151,28 @@ , transformers , transformers-base , mtl >= 2.0 - , monad-control + , monad-control >= 1 , split , haskell-src-exts , text , djinn-ghc >= 0.0.2.2 - if impl(ghc >= 7.8) - Build-Depends: Cabal >= 1.18 - else + , fclabels + if impl(ghc < 7.8) Build-Depends: convertible - , Cabal >= 1.10 && < 1.17 - if impl(ghc <= 7.4.2) + if impl(ghc < 7.5) -- Only used to constrain random to a version that still works with GHC 7.4 - Build-Depends: random <= 1.0.1.1 + Build-Depends: random <= 1.0.1.1, + ghc-prim Executable ghc-mod Default-Language: Haskell2010 Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod - GHC-Options: -Wall + GHC-Options: -Wall -fno-warn-deprecations Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 , async - , data-default , directory , filepath , pretty @@ -156,22 +188,17 @@ Other-Modules: Paths_ghc_mod Misc Utils - GHC-Options: -Wall -threaded + GHC-Options: -Wall -threaded -fno-warn-deprecations if os(windows) Cpp-Options: -DWINDOWS Default-Extensions: ConstraintKinds, FlexibleContexts - HS-Source-Dirs: src + HS-Source-Dirs: src, . Build-Depends: base >= 4.0 && < 5 - , async - , containers , directory , filepath - , old-time , process - , split , time - , ghc - , ghc-mod + , old-time Test-Suite doctest Type: exitcode-stdio-1.0 @@ -180,20 +207,27 @@ Ghc-Options: -Wall Default-Extensions: ConstraintKinds, FlexibleContexts Main-Is: doctests.hs + if impl(ghc == 7.4.*) + Buildable: False Build-Depends: base , doctest >= 0.9.3 Test-Suite spec Default-Language: Haskell2010 - Default-Extensions: ConstraintKinds, FlexibleContexts + Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, + ConstraintKinds, FlexibleContexts, + DataKinds, KindSignatures, TypeOperators Main-Is: Main.hs Hs-Source-Dirs: test, . - Ghc-Options: -Wall + Ghc-Options: -Wall -fno-warn-deprecations + CPP-Options: -DSPEC=1 Type: exitcode-stdio-1.0 - Other-Modules: BrowseSpec - CabalApiSpec - CheckSpec + Other-Modules: Paths_ghc_mod Dir + Spec + TestUtils + BrowseSpec + CheckSpec FlagSpec InfoSpec LangSpec @@ -201,42 +235,14 @@ ListSpec MonadSpec PathsAndFilesSpec - Spec - TestUtils - Build-Depends: base >= 4.0 && < 5 - , containers - , deepseq - , directory - , filepath - , ghc - , ghc-paths - , ghc-syb-utils - , hlint >= 1.7.1 - , io-choice - , monad-journal >= 0.4 - , old-time - , pretty - , process - , syb - , temporary - , 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 + HomeModuleGraphSpec + + Build-Depends: hspec >= 2.0.0 + if impl(ghc == 7.4.*) + Build-Depends: executable-path + X-Build-Depends-Like: CLibName + + Source-Repository head Type: git diff --git a/src/GHCMod.hs b/src/GHCMod.hs --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -6,41 +6,40 @@ import MonadUtils (liftIO) import Control.Applicative import Control.Monad -import Control.Exception ( SomeException(..), fromException, Exception - , Handler(..), catches, throw) import Data.Typeable (Typeable) import Data.Version (showVersion) -import Data.Default import Data.List import Data.List.Split -import Data.Maybe import Data.Char (isSpace) +import Data.Maybe +import Exception import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal +import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) import Paths_ghc_mod import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import qualified System.Console.GetOpt as O -import System.Directory (setCurrentDirectory) -import System.Environment (getArgs,getProgName) +import System.FilePath (()) +import System.Directory (setCurrentDirectory, getAppUserDataDirectory, + removeDirectoryRecursive) +import System.Environment (getArgs) import System.Exit (exitFailure) -import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush) -import System.IO.Unsafe (unsafePerformIO) -import System.FilePath (takeFileName) -import System.Exit (ExitCode, exitSuccess) +import System.IO (stdout, hSetEncoding, utf8, hFlush) +import System.Exit (exitSuccess) import Text.PrettyPrint +import Prelude import Misc - +progVersion :: String -> String +progVersion pf = + "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC " + ++ cProjectVersion ++ "\n" -progVersion :: String -progVersion = - progName ++ " version " ++ showVersion version ++ " compiled by GHC " - ++ cProjectVersion ++ "\n" +ghcModVersion :: String +ghcModVersion = progVersion "" --- TODO: remove (ghc) version prefix! -progName :: String -progName = unsafePerformIO $ takeFileName <$> getProgName +ghcModiVersion :: String +ghcModiVersion = progVersion "i" optionUsage :: (String -> String) -> [OptDescr a] -> [String] optionUsage indent opts = concatMap optUsage opts @@ -65,33 +64,27 @@ ReqArg _ label -> s ++ label OptArg _ label -> s ++ "["++label++"]" +-- TODO: Generate the stuff below automatically usage :: String usage = - case progName of - "ghc-modi" -> ghcModiUsage - _ -> ghcModUsage - --- TODO: Generate the stuff below automatically -ghcModUsage :: String -ghcModUsage = - "Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\ + "Usage: ghc-mod [OPTIONS...] COMMAND [CMD_ARGS...] \n\ \*Global Options (OPTIONS)*\n\ \ Global options can be specified before and after the command and\n\ \ interspersed with command specific options\n\ \\n" ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++ "*Commands*\n\ - \ - version | --version\n\ + \ - version\n\ \ Print the version of the program.\n\ \\n\ - \ - help | --help\n\ + \ - help\n\ \ Print this help message.\n\ \\n\ \ - list [FLAGS...] | modules [FLAGS...]\n\ \ List all visible modules.\n\ \ Flags:\n\ \ -d\n\ - \ Also print the modules' package.\n\ + \ Print package modules belong to.\n\ \\n\ \ - lang\n\ \ List all known GHC language extensions.\n\ @@ -183,12 +176,12 @@ \ -l\n\ \ Option to be passed to hlint.\n\ \\n\ - \ - root FILE\n\ - \ Try to find the project directory given FILE. For Cabal\n\ - \ projects this is the directory containing the cabal file, for\n\ - \ projects that use a cabal sandbox but have no cabal file this is the\n\ - \ directory containing the sandbox and otherwise this is the directory\n\ - \ containing FILE.\n\ + \ - root\n\ + \ Try to find the project directory. For Cabal projects this is the\n\ + \ directory containing the cabal file, for projects that use a cabal\n\ + \ sandbox but have no cabal file this is the directory containing the\n\ + \ cabal.sandbox.config file and otherwise this is the current\n\ + \ directory.\n\ \\n\ \ - doc MODULE\n\ \ Try finding the html documentation directory for the given MODULE.\n\ @@ -197,57 +190,46 @@ \ Print debugging information. Please include the output in any bug\n\ \ reports you submit.\n\ \\n\ + \ - debugComponent [MODULE_OR_FILE...]\n\ + \ Debugging information related to cabal component resolution.\n\ + \\n\ \ - boot\n\ - \ Internal command used by the emacs frontend.\n" - -- "\n\ - -- \The following forms are supported so ghc-mod can be invoked by\n\ - -- \`cabal repl':\n\ - -- \\n\ - -- \ ghc-mod --make GHC_OPTIONS\n\ - -- \ Pass all options through to the GHC executable.\n\ - -- \\n\ - -- \ ghc-mod --interactive GHC_OPTIONS [--ghc-mod]\n\ - -- \ Start ghci emulation mode. GHC_OPTIONS are passed to the\n\ - -- \ GHC API. If `--ghc-mod' is given ghc-mod specific extensions\n\ - -- \ are enabled.\n" - where - indent = (" "++) - -ghcModiUsage :: String -ghcModiUsage = - "Usage: ghc-modi [OPTIONS...] COMMAND\n\ - \*Options*\n" - ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++ - "*Commands*\n\ - \ - version | --version\n\ - \ Print the version of the program.\n\ + \ Internal command used by the emacs frontend.\n\ \\n\ - \ - help | --help\n\ - \ Print this help message.\n" + \ - legacy-interactive\n\ + \ ghc-modi compatibility mode.\n" where indent = (" "++) - - - cmdUsage :: String -> String -> String -cmdUsage cmd s = +cmdUsage cmd realUsage = let -- Find command head - a = dropWhile (not . ((" - " ++ cmd) `isInfixOf`)) $ lines s + a = dropWhile (not . isCmdHead) $ lines realUsage -- Take til the end of the current command block b = flip takeWhile a $ \l -> - all isSpace l || (isIndented l && (isCurrCmdHead l || isNotCmdHead l)) + all isSpace l || (isIndented l && (isCmdHead l || isNotCmdHead l)) -- Drop extra newline from the end c = dropWhileEnd (all isSpace) b isIndented = (" " `isPrefixOf`) isNotCmdHead = ( not . (" - " `isPrefixOf`)) - isCurrCmdHead = ((" - " ++ cmd) `isPrefixOf`) + containsAnyCmdHead s = ((" - ") `isInfixOf` s) + containsCurrCmdHead s = ((" - " ++ cmd) `isInfixOf` s) + isCmdHead s = + containsAnyCmdHead s && + or [ containsCurrCmdHead s + , any (cmd `isPrefixOf`) (splitOn " | " s) + ] + unindent (' ':' ':' ':' ':l) = l unindent l = l in unlines $ unindent <$> c + +ghcModStyle :: Style +ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 } + ---------------------------------------------------------------- option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a @@ -256,43 +238,78 @@ reqArg :: String -> (String -> a) -> ArgDescr a reqArg udsc dsc = ReqArg dsc udsc -globalArgSpec :: [OptDescr (Options -> Options)] +optArg :: String -> (Maybe String -> a) -> ArgDescr a +optArg udsc dsc = OptArg dsc udsc + +intToLogLevel :: Int -> GmLogLevel +intToLogLevel = toEnum + +globalArgSpec :: [OptDescr (Options -> Either [String] Options)] globalArgSpec = - [ option "v" ["verbose"] "Be more verbose." $ - NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o } + [ option "v" ["verbose"] "Increase or set log level. (0-7)" $ + optArg "LEVEL" $ \ml o -> Right $ o { + logLevel = case ml of + Nothing -> increaseLogLevel (logLevel o) + Just l -> toEnum $ min 7 $ read l + } + , option "s" [] "Be silent, set log level to 0" $ + NoArg $ \o -> Right $ o { logLevel = toEnum 0 } + , option "l" ["tolisp"] "Format output as an S-Expression" $ - NoArg $ \o -> o { outputStyle = LispStyle } + NoArg $ \o -> Right $ o { outputStyle = LispStyle } - , option "b" ["boundary"] "Output line separator"$ - reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s } + , option "b" ["boundary", "line-seperator"] "Output line separator"$ + reqArg "SEP" $ \s o -> Right $ o { lineSeparator = LineSeparator s } + , option "" ["line-prefix"] "Output line separator"$ + reqArg "OUT,ERR" $ \s o -> let + [out, err] = splitOn "," s + in Right $ o { linePrefix = Just (out, err) } - , option "g" ["ghcOpt"] "Option to be passed to GHC" $ - reqArg "OPT" $ \g o -> + , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $ + reqArg "OPT" $ \g o -> Right $ o { ghcUserOptions = g : ghcUserOptions o } , option "" ["with-ghc"] "GHC executable to use" $ - reqArg "PROG" $ \p o -> o { ghcProgram = p } + reqArg "PROG" $ \p o -> Right $ o { ghcProgram = p } + , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $ + reqArg "PROG" $ \p o -> Right $ o { ghcPkgProgram = p } + , option "" ["with-cabal"] "cabal-install executable to use" $ - reqArg "PROG" $ \p o -> o { cabalProgram = p } + reqArg "PROG" $ \p o -> Right $ o { cabalProgram = p } + + , option "" ["version"] "print version information" $ + NoArg $ \_ -> Left ["version"] + + , option "" ["help"] "print this help message" $ + NoArg $ \_ -> Left ["help"] + ] parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String]) parseGlobalArgs argv - = case O.getOpt RequireOrder globalArgSpec argv of - (o,r,[] ) -> Right $ (foldr id defaultOptions o, r) - (_,_,errs) -> Left $ InvalidCommandLine $ Right $ - "Parsing command line options failed: " ++ concat errs + = case O.getOpt' RequireOrder globalArgSpec argv of + (o,r,u,[]) -> case foldr (=<<) (Right defaultOptions) o of + Right o' -> Right (o', u ++ r) + Left c -> Right (defaultOptions, c) + (_,_,u,e) -> Left $ InvalidCommandLine $ Right $ + "Parsing command line options failed: " + ++ concat (e ++ map errUnrec u) + where + errUnrec :: String -> String + errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" -parseCommandArgs :: [OptDescr (Options -> Options)] +parseCommandArgs :: [OptDescr (Options -> Either [String] Options)] -> [String] -> Options -> (Options, [String]) parseCommandArgs spec argv opts = case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of - (o,r,[]) -> (foldr id opts o, r) + (o,r,[]) -> case foldr (=<<) (Right opts) o of + Right o' -> (o', r) + Left c -> (defaultOptions, c) (_,_,errs) -> fatalError $ "Parsing command options failed: " ++ concat errs @@ -306,121 +323,65 @@ instance Exception CmdError ----------------------------------------------------------------- - data InteractiveOptions = InteractiveOptions { ghcModExtensions :: Bool } -instance Default InteractiveOptions where - def = InteractiveOptions False - -handler :: IO a -> IO a -handler = flip catches $ - [ Handler $ \(FatalError msg) -> exitError msg - , Handler $ \(InvalidCommandLine e) -> do +handler :: IOish m => GhcModT m a -> GhcModT m a +handler = flip gcatches $ + [ GHandler $ \(FatalError msg) -> exitError msg + , GHandler $ \(InvalidCommandLine e) -> do case e of Left cmd -> - exitError $ (cmdUsage cmd ghcModUsage) ++ "\n" - ++ progName ++ ": Invalid command line form." - Right msg -> exitError $ progName ++ ": " ++ msg + exitError $ "Usage for `"++cmd++"' command:\n\n" + ++ (cmdUsage cmd usage) ++ "\n" + ++ "ghc-mod: Invalid command line form." + Right msg -> exitError $ "ghc-mod: " ++ msg + , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e ] main :: IO () -main = handler $ do +main = do hSetEncoding stdout utf8 args <- getArgs - - -- This doesn't handle --help and --version being given after any global - -- options. To do that we'd have to fiddle with getOpt. case parseGlobalArgs args of - Left e -> case globalCommands args of - Just s -> putStr s - Nothing -> throw e - - Right res@(_,cmdArgs) -> - case globalCommands cmdArgs of - Just s -> putStr s - Nothing -> progMain res + Left e -> throw e + Right res -> progMain res progMain :: (Options,[String]) -> IO () -progMain (globalOptions,cmdArgs) = do - -- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args - -- _realGhcArgs = filter (/="--ghc-mod") ghcArgs - - -- (globalOptions,_cmdArgs) = parseGlobalArgs modArgs - - -- stripSeperator ("--":rest) = rest - -- stripSeperator l = l - - case progName of - "ghc-modi" -> do - legacyInteractive globalOptions =<< emptyNewUnGetLine - - - _ - -- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do - -- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith - - -- | "--interactive" `elem` ghcArgs -> do - -- let interactiveOptions = if "--ghc-mod" `elem` ghcArgs - -- then def { ghcModExtensions = True } - -- else def - - -- -- TODO: pass ghcArgs' to ghc API - -- putStrLn "\ninteractive\n" - -- --print realGhcArgs - -- (res, _) <- runGhcModT globalOptions $ undefined - -- case res of - -- Right s -> putStr s - -- Left e -> exitError $ render (gmeDoc e) - - - | otherwise -> do - (res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs - case res of - Right s -> putStr s - Left e -> exitError $ render (gmeDoc e) - - -- Obtain ghc options by letting ourselfs be executed by - -- @cabal repl@ - -- TODO: need to do something about non-cabal projects - -- exe <- ghcModExecutable - -- let cabalArgs = ["repl", "-v0", "--with-ghc="++exe] - -- ++ (("--ghc-option="++) `map` ("--ghc-mod":"--":args)) - - -- print cabalArgs - - -- rawSystem "cabal" cabalArgs >>= exitWith - - - --- ghc-modi -legacyInteractive :: Options -> UnGetLine -> IO () -legacyInteractive opt ref = flip catches handlers $ do - (res,_) <- runGhcModT opt $ do - symdbreq <- liftIO $ newSymDbReq opt - world <- liftIO . getCurrentWorld =<< cradle - legacyInteractiveLoop symdbreq ref world - - case res of - Right () -> return () - Left e -> putStrLn $ notGood $ render (gmeDoc e) - +progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do + case globalCommands cmdArgs of + Just s -> gmPutStr s + Nothing -> ghcCommands cmdArgs where - handlers = [ Handler $ \Restart -> legacyInteractive opt ref ] + hndle action = do + (e, _l) <- action + case e of + Right _ -> + return () + Left ed -> + exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc ed) -isExitCodeException :: SomeException -> Bool -isExitCodeException e = isJust mExitCode - where - mExitCode :: Maybe ExitCode - mExitCode = fromException e +globalCommands :: [String] -> Maybe String +globalCommands (cmd:_) + | cmd == "help" = Just usage + | cmd == "version" = Just ghcModVersion +globalCommands _ = Nothing +-- ghc-modi +legacyInteractive :: IOish m => GhcModT m () +legacyInteractive = do + opt <- options + prepareCabalHelper + tmpdir <- cradleTempDir <$> cradle + symdbreq <- liftIO $ newSymDbReq opt tmpdir + world <- getCurrentWorld + legacyInteractiveLoop symdbreq world -bug :: String -> IO () +bug :: IOish m => String -> GhcModT m () bug msg = do - putStrLn $ notGood $ "BUG: " ++ msg - exitFailure + gmPutStrLn $ notGood $ "BUG: " ++ msg + liftIO exitFailure notGood :: String -> String notGood msg = "NG " ++ escapeNewlines msg @@ -431,30 +392,26 @@ replace :: String -> String -> String -> String replace needle replacement = intercalate replacement . splitOn needle - legacyInteractiveLoop :: IOish m - => SymDbReq -> UnGetLine -> World -> GhcModT m () -legacyInteractiveLoop symdbreq ref world = do + => SymDbReq -> World -> GhcModT m () +legacyInteractiveLoop symdbreq world = do liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle -- blocking - cmdArg <- liftIO $ getCommand ref + cmdArg <- liftIO $ getLine -- after blocking, we need to see if the world has changed. - changed <- liftIO . didWorldChange world =<< cradle + changed <- didWorldChange world when changed $ do - liftIO $ ungetCommand ref cmdArg - throw Restart - - liftIO . prepareAutogen =<< cradle + dropSession let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg arg = concat args' cmd = dropWhileEnd isSpace cmd' args = dropWhileEnd isSpace `map` args' - res <- case dropWhileEnd isSpace cmd of + res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of "check" -> checkSyntaxCmd [arg] "lint" -> lintCmd [arg] "find" -> do @@ -476,22 +433,20 @@ "" -> liftIO $ exitSuccess _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" - liftIO $ putStr res >> putStrLn "OK" >> hFlush stdout - legacyInteractiveLoop symdbreq ref world - - -globalCommands :: [String] -> Maybe String -globalCommands [] = Nothing -globalCommands (cmd:_) = case cmd of - _ | cmd == "help" || cmd == "--help" -> Just usage - _ | cmd == "version" || cmd == "--version" -> Just progVersion - _ -> Nothing + gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout) + legacyInteractiveLoop symdbreq world + where + interactiveHandlers = + [ GHandler $ \e@(FatalError _) -> throw e + , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return "" + ] -ghcCommands :: IOish m => [String] -> GhcModT m String +ghcCommands :: IOish m => [String] -> GhcModT m () ghcCommands [] = fatalError "No command given (try --help)" -ghcCommands (cmd:args) = fn args +ghcCommands (cmd:args) = do + gmPutStr =<< action args where - fn = case cmd of + action = case cmd of _ | cmd == "list" || cmd == "modules" -> modulesCmd "lang" -> languagesCmd "flag" -> flagsCmd @@ -499,6 +454,7 @@ "check" -> checkSyntaxCmd "expand" -> expandTemplateCmd "debug" -> debugInfoCmd + "debug-component" -> componentInfoCmd "info" -> infoCmd "type" -> typesCmd "split" -> splitsCmd @@ -511,6 +467,8 @@ "doc" -> pkgDocCmd "dumpsym" -> dumpSymbolCmd "boot" -> bootCmd + "legacy-interactive" -> legacyInteractiveCmd +-- "nuke-caches" -> nukeCachesCmd _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" newtype FatalError = FatalError String deriving (Show, Typeable) @@ -520,14 +478,18 @@ deriving (Show, Typeable) instance Exception InvalidCommandLine -exitError :: String -> IO a -exitError msg = hPutStrLn stderr msg >> exitFailure +exitError :: IOish m => String -> GhcModT m a +exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure +exitError' :: Options -> String -> IO a +exitError' opts msg = + gmUnsafeErrStrLn opts (dropWhileEnd (=='\n') msg) >> liftIO exitFailure + fatalError :: String -> a -fatalError s = throw $ FatalError $ progName ++ ": " ++ s +fatalError s = throw $ FatalError $ "ghc-mod: " ++ s withParseCmd :: IOish m - => [OptDescr (Options -> Options)] + => [OptDescr (Options -> Either [String] Options)] -> ([String] -> GhcModT m a) -> [String] -> GhcModT m a @@ -535,25 +497,43 @@ (opts', rest) <- parseCommandArgs spec args <$> options withOptions (const opts') $ action rest +withParseCmd' :: (IOish m, ExceptionMonad m) + => String + -> [OptDescr (Options -> Either [String] Options)] + -> ([String] -> GhcModT m a) + -> [String] + -> GhcModT m a +withParseCmd' cmd spec action args = + catchArgs cmd $ withParseCmd spec action args + +catchArgs :: (Monad m, ExceptionMonad m) => String -> m a -> m a +catchArgs cmd action = + action `gcatch` \(PatternMatchFail _) -> + throw $ InvalidCommandLine (Left cmd) + modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd, - debugInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd, - findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd + debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, + refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, + dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd :: IOish m => [String] -> GhcModT m String -modulesCmd = withParseCmd [] $ \[] -> modules -languagesCmd = withParseCmd [] $ \[] -> languages -flagsCmd = withParseCmd [] $ \[] -> flags -debugInfoCmd = withParseCmd [] $ \[] -> debugInfo -rootInfoCmd = withParseCmd [] $ \[] -> rootInfo +modulesCmd = withParseCmd' "modules" s $ \[] -> modules + where s = modulesArgSpec +languagesCmd = withParseCmd' "lang" [] $ \[] -> languages +flagsCmd = withParseCmd' "flag" [] $ \[] -> flags +debugInfoCmd = withParseCmd' "debug" [] $ \[] -> debugInfo +rootInfoCmd = withParseCmd' "root" [] $ \[] -> rootInfo +componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts -- internal -bootCmd = withParseCmd [] $ \[] -> boot +bootCmd = withParseCmd' "boot" [] $ \[] -> boot +nukeCachesCmd = withParseCmd' "nuke-caches" [] $ \[] -> nukeCaches >> return "" -dumpSymbolCmd = withParseCmd [] $ \[tmpdir] -> dumpSymbol tmpdir -findSymbolCmd = withParseCmd [] $ \[sym] -> findSymbol sym -pkgDocCmd = withParseCmd [] $ \[mdl] -> pkgDoc mdl -lintCmd = withParseCmd s $ \[file] -> lint file +dumpSymbolCmd = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir +findSymbolCmd = withParseCmd' "find" [] $ \[sym] -> findSymbol sym +pkgDocCmd = withParseCmd' "doc" [] $ \[mdl] -> pkgDoc mdl +lintCmd = withParseCmd' "lint" s $ \[file] -> lint file where s = hlintArgSpec -browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls +browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls where s = browseArgSpec checkSyntaxCmd = withParseCmd [] $ checkAction checkSyntax expandTemplateCmd = withParseCmd [] $ checkAction expandTemplate @@ -565,10 +545,20 @@ refineCmd = withParseCmd [] $ locAction' "refine" refine infoCmd = withParseCmd [] $ action - where action [file,_,expr] = info file expr - action [file,expr] = info file expr + where action [file,_,expr] = info file $ Expression expr + action [file,expr] = info file $ Expression expr action _ = throw $ InvalidCommandLine (Left "info") +legacyInteractiveCmd = withParseCmd [] go + where + go [] = + legacyInteractive >> return "" + go ("help":[]) = + return usage + go ("version":[]) = + return ghcModiVersion + go _ = throw $ InvalidCommandLine (Left "legacy-interactive") + checkAction :: ([t] -> a) -> [t] -> a checkAction _ [] = throw $ InvalidCommandLine (Right "No files given.") checkAction action files = action files @@ -578,22 +568,43 @@ locAction _ action [file, line,col] = action file (read line) (read col) locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd) -locAction' :: String -> (String -> Int -> Int -> String -> a) -> [String] -> a -locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) expr -locAction' _ action [f, line,col,expr] = action f (read line) (read col) expr +locAction' :: String -> (String -> Int -> Int -> Expression -> a) -> [String] -> a +locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) (Expression expr) +locAction' _ action [f, line,col,expr] = action f (read line) (read col) (Expression expr) locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd) -hlintArgSpec :: [OptDescr (Options -> Options)] + +modulesArgSpec :: [OptDescr (Options -> Either [String] Options)] +modulesArgSpec = + [ option "d" ["detailed"] "Print package modules belong to." $ + NoArg $ \o -> Right $ o { detailed = True } + ] + + +hlintArgSpec :: [OptDescr (Options -> Either [String] Options)] hlintArgSpec = [ option "h" ["hlintOpt"] "Option to be passed to hlint" $ - reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o } + reqArg "hlintOpt" $ \h o -> Right $ o { hlintOpts = h : hlintOpts o } ] -browseArgSpec :: [OptDescr (Options -> Options)] + +browseArgSpec :: [OptDescr (Options -> Either [String] Options)] browseArgSpec = [ option "o" ["operators"] "Also print operators." $ - NoArg $ \o -> o { operators = True } + NoArg $ \o -> Right $ o { operators = True } , option "d" ["detailed"] "Print symbols with accompanying signature." $ - NoArg $ \o -> o { detailed = True } + NoArg $ \o -> Right $ o { detailed = True } , option "q" ["qualified"] "Qualify symbols" $ - NoArg $ \o -> o { qualified = True } + NoArg $ \o -> Right $ o { qualified = True } ] + +nukeCaches :: IOish m => GhcModT m () +nukeCaches = do + chdir <- liftIO $ ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" + c <- cradle + + when (cradleProjectType c == CabalProject) $ do + let root = cradleRootDir 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 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -1,262 +1,55 @@ {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} -- | WARNING --- This program in the process of being deprecated, use `ghc-mod --interactive` --- instead. - --- 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 +-- This program is deprecated, use `ghc-mod legacy-interactive` instead. module Main where -import Config (cProjectVersion) -import Control.Applicative ((<$>)) -import Control.Exception (SomeException(..)) -import qualified Control.Exception as E -import Control.Monad (when) -import CoreMonad (liftIO) -import Data.List (intercalate) -import Data.List.Split (splitOn) -import Data.Version (showVersion) -import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal +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 System.Console.GetOpt -import System.Directory (setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (ExitCode, exitFailure) -import System.IO (hFlush,stdout) - -import Misc import Utils - ----------------------------------------------------------------- - -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) - ----------------------------------------------------------------- - --- Running two GHC monad threads disables the handling of --- C-c since installSignalHandlers is called twice, sigh. +import Prelude 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,_) = emptyNewUnGetLine >>= run opt - -run :: Options -> UnGetLine -> IO () -run opt ref = flip E.catches handlers $ do - cradle0 <- findCradle - let rootdir = cradleRootDir cradle0 --- c = cradle0 { cradleCurrentDir = rootdir } TODO: ????? - setCurrentDirectory rootdir - prepareAutogen cradle0 - -- Asynchronous db loading starts here. - symdbreq <- newSymDbReq opt - (res, _) <- runGhcModT opt $ do - crdl <- cradle - world <- liftIO $ getCurrentWorld crdl - loop symdbreq ref world - 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 (\(_ :: Restart) -> run opt ref) - , 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 => SymDbReq -> UnGetLine -> World -> GhcModT m () -loop symdbreq ref world = do - -- blocking - cmdArg <- liftIO $ getCommand ref - -- after blocking, we need to see if the world has changed. - crdl <- cradle - changed <- liftIO $ didWorldChange world crdl - when changed $ do - liftIO $ ungetCommand ref cmdArg - E.throw Restart - cradle >>= liftIO . prepareAutogen - let (cmd,arg') = break (== ' ') cmdArg - arg = dropWhile (== ' ') arg' - (ret,ok) <- case cmd of - "check" -> checkStx arg - "find" -> findSym arg symdbreq - "lint" -> lintStx arg - "info" -> showInfo arg - "type" -> showType arg - "split" -> doSplit arg - "sig" -> doSig arg - "refine" -> doRefine arg - "auto" -> doAuto arg - "boot" -> bootIt - "browse" -> browseIt arg - "quit" -> return ("quit", False) - "" -> return ("quit", False) - _ -> return ([], True) - if ok then do - liftIO $ putStr ret - liftIO $ putStrLn "OK" - else do - liftIO $ putStrLn $ notGood ret - liftIO $ hFlush stdout - when ok $ loop symdbreq ref world - ----------------------------------------------------------------- - -checkStx :: IOish m => FilePath -> GhcModT m (String, Bool) -checkStx file = do - eret <- check [file] - case eret of - Right ret -> return (ret, True) - Left ret -> return (ret, True) - ----------------------------------------------------------------- - -findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool) -findSym sym symdbreq = do - db <- getDb symdbreq >>= checkDb symdbreq - ret <- lookupSymbol sym db - return (ret, True) - -lintStx :: IOish m => FilePath -> GhcModT m (String, Bool) -lintStx optFile = do - ret <- withOptions changeOpt $ lint file - return (ret, True) - 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 => FilePath -> GhcModT m (String, Bool) -showInfo fileArg = do - let [file, expr] = splitN 2 fileArg - ret <- info file expr - return (ret, True) - -showType :: IOish m => FilePath -> GhcModT m (String, Bool) -showType fileArg = do - let [file, line, column] = splitN 3 fileArg - ret <- types file (read line) (read column) - return (ret, True) - -doSplit :: IOish m => FilePath -> GhcModT m (String, Bool) -doSplit fileArg = do - let [file, line, column] = splitN 3 fileArg - ret <- splits file (read line) (read column) - return (ret, True) - -doSig :: IOish m => FilePath -> GhcModT m (String, Bool) -doSig fileArg = do - let [file, line, column] = splitN 3 fileArg - ret <- sig file (read line) (read column) - return (ret, True) - -doRefine :: IOish m => FilePath -> GhcModT m (String, Bool) -doRefine fileArg = do - let [file, line, column, expr] = splitN 4 fileArg - ret <- refine file (read line) (read column) expr - return (ret, True) +main = do + hPutStrLn stderr $ + "Warning: ghc-modi is deprecated please use 'ghc-mod legacy-interactive' instead" -doAuto :: IOish m => FilePath -> GhcModT m (String, Bool) -doAuto fileArg = do - let [file, line, column] = splitN 3 fileArg - ret <- auto file (read line) (read column) - return (ret, True) + 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 -bootIt :: IOish m => GhcModT m (String, Bool) -bootIt = do - ret <- boot - return (ret, True) +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 -browseIt :: IOish m => ModuleString -> GhcModT m (String, Bool) -browseIt 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) - where - setDetailed opt = opt { detailed = True } + when (isNothing mexe) $ + hPutStrLn stderr "ghc-modi: ghc-mod executable on PATH has different version, check your installation!" + return mexe diff --git a/src/Misc.hs b/src/Misc.hs --- a/src/Misc.hs +++ b/src/Misc.hs @@ -1,75 +1,28 @@ {-# LANGUAGE DeriveDataTypeable, CPP #-} module Misc ( - GHCModiError(..) - , Restart(..) - , UnGetLine - , emptyNewUnGetLine - , ungetCommand - , getCommand - , SymDbReq + SymDbReq , newSymDbReq , getDb , checkDb - , prepareAutogen ) where -import Control.Applicative ((<$>)) -import Control.Concurrent (threadDelay) import Control.Concurrent.Async (Async, async, wait) -import Control.Exception (Exception) -import Control.Monad (unless, when) import CoreMonad (liftIO) import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.List (isPrefixOf) -import Data.Maybe (isJust) -import Data.Typeable (Typeable) -import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.IO (openBinaryFile, IOMode(..)) -import System.Process +import Prelude import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal - ----------------------------------------------------------------- - -data GHCModiError = CmdArg [String] deriving (Show, Typeable) - -instance Exception GHCModiError - ----------------------------------------------------------------- - -data Restart = Restart deriving (Show, Typeable) - -instance Exception Restart - ----------------------------------------------------------------- - -newtype UnGetLine = UnGetLine (IORef (Maybe String)) - -emptyNewUnGetLine :: IO UnGetLine -emptyNewUnGetLine = UnGetLine <$> newIORef Nothing - -ungetCommand :: UnGetLine -> String -> IO () -ungetCommand (UnGetLine ref) cmd = writeIORef ref (Just cmd) - -getCommand :: UnGetLine -> IO String -getCommand (UnGetLine ref) = do - mcmd <- readIORef ref - case mcmd of - Nothing -> getLine - Just cmd -> do - writeIORef ref Nothing - return cmd +import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) ---------------------------------------------------------------- type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog) data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction) -newSymDbReq :: Options -> IO SymDbReq -newSymDbReq opt = do - let act = runGhcModT opt loadSymbolDb +newSymDbReq :: Options -> FilePath -> IO SymDbReq +newSymDbReq opt dir = do + let act = runGhcModT opt $ loadSymbolDb dir req <- async act ref <- newIORef req return $ SymDbReq ref act @@ -83,7 +36,7 @@ checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb checkDb (SymDbReq ref act) db = do - outdated <- liftIO $ isOutdated db + outdated <- isOutdated db if outdated then do -- async and wait here is unnecessary because this is essentially -- synchronous. But Async can be used a cache. @@ -92,63 +45,3 @@ hoistGhcModT =<< liftIO (wait req) else return db - ----------------------------------------------------------------- - -build :: IO ProcessHandle -build = do -#ifdef WINDOWS - nul <- openBinaryFile "NUL" AppendMode -#else - nul <- openBinaryFile "/dev/null" AppendMode -#endif - (_, _, _, hdl) <- createProcess $ pro nul - return hdl - where - pro nul = CreateProcess { - cmdspec = RawCommand "cabal" ["build"] - , cwd = Nothing - , env = Nothing - , std_in = Inherit - , std_out = UseHandle nul - , std_err = UseHandle nul - , close_fds = False -#if __GLASGOW_HASKELL__ >= 702 - , create_group = True -#endif -#if __GLASGOW_HASKELL__ >= 707 - , delegate_ctlc = False -#endif - } - -autogen :: String -autogen = "dist/build/autogen" - -isAutogenPrepared :: IO Bool -isAutogenPrepared = do - exist <- doesDirectoryExist autogen - if exist then do - files <- filter ("." `isPrefixOf`) <$> getDirectoryContents autogen - if length files >= 2 then - return True - else - return False - else - return False - -watch :: Int -> ProcessHandle -> IO () -watch 0 _ = return () -watch n hdl = do - prepared <- isAutogenPrepared - if prepared then - interruptProcessGroupOf hdl - else do - threadDelay 100000 - watch (n - 1) hdl - -prepareAutogen :: Cradle -> IO () -prepareAutogen crdl = when (isJust $ cradleCabalFile crdl) $ do - prepared <- isAutogenPrepared - unless prepared $ do - hdl <- build - watch 30 hdl 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 @@ -26,7 +26,8 @@ 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/lib" $ do + syms <- runD $ lines <$> browse "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 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 - let Just cabalFile = cradleCabalFile crdl - pkgDesc <- runD $ parseCabalFile crdl cabalFile - 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/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 Data.List +import System.Process import Test.Hspec import TestUtils @@ -14,38 +15,55 @@ 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 `shouldBe` "DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched: _ : _\n" +#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" 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/HomeModuleGraphSpec.hs b/test/HomeModuleGraphSpec.hs new file mode 100644 --- /dev/null +++ b/test/HomeModuleGraphSpec.hs @@ -0,0 +1,178 @@ +-- ghc-mod: Making Haskell development *more* fun +-- 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 Language.Haskell.GhcMod.HomeModuleGraph +import Language.Haskell.GhcMod.Target +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 @@ -9,51 +9,43 @@ #else import System.Environment (getExecutablePath) #endif -import System.Exit import System.FilePath -import System.Process import Test.Hspec import TestUtils -import Dir 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 "lib/Data/Foo.hs" 9 5 + res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" 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 "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 "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/LintSpec.hs b/test/LintSpec.hs --- a/test/LintSpec.hs +++ b/test/LintSpec.hs @@ -8,10 +8,10 @@ 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 "test/data/hlint/hlint.hs" + res `shouldBe` "test/data/hlint/hlint.hs:4:8: Error: 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 "test/data/ghc-mod-check/lib/Data/Foo.hs" res `shouldBe` "" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,6 +4,7 @@ import Control.Exception as E import Control.Monad (void) +import Data.List import Language.Haskell.GhcMod (debugInfo) import System.Process import Test.Hspec @@ -11,22 +12,38 @@ main :: IO () main = do - let sandboxes = [ "test/data", "test/data/check-packageid" + 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") 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 caches = [ "setup-config" + , "setup-config.ghc-mod.cabal-helper" + , "setup-config.ghc-mod.cabal-components" + , "setup-config.ghc-mod.resolved-components" + , "setup-config.ghc-mod.package-options" + , "setup-config.ghc-mod.package-db-stack" + , "ghc-mod.cache" + ] + cachesFindExp :: String + cachesFindExp = unwords $ intersperse "-o " $ map ("-name "++) caches + + cleanCmd = "find test \\( "++ cachesFindExp ++" \\) -exec rm {} \\;" + + putStrLn $ "$ " ++ cleanCmd + void $ system cleanCmd void $ system "cabal --version" - putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal void $ system "ghc --version" (putStrLn =<< runD debugInfo) diff --git a/test/MonadSpec.hs b/test/MonadSpec.hs --- a/test/MonadSpec.hs +++ b/test/MonadSpec.hs @@ -1,39 +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 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, _) + (a, _h) <- runGhcModT defaultOptions $ do Just _ <- return Nothing return "hello" `catchError` (const $ fail "oh noes") 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) - - describe "gmsGet/Put" $ - it "work" $ do - (runD $ gmsPut (GhcModState Intelligent) >> gmsGet) - `shouldReturn` (GhcModState Intelligent) - - describe "liftIO" $ do - it "converts user errors to GhcModError" $ do - shouldReturnError $ - runD' $ liftIO $ throw (userError "hello") >> return "" - - it "converts a file not found exception to GhcModError" $ do - shouldReturnError $ - runD' $ liftIO $ readFile "/DOES_NOT_EXIST" >> return "" diff --git a/test/PathsAndFilesSpec.hs b/test/PathsAndFilesSpec.hs --- a/test/PathsAndFilesSpec.hs +++ b/test/PathsAndFilesSpec.hs @@ -1,42 +1,33 @@ -{-# LANGUAGE CPP #-} module PathsAndFilesSpec where import Language.Haskell.GhcMod.PathsAndFiles -#if __GLASGOW_HASKELL__ <= 706 -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.GhcPkg -#endif import System.Directory -import System.Environment -import System.FilePath (()) +import System.FilePath import Test.Hspec +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` Just (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") + Just db <- getSandboxDb "test/data/cabal-project" + db `shouldSatisfy` isPkgDbAt (cwd "test/data/cabal-project/.cabal-sandbox") it "returns Nothing if the sandbox config file is broken" $ do getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing - describe "getCabalFiles" $ do - it "doesn't think $HOME/.cabal is a cabal file" $ do - (getCabalFiles =<< getEnv "HOME") `shouldReturn` [] - describe "findCabalFile" $ do it "works" $ do - findCabalFile "test/data" `shouldReturn` Just "test/data/cabalapi.cabal" + findCabalFile "test/data/cabal-project" `shouldReturn` Just "test/data/cabal-project/cabalapi.cabal" it "finds cabal files in parent directories" $ do - findCabalFile "test/data/subdir1/subdir2" `shouldReturn` Just "test/data/cabalapi.cabal" + findCabalFile "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just "test/data/cabal-project/cabalapi.cabal" + + describe "findCabalSandboxDir" $ do + it "works" $ do + findCabalSandboxDir "test/data/cabal-project" `shouldReturn` Just "test/data/cabal-project" + + it "finds sandboxes in parent directories" $ do + findCabalSandboxDir "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just "test/data/cabal-project" diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -1,27 +1,37 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} module TestUtils ( run , runD , runD' - , runI - , runID - , runIsolatedGhcMod - , isolateCradle + , runE + , runNullLog , shouldReturnError + , isPkgDbAt + , isPkgConfDAt , module Language.Haskell.GhcMod.Monad , module Language.Haskell.GhcMod.Types ) where +import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Types +import Control.Arrow +import Control.Applicative +import Control.Monad.Error (ErrorT, runErrorT) +import Control.Monad.Trans.Journal +import Data.List.Split +import Data.String +import System.FilePath +import System.Directory import Test.Hspec -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 +39,47 @@ 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 +withSpecCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a +withSpecCradle cradledir f = + gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f --- | Run GhcMod in isolated cradle with default options -runID :: GhcModT IO a -> IO a -runID = runIsolatedGhcMod defaultOptions +withGhcModEnvSpec :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a +withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f --- | Run GhcMod in isolated cradle -runI :: Options -> GhcModT IO a -> IO a -runI = runIsolatedGhcMod +runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog) +runGhcModTSpec opt action = do + dir <- getCurrentDirectory + runGhcModTSpec' dir opt action +runGhcModTSpec' :: IOish m + => FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog) +runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> + withGhcModEnvSpec dir' opt $ \env -> do + first (fst <$>) <$> runGhcModT'' env defaultGhcModState + (gmSetLogLevel (logLevel opt) >> action) + -- | 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 defaultOptions { logLevel = testLogLevel } -runD' :: GhcModT IO a -> IO (Either GhcModError a, GhcModLog) -runD' = runGhcModT defaultOptions +runD' :: FilePath -> GhcModT IO a -> IO a +runD' dir = + extract . runGhcModTSpec' dir defaultOptions { logLevel = testLogLevel } +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 + shouldReturnError :: Show a => IO (Either GhcModError a, GhcModLog) -> Expectation @@ -61,3 +89,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/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/cabal.sandbox.config.in b/test/data/cabal-project/cabal.sandbox.config.in new file mode 100644 --- /dev/null +++ b/test/data/cabal-project/cabal.sandbox.config.in @@ -0,0 +1,25 @@ +-- 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-project/.cabal-sandbox/packages +logs-dir: @CWD@/test/data/cabal-project/.cabal-sandbox/logs +world-file: @CWD@/test/data/cabal-project/.cabal-sandbox/world +user-install: False +package-db: @CWD@/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d +build-summary: @CWD@/test/data/cabal-project/.cabal-sandbox/logs/build.log + +install-dirs + prefix: @CWD@/test/data/cabal-project/.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-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/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-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/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 +psogduapzsü9 +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/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/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,25 @@ --- 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 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/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,12 +1,15 @@ +{-# LANGUAGE CPP #-} module Main where import Test.DocTest main :: IO () -main = doctest [ - "-package" - , "ghc" - , "-XConstraintKinds", "-XFlexibleContexts" +main = 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" , "-idist/build/autogen/" , "-optP-include" , "-optPdist/build/autogen/cabal_macros.h"